testsuite for cvs co -c
[git/dscho.git] / gitk-git / gitk
blobfddcb45817ed6839ba95965d7e57e9a2e04ae30a
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 unmerged_files {files} {
94 global nr_unmerged
96 # find the list of unmerged files
97 set mlist {}
98 set nr_unmerged 0
99 if {[catch {
100 set fd [open "| git ls-files -u" r]
101 } err]} {
102 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
103 exit 1
105 while {[gets $fd line] >= 0} {
106 set i [string first "\t" $line]
107 if {$i < 0} continue
108 set fname [string range $line [expr {$i+1}] end]
109 if {[lsearch -exact $mlist $fname] >= 0} continue
110 incr nr_unmerged
111 if {$files eq {} || [path_filter $files $fname]} {
112 lappend mlist $fname
115 catch {close $fd}
116 return $mlist
119 proc parseviewargs {n arglist} {
120 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
122 set vdatemode($n) 0
123 set vmergeonly($n) 0
124 set glflags {}
125 set diffargs {}
126 set nextisval 0
127 set revargs {}
128 set origargs $arglist
129 set allknown 1
130 set filtered 0
131 set i -1
132 foreach arg $arglist {
133 incr i
134 if {$nextisval} {
135 lappend glflags $arg
136 set nextisval 0
137 continue
139 switch -glob -- $arg {
140 "-d" -
141 "--date-order" {
142 set vdatemode($n) 1
143 # remove from origargs in case we hit an unknown option
144 set origargs [lreplace $origargs $i $i]
145 incr i -1
147 # These request or affect diff output, which we don't want.
148 # Some could be used to set our defaults for diff display.
149 "-[puabwcrRBMC]" -
150 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
151 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
152 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
153 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
154 "--ignore-space-change" - "-U*" - "--unified=*" {
155 lappend diffargs $arg
157 # These cause our parsing of git log's output to fail, or else
158 # they're options we want to set ourselves, so ignore them.
159 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
160 "--name-only" - "--name-status" - "--color" - "--color-words" -
161 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
162 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
163 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
164 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
165 "--objects" - "--objects-edge" - "--reverse" {
167 # These are harmless, and some are even useful
168 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
169 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
170 "--full-history" - "--dense" - "--sparse" -
171 "--follow" - "--left-right" - "--encoding=*" {
172 lappend glflags $arg
174 # These mean that we get a subset of the commits
175 "--diff-filter=*" - "--no-merges" - "--unpacked" -
176 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
177 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
178 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
179 "--remove-empty" - "--first-parent" - "--cherry-pick" -
180 "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
181 set filtered 1
182 lappend glflags $arg
184 # This appears to be the only one that has a value as a
185 # separate word following it
186 "-n" {
187 set filtered 1
188 set nextisval 1
189 lappend glflags $arg
191 "--not" {
192 set notflag [expr {!$notflag}]
193 lappend revargs $arg
195 "--all" {
196 lappend revargs $arg
198 "--merge" {
199 set vmergeonly($n) 1
200 # git rev-parse doesn't understand --merge
201 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
203 # Other flag arguments including -<n>
204 "-*" {
205 if {[string is digit -strict [string range $arg 1 end]]} {
206 set filtered 1
207 } else {
208 # a flag argument that we don't recognize;
209 # that means we can't optimize
210 set allknown 0
212 lappend glflags $arg
214 # Non-flag arguments specify commits or ranges of commits
215 default {
216 if {[string match "*...*" $arg]} {
217 lappend revargs --gitk-symmetric-diff-marker
219 lappend revargs $arg
223 set vdflags($n) $diffargs
224 set vflags($n) $glflags
225 set vrevs($n) $revargs
226 set vfiltered($n) $filtered
227 set vorigargs($n) $origargs
228 return $allknown
231 proc parseviewrevs {view revs} {
232 global vposids vnegids
234 if {$revs eq {}} {
235 set revs HEAD
237 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
238 # we get stdout followed by stderr in $err
239 # for an unknown rev, git rev-parse echoes it and then errors out
240 set errlines [split $err "\n"]
241 set badrev {}
242 for {set l 0} {$l < [llength $errlines]} {incr l} {
243 set line [lindex $errlines $l]
244 if {!([string length $line] == 40 && [string is xdigit $line])} {
245 if {[string match "fatal:*" $line]} {
246 if {[string match "fatal: ambiguous argument*" $line]
247 && $badrev ne {}} {
248 if {[llength $badrev] == 1} {
249 set err "unknown revision $badrev"
250 } else {
251 set err "unknown revisions: [join $badrev ", "]"
253 } else {
254 set err [join [lrange $errlines $l end] "\n"]
256 break
258 lappend badrev $line
261 error_popup "Error parsing revisions: $err"
262 return {}
264 set ret {}
265 set pos {}
266 set neg {}
267 set sdm 0
268 foreach id [split $ids "\n"] {
269 if {$id eq "--gitk-symmetric-diff-marker"} {
270 set sdm 4
271 } elseif {[string match "^*" $id]} {
272 if {$sdm != 1} {
273 lappend ret $id
274 if {$sdm == 3} {
275 set sdm 0
278 lappend neg [string range $id 1 end]
279 } else {
280 if {$sdm != 2} {
281 lappend ret $id
282 } else {
283 lset ret end [lindex $ret end]...$id
285 lappend pos $id
287 incr sdm -1
289 set vposids($view) $pos
290 set vnegids($view) $neg
291 return $ret
294 # Start off a git log process and arrange to read its output
295 proc start_rev_list {view} {
296 global startmsecs commitidx viewcomplete curview
297 global commfd leftover tclencoding
298 global viewargs viewargscmd viewfiles vfilelimit
299 global showlocalchanges commitinterest
300 global viewactive loginstance viewinstances vmergeonly
301 global pending_select mainheadid
302 global vcanopt vflags vrevs vorigargs
304 set startmsecs [clock clicks -milliseconds]
305 set commitidx($view) 0
306 # these are set this way for the error exits
307 set viewcomplete($view) 1
308 set viewactive($view) 0
309 varcinit $view
311 set args $viewargs($view)
312 if {$viewargscmd($view) ne {}} {
313 if {[catch {
314 set str [exec sh -c $viewargscmd($view)]
315 } err]} {
316 error_popup "Error executing --argscmd command: $err"
317 return 0
319 set args [concat $args [split $str "\n"]]
321 set vcanopt($view) [parseviewargs $view $args]
323 set files $viewfiles($view)
324 if {$vmergeonly($view)} {
325 set files [unmerged_files $files]
326 if {$files eq {}} {
327 global nr_unmerged
328 if {$nr_unmerged == 0} {
329 error_popup [mc "No files selected: --merge specified but\
330 no files are unmerged."]
331 } else {
332 error_popup [mc "No files selected: --merge specified but\
333 no unmerged files are within file limit."]
335 return 0
338 set vfilelimit($view) $files
340 if {$vcanopt($view)} {
341 set revs [parseviewrevs $view $vrevs($view)]
342 if {$revs eq {}} {
343 return 0
345 set args [concat $vflags($view) $revs]
346 } else {
347 set args $vorigargs($view)
350 if {[catch {
351 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
352 --boundary $args "--" $files] r]
353 } err]} {
354 error_popup "[mc "Error executing git log:"] $err"
355 return 0
357 set i [incr loginstance]
358 set viewinstances($view) [list $i]
359 set commfd($i) $fd
360 set leftover($i) {}
361 if {$showlocalchanges && $mainheadid ne {}} {
362 lappend commitinterest($mainheadid) {dodiffindex}
364 fconfigure $fd -blocking 0 -translation lf -eofchar {}
365 if {$tclencoding != {}} {
366 fconfigure $fd -encoding $tclencoding
368 filerun $fd [list getcommitlines $fd $i $view 0]
369 nowbusy $view [mc "Reading"]
370 if {$view == $curview} {
371 set pending_select $mainheadid
373 set viewcomplete($view) 0
374 set viewactive($view) 1
375 return 1
378 proc stop_rev_list {view} {
379 global commfd viewinstances leftover
381 foreach inst $viewinstances($view) {
382 set fd $commfd($inst)
383 catch {
384 set pid [pid $fd]
385 exec kill $pid
387 catch {close $fd}
388 nukefile $fd
389 unset commfd($inst)
390 unset leftover($inst)
392 set viewinstances($view) {}
395 proc getcommits {} {
396 global canv curview need_redisplay viewactive
398 initlayout
399 if {[start_rev_list $curview]} {
400 show_status [mc "Reading commits..."]
401 set need_redisplay 1
402 } else {
403 show_status [mc "No commits selected"]
407 proc updatecommits {} {
408 global curview vcanopt vorigargs vfilelimit viewinstances
409 global viewactive viewcomplete loginstance tclencoding
410 global startmsecs commfd showneartags showlocalchanges leftover
411 global mainheadid pending_select
412 global isworktree
413 global varcid vposids vnegids vflags vrevs
415 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
416 set oldmainid $mainheadid
417 rereadrefs
418 if {$showlocalchanges} {
419 if {$mainheadid ne $oldmainid} {
420 dohidelocalchanges
422 if {[commitinview $mainheadid $curview]} {
423 dodiffindex
426 set view $curview
427 if {$vcanopt($view)} {
428 set oldpos $vposids($view)
429 set oldneg $vnegids($view)
430 set revs [parseviewrevs $view $vrevs($view)]
431 if {$revs eq {}} {
432 return
434 # note: getting the delta when negative refs change is hard,
435 # and could require multiple git log invocations, so in that
436 # case we ask git log for all the commits (not just the delta)
437 if {$oldneg eq $vnegids($view)} {
438 set newrevs {}
439 set npos 0
440 # take out positive refs that we asked for before or
441 # that we have already seen
442 foreach rev $revs {
443 if {[string length $rev] == 40} {
444 if {[lsearch -exact $oldpos $rev] < 0
445 && ![info exists varcid($view,$rev)]} {
446 lappend newrevs $rev
447 incr npos
449 } else {
450 lappend $newrevs $rev
453 if {$npos == 0} return
454 set revs $newrevs
455 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
457 set args [concat $vflags($view) $revs --not $oldpos]
458 } else {
459 set args $vorigargs($view)
461 if {[catch {
462 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
463 --boundary $args "--" $vfilelimit($view)] r]
464 } err]} {
465 error_popup "Error executing git log: $err"
466 return
468 if {$viewactive($view) == 0} {
469 set startmsecs [clock clicks -milliseconds]
471 set i [incr loginstance]
472 lappend viewinstances($view) $i
473 set commfd($i) $fd
474 set leftover($i) {}
475 fconfigure $fd -blocking 0 -translation lf -eofchar {}
476 if {$tclencoding != {}} {
477 fconfigure $fd -encoding $tclencoding
479 filerun $fd [list getcommitlines $fd $i $view 1]
480 incr viewactive($view)
481 set viewcomplete($view) 0
482 set pending_select $mainheadid
483 nowbusy $view "Reading"
484 if {$showneartags} {
485 getallcommits
489 proc reloadcommits {} {
490 global curview viewcomplete selectedline currentid thickerline
491 global showneartags treediffs commitinterest cached_commitrow
492 global targetid
494 if {!$viewcomplete($curview)} {
495 stop_rev_list $curview
497 resetvarcs $curview
498 set selectedline {}
499 catch {unset currentid}
500 catch {unset thickerline}
501 catch {unset treediffs}
502 readrefs
503 changedrefs
504 if {$showneartags} {
505 getallcommits
507 clear_display
508 catch {unset commitinterest}
509 catch {unset cached_commitrow}
510 catch {unset targetid}
511 setcanvscroll
512 getcommits
513 return 0
516 # This makes a string representation of a positive integer which
517 # sorts as a string in numerical order
518 proc strrep {n} {
519 if {$n < 16} {
520 return [format "%x" $n]
521 } elseif {$n < 256} {
522 return [format "x%.2x" $n]
523 } elseif {$n < 65536} {
524 return [format "y%.4x" $n]
526 return [format "z%.8x" $n]
529 # Procedures used in reordering commits from git log (without
530 # --topo-order) into the order for display.
532 proc varcinit {view} {
533 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
534 global vtokmod varcmod vrowmod varcix vlastins
536 set varcstart($view) {{}}
537 set vupptr($view) {0}
538 set vdownptr($view) {0}
539 set vleftptr($view) {0}
540 set vbackptr($view) {0}
541 set varctok($view) {{}}
542 set varcrow($view) {{}}
543 set vtokmod($view) {}
544 set varcmod($view) 0
545 set vrowmod($view) 0
546 set varcix($view) {{}}
547 set vlastins($view) {0}
550 proc resetvarcs {view} {
551 global varcid varccommits parents children vseedcount ordertok
553 foreach vid [array names varcid $view,*] {
554 unset varcid($vid)
555 unset children($vid)
556 unset parents($vid)
558 # some commits might have children but haven't been seen yet
559 foreach vid [array names children $view,*] {
560 unset children($vid)
562 foreach va [array names varccommits $view,*] {
563 unset varccommits($va)
565 foreach vd [array names vseedcount $view,*] {
566 unset vseedcount($vd)
568 catch {unset ordertok}
571 # returns a list of the commits with no children
572 proc seeds {v} {
573 global vdownptr vleftptr varcstart
575 set ret {}
576 set a [lindex $vdownptr($v) 0]
577 while {$a != 0} {
578 lappend ret [lindex $varcstart($v) $a]
579 set a [lindex $vleftptr($v) $a]
581 return $ret
584 proc newvarc {view id} {
585 global varcid varctok parents children vdatemode
586 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
587 global commitdata commitinfo vseedcount varccommits vlastins
589 set a [llength $varctok($view)]
590 set vid $view,$id
591 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
592 if {![info exists commitinfo($id)]} {
593 parsecommit $id $commitdata($id) 1
595 set cdate [lindex $commitinfo($id) 4]
596 if {![string is integer -strict $cdate]} {
597 set cdate 0
599 if {![info exists vseedcount($view,$cdate)]} {
600 set vseedcount($view,$cdate) -1
602 set c [incr vseedcount($view,$cdate)]
603 set cdate [expr {$cdate ^ 0xffffffff}]
604 set tok "s[strrep $cdate][strrep $c]"
605 } else {
606 set tok {}
608 set ka 0
609 if {[llength $children($vid)] > 0} {
610 set kid [lindex $children($vid) end]
611 set k $varcid($view,$kid)
612 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
613 set ki $kid
614 set ka $k
615 set tok [lindex $varctok($view) $k]
618 if {$ka != 0} {
619 set i [lsearch -exact $parents($view,$ki) $id]
620 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
621 append tok [strrep $j]
623 set c [lindex $vlastins($view) $ka]
624 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
625 set c $ka
626 set b [lindex $vdownptr($view) $ka]
627 } else {
628 set b [lindex $vleftptr($view) $c]
630 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
631 set c $b
632 set b [lindex $vleftptr($view) $c]
634 if {$c == $ka} {
635 lset vdownptr($view) $ka $a
636 lappend vbackptr($view) 0
637 } else {
638 lset vleftptr($view) $c $a
639 lappend vbackptr($view) $c
641 lset vlastins($view) $ka $a
642 lappend vupptr($view) $ka
643 lappend vleftptr($view) $b
644 if {$b != 0} {
645 lset vbackptr($view) $b $a
647 lappend varctok($view) $tok
648 lappend varcstart($view) $id
649 lappend vdownptr($view) 0
650 lappend varcrow($view) {}
651 lappend varcix($view) {}
652 set varccommits($view,$a) {}
653 lappend vlastins($view) 0
654 return $a
657 proc splitvarc {p v} {
658 global varcid varcstart varccommits varctok
659 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
661 set oa $varcid($v,$p)
662 set ac $varccommits($v,$oa)
663 set i [lsearch -exact $varccommits($v,$oa) $p]
664 if {$i <= 0} return
665 set na [llength $varctok($v)]
666 # "%" sorts before "0"...
667 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
668 lappend varctok($v) $tok
669 lappend varcrow($v) {}
670 lappend varcix($v) {}
671 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
672 set varccommits($v,$na) [lrange $ac $i end]
673 lappend varcstart($v) $p
674 foreach id $varccommits($v,$na) {
675 set varcid($v,$id) $na
677 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
678 lappend vlastins($v) [lindex $vlastins($v) $oa]
679 lset vdownptr($v) $oa $na
680 lset vlastins($v) $oa 0
681 lappend vupptr($v) $oa
682 lappend vleftptr($v) 0
683 lappend vbackptr($v) 0
684 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
685 lset vupptr($v) $b $na
689 proc renumbervarc {a v} {
690 global parents children varctok varcstart varccommits
691 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
693 set t1 [clock clicks -milliseconds]
694 set todo {}
695 set isrelated($a) 1
696 set kidchanged($a) 1
697 set ntot 0
698 while {$a != 0} {
699 if {[info exists isrelated($a)]} {
700 lappend todo $a
701 set id [lindex $varccommits($v,$a) end]
702 foreach p $parents($v,$id) {
703 if {[info exists varcid($v,$p)]} {
704 set isrelated($varcid($v,$p)) 1
708 incr ntot
709 set b [lindex $vdownptr($v) $a]
710 if {$b == 0} {
711 while {$a != 0} {
712 set b [lindex $vleftptr($v) $a]
713 if {$b != 0} break
714 set a [lindex $vupptr($v) $a]
717 set a $b
719 foreach a $todo {
720 if {![info exists kidchanged($a)]} continue
721 set id [lindex $varcstart($v) $a]
722 if {[llength $children($v,$id)] > 1} {
723 set children($v,$id) [lsort -command [list vtokcmp $v] \
724 $children($v,$id)]
726 set oldtok [lindex $varctok($v) $a]
727 if {!$vdatemode($v)} {
728 set tok {}
729 } else {
730 set tok $oldtok
732 set ka 0
733 set kid [last_real_child $v,$id]
734 if {$kid ne {}} {
735 set k $varcid($v,$kid)
736 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
737 set ki $kid
738 set ka $k
739 set tok [lindex $varctok($v) $k]
742 if {$ka != 0} {
743 set i [lsearch -exact $parents($v,$ki) $id]
744 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
745 append tok [strrep $j]
747 if {$tok eq $oldtok} {
748 continue
750 set id [lindex $varccommits($v,$a) end]
751 foreach p $parents($v,$id) {
752 if {[info exists varcid($v,$p)]} {
753 set kidchanged($varcid($v,$p)) 1
754 } else {
755 set sortkids($p) 1
758 lset varctok($v) $a $tok
759 set b [lindex $vupptr($v) $a]
760 if {$b != $ka} {
761 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
762 modify_arc $v $ka
764 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
765 modify_arc $v $b
767 set c [lindex $vbackptr($v) $a]
768 set d [lindex $vleftptr($v) $a]
769 if {$c == 0} {
770 lset vdownptr($v) $b $d
771 } else {
772 lset vleftptr($v) $c $d
774 if {$d != 0} {
775 lset vbackptr($v) $d $c
777 if {[lindex $vlastins($v) $b] == $a} {
778 lset vlastins($v) $b $c
780 lset vupptr($v) $a $ka
781 set c [lindex $vlastins($v) $ka]
782 if {$c == 0 || \
783 [string compare $tok [lindex $varctok($v) $c]] < 0} {
784 set c $ka
785 set b [lindex $vdownptr($v) $ka]
786 } else {
787 set b [lindex $vleftptr($v) $c]
789 while {$b != 0 && \
790 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
791 set c $b
792 set b [lindex $vleftptr($v) $c]
794 if {$c == $ka} {
795 lset vdownptr($v) $ka $a
796 lset vbackptr($v) $a 0
797 } else {
798 lset vleftptr($v) $c $a
799 lset vbackptr($v) $a $c
801 lset vleftptr($v) $a $b
802 if {$b != 0} {
803 lset vbackptr($v) $b $a
805 lset vlastins($v) $ka $a
808 foreach id [array names sortkids] {
809 if {[llength $children($v,$id)] > 1} {
810 set children($v,$id) [lsort -command [list vtokcmp $v] \
811 $children($v,$id)]
814 set t2 [clock clicks -milliseconds]
815 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
818 # Fix up the graph after we have found out that in view $v,
819 # $p (a commit that we have already seen) is actually the parent
820 # of the last commit in arc $a.
821 proc fix_reversal {p a v} {
822 global varcid varcstart varctok vupptr
824 set pa $varcid($v,$p)
825 if {$p ne [lindex $varcstart($v) $pa]} {
826 splitvarc $p $v
827 set pa $varcid($v,$p)
829 # seeds always need to be renumbered
830 if {[lindex $vupptr($v) $pa] == 0 ||
831 [string compare [lindex $varctok($v) $a] \
832 [lindex $varctok($v) $pa]] > 0} {
833 renumbervarc $pa $v
837 proc insertrow {id p v} {
838 global cmitlisted children parents varcid varctok vtokmod
839 global varccommits ordertok commitidx numcommits curview
840 global targetid targetrow
842 readcommit $id
843 set vid $v,$id
844 set cmitlisted($vid) 1
845 set children($vid) {}
846 set parents($vid) [list $p]
847 set a [newvarc $v $id]
848 set varcid($vid) $a
849 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
850 modify_arc $v $a
852 lappend varccommits($v,$a) $id
853 set vp $v,$p
854 if {[llength [lappend children($vp) $id]] > 1} {
855 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
856 catch {unset ordertok}
858 fix_reversal $p $a $v
859 incr commitidx($v)
860 if {$v == $curview} {
861 set numcommits $commitidx($v)
862 setcanvscroll
863 if {[info exists targetid]} {
864 if {![comes_before $targetid $p]} {
865 incr targetrow
871 proc insertfakerow {id p} {
872 global varcid varccommits parents children cmitlisted
873 global commitidx varctok vtokmod targetid targetrow curview numcommits
875 set v $curview
876 set a $varcid($v,$p)
877 set i [lsearch -exact $varccommits($v,$a) $p]
878 if {$i < 0} {
879 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
880 return
882 set children($v,$id) {}
883 set parents($v,$id) [list $p]
884 set varcid($v,$id) $a
885 lappend children($v,$p) $id
886 set cmitlisted($v,$id) 1
887 set numcommits [incr commitidx($v)]
888 # note we deliberately don't update varcstart($v) even if $i == 0
889 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
890 modify_arc $v $a $i
891 if {[info exists targetid]} {
892 if {![comes_before $targetid $p]} {
893 incr targetrow
896 setcanvscroll
897 drawvisible
900 proc removefakerow {id} {
901 global varcid varccommits parents children commitidx
902 global varctok vtokmod cmitlisted currentid selectedline
903 global targetid curview numcommits
905 set v $curview
906 if {[llength $parents($v,$id)] != 1} {
907 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
908 return
910 set p [lindex $parents($v,$id) 0]
911 set a $varcid($v,$id)
912 set i [lsearch -exact $varccommits($v,$a) $id]
913 if {$i < 0} {
914 puts "oops: removefakerow can't find [shortids $id] on arc $a"
915 return
917 unset varcid($v,$id)
918 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
919 unset parents($v,$id)
920 unset children($v,$id)
921 unset cmitlisted($v,$id)
922 set numcommits [incr commitidx($v) -1]
923 set j [lsearch -exact $children($v,$p) $id]
924 if {$j >= 0} {
925 set children($v,$p) [lreplace $children($v,$p) $j $j]
927 modify_arc $v $a $i
928 if {[info exist currentid] && $id eq $currentid} {
929 unset currentid
930 set selectedline {}
932 if {[info exists targetid] && $targetid eq $id} {
933 set targetid $p
935 setcanvscroll
936 drawvisible
939 proc first_real_child {vp} {
940 global children nullid nullid2
942 foreach id $children($vp) {
943 if {$id ne $nullid && $id ne $nullid2} {
944 return $id
947 return {}
950 proc last_real_child {vp} {
951 global children nullid nullid2
953 set kids $children($vp)
954 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
955 set id [lindex $kids $i]
956 if {$id ne $nullid && $id ne $nullid2} {
957 return $id
960 return {}
963 proc vtokcmp {v a b} {
964 global varctok varcid
966 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
967 [lindex $varctok($v) $varcid($v,$b)]]
970 # This assumes that if lim is not given, the caller has checked that
971 # arc a's token is less than $vtokmod($v)
972 proc modify_arc {v a {lim {}}} {
973 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
975 if {$lim ne {}} {
976 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
977 if {$c > 0} return
978 if {$c == 0} {
979 set r [lindex $varcrow($v) $a]
980 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
983 set vtokmod($v) [lindex $varctok($v) $a]
984 set varcmod($v) $a
985 if {$v == $curview} {
986 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
987 set a [lindex $vupptr($v) $a]
988 set lim {}
990 set r 0
991 if {$a != 0} {
992 if {$lim eq {}} {
993 set lim [llength $varccommits($v,$a)]
995 set r [expr {[lindex $varcrow($v) $a] + $lim}]
997 set vrowmod($v) $r
998 undolayout $r
1002 proc update_arcrows {v} {
1003 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1004 global varcid vrownum varcorder varcix varccommits
1005 global vupptr vdownptr vleftptr varctok
1006 global displayorder parentlist curview cached_commitrow
1008 if {$vrowmod($v) == $commitidx($v)} return
1009 if {$v == $curview} {
1010 if {[llength $displayorder] > $vrowmod($v)} {
1011 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1012 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1014 catch {unset cached_commitrow}
1016 set narctot [expr {[llength $varctok($v)] - 1}]
1017 set a $varcmod($v)
1018 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1019 # go up the tree until we find something that has a row number,
1020 # or we get to a seed
1021 set a [lindex $vupptr($v) $a]
1023 if {$a == 0} {
1024 set a [lindex $vdownptr($v) 0]
1025 if {$a == 0} return
1026 set vrownum($v) {0}
1027 set varcorder($v) [list $a]
1028 lset varcix($v) $a 0
1029 lset varcrow($v) $a 0
1030 set arcn 0
1031 set row 0
1032 } else {
1033 set arcn [lindex $varcix($v) $a]
1034 if {[llength $vrownum($v)] > $arcn + 1} {
1035 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1036 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1038 set row [lindex $varcrow($v) $a]
1040 while {1} {
1041 set p $a
1042 incr row [llength $varccommits($v,$a)]
1043 # go down if possible
1044 set b [lindex $vdownptr($v) $a]
1045 if {$b == 0} {
1046 # if not, go left, or go up until we can go left
1047 while {$a != 0} {
1048 set b [lindex $vleftptr($v) $a]
1049 if {$b != 0} break
1050 set a [lindex $vupptr($v) $a]
1052 if {$a == 0} break
1054 set a $b
1055 incr arcn
1056 lappend vrownum($v) $row
1057 lappend varcorder($v) $a
1058 lset varcix($v) $a $arcn
1059 lset varcrow($v) $a $row
1061 set vtokmod($v) [lindex $varctok($v) $p]
1062 set varcmod($v) $p
1063 set vrowmod($v) $row
1064 if {[info exists currentid]} {
1065 set selectedline [rowofcommit $currentid]
1069 # Test whether view $v contains commit $id
1070 proc commitinview {id v} {
1071 global varcid
1073 return [info exists varcid($v,$id)]
1076 # Return the row number for commit $id in the current view
1077 proc rowofcommit {id} {
1078 global varcid varccommits varcrow curview cached_commitrow
1079 global varctok vtokmod
1081 set v $curview
1082 if {![info exists varcid($v,$id)]} {
1083 puts "oops rowofcommit no arc for [shortids $id]"
1084 return {}
1086 set a $varcid($v,$id)
1087 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1088 update_arcrows $v
1090 if {[info exists cached_commitrow($id)]} {
1091 return $cached_commitrow($id)
1093 set i [lsearch -exact $varccommits($v,$a) $id]
1094 if {$i < 0} {
1095 puts "oops didn't find commit [shortids $id] in arc $a"
1096 return {}
1098 incr i [lindex $varcrow($v) $a]
1099 set cached_commitrow($id) $i
1100 return $i
1103 # Returns 1 if a is on an earlier row than b, otherwise 0
1104 proc comes_before {a b} {
1105 global varcid varctok curview
1107 set v $curview
1108 if {$a eq $b || ![info exists varcid($v,$a)] || \
1109 ![info exists varcid($v,$b)]} {
1110 return 0
1112 if {$varcid($v,$a) != $varcid($v,$b)} {
1113 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1114 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1116 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1119 proc bsearch {l elt} {
1120 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1121 return 0
1123 set lo 0
1124 set hi [llength $l]
1125 while {$hi - $lo > 1} {
1126 set mid [expr {int(($lo + $hi) / 2)}]
1127 set t [lindex $l $mid]
1128 if {$elt < $t} {
1129 set hi $mid
1130 } elseif {$elt > $t} {
1131 set lo $mid
1132 } else {
1133 return $mid
1136 return $lo
1139 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1140 proc make_disporder {start end} {
1141 global vrownum curview commitidx displayorder parentlist
1142 global varccommits varcorder parents vrowmod varcrow
1143 global d_valid_start d_valid_end
1145 if {$end > $vrowmod($curview)} {
1146 update_arcrows $curview
1148 set ai [bsearch $vrownum($curview) $start]
1149 set start [lindex $vrownum($curview) $ai]
1150 set narc [llength $vrownum($curview)]
1151 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1152 set a [lindex $varcorder($curview) $ai]
1153 set l [llength $displayorder]
1154 set al [llength $varccommits($curview,$a)]
1155 if {$l < $r + $al} {
1156 if {$l < $r} {
1157 set pad [ntimes [expr {$r - $l}] {}]
1158 set displayorder [concat $displayorder $pad]
1159 set parentlist [concat $parentlist $pad]
1160 } elseif {$l > $r} {
1161 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1162 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1164 foreach id $varccommits($curview,$a) {
1165 lappend displayorder $id
1166 lappend parentlist $parents($curview,$id)
1168 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1169 set i $r
1170 foreach id $varccommits($curview,$a) {
1171 lset displayorder $i $id
1172 lset parentlist $i $parents($curview,$id)
1173 incr i
1176 incr r $al
1180 proc commitonrow {row} {
1181 global displayorder
1183 set id [lindex $displayorder $row]
1184 if {$id eq {}} {
1185 make_disporder $row [expr {$row + 1}]
1186 set id [lindex $displayorder $row]
1188 return $id
1191 proc closevarcs {v} {
1192 global varctok varccommits varcid parents children
1193 global cmitlisted commitidx commitinterest vtokmod
1195 set missing_parents 0
1196 set scripts {}
1197 set narcs [llength $varctok($v)]
1198 for {set a 1} {$a < $narcs} {incr a} {
1199 set id [lindex $varccommits($v,$a) end]
1200 foreach p $parents($v,$id) {
1201 if {[info exists varcid($v,$p)]} continue
1202 # add p as a new commit
1203 incr missing_parents
1204 set cmitlisted($v,$p) 0
1205 set parents($v,$p) {}
1206 if {[llength $children($v,$p)] == 1 &&
1207 [llength $parents($v,$id)] == 1} {
1208 set b $a
1209 } else {
1210 set b [newvarc $v $p]
1212 set varcid($v,$p) $b
1213 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1214 modify_arc $v $b
1216 lappend varccommits($v,$b) $p
1217 incr commitidx($v)
1218 if {[info exists commitinterest($p)]} {
1219 foreach script $commitinterest($p) {
1220 lappend scripts [string map [list "%I" $p] $script]
1222 unset commitinterest($id)
1226 if {$missing_parents > 0} {
1227 foreach s $scripts {
1228 eval $s
1233 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1234 # Assumes we already have an arc for $rwid.
1235 proc rewrite_commit {v id rwid} {
1236 global children parents varcid varctok vtokmod varccommits
1238 foreach ch $children($v,$id) {
1239 # make $rwid be $ch's parent in place of $id
1240 set i [lsearch -exact $parents($v,$ch) $id]
1241 if {$i < 0} {
1242 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1244 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1245 # add $ch to $rwid's children and sort the list if necessary
1246 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1247 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1248 $children($v,$rwid)]
1250 # fix the graph after joining $id to $rwid
1251 set a $varcid($v,$ch)
1252 fix_reversal $rwid $a $v
1253 # parentlist is wrong for the last element of arc $a
1254 # even if displayorder is right, hence the 3rd arg here
1255 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1259 proc getcommitlines {fd inst view updating} {
1260 global cmitlisted commitinterest leftover
1261 global commitidx commitdata vdatemode
1262 global parents children curview hlview
1263 global idpending ordertok
1264 global varccommits varcid varctok vtokmod vfilelimit
1266 set stuff [read $fd 500000]
1267 # git log doesn't terminate the last commit with a null...
1268 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1269 set stuff "\0"
1271 if {$stuff == {}} {
1272 if {![eof $fd]} {
1273 return 1
1275 global commfd viewcomplete viewactive viewname
1276 global viewinstances
1277 unset commfd($inst)
1278 set i [lsearch -exact $viewinstances($view) $inst]
1279 if {$i >= 0} {
1280 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1282 # set it blocking so we wait for the process to terminate
1283 fconfigure $fd -blocking 1
1284 if {[catch {close $fd} err]} {
1285 set fv {}
1286 if {$view != $curview} {
1287 set fv " for the \"$viewname($view)\" view"
1289 if {[string range $err 0 4] == "usage"} {
1290 set err "Gitk: error reading commits$fv:\
1291 bad arguments to git log."
1292 if {$viewname($view) eq "Command line"} {
1293 append err \
1294 " (Note: arguments to gitk are passed to git log\
1295 to allow selection of commits to be displayed.)"
1297 } else {
1298 set err "Error reading commits$fv: $err"
1300 error_popup $err
1302 if {[incr viewactive($view) -1] <= 0} {
1303 set viewcomplete($view) 1
1304 # Check if we have seen any ids listed as parents that haven't
1305 # appeared in the list
1306 closevarcs $view
1307 notbusy $view
1309 if {$view == $curview} {
1310 run chewcommits
1312 return 0
1314 set start 0
1315 set gotsome 0
1316 set scripts {}
1317 while 1 {
1318 set i [string first "\0" $stuff $start]
1319 if {$i < 0} {
1320 append leftover($inst) [string range $stuff $start end]
1321 break
1323 if {$start == 0} {
1324 set cmit $leftover($inst)
1325 append cmit [string range $stuff 0 [expr {$i - 1}]]
1326 set leftover($inst) {}
1327 } else {
1328 set cmit [string range $stuff $start [expr {$i - 1}]]
1330 set start [expr {$i + 1}]
1331 set j [string first "\n" $cmit]
1332 set ok 0
1333 set listed 1
1334 if {$j >= 0 && [string match "commit *" $cmit]} {
1335 set ids [string range $cmit 7 [expr {$j - 1}]]
1336 if {[string match {[-^<>]*} $ids]} {
1337 switch -- [string index $ids 0] {
1338 "-" {set listed 0}
1339 "^" {set listed 2}
1340 "<" {set listed 3}
1341 ">" {set listed 4}
1343 set ids [string range $ids 1 end]
1345 set ok 1
1346 foreach id $ids {
1347 if {[string length $id] != 40} {
1348 set ok 0
1349 break
1353 if {!$ok} {
1354 set shortcmit $cmit
1355 if {[string length $shortcmit] > 80} {
1356 set shortcmit "[string range $shortcmit 0 80]..."
1358 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1359 exit 1
1361 set id [lindex $ids 0]
1362 set vid $view,$id
1364 if {!$listed && $updating && ![info exists varcid($vid)] &&
1365 $vfilelimit($view) ne {}} {
1366 # git log doesn't rewrite parents for unlisted commits
1367 # when doing path limiting, so work around that here
1368 # by working out the rewritten parent with git rev-list
1369 # and if we already know about it, using the rewritten
1370 # parent as a substitute parent for $id's children.
1371 if {![catch {
1372 set rwid [exec git rev-list --first-parent --max-count=1 \
1373 $id -- $vfilelimit($view)]
1374 }]} {
1375 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1376 # use $rwid in place of $id
1377 rewrite_commit $view $id $rwid
1378 continue
1383 set a 0
1384 if {[info exists varcid($vid)]} {
1385 if {$cmitlisted($vid) || !$listed} continue
1386 set a $varcid($vid)
1388 if {$listed} {
1389 set olds [lrange $ids 1 end]
1390 } else {
1391 set olds {}
1393 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1394 set cmitlisted($vid) $listed
1395 set parents($vid) $olds
1396 if {![info exists children($vid)]} {
1397 set children($vid) {}
1398 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1399 set k [lindex $children($vid) 0]
1400 if {[llength $parents($view,$k)] == 1 &&
1401 (!$vdatemode($view) ||
1402 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1403 set a $varcid($view,$k)
1406 if {$a == 0} {
1407 # new arc
1408 set a [newvarc $view $id]
1410 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1411 modify_arc $view $a
1413 if {![info exists varcid($vid)]} {
1414 set varcid($vid) $a
1415 lappend varccommits($view,$a) $id
1416 incr commitidx($view)
1419 set i 0
1420 foreach p $olds {
1421 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1422 set vp $view,$p
1423 if {[llength [lappend children($vp) $id]] > 1 &&
1424 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1425 set children($vp) [lsort -command [list vtokcmp $view] \
1426 $children($vp)]
1427 catch {unset ordertok}
1429 if {[info exists varcid($view,$p)]} {
1430 fix_reversal $p $a $view
1433 incr i
1436 if {[info exists commitinterest($id)]} {
1437 foreach script $commitinterest($id) {
1438 lappend scripts [string map [list "%I" $id] $script]
1440 unset commitinterest($id)
1442 set gotsome 1
1444 if {$gotsome} {
1445 global numcommits hlview
1447 if {$view == $curview} {
1448 set numcommits $commitidx($view)
1449 run chewcommits
1451 if {[info exists hlview] && $view == $hlview} {
1452 # we never actually get here...
1453 run vhighlightmore
1455 foreach s $scripts {
1456 eval $s
1459 return 2
1462 proc chewcommits {} {
1463 global curview hlview viewcomplete
1464 global pending_select
1466 layoutmore
1467 if {$viewcomplete($curview)} {
1468 global commitidx varctok
1469 global numcommits startmsecs
1471 if {[info exists pending_select]} {
1472 set row [first_real_row]
1473 selectline $row 1
1475 if {$commitidx($curview) > 0} {
1476 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1477 #puts "overall $ms ms for $numcommits commits"
1478 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1479 } else {
1480 show_status [mc "No commits selected"]
1482 notbusy layout
1484 return 0
1487 proc readcommit {id} {
1488 if {[catch {set contents [exec git cat-file commit $id]}]} return
1489 parsecommit $id $contents 0
1492 proc parsecommit {id contents listed} {
1493 global commitinfo cdate
1495 set inhdr 1
1496 set comment {}
1497 set headline {}
1498 set auname {}
1499 set audate {}
1500 set comname {}
1501 set comdate {}
1502 set hdrend [string first "\n\n" $contents]
1503 if {$hdrend < 0} {
1504 # should never happen...
1505 set hdrend [string length $contents]
1507 set header [string range $contents 0 [expr {$hdrend - 1}]]
1508 set comment [string range $contents [expr {$hdrend + 2}] end]
1509 foreach line [split $header "\n"] {
1510 set tag [lindex $line 0]
1511 if {$tag == "author"} {
1512 set audate [lindex $line end-1]
1513 set auname [lrange $line 1 end-2]
1514 } elseif {$tag == "committer"} {
1515 set comdate [lindex $line end-1]
1516 set comname [lrange $line 1 end-2]
1519 set headline {}
1520 # take the first non-blank line of the comment as the headline
1521 set headline [string trimleft $comment]
1522 set i [string first "\n" $headline]
1523 if {$i >= 0} {
1524 set headline [string range $headline 0 $i]
1526 set headline [string trimright $headline]
1527 set i [string first "\r" $headline]
1528 if {$i >= 0} {
1529 set headline [string trimright [string range $headline 0 $i]]
1531 if {!$listed} {
1532 # git log indents the comment by 4 spaces;
1533 # if we got this via git cat-file, add the indentation
1534 set newcomment {}
1535 foreach line [split $comment "\n"] {
1536 append newcomment " "
1537 append newcomment $line
1538 append newcomment "\n"
1540 set comment $newcomment
1542 if {$comdate != {}} {
1543 set cdate($id) $comdate
1545 set commitinfo($id) [list $headline $auname $audate \
1546 $comname $comdate $comment]
1549 proc getcommit {id} {
1550 global commitdata commitinfo
1552 if {[info exists commitdata($id)]} {
1553 parsecommit $id $commitdata($id) 1
1554 } else {
1555 readcommit $id
1556 if {![info exists commitinfo($id)]} {
1557 set commitinfo($id) [list [mc "No commit information available"]]
1560 return 1
1563 proc readrefs {} {
1564 global tagids idtags headids idheads tagobjid
1565 global otherrefids idotherrefs mainhead mainheadid
1567 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1568 catch {unset $v}
1570 set refd [open [list | git show-ref -d] r]
1571 while {[gets $refd line] >= 0} {
1572 if {[string index $line 40] ne " "} continue
1573 set id [string range $line 0 39]
1574 set ref [string range $line 41 end]
1575 if {![string match "refs/*" $ref]} continue
1576 set name [string range $ref 5 end]
1577 if {[string match "remotes/*" $name]} {
1578 if {![string match "*/HEAD" $name]} {
1579 set headids($name) $id
1580 lappend idheads($id) $name
1582 } elseif {[string match "heads/*" $name]} {
1583 set name [string range $name 6 end]
1584 set headids($name) $id
1585 lappend idheads($id) $name
1586 } elseif {[string match "tags/*" $name]} {
1587 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1588 # which is what we want since the former is the commit ID
1589 set name [string range $name 5 end]
1590 if {[string match "*^{}" $name]} {
1591 set name [string range $name 0 end-3]
1592 } else {
1593 set tagobjid($name) $id
1595 set tagids($name) $id
1596 lappend idtags($id) $name
1597 } else {
1598 set otherrefids($name) $id
1599 lappend idotherrefs($id) $name
1602 catch {close $refd}
1603 set mainhead {}
1604 set mainheadid {}
1605 catch {
1606 set mainheadid [exec git rev-parse HEAD]
1607 set thehead [exec git symbolic-ref HEAD]
1608 if {[string match "refs/heads/*" $thehead]} {
1609 set mainhead [string range $thehead 11 end]
1614 # skip over fake commits
1615 proc first_real_row {} {
1616 global nullid nullid2 numcommits
1618 for {set row 0} {$row < $numcommits} {incr row} {
1619 set id [commitonrow $row]
1620 if {$id ne $nullid && $id ne $nullid2} {
1621 break
1624 return $row
1627 # update things for a head moved to a child of its previous location
1628 proc movehead {id name} {
1629 global headids idheads
1631 removehead $headids($name) $name
1632 set headids($name) $id
1633 lappend idheads($id) $name
1636 # update things when a head has been removed
1637 proc removehead {id name} {
1638 global headids idheads
1640 if {$idheads($id) eq $name} {
1641 unset idheads($id)
1642 } else {
1643 set i [lsearch -exact $idheads($id) $name]
1644 if {$i >= 0} {
1645 set idheads($id) [lreplace $idheads($id) $i $i]
1648 unset headids($name)
1651 proc show_error {w top msg} {
1652 message $w.m -text $msg -justify center -aspect 400
1653 pack $w.m -side top -fill x -padx 20 -pady 20
1654 button $w.ok -text [mc OK] -command "destroy $top"
1655 pack $w.ok -side bottom -fill x
1656 bind $top <Visibility> "grab $top; focus $top"
1657 bind $top <Key-Return> "destroy $top"
1658 tkwait window $top
1661 proc error_popup msg {
1662 set w .error
1663 toplevel $w
1664 wm transient $w .
1665 show_error $w $w $msg
1668 proc confirm_popup msg {
1669 global confirm_ok
1670 set confirm_ok 0
1671 set w .confirm
1672 toplevel $w
1673 wm transient $w .
1674 message $w.m -text $msg -justify center -aspect 400
1675 pack $w.m -side top -fill x -padx 20 -pady 20
1676 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1677 pack $w.ok -side left -fill x
1678 button $w.cancel -text [mc Cancel] -command "destroy $w"
1679 pack $w.cancel -side right -fill x
1680 bind $w <Visibility> "grab $w; focus $w"
1681 tkwait window $w
1682 return $confirm_ok
1685 proc setoptions {} {
1686 option add *Panedwindow.showHandle 1 startupFile
1687 option add *Panedwindow.sashRelief raised startupFile
1688 option add *Button.font uifont startupFile
1689 option add *Checkbutton.font uifont startupFile
1690 option add *Radiobutton.font uifont startupFile
1691 option add *Menu.font uifont startupFile
1692 option add *Menubutton.font uifont startupFile
1693 option add *Label.font uifont startupFile
1694 option add *Message.font uifont startupFile
1695 option add *Entry.font uifont startupFile
1698 proc makewindow {} {
1699 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1700 global tabstop
1701 global findtype findtypemenu findloc findstring fstring geometry
1702 global entries sha1entry sha1string sha1but
1703 global diffcontextstring diffcontext
1704 global ignorespace
1705 global maincursor textcursor curtextcursor
1706 global rowctxmenu fakerowmenu mergemax wrapcomment
1707 global highlight_files gdttype
1708 global searchstring sstring
1709 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1710 global headctxmenu progresscanv progressitem progresscoords statusw
1711 global fprogitem fprogcoord lastprogupdate progupdatepending
1712 global rprogitem rprogcoord rownumsel numcommits
1713 global have_tk85
1715 menu .bar
1716 .bar add cascade -label [mc "File"] -menu .bar.file
1717 menu .bar.file
1718 .bar.file add command -label [mc "Update"] -command updatecommits
1719 .bar.file add command -label [mc "Reload"] -command reloadcommits
1720 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1721 .bar.file add command -label [mc "List references"] -command showrefs
1722 .bar.file add command -label [mc "Quit"] -command doquit
1723 menu .bar.edit
1724 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1725 .bar.edit add command -label [mc "Preferences"] -command doprefs
1727 menu .bar.view
1728 .bar add cascade -label [mc "View"] -menu .bar.view
1729 .bar.view add command -label [mc "New view..."] -command {newview 0}
1730 .bar.view add command -label [mc "Edit view..."] -command editview \
1731 -state disabled
1732 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1733 .bar.view add separator
1734 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1735 -variable selectedview -value 0
1737 menu .bar.help
1738 .bar add cascade -label [mc "Help"] -menu .bar.help
1739 .bar.help add command -label [mc "About gitk"] -command about
1740 .bar.help add command -label [mc "Key bindings"] -command keys
1741 .bar.help configure
1742 . configure -menu .bar
1744 # the gui has upper and lower half, parts of a paned window.
1745 panedwindow .ctop -orient vertical
1747 # possibly use assumed geometry
1748 if {![info exists geometry(pwsash0)]} {
1749 set geometry(topheight) [expr {15 * $linespc}]
1750 set geometry(topwidth) [expr {80 * $charspc}]
1751 set geometry(botheight) [expr {15 * $linespc}]
1752 set geometry(botwidth) [expr {50 * $charspc}]
1753 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1754 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1757 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1758 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1759 frame .tf.histframe
1760 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1762 # create three canvases
1763 set cscroll .tf.histframe.csb
1764 set canv .tf.histframe.pwclist.canv
1765 canvas $canv \
1766 -selectbackground $selectbgcolor \
1767 -background $bgcolor -bd 0 \
1768 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1769 .tf.histframe.pwclist add $canv
1770 set canv2 .tf.histframe.pwclist.canv2
1771 canvas $canv2 \
1772 -selectbackground $selectbgcolor \
1773 -background $bgcolor -bd 0 -yscrollincr $linespc
1774 .tf.histframe.pwclist add $canv2
1775 set canv3 .tf.histframe.pwclist.canv3
1776 canvas $canv3 \
1777 -selectbackground $selectbgcolor \
1778 -background $bgcolor -bd 0 -yscrollincr $linespc
1779 .tf.histframe.pwclist add $canv3
1780 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1781 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1783 # a scroll bar to rule them
1784 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1785 pack $cscroll -side right -fill y
1786 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1787 lappend bglist $canv $canv2 $canv3
1788 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1790 # we have two button bars at bottom of top frame. Bar 1
1791 frame .tf.bar
1792 frame .tf.lbar -height 15
1794 set sha1entry .tf.bar.sha1
1795 set entries $sha1entry
1796 set sha1but .tf.bar.sha1label
1797 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1798 -command gotocommit -width 8
1799 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1800 pack .tf.bar.sha1label -side left
1801 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1802 trace add variable sha1string write sha1change
1803 pack $sha1entry -side left -pady 2
1805 image create bitmap bm-left -data {
1806 #define left_width 16
1807 #define left_height 16
1808 static unsigned char left_bits[] = {
1809 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1810 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1811 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1813 image create bitmap bm-right -data {
1814 #define right_width 16
1815 #define right_height 16
1816 static unsigned char right_bits[] = {
1817 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1818 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1819 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1821 button .tf.bar.leftbut -image bm-left -command goback \
1822 -state disabled -width 26
1823 pack .tf.bar.leftbut -side left -fill y
1824 button .tf.bar.rightbut -image bm-right -command goforw \
1825 -state disabled -width 26
1826 pack .tf.bar.rightbut -side left -fill y
1828 label .tf.bar.rowlabel -text [mc "Row"]
1829 set rownumsel {}
1830 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1831 -relief sunken -anchor e
1832 label .tf.bar.rowlabel2 -text "/"
1833 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1834 -relief sunken -anchor e
1835 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1836 -side left
1837 global selectedline
1838 trace add variable selectedline write selectedline_change
1840 # Status label and progress bar
1841 set statusw .tf.bar.status
1842 label $statusw -width 15 -relief sunken
1843 pack $statusw -side left -padx 5
1844 set h [expr {[font metrics uifont -linespace] + 2}]
1845 set progresscanv .tf.bar.progress
1846 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1847 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1848 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1849 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1850 pack $progresscanv -side right -expand 1 -fill x
1851 set progresscoords {0 0}
1852 set fprogcoord 0
1853 set rprogcoord 0
1854 bind $progresscanv <Configure> adjustprogress
1855 set lastprogupdate [clock clicks -milliseconds]
1856 set progupdatepending 0
1858 # build up the bottom bar of upper window
1859 label .tf.lbar.flabel -text "[mc "Find"] "
1860 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1861 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1862 label .tf.lbar.flab2 -text " [mc "commit"] "
1863 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1864 -side left -fill y
1865 set gdttype [mc "containing:"]
1866 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1867 [mc "containing:"] \
1868 [mc "touching paths:"] \
1869 [mc "adding/removing string:"]]
1870 trace add variable gdttype write gdttype_change
1871 pack .tf.lbar.gdttype -side left -fill y
1873 set findstring {}
1874 set fstring .tf.lbar.findstring
1875 lappend entries $fstring
1876 entry $fstring -width 30 -font textfont -textvariable findstring
1877 trace add variable findstring write find_change
1878 set findtype [mc "Exact"]
1879 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1880 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1881 trace add variable findtype write findcom_change
1882 set findloc [mc "All fields"]
1883 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1884 [mc "Comments"] [mc "Author"] [mc "Committer"]
1885 trace add variable findloc write find_change
1886 pack .tf.lbar.findloc -side right
1887 pack .tf.lbar.findtype -side right
1888 pack $fstring -side left -expand 1 -fill x
1890 # Finish putting the upper half of the viewer together
1891 pack .tf.lbar -in .tf -side bottom -fill x
1892 pack .tf.bar -in .tf -side bottom -fill x
1893 pack .tf.histframe -fill both -side top -expand 1
1894 .ctop add .tf
1895 .ctop paneconfigure .tf -height $geometry(topheight)
1896 .ctop paneconfigure .tf -width $geometry(topwidth)
1898 # now build up the bottom
1899 panedwindow .pwbottom -orient horizontal
1901 # lower left, a text box over search bar, scroll bar to the right
1902 # if we know window height, then that will set the lower text height, otherwise
1903 # we set lower text height which will drive window height
1904 if {[info exists geometry(main)]} {
1905 frame .bleft -width $geometry(botwidth)
1906 } else {
1907 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1909 frame .bleft.top
1910 frame .bleft.mid
1911 frame .bleft.bottom
1913 button .bleft.top.search -text [mc "Search"] -command dosearch
1914 pack .bleft.top.search -side left -padx 5
1915 set sstring .bleft.top.sstring
1916 entry $sstring -width 20 -font textfont -textvariable searchstring
1917 lappend entries $sstring
1918 trace add variable searchstring write incrsearch
1919 pack $sstring -side left -expand 1 -fill x
1920 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1921 -command changediffdisp -variable diffelide -value {0 0}
1922 radiobutton .bleft.mid.old -text [mc "Old version"] \
1923 -command changediffdisp -variable diffelide -value {0 1}
1924 radiobutton .bleft.mid.new -text [mc "New version"] \
1925 -command changediffdisp -variable diffelide -value {1 0}
1926 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1927 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1928 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1929 -from 1 -increment 1 -to 10000000 \
1930 -validate all -validatecommand "diffcontextvalidate %P" \
1931 -textvariable diffcontextstring
1932 .bleft.mid.diffcontext set $diffcontext
1933 trace add variable diffcontextstring write diffcontextchange
1934 lappend entries .bleft.mid.diffcontext
1935 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1936 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1937 -command changeignorespace -variable ignorespace
1938 pack .bleft.mid.ignspace -side left -padx 5
1939 set ctext .bleft.bottom.ctext
1940 text $ctext -background $bgcolor -foreground $fgcolor \
1941 -state disabled -font textfont \
1942 -yscrollcommand scrolltext -wrap none \
1943 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1944 if {$have_tk85} {
1945 $ctext conf -tabstyle wordprocessor
1947 scrollbar .bleft.bottom.sb -command "$ctext yview"
1948 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
1949 -width 10
1950 pack .bleft.top -side top -fill x
1951 pack .bleft.mid -side top -fill x
1952 grid $ctext .bleft.bottom.sb -sticky nsew
1953 grid .bleft.bottom.sbhorizontal -sticky ew
1954 grid columnconfigure .bleft.bottom 0 -weight 1
1955 grid rowconfigure .bleft.bottom 0 -weight 1
1956 grid rowconfigure .bleft.bottom 1 -weight 0
1957 pack .bleft.bottom -side top -fill both -expand 1
1958 lappend bglist $ctext
1959 lappend fglist $ctext
1961 $ctext tag conf comment -wrap $wrapcomment
1962 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1963 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1964 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1965 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1966 $ctext tag conf m0 -fore red
1967 $ctext tag conf m1 -fore blue
1968 $ctext tag conf m2 -fore green
1969 $ctext tag conf m3 -fore purple
1970 $ctext tag conf m4 -fore brown
1971 $ctext tag conf m5 -fore "#009090"
1972 $ctext tag conf m6 -fore magenta
1973 $ctext tag conf m7 -fore "#808000"
1974 $ctext tag conf m8 -fore "#009000"
1975 $ctext tag conf m9 -fore "#ff0080"
1976 $ctext tag conf m10 -fore cyan
1977 $ctext tag conf m11 -fore "#b07070"
1978 $ctext tag conf m12 -fore "#70b0f0"
1979 $ctext tag conf m13 -fore "#70f0b0"
1980 $ctext tag conf m14 -fore "#f0b070"
1981 $ctext tag conf m15 -fore "#ff70b0"
1982 $ctext tag conf mmax -fore darkgrey
1983 set mergemax 16
1984 $ctext tag conf mresult -font textfontbold
1985 $ctext tag conf msep -font textfontbold
1986 $ctext tag conf found -back yellow
1988 .pwbottom add .bleft
1989 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1991 # lower right
1992 frame .bright
1993 frame .bright.mode
1994 radiobutton .bright.mode.patch -text [mc "Patch"] \
1995 -command reselectline -variable cmitmode -value "patch"
1996 radiobutton .bright.mode.tree -text [mc "Tree"] \
1997 -command reselectline -variable cmitmode -value "tree"
1998 grid .bright.mode.patch .bright.mode.tree -sticky ew
1999 pack .bright.mode -side top -fill x
2000 set cflist .bright.cfiles
2001 set indent [font measure mainfont "nn"]
2002 text $cflist \
2003 -selectbackground $selectbgcolor \
2004 -background $bgcolor -foreground $fgcolor \
2005 -font mainfont \
2006 -tabs [list $indent [expr {2 * $indent}]] \
2007 -yscrollcommand ".bright.sb set" \
2008 -cursor [. cget -cursor] \
2009 -spacing1 1 -spacing3 1
2010 lappend bglist $cflist
2011 lappend fglist $cflist
2012 scrollbar .bright.sb -command "$cflist yview"
2013 pack .bright.sb -side right -fill y
2014 pack $cflist -side left -fill both -expand 1
2015 $cflist tag configure highlight \
2016 -background [$cflist cget -selectbackground]
2017 $cflist tag configure bold -font mainfontbold
2019 .pwbottom add .bright
2020 .ctop add .pwbottom
2022 # restore window width & height if known
2023 if {[info exists geometry(main)]} {
2024 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2025 if {$w > [winfo screenwidth .]} {
2026 set w [winfo screenwidth .]
2028 if {$h > [winfo screenheight .]} {
2029 set h [winfo screenheight .]
2031 wm geometry . "${w}x$h"
2035 if {[tk windowingsystem] eq {aqua}} {
2036 set M1B M1
2037 } else {
2038 set M1B Control
2041 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2042 pack .ctop -fill both -expand 1
2043 bindall <1> {selcanvline %W %x %y}
2044 #bindall <B1-Motion> {selcanvline %W %x %y}
2045 if {[tk windowingsystem] == "win32"} {
2046 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2047 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2048 } else {
2049 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2050 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2051 if {[tk windowingsystem] eq "aqua"} {
2052 bindall <MouseWheel> {
2053 set delta [expr {- (%D)}]
2054 allcanvs yview scroll $delta units
2058 bindall <2> "canvscan mark %W %x %y"
2059 bindall <B2-Motion> "canvscan dragto %W %x %y"
2060 bindkey <Home> selfirstline
2061 bindkey <End> sellastline
2062 bind . <Key-Up> "selnextline -1"
2063 bind . <Key-Down> "selnextline 1"
2064 bind . <Shift-Key-Up> "dofind -1 0"
2065 bind . <Shift-Key-Down> "dofind 1 0"
2066 bindkey <Key-Right> "goforw"
2067 bindkey <Key-Left> "goback"
2068 bind . <Key-Prior> "selnextpage -1"
2069 bind . <Key-Next> "selnextpage 1"
2070 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2071 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2072 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2073 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2074 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2075 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2076 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2077 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2078 bindkey <Key-space> "$ctext yview scroll 1 pages"
2079 bindkey p "selnextline -1"
2080 bindkey n "selnextline 1"
2081 bindkey z "goback"
2082 bindkey x "goforw"
2083 bindkey i "selnextline -1"
2084 bindkey k "selnextline 1"
2085 bindkey j "goback"
2086 bindkey l "goforw"
2087 bindkey b prevfile
2088 bindkey d "$ctext yview scroll 18 units"
2089 bindkey u "$ctext yview scroll -18 units"
2090 bindkey / {dofind 1 1}
2091 bindkey <Key-Return> {dofind 1 1}
2092 bindkey ? {dofind -1 1}
2093 bindkey f nextfile
2094 bindkey <F5> updatecommits
2095 bind . <$M1B-q> doquit
2096 bind . <$M1B-f> {dofind 1 1}
2097 bind . <$M1B-g> {dofind 1 0}
2098 bind . <$M1B-r> dosearchback
2099 bind . <$M1B-s> dosearch
2100 bind . <$M1B-equal> {incrfont 1}
2101 bind . <$M1B-plus> {incrfont 1}
2102 bind . <$M1B-KP_Add> {incrfont 1}
2103 bind . <$M1B-minus> {incrfont -1}
2104 bind . <$M1B-KP_Subtract> {incrfont -1}
2105 wm protocol . WM_DELETE_WINDOW doquit
2106 bind . <Button-1> "click %W"
2107 bind $fstring <Key-Return> {dofind 1 1}
2108 bind $sha1entry <Key-Return> gotocommit
2109 bind $sha1entry <<PasteSelection>> clearsha1
2110 bind $cflist <1> {sel_flist %W %x %y; break}
2111 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2112 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2113 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
2115 set maincursor [. cget -cursor]
2116 set textcursor [$ctext cget -cursor]
2117 set curtextcursor $textcursor
2119 set rowctxmenu .rowctxmenu
2120 menu $rowctxmenu -tearoff 0
2121 $rowctxmenu add command -label [mc "Diff this -> selected"] \
2122 -command {diffvssel 0}
2123 $rowctxmenu add command -label [mc "Diff selected -> this"] \
2124 -command {diffvssel 1}
2125 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2126 $rowctxmenu add command -label [mc "Create tag"] -command mktag
2127 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2128 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2129 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2130 -command cherrypick
2131 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2132 -command resethead
2134 set fakerowmenu .fakerowmenu
2135 menu $fakerowmenu -tearoff 0
2136 $fakerowmenu add command -label [mc "Diff this -> selected"] \
2137 -command {diffvssel 0}
2138 $fakerowmenu add command -label [mc "Diff selected -> this"] \
2139 -command {diffvssel 1}
2140 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2141 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2142 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2143 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2145 set headctxmenu .headctxmenu
2146 menu $headctxmenu -tearoff 0
2147 $headctxmenu add command -label [mc "Check out this branch"] \
2148 -command cobranch
2149 $headctxmenu add command -label [mc "Remove this branch"] \
2150 -command rmbranch
2152 global flist_menu
2153 set flist_menu .flistctxmenu
2154 menu $flist_menu -tearoff 0
2155 $flist_menu add command -label [mc "Highlight this too"] \
2156 -command {flist_hl 0}
2157 $flist_menu add command -label [mc "Highlight this only"] \
2158 -command {flist_hl 1}
2159 $flist_menu add command -label [mc "External diff"] \
2160 -command {external_diff}
2163 # Windows sends all mouse wheel events to the current focused window, not
2164 # the one where the mouse hovers, so bind those events here and redirect
2165 # to the correct window
2166 proc windows_mousewheel_redirector {W X Y D} {
2167 global canv canv2 canv3
2168 set w [winfo containing -displayof $W $X $Y]
2169 if {$w ne ""} {
2170 set u [expr {$D < 0 ? 5 : -5}]
2171 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2172 allcanvs yview scroll $u units
2173 } else {
2174 catch {
2175 $w yview scroll $u units
2181 # Update row number label when selectedline changes
2182 proc selectedline_change {n1 n2 op} {
2183 global selectedline rownumsel
2185 if {$selectedline eq {}} {
2186 set rownumsel {}
2187 } else {
2188 set rownumsel [expr {$selectedline + 1}]
2192 # mouse-2 makes all windows scan vertically, but only the one
2193 # the cursor is in scans horizontally
2194 proc canvscan {op w x y} {
2195 global canv canv2 canv3
2196 foreach c [list $canv $canv2 $canv3] {
2197 if {$c == $w} {
2198 $c scan $op $x $y
2199 } else {
2200 $c scan $op 0 $y
2205 proc scrollcanv {cscroll f0 f1} {
2206 $cscroll set $f0 $f1
2207 drawvisible
2208 flushhighlights
2211 # when we make a key binding for the toplevel, make sure
2212 # it doesn't get triggered when that key is pressed in the
2213 # find string entry widget.
2214 proc bindkey {ev script} {
2215 global entries
2216 bind . $ev $script
2217 set escript [bind Entry $ev]
2218 if {$escript == {}} {
2219 set escript [bind Entry <Key>]
2221 foreach e $entries {
2222 bind $e $ev "$escript; break"
2226 # set the focus back to the toplevel for any click outside
2227 # the entry widgets
2228 proc click {w} {
2229 global ctext entries
2230 foreach e [concat $entries $ctext] {
2231 if {$w == $e} return
2233 focus .
2236 # Adjust the progress bar for a change in requested extent or canvas size
2237 proc adjustprogress {} {
2238 global progresscanv progressitem progresscoords
2239 global fprogitem fprogcoord lastprogupdate progupdatepending
2240 global rprogitem rprogcoord
2242 set w [expr {[winfo width $progresscanv] - 4}]
2243 set x0 [expr {$w * [lindex $progresscoords 0]}]
2244 set x1 [expr {$w * [lindex $progresscoords 1]}]
2245 set h [winfo height $progresscanv]
2246 $progresscanv coords $progressitem $x0 0 $x1 $h
2247 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2248 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2249 set now [clock clicks -milliseconds]
2250 if {$now >= $lastprogupdate + 100} {
2251 set progupdatepending 0
2252 update
2253 } elseif {!$progupdatepending} {
2254 set progupdatepending 1
2255 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2259 proc doprogupdate {} {
2260 global lastprogupdate progupdatepending
2262 if {$progupdatepending} {
2263 set progupdatepending 0
2264 set lastprogupdate [clock clicks -milliseconds]
2265 update
2269 proc savestuff {w} {
2270 global canv canv2 canv3 mainfont textfont uifont tabstop
2271 global stuffsaved findmergefiles maxgraphpct
2272 global maxwidth showneartags showlocalchanges
2273 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2274 global cmitmode wrapcomment datetimeformat limitdiffs
2275 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2276 global autoselect extdifftool
2278 if {$stuffsaved} return
2279 if {![winfo viewable .]} return
2280 catch {
2281 set f [open "~/.gitk-new" w]
2282 puts $f [list set mainfont $mainfont]
2283 puts $f [list set textfont $textfont]
2284 puts $f [list set uifont $uifont]
2285 puts $f [list set tabstop $tabstop]
2286 puts $f [list set findmergefiles $findmergefiles]
2287 puts $f [list set maxgraphpct $maxgraphpct]
2288 puts $f [list set maxwidth $maxwidth]
2289 puts $f [list set cmitmode $cmitmode]
2290 puts $f [list set wrapcomment $wrapcomment]
2291 puts $f [list set autoselect $autoselect]
2292 puts $f [list set showneartags $showneartags]
2293 puts $f [list set showlocalchanges $showlocalchanges]
2294 puts $f [list set datetimeformat $datetimeformat]
2295 puts $f [list set limitdiffs $limitdiffs]
2296 puts $f [list set bgcolor $bgcolor]
2297 puts $f [list set fgcolor $fgcolor]
2298 puts $f [list set colors $colors]
2299 puts $f [list set diffcolors $diffcolors]
2300 puts $f [list set diffcontext $diffcontext]
2301 puts $f [list set selectbgcolor $selectbgcolor]
2302 puts $f [list set extdifftool $extdifftool]
2304 puts $f "set geometry(main) [wm geometry .]"
2305 puts $f "set geometry(topwidth) [winfo width .tf]"
2306 puts $f "set geometry(topheight) [winfo height .tf]"
2307 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2308 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2309 puts $f "set geometry(botwidth) [winfo width .bleft]"
2310 puts $f "set geometry(botheight) [winfo height .bleft]"
2312 puts -nonewline $f "set permviews {"
2313 for {set v 0} {$v < $nextviewnum} {incr v} {
2314 if {$viewperm($v)} {
2315 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2318 puts $f "}"
2319 close $f
2320 file rename -force "~/.gitk-new" "~/.gitk"
2322 set stuffsaved 1
2325 proc resizeclistpanes {win w} {
2326 global oldwidth
2327 if {[info exists oldwidth($win)]} {
2328 set s0 [$win sash coord 0]
2329 set s1 [$win sash coord 1]
2330 if {$w < 60} {
2331 set sash0 [expr {int($w/2 - 2)}]
2332 set sash1 [expr {int($w*5/6 - 2)}]
2333 } else {
2334 set factor [expr {1.0 * $w / $oldwidth($win)}]
2335 set sash0 [expr {int($factor * [lindex $s0 0])}]
2336 set sash1 [expr {int($factor * [lindex $s1 0])}]
2337 if {$sash0 < 30} {
2338 set sash0 30
2340 if {$sash1 < $sash0 + 20} {
2341 set sash1 [expr {$sash0 + 20}]
2343 if {$sash1 > $w - 10} {
2344 set sash1 [expr {$w - 10}]
2345 if {$sash0 > $sash1 - 20} {
2346 set sash0 [expr {$sash1 - 20}]
2350 $win sash place 0 $sash0 [lindex $s0 1]
2351 $win sash place 1 $sash1 [lindex $s1 1]
2353 set oldwidth($win) $w
2356 proc resizecdetpanes {win w} {
2357 global oldwidth
2358 if {[info exists oldwidth($win)]} {
2359 set s0 [$win sash coord 0]
2360 if {$w < 60} {
2361 set sash0 [expr {int($w*3/4 - 2)}]
2362 } else {
2363 set factor [expr {1.0 * $w / $oldwidth($win)}]
2364 set sash0 [expr {int($factor * [lindex $s0 0])}]
2365 if {$sash0 < 45} {
2366 set sash0 45
2368 if {$sash0 > $w - 15} {
2369 set sash0 [expr {$w - 15}]
2372 $win sash place 0 $sash0 [lindex $s0 1]
2374 set oldwidth($win) $w
2377 proc allcanvs args {
2378 global canv canv2 canv3
2379 eval $canv $args
2380 eval $canv2 $args
2381 eval $canv3 $args
2384 proc bindall {event action} {
2385 global canv canv2 canv3
2386 bind $canv $event $action
2387 bind $canv2 $event $action
2388 bind $canv3 $event $action
2391 proc about {} {
2392 global uifont
2393 set w .about
2394 if {[winfo exists $w]} {
2395 raise $w
2396 return
2398 toplevel $w
2399 wm title $w [mc "About gitk"]
2400 message $w.m -text [mc "
2401 Gitk - a commit viewer for git
2403 Copyright © 2005-2008 Paul Mackerras
2405 Use and redistribute under the terms of the GNU General Public License"] \
2406 -justify center -aspect 400 -border 2 -bg white -relief groove
2407 pack $w.m -side top -fill x -padx 2 -pady 2
2408 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2409 pack $w.ok -side bottom
2410 bind $w <Visibility> "focus $w.ok"
2411 bind $w <Key-Escape> "destroy $w"
2412 bind $w <Key-Return> "destroy $w"
2415 proc keys {} {
2416 set w .keys
2417 if {[winfo exists $w]} {
2418 raise $w
2419 return
2421 if {[tk windowingsystem] eq {aqua}} {
2422 set M1T Cmd
2423 } else {
2424 set M1T Ctrl
2426 toplevel $w
2427 wm title $w [mc "Gitk key bindings"]
2428 message $w.m -text "
2429 [mc "Gitk key bindings:"]
2431 [mc "<%s-Q> Quit" $M1T]
2432 [mc "<Home> Move to first commit"]
2433 [mc "<End> Move to last commit"]
2434 [mc "<Up>, p, i Move up one commit"]
2435 [mc "<Down>, n, k Move down one commit"]
2436 [mc "<Left>, z, j Go back in history list"]
2437 [mc "<Right>, x, l Go forward in history list"]
2438 [mc "<PageUp> Move up one page in commit list"]
2439 [mc "<PageDown> Move down one page in commit list"]
2440 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2441 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2442 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2443 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2444 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2445 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2446 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2447 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2448 [mc "<Delete>, b Scroll diff view up one page"]
2449 [mc "<Backspace> Scroll diff view up one page"]
2450 [mc "<Space> Scroll diff view down one page"]
2451 [mc "u Scroll diff view up 18 lines"]
2452 [mc "d Scroll diff view down 18 lines"]
2453 [mc "<%s-F> Find" $M1T]
2454 [mc "<%s-G> Move to next find hit" $M1T]
2455 [mc "<Return> Move to next find hit"]
2456 [mc "/ Move to next find hit, or redo find"]
2457 [mc "? Move to previous find hit"]
2458 [mc "f Scroll diff view to next file"]
2459 [mc "<%s-S> Search for next hit in diff view" $M1T]
2460 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2461 [mc "<%s-KP+> Increase font size" $M1T]
2462 [mc "<%s-plus> Increase font size" $M1T]
2463 [mc "<%s-KP-> Decrease font size" $M1T]
2464 [mc "<%s-minus> Decrease font size" $M1T]
2465 [mc "<F5> Update"]
2467 -justify left -bg white -border 2 -relief groove
2468 pack $w.m -side top -fill both -padx 2 -pady 2
2469 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2470 pack $w.ok -side bottom
2471 bind $w <Visibility> "focus $w.ok"
2472 bind $w <Key-Escape> "destroy $w"
2473 bind $w <Key-Return> "destroy $w"
2476 # Procedures for manipulating the file list window at the
2477 # bottom right of the overall window.
2479 proc treeview {w l openlevs} {
2480 global treecontents treediropen treeheight treeparent treeindex
2482 set ix 0
2483 set treeindex() 0
2484 set lev 0
2485 set prefix {}
2486 set prefixend -1
2487 set prefendstack {}
2488 set htstack {}
2489 set ht 0
2490 set treecontents() {}
2491 $w conf -state normal
2492 foreach f $l {
2493 while {[string range $f 0 $prefixend] ne $prefix} {
2494 if {$lev <= $openlevs} {
2495 $w mark set e:$treeindex($prefix) "end -1c"
2496 $w mark gravity e:$treeindex($prefix) left
2498 set treeheight($prefix) $ht
2499 incr ht [lindex $htstack end]
2500 set htstack [lreplace $htstack end end]
2501 set prefixend [lindex $prefendstack end]
2502 set prefendstack [lreplace $prefendstack end end]
2503 set prefix [string range $prefix 0 $prefixend]
2504 incr lev -1
2506 set tail [string range $f [expr {$prefixend+1}] end]
2507 while {[set slash [string first "/" $tail]] >= 0} {
2508 lappend htstack $ht
2509 set ht 0
2510 lappend prefendstack $prefixend
2511 incr prefixend [expr {$slash + 1}]
2512 set d [string range $tail 0 $slash]
2513 lappend treecontents($prefix) $d
2514 set oldprefix $prefix
2515 append prefix $d
2516 set treecontents($prefix) {}
2517 set treeindex($prefix) [incr ix]
2518 set treeparent($prefix) $oldprefix
2519 set tail [string range $tail [expr {$slash+1}] end]
2520 if {$lev <= $openlevs} {
2521 set ht 1
2522 set treediropen($prefix) [expr {$lev < $openlevs}]
2523 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2524 $w mark set d:$ix "end -1c"
2525 $w mark gravity d:$ix left
2526 set str "\n"
2527 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2528 $w insert end $str
2529 $w image create end -align center -image $bm -padx 1 \
2530 -name a:$ix
2531 $w insert end $d [highlight_tag $prefix]
2532 $w mark set s:$ix "end -1c"
2533 $w mark gravity s:$ix left
2535 incr lev
2537 if {$tail ne {}} {
2538 if {$lev <= $openlevs} {
2539 incr ht
2540 set str "\n"
2541 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2542 $w insert end $str
2543 $w insert end $tail [highlight_tag $f]
2545 lappend treecontents($prefix) $tail
2548 while {$htstack ne {}} {
2549 set treeheight($prefix) $ht
2550 incr ht [lindex $htstack end]
2551 set htstack [lreplace $htstack end end]
2552 set prefixend [lindex $prefendstack end]
2553 set prefendstack [lreplace $prefendstack end end]
2554 set prefix [string range $prefix 0 $prefixend]
2556 $w conf -state disabled
2559 proc linetoelt {l} {
2560 global treeheight treecontents
2562 set y 2
2563 set prefix {}
2564 while {1} {
2565 foreach e $treecontents($prefix) {
2566 if {$y == $l} {
2567 return "$prefix$e"
2569 set n 1
2570 if {[string index $e end] eq "/"} {
2571 set n $treeheight($prefix$e)
2572 if {$y + $n > $l} {
2573 append prefix $e
2574 incr y
2575 break
2578 incr y $n
2583 proc highlight_tree {y prefix} {
2584 global treeheight treecontents cflist
2586 foreach e $treecontents($prefix) {
2587 set path $prefix$e
2588 if {[highlight_tag $path] ne {}} {
2589 $cflist tag add bold $y.0 "$y.0 lineend"
2591 incr y
2592 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2593 set y [highlight_tree $y $path]
2596 return $y
2599 proc treeclosedir {w dir} {
2600 global treediropen treeheight treeparent treeindex
2602 set ix $treeindex($dir)
2603 $w conf -state normal
2604 $w delete s:$ix e:$ix
2605 set treediropen($dir) 0
2606 $w image configure a:$ix -image tri-rt
2607 $w conf -state disabled
2608 set n [expr {1 - $treeheight($dir)}]
2609 while {$dir ne {}} {
2610 incr treeheight($dir) $n
2611 set dir $treeparent($dir)
2615 proc treeopendir {w dir} {
2616 global treediropen treeheight treeparent treecontents treeindex
2618 set ix $treeindex($dir)
2619 $w conf -state normal
2620 $w image configure a:$ix -image tri-dn
2621 $w mark set e:$ix s:$ix
2622 $w mark gravity e:$ix right
2623 set lev 0
2624 set str "\n"
2625 set n [llength $treecontents($dir)]
2626 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2627 incr lev
2628 append str "\t"
2629 incr treeheight($x) $n
2631 foreach e $treecontents($dir) {
2632 set de $dir$e
2633 if {[string index $e end] eq "/"} {
2634 set iy $treeindex($de)
2635 $w mark set d:$iy e:$ix
2636 $w mark gravity d:$iy left
2637 $w insert e:$ix $str
2638 set treediropen($de) 0
2639 $w image create e:$ix -align center -image tri-rt -padx 1 \
2640 -name a:$iy
2641 $w insert e:$ix $e [highlight_tag $de]
2642 $w mark set s:$iy e:$ix
2643 $w mark gravity s:$iy left
2644 set treeheight($de) 1
2645 } else {
2646 $w insert e:$ix $str
2647 $w insert e:$ix $e [highlight_tag $de]
2650 $w mark gravity e:$ix left
2651 $w conf -state disabled
2652 set treediropen($dir) 1
2653 set top [lindex [split [$w index @0,0] .] 0]
2654 set ht [$w cget -height]
2655 set l [lindex [split [$w index s:$ix] .] 0]
2656 if {$l < $top} {
2657 $w yview $l.0
2658 } elseif {$l + $n + 1 > $top + $ht} {
2659 set top [expr {$l + $n + 2 - $ht}]
2660 if {$l < $top} {
2661 set top $l
2663 $w yview $top.0
2667 proc treeclick {w x y} {
2668 global treediropen cmitmode ctext cflist cflist_top
2670 if {$cmitmode ne "tree"} return
2671 if {![info exists cflist_top]} return
2672 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2673 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2674 $cflist tag add highlight $l.0 "$l.0 lineend"
2675 set cflist_top $l
2676 if {$l == 1} {
2677 $ctext yview 1.0
2678 return
2680 set e [linetoelt $l]
2681 if {[string index $e end] ne "/"} {
2682 showfile $e
2683 } elseif {$treediropen($e)} {
2684 treeclosedir $w $e
2685 } else {
2686 treeopendir $w $e
2690 proc setfilelist {id} {
2691 global treefilelist cflist
2693 treeview $cflist $treefilelist($id) 0
2696 image create bitmap tri-rt -background black -foreground blue -data {
2697 #define tri-rt_width 13
2698 #define tri-rt_height 13
2699 static unsigned char tri-rt_bits[] = {
2700 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2701 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2702 0x00, 0x00};
2703 } -maskdata {
2704 #define tri-rt-mask_width 13
2705 #define tri-rt-mask_height 13
2706 static unsigned char tri-rt-mask_bits[] = {
2707 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2708 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2709 0x08, 0x00};
2711 image create bitmap tri-dn -background black -foreground blue -data {
2712 #define tri-dn_width 13
2713 #define tri-dn_height 13
2714 static unsigned char tri-dn_bits[] = {
2715 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2716 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2717 0x00, 0x00};
2718 } -maskdata {
2719 #define tri-dn-mask_width 13
2720 #define tri-dn-mask_height 13
2721 static unsigned char tri-dn-mask_bits[] = {
2722 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2723 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2724 0x00, 0x00};
2727 image create bitmap reficon-T -background black -foreground yellow -data {
2728 #define tagicon_width 13
2729 #define tagicon_height 9
2730 static unsigned char tagicon_bits[] = {
2731 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2732 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2733 } -maskdata {
2734 #define tagicon-mask_width 13
2735 #define tagicon-mask_height 9
2736 static unsigned char tagicon-mask_bits[] = {
2737 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2738 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2740 set rectdata {
2741 #define headicon_width 13
2742 #define headicon_height 9
2743 static unsigned char headicon_bits[] = {
2744 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2745 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2747 set rectmask {
2748 #define headicon-mask_width 13
2749 #define headicon-mask_height 9
2750 static unsigned char headicon-mask_bits[] = {
2751 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2752 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2754 image create bitmap reficon-H -background black -foreground green \
2755 -data $rectdata -maskdata $rectmask
2756 image create bitmap reficon-o -background black -foreground "#ddddff" \
2757 -data $rectdata -maskdata $rectmask
2759 proc init_flist {first} {
2760 global cflist cflist_top difffilestart
2762 $cflist conf -state normal
2763 $cflist delete 0.0 end
2764 if {$first ne {}} {
2765 $cflist insert end $first
2766 set cflist_top 1
2767 $cflist tag add highlight 1.0 "1.0 lineend"
2768 } else {
2769 catch {unset cflist_top}
2771 $cflist conf -state disabled
2772 set difffilestart {}
2775 proc highlight_tag {f} {
2776 global highlight_paths
2778 foreach p $highlight_paths {
2779 if {[string match $p $f]} {
2780 return "bold"
2783 return {}
2786 proc highlight_filelist {} {
2787 global cmitmode cflist
2789 $cflist conf -state normal
2790 if {$cmitmode ne "tree"} {
2791 set end [lindex [split [$cflist index end] .] 0]
2792 for {set l 2} {$l < $end} {incr l} {
2793 set line [$cflist get $l.0 "$l.0 lineend"]
2794 if {[highlight_tag $line] ne {}} {
2795 $cflist tag add bold $l.0 "$l.0 lineend"
2798 } else {
2799 highlight_tree 2 {}
2801 $cflist conf -state disabled
2804 proc unhighlight_filelist {} {
2805 global cflist
2807 $cflist conf -state normal
2808 $cflist tag remove bold 1.0 end
2809 $cflist conf -state disabled
2812 proc add_flist {fl} {
2813 global cflist
2815 $cflist conf -state normal
2816 foreach f $fl {
2817 $cflist insert end "\n"
2818 $cflist insert end $f [highlight_tag $f]
2820 $cflist conf -state disabled
2823 proc sel_flist {w x y} {
2824 global ctext difffilestart cflist cflist_top cmitmode
2826 if {$cmitmode eq "tree"} return
2827 if {![info exists cflist_top]} return
2828 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2829 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2830 $cflist tag add highlight $l.0 "$l.0 lineend"
2831 set cflist_top $l
2832 if {$l == 1} {
2833 $ctext yview 1.0
2834 } else {
2835 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2839 proc pop_flist_menu {w X Y x y} {
2840 global ctext cflist cmitmode flist_menu flist_menu_file
2841 global treediffs diffids
2843 stopfinding
2844 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2845 if {$l <= 1} return
2846 if {$cmitmode eq "tree"} {
2847 set e [linetoelt $l]
2848 if {[string index $e end] eq "/"} return
2849 } else {
2850 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2852 set flist_menu_file $e
2853 set xdiffstate "normal"
2854 if {$cmitmode eq "tree"} {
2855 set xdiffstate "disabled"
2857 # Disable "External diff" item in tree mode
2858 $flist_menu entryconf 2 -state $xdiffstate
2859 tk_popup $flist_menu $X $Y
2862 proc flist_hl {only} {
2863 global flist_menu_file findstring gdttype
2865 set x [shellquote $flist_menu_file]
2866 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2867 set findstring $x
2868 } else {
2869 append findstring " " $x
2871 set gdttype [mc "touching paths:"]
2874 proc save_file_from_commit {filename output what} {
2875 global nullfile
2877 if {[catch {exec git show $filename -- > $output} err]} {
2878 if {[string match "fatal: bad revision *" $err]} {
2879 return $nullfile
2881 error_popup "Error getting \"$filename\" from $what: $err"
2882 return {}
2884 return $output
2887 proc external_diff_get_one_file {diffid filename diffdir} {
2888 global nullid nullid2 nullfile
2889 global gitdir
2891 if {$diffid == $nullid} {
2892 set difffile [file join [file dirname $gitdir] $filename]
2893 if {[file exists $difffile]} {
2894 return $difffile
2896 return $nullfile
2898 if {$diffid == $nullid2} {
2899 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2900 return [save_file_from_commit :$filename $difffile index]
2902 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2903 return [save_file_from_commit $diffid:$filename $difffile \
2904 "revision $diffid"]
2907 proc external_diff {} {
2908 global gitktmpdir nullid nullid2
2909 global flist_menu_file
2910 global diffids
2911 global diffnum
2912 global gitdir extdifftool
2914 if {[llength $diffids] == 1} {
2915 # no reference commit given
2916 set diffidto [lindex $diffids 0]
2917 if {$diffidto eq $nullid} {
2918 # diffing working copy with index
2919 set diffidfrom $nullid2
2920 } elseif {$diffidto eq $nullid2} {
2921 # diffing index with HEAD
2922 set diffidfrom "HEAD"
2923 } else {
2924 # use first parent commit
2925 global parentlist selectedline
2926 set diffidfrom [lindex $parentlist $selectedline 0]
2928 } else {
2929 set diffidfrom [lindex $diffids 0]
2930 set diffidto [lindex $diffids 1]
2933 # make sure that several diffs wont collide
2934 if {![info exists gitktmpdir]} {
2935 set gitktmpdir [file join [file dirname $gitdir] \
2936 [format ".gitk-tmp.%s" [pid]]]
2937 if {[catch {file mkdir $gitktmpdir} err]} {
2938 error_popup "Error creating temporary directory $gitktmpdir: $err"
2939 unset gitktmpdir
2940 return
2942 set diffnum 0
2944 incr diffnum
2945 set diffdir [file join $gitktmpdir $diffnum]
2946 if {[catch {file mkdir $diffdir} err]} {
2947 error_popup "Error creating temporary directory $diffdir: $err"
2948 return
2951 # gather files to diff
2952 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
2953 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
2955 if {$difffromfile ne {} && $difftofile ne {}} {
2956 set cmd [concat | [shellsplit $extdifftool] \
2957 [list $difffromfile $difftofile]]
2958 if {[catch {set fl [open $cmd r]} err]} {
2959 file delete -force $diffdir
2960 error_popup [mc "$extdifftool: command failed: $err"]
2961 } else {
2962 fconfigure $fl -blocking 0
2963 filerun $fl [list delete_at_eof $fl $diffdir]
2968 # delete $dir when we see eof on $f (presumably because the child has exited)
2969 proc delete_at_eof {f dir} {
2970 while {[gets $f line] >= 0} {}
2971 if {[eof $f]} {
2972 if {[catch {close $f} err]} {
2973 error_popup "External diff viewer failed: $err"
2975 file delete -force $dir
2976 return 0
2978 return 1
2981 # Functions for adding and removing shell-type quoting
2983 proc shellquote {str} {
2984 if {![string match "*\['\"\\ \t]*" $str]} {
2985 return $str
2987 if {![string match "*\['\"\\]*" $str]} {
2988 return "\"$str\""
2990 if {![string match "*'*" $str]} {
2991 return "'$str'"
2993 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2996 proc shellarglist {l} {
2997 set str {}
2998 foreach a $l {
2999 if {$str ne {}} {
3000 append str " "
3002 append str [shellquote $a]
3004 return $str
3007 proc shelldequote {str} {
3008 set ret {}
3009 set used -1
3010 while {1} {
3011 incr used
3012 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3013 append ret [string range $str $used end]
3014 set used [string length $str]
3015 break
3017 set first [lindex $first 0]
3018 set ch [string index $str $first]
3019 if {$first > $used} {
3020 append ret [string range $str $used [expr {$first - 1}]]
3021 set used $first
3023 if {$ch eq " " || $ch eq "\t"} break
3024 incr used
3025 if {$ch eq "'"} {
3026 set first [string first "'" $str $used]
3027 if {$first < 0} {
3028 error "unmatched single-quote"
3030 append ret [string range $str $used [expr {$first - 1}]]
3031 set used $first
3032 continue
3034 if {$ch eq "\\"} {
3035 if {$used >= [string length $str]} {
3036 error "trailing backslash"
3038 append ret [string index $str $used]
3039 continue
3041 # here ch == "\""
3042 while {1} {
3043 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3044 error "unmatched double-quote"
3046 set first [lindex $first 0]
3047 set ch [string index $str $first]
3048 if {$first > $used} {
3049 append ret [string range $str $used [expr {$first - 1}]]
3050 set used $first
3052 if {$ch eq "\""} break
3053 incr used
3054 append ret [string index $str $used]
3055 incr used
3058 return [list $used $ret]
3061 proc shellsplit {str} {
3062 set l {}
3063 while {1} {
3064 set str [string trimleft $str]
3065 if {$str eq {}} break
3066 set dq [shelldequote $str]
3067 set n [lindex $dq 0]
3068 set word [lindex $dq 1]
3069 set str [string range $str $n end]
3070 lappend l $word
3072 return $l
3075 # Code to implement multiple views
3077 proc newview {ishighlight} {
3078 global nextviewnum newviewname newviewperm newishighlight
3079 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3081 set newishighlight $ishighlight
3082 set top .gitkview
3083 if {[winfo exists $top]} {
3084 raise $top
3085 return
3087 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3088 set newviewperm($nextviewnum) 0
3089 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3090 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3091 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3094 proc editview {} {
3095 global curview
3096 global viewname viewperm newviewname newviewperm
3097 global viewargs newviewargs viewargscmd newviewargscmd
3099 set top .gitkvedit-$curview
3100 if {[winfo exists $top]} {
3101 raise $top
3102 return
3104 set newviewname($curview) $viewname($curview)
3105 set newviewperm($curview) $viewperm($curview)
3106 set newviewargs($curview) [shellarglist $viewargs($curview)]
3107 set newviewargscmd($curview) $viewargscmd($curview)
3108 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3111 proc vieweditor {top n title} {
3112 global newviewname newviewperm viewfiles bgcolor
3114 toplevel $top
3115 wm title $top $title
3116 label $top.nl -text [mc "Name"]
3117 entry $top.name -width 20 -textvariable newviewname($n)
3118 grid $top.nl $top.name -sticky w -pady 5
3119 checkbutton $top.perm -text [mc "Remember this view"] \
3120 -variable newviewperm($n)
3121 grid $top.perm - -pady 5 -sticky w
3122 message $top.al -aspect 1000 \
3123 -text [mc "Commits to include (arguments to git log):"]
3124 grid $top.al - -sticky w -pady 5
3125 entry $top.args -width 50 -textvariable newviewargs($n) \
3126 -background $bgcolor
3127 grid $top.args - -sticky ew -padx 5
3129 message $top.ac -aspect 1000 \
3130 -text [mc "Command to generate more commits to include:"]
3131 grid $top.ac - -sticky w -pady 5
3132 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3133 -background white
3134 grid $top.argscmd - -sticky ew -padx 5
3136 message $top.l -aspect 1000 \
3137 -text [mc "Enter files and directories to include, one per line:"]
3138 grid $top.l - -sticky w
3139 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3140 if {[info exists viewfiles($n)]} {
3141 foreach f $viewfiles($n) {
3142 $top.t insert end $f
3143 $top.t insert end "\n"
3145 $top.t delete {end - 1c} end
3146 $top.t mark set insert 0.0
3148 grid $top.t - -sticky ew -padx 5
3149 frame $top.buts
3150 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3151 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3152 grid $top.buts.ok $top.buts.can
3153 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3154 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3155 grid $top.buts - -pady 10 -sticky ew
3156 focus $top.t
3159 proc doviewmenu {m first cmd op argv} {
3160 set nmenu [$m index end]
3161 for {set i $first} {$i <= $nmenu} {incr i} {
3162 if {[$m entrycget $i -command] eq $cmd} {
3163 eval $m $op $i $argv
3164 break
3169 proc allviewmenus {n op args} {
3170 # global viewhlmenu
3172 doviewmenu .bar.view 5 [list showview $n] $op $args
3173 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3176 proc newviewok {top n} {
3177 global nextviewnum newviewperm newviewname newishighlight
3178 global viewname viewfiles viewperm selectedview curview
3179 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3181 if {[catch {
3182 set newargs [shellsplit $newviewargs($n)]
3183 } err]} {
3184 error_popup "[mc "Error in commit selection arguments:"] $err"
3185 wm raise $top
3186 focus $top
3187 return
3189 set files {}
3190 foreach f [split [$top.t get 0.0 end] "\n"] {
3191 set ft [string trim $f]
3192 if {$ft ne {}} {
3193 lappend files $ft
3196 if {![info exists viewfiles($n)]} {
3197 # creating a new view
3198 incr nextviewnum
3199 set viewname($n) $newviewname($n)
3200 set viewperm($n) $newviewperm($n)
3201 set viewfiles($n) $files
3202 set viewargs($n) $newargs
3203 set viewargscmd($n) $newviewargscmd($n)
3204 addviewmenu $n
3205 if {!$newishighlight} {
3206 run showview $n
3207 } else {
3208 run addvhighlight $n
3210 } else {
3211 # editing an existing view
3212 set viewperm($n) $newviewperm($n)
3213 if {$newviewname($n) ne $viewname($n)} {
3214 set viewname($n) $newviewname($n)
3215 doviewmenu .bar.view 5 [list showview $n] \
3216 entryconf [list -label $viewname($n)]
3217 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3218 # entryconf [list -label $viewname($n) -value $viewname($n)]
3220 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3221 $newviewargscmd($n) ne $viewargscmd($n)} {
3222 set viewfiles($n) $files
3223 set viewargs($n) $newargs
3224 set viewargscmd($n) $newviewargscmd($n)
3225 if {$curview == $n} {
3226 run reloadcommits
3230 catch {destroy $top}
3233 proc delview {} {
3234 global curview viewperm hlview selectedhlview
3236 if {$curview == 0} return
3237 if {[info exists hlview] && $hlview == $curview} {
3238 set selectedhlview [mc "None"]
3239 unset hlview
3241 allviewmenus $curview delete
3242 set viewperm($curview) 0
3243 showview 0
3246 proc addviewmenu {n} {
3247 global viewname viewhlmenu
3249 .bar.view add radiobutton -label $viewname($n) \
3250 -command [list showview $n] -variable selectedview -value $n
3251 #$viewhlmenu add radiobutton -label $viewname($n) \
3252 # -command [list addvhighlight $n] -variable selectedhlview
3255 proc showview {n} {
3256 global curview cached_commitrow ordertok
3257 global displayorder parentlist rowidlist rowisopt rowfinal
3258 global colormap rowtextx nextcolor canvxmax
3259 global numcommits viewcomplete
3260 global selectedline currentid canv canvy0
3261 global treediffs
3262 global pending_select mainheadid
3263 global commitidx
3264 global selectedview
3265 global hlview selectedhlview commitinterest
3267 if {$n == $curview} return
3268 set selid {}
3269 set ymax [lindex [$canv cget -scrollregion] 3]
3270 set span [$canv yview]
3271 set ytop [expr {[lindex $span 0] * $ymax}]
3272 set ybot [expr {[lindex $span 1] * $ymax}]
3273 set yscreen [expr {($ybot - $ytop) / 2}]
3274 if {$selectedline ne {}} {
3275 set selid $currentid
3276 set y [yc $selectedline]
3277 if {$ytop < $y && $y < $ybot} {
3278 set yscreen [expr {$y - $ytop}]
3280 } elseif {[info exists pending_select]} {
3281 set selid $pending_select
3282 unset pending_select
3284 unselectline
3285 normalline
3286 catch {unset treediffs}
3287 clear_display
3288 if {[info exists hlview] && $hlview == $n} {
3289 unset hlview
3290 set selectedhlview [mc "None"]
3292 catch {unset commitinterest}
3293 catch {unset cached_commitrow}
3294 catch {unset ordertok}
3296 set curview $n
3297 set selectedview $n
3298 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3299 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3301 run refill_reflist
3302 if {![info exists viewcomplete($n)]} {
3303 if {$selid ne {}} {
3304 set pending_select $selid
3306 getcommits
3307 return
3310 set displayorder {}
3311 set parentlist {}
3312 set rowidlist {}
3313 set rowisopt {}
3314 set rowfinal {}
3315 set numcommits $commitidx($n)
3317 catch {unset colormap}
3318 catch {unset rowtextx}
3319 set nextcolor 0
3320 set canvxmax [$canv cget -width]
3321 set curview $n
3322 set row 0
3323 setcanvscroll
3324 set yf 0
3325 set row {}
3326 if {$selid ne {} && [commitinview $selid $n]} {
3327 set row [rowofcommit $selid]
3328 # try to get the selected row in the same position on the screen
3329 set ymax [lindex [$canv cget -scrollregion] 3]
3330 set ytop [expr {[yc $row] - $yscreen}]
3331 if {$ytop < 0} {
3332 set ytop 0
3334 set yf [expr {$ytop * 1.0 / $ymax}]
3336 allcanvs yview moveto $yf
3337 drawvisible
3338 if {$row ne {}} {
3339 selectline $row 0
3340 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
3341 selectline [rowofcommit $mainheadid] 1
3342 } elseif {!$viewcomplete($n)} {
3343 if {$selid ne {}} {
3344 set pending_select $selid
3345 } else {
3346 set pending_select $mainheadid
3348 } else {
3349 set row [first_real_row]
3350 if {$row < $numcommits} {
3351 selectline $row 0
3354 if {!$viewcomplete($n)} {
3355 if {$numcommits == 0} {
3356 show_status [mc "Reading commits..."]
3358 } elseif {$numcommits == 0} {
3359 show_status [mc "No commits selected"]
3363 # Stuff relating to the highlighting facility
3365 proc ishighlighted {id} {
3366 global vhighlights fhighlights nhighlights rhighlights
3368 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3369 return $nhighlights($id)
3371 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3372 return $vhighlights($id)
3374 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3375 return $fhighlights($id)
3377 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3378 return $rhighlights($id)
3380 return 0
3383 proc bolden {row font} {
3384 global canv linehtag selectedline boldrows
3386 lappend boldrows $row
3387 $canv itemconf $linehtag($row) -font $font
3388 if {$row == $selectedline} {
3389 $canv delete secsel
3390 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3391 -outline {{}} -tags secsel \
3392 -fill [$canv cget -selectbackground]]
3393 $canv lower $t
3397 proc bolden_name {row font} {
3398 global canv2 linentag selectedline boldnamerows
3400 lappend boldnamerows $row
3401 $canv2 itemconf $linentag($row) -font $font
3402 if {$row == $selectedline} {
3403 $canv2 delete secsel
3404 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3405 -outline {{}} -tags secsel \
3406 -fill [$canv2 cget -selectbackground]]
3407 $canv2 lower $t
3411 proc unbolden {} {
3412 global boldrows
3414 set stillbold {}
3415 foreach row $boldrows {
3416 if {![ishighlighted [commitonrow $row]]} {
3417 bolden $row mainfont
3418 } else {
3419 lappend stillbold $row
3422 set boldrows $stillbold
3425 proc addvhighlight {n} {
3426 global hlview viewcomplete curview vhl_done commitidx
3428 if {[info exists hlview]} {
3429 delvhighlight
3431 set hlview $n
3432 if {$n != $curview && ![info exists viewcomplete($n)]} {
3433 start_rev_list $n
3435 set vhl_done $commitidx($hlview)
3436 if {$vhl_done > 0} {
3437 drawvisible
3441 proc delvhighlight {} {
3442 global hlview vhighlights
3444 if {![info exists hlview]} return
3445 unset hlview
3446 catch {unset vhighlights}
3447 unbolden
3450 proc vhighlightmore {} {
3451 global hlview vhl_done commitidx vhighlights curview
3453 set max $commitidx($hlview)
3454 set vr [visiblerows]
3455 set r0 [lindex $vr 0]
3456 set r1 [lindex $vr 1]
3457 for {set i $vhl_done} {$i < $max} {incr i} {
3458 set id [commitonrow $i $hlview]
3459 if {[commitinview $id $curview]} {
3460 set row [rowofcommit $id]
3461 if {$r0 <= $row && $row <= $r1} {
3462 if {![highlighted $row]} {
3463 bolden $row mainfontbold
3465 set vhighlights($id) 1
3469 set vhl_done $max
3470 return 0
3473 proc askvhighlight {row id} {
3474 global hlview vhighlights iddrawn
3476 if {[commitinview $id $hlview]} {
3477 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3478 bolden $row mainfontbold
3480 set vhighlights($id) 1
3481 } else {
3482 set vhighlights($id) 0
3486 proc hfiles_change {} {
3487 global highlight_files filehighlight fhighlights fh_serial
3488 global highlight_paths gdttype
3490 if {[info exists filehighlight]} {
3491 # delete previous highlights
3492 catch {close $filehighlight}
3493 unset filehighlight
3494 catch {unset fhighlights}
3495 unbolden
3496 unhighlight_filelist
3498 set highlight_paths {}
3499 after cancel do_file_hl $fh_serial
3500 incr fh_serial
3501 if {$highlight_files ne {}} {
3502 after 300 do_file_hl $fh_serial
3506 proc gdttype_change {name ix op} {
3507 global gdttype highlight_files findstring findpattern
3509 stopfinding
3510 if {$findstring ne {}} {
3511 if {$gdttype eq [mc "containing:"]} {
3512 if {$highlight_files ne {}} {
3513 set highlight_files {}
3514 hfiles_change
3516 findcom_change
3517 } else {
3518 if {$findpattern ne {}} {
3519 set findpattern {}
3520 findcom_change
3522 set highlight_files $findstring
3523 hfiles_change
3525 drawvisible
3527 # enable/disable findtype/findloc menus too
3530 proc find_change {name ix op} {
3531 global gdttype findstring highlight_files
3533 stopfinding
3534 if {$gdttype eq [mc "containing:"]} {
3535 findcom_change
3536 } else {
3537 if {$highlight_files ne $findstring} {
3538 set highlight_files $findstring
3539 hfiles_change
3542 drawvisible
3545 proc findcom_change args {
3546 global nhighlights boldnamerows
3547 global findpattern findtype findstring gdttype
3549 stopfinding
3550 # delete previous highlights, if any
3551 foreach row $boldnamerows {
3552 bolden_name $row mainfont
3554 set boldnamerows {}
3555 catch {unset nhighlights}
3556 unbolden
3557 unmarkmatches
3558 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3559 set findpattern {}
3560 } elseif {$findtype eq [mc "Regexp"]} {
3561 set findpattern $findstring
3562 } else {
3563 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3564 $findstring]
3565 set findpattern "*$e*"
3569 proc makepatterns {l} {
3570 set ret {}
3571 foreach e $l {
3572 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3573 if {[string index $ee end] eq "/"} {
3574 lappend ret "$ee*"
3575 } else {
3576 lappend ret $ee
3577 lappend ret "$ee/*"
3580 return $ret
3583 proc do_file_hl {serial} {
3584 global highlight_files filehighlight highlight_paths gdttype fhl_list
3586 if {$gdttype eq [mc "touching paths:"]} {
3587 if {[catch {set paths [shellsplit $highlight_files]}]} return
3588 set highlight_paths [makepatterns $paths]
3589 highlight_filelist
3590 set gdtargs [concat -- $paths]
3591 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3592 set gdtargs [list "-S$highlight_files"]
3593 } else {
3594 # must be "containing:", i.e. we're searching commit info
3595 return
3597 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3598 set filehighlight [open $cmd r+]
3599 fconfigure $filehighlight -blocking 0
3600 filerun $filehighlight readfhighlight
3601 set fhl_list {}
3602 drawvisible
3603 flushhighlights
3606 proc flushhighlights {} {
3607 global filehighlight fhl_list
3609 if {[info exists filehighlight]} {
3610 lappend fhl_list {}
3611 puts $filehighlight ""
3612 flush $filehighlight
3616 proc askfilehighlight {row id} {
3617 global filehighlight fhighlights fhl_list
3619 lappend fhl_list $id
3620 set fhighlights($id) -1
3621 puts $filehighlight $id
3624 proc readfhighlight {} {
3625 global filehighlight fhighlights curview iddrawn
3626 global fhl_list find_dirn
3628 if {![info exists filehighlight]} {
3629 return 0
3631 set nr 0
3632 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3633 set line [string trim $line]
3634 set i [lsearch -exact $fhl_list $line]
3635 if {$i < 0} continue
3636 for {set j 0} {$j < $i} {incr j} {
3637 set id [lindex $fhl_list $j]
3638 set fhighlights($id) 0
3640 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3641 if {$line eq {}} continue
3642 if {![commitinview $line $curview]} continue
3643 set row [rowofcommit $line]
3644 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3645 bolden $row mainfontbold
3647 set fhighlights($line) 1
3649 if {[eof $filehighlight]} {
3650 # strange...
3651 puts "oops, git diff-tree died"
3652 catch {close $filehighlight}
3653 unset filehighlight
3654 return 0
3656 if {[info exists find_dirn]} {
3657 run findmore
3659 return 1
3662 proc doesmatch {f} {
3663 global findtype findpattern
3665 if {$findtype eq [mc "Regexp"]} {
3666 return [regexp $findpattern $f]
3667 } elseif {$findtype eq [mc "IgnCase"]} {
3668 return [string match -nocase $findpattern $f]
3669 } else {
3670 return [string match $findpattern $f]
3674 proc askfindhighlight {row id} {
3675 global nhighlights commitinfo iddrawn
3676 global findloc
3677 global markingmatches
3679 if {![info exists commitinfo($id)]} {
3680 getcommit $id
3682 set info $commitinfo($id)
3683 set isbold 0
3684 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3685 foreach f $info ty $fldtypes {
3686 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3687 [doesmatch $f]} {
3688 if {$ty eq [mc "Author"]} {
3689 set isbold 2
3690 break
3692 set isbold 1
3695 if {$isbold && [info exists iddrawn($id)]} {
3696 if {![ishighlighted $id]} {
3697 bolden $row mainfontbold
3698 if {$isbold > 1} {
3699 bolden_name $row mainfontbold
3702 if {$markingmatches} {
3703 markrowmatches $row $id
3706 set nhighlights($id) $isbold
3709 proc markrowmatches {row id} {
3710 global canv canv2 linehtag linentag commitinfo findloc
3712 set headline [lindex $commitinfo($id) 0]
3713 set author [lindex $commitinfo($id) 1]
3714 $canv delete match$row
3715 $canv2 delete match$row
3716 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3717 set m [findmatches $headline]
3718 if {$m ne {}} {
3719 markmatches $canv $row $headline $linehtag($row) $m \
3720 [$canv itemcget $linehtag($row) -font] $row
3723 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3724 set m [findmatches $author]
3725 if {$m ne {}} {
3726 markmatches $canv2 $row $author $linentag($row) $m \
3727 [$canv2 itemcget $linentag($row) -font] $row
3732 proc vrel_change {name ix op} {
3733 global highlight_related
3735 rhighlight_none
3736 if {$highlight_related ne [mc "None"]} {
3737 run drawvisible
3741 # prepare for testing whether commits are descendents or ancestors of a
3742 proc rhighlight_sel {a} {
3743 global descendent desc_todo ancestor anc_todo
3744 global highlight_related
3746 catch {unset descendent}
3747 set desc_todo [list $a]
3748 catch {unset ancestor}
3749 set anc_todo [list $a]
3750 if {$highlight_related ne [mc "None"]} {
3751 rhighlight_none
3752 run drawvisible
3756 proc rhighlight_none {} {
3757 global rhighlights
3759 catch {unset rhighlights}
3760 unbolden
3763 proc is_descendent {a} {
3764 global curview children descendent desc_todo
3766 set v $curview
3767 set la [rowofcommit $a]
3768 set todo $desc_todo
3769 set leftover {}
3770 set done 0
3771 for {set i 0} {$i < [llength $todo]} {incr i} {
3772 set do [lindex $todo $i]
3773 if {[rowofcommit $do] < $la} {
3774 lappend leftover $do
3775 continue
3777 foreach nk $children($v,$do) {
3778 if {![info exists descendent($nk)]} {
3779 set descendent($nk) 1
3780 lappend todo $nk
3781 if {$nk eq $a} {
3782 set done 1
3786 if {$done} {
3787 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3788 return
3791 set descendent($a) 0
3792 set desc_todo $leftover
3795 proc is_ancestor {a} {
3796 global curview parents ancestor anc_todo
3798 set v $curview
3799 set la [rowofcommit $a]
3800 set todo $anc_todo
3801 set leftover {}
3802 set done 0
3803 for {set i 0} {$i < [llength $todo]} {incr i} {
3804 set do [lindex $todo $i]
3805 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3806 lappend leftover $do
3807 continue
3809 foreach np $parents($v,$do) {
3810 if {![info exists ancestor($np)]} {
3811 set ancestor($np) 1
3812 lappend todo $np
3813 if {$np eq $a} {
3814 set done 1
3818 if {$done} {
3819 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3820 return
3823 set ancestor($a) 0
3824 set anc_todo $leftover
3827 proc askrelhighlight {row id} {
3828 global descendent highlight_related iddrawn rhighlights
3829 global selectedline ancestor
3831 if {$selectedline eq {}} return
3832 set isbold 0
3833 if {$highlight_related eq [mc "Descendant"] ||
3834 $highlight_related eq [mc "Not descendant"]} {
3835 if {![info exists descendent($id)]} {
3836 is_descendent $id
3838 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3839 set isbold 1
3841 } elseif {$highlight_related eq [mc "Ancestor"] ||
3842 $highlight_related eq [mc "Not ancestor"]} {
3843 if {![info exists ancestor($id)]} {
3844 is_ancestor $id
3846 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3847 set isbold 1
3850 if {[info exists iddrawn($id)]} {
3851 if {$isbold && ![ishighlighted $id]} {
3852 bolden $row mainfontbold
3855 set rhighlights($id) $isbold
3858 # Graph layout functions
3860 proc shortids {ids} {
3861 set res {}
3862 foreach id $ids {
3863 if {[llength $id] > 1} {
3864 lappend res [shortids $id]
3865 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3866 lappend res [string range $id 0 7]
3867 } else {
3868 lappend res $id
3871 return $res
3874 proc ntimes {n o} {
3875 set ret {}
3876 set o [list $o]
3877 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3878 if {($n & $mask) != 0} {
3879 set ret [concat $ret $o]
3881 set o [concat $o $o]
3883 return $ret
3886 proc ordertoken {id} {
3887 global ordertok curview varcid varcstart varctok curview parents children
3888 global nullid nullid2
3890 if {[info exists ordertok($id)]} {
3891 return $ordertok($id)
3893 set origid $id
3894 set todo {}
3895 while {1} {
3896 if {[info exists varcid($curview,$id)]} {
3897 set a $varcid($curview,$id)
3898 set p [lindex $varcstart($curview) $a]
3899 } else {
3900 set p [lindex $children($curview,$id) 0]
3902 if {[info exists ordertok($p)]} {
3903 set tok $ordertok($p)
3904 break
3906 set id [first_real_child $curview,$p]
3907 if {$id eq {}} {
3908 # it's a root
3909 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3910 break
3912 if {[llength $parents($curview,$id)] == 1} {
3913 lappend todo [list $p {}]
3914 } else {
3915 set j [lsearch -exact $parents($curview,$id) $p]
3916 if {$j < 0} {
3917 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3919 lappend todo [list $p [strrep $j]]
3922 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3923 set p [lindex $todo $i 0]
3924 append tok [lindex $todo $i 1]
3925 set ordertok($p) $tok
3927 set ordertok($origid) $tok
3928 return $tok
3931 # Work out where id should go in idlist so that order-token
3932 # values increase from left to right
3933 proc idcol {idlist id {i 0}} {
3934 set t [ordertoken $id]
3935 if {$i < 0} {
3936 set i 0
3938 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3939 if {$i > [llength $idlist]} {
3940 set i [llength $idlist]
3942 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3943 incr i
3944 } else {
3945 if {$t > [ordertoken [lindex $idlist $i]]} {
3946 while {[incr i] < [llength $idlist] &&
3947 $t >= [ordertoken [lindex $idlist $i]]} {}
3950 return $i
3953 proc initlayout {} {
3954 global rowidlist rowisopt rowfinal displayorder parentlist
3955 global numcommits canvxmax canv
3956 global nextcolor
3957 global colormap rowtextx
3959 set numcommits 0
3960 set displayorder {}
3961 set parentlist {}
3962 set nextcolor 0
3963 set rowidlist {}
3964 set rowisopt {}
3965 set rowfinal {}
3966 set canvxmax [$canv cget -width]
3967 catch {unset colormap}
3968 catch {unset rowtextx}
3969 setcanvscroll
3972 proc setcanvscroll {} {
3973 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3974 global lastscrollset lastscrollrows
3976 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3977 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3978 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3979 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3980 set lastscrollset [clock clicks -milliseconds]
3981 set lastscrollrows $numcommits
3984 proc visiblerows {} {
3985 global canv numcommits linespc
3987 set ymax [lindex [$canv cget -scrollregion] 3]
3988 if {$ymax eq {} || $ymax == 0} return
3989 set f [$canv yview]
3990 set y0 [expr {int([lindex $f 0] * $ymax)}]
3991 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3992 if {$r0 < 0} {
3993 set r0 0
3995 set y1 [expr {int([lindex $f 1] * $ymax)}]
3996 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3997 if {$r1 >= $numcommits} {
3998 set r1 [expr {$numcommits - 1}]
4000 return [list $r0 $r1]
4003 proc layoutmore {} {
4004 global commitidx viewcomplete curview
4005 global numcommits pending_select curview
4006 global lastscrollset lastscrollrows commitinterest
4008 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4009 [clock clicks -milliseconds] - $lastscrollset > 500} {
4010 setcanvscroll
4012 if {[info exists pending_select] &&
4013 [commitinview $pending_select $curview]} {
4014 selectline [rowofcommit $pending_select] 1
4016 drawvisible
4019 proc doshowlocalchanges {} {
4020 global curview mainheadid
4022 if {$mainheadid eq {}} return
4023 if {[commitinview $mainheadid $curview]} {
4024 dodiffindex
4025 } else {
4026 lappend commitinterest($mainheadid) {dodiffindex}
4030 proc dohidelocalchanges {} {
4031 global nullid nullid2 lserial curview
4033 if {[commitinview $nullid $curview]} {
4034 removefakerow $nullid
4036 if {[commitinview $nullid2 $curview]} {
4037 removefakerow $nullid2
4039 incr lserial
4042 # spawn off a process to do git diff-index --cached HEAD
4043 proc dodiffindex {} {
4044 global lserial showlocalchanges
4045 global isworktree
4047 if {!$showlocalchanges || !$isworktree} return
4048 incr lserial
4049 set fd [open "|git diff-index --cached HEAD" r]
4050 fconfigure $fd -blocking 0
4051 filerun $fd [list readdiffindex $fd $lserial]
4054 proc readdiffindex {fd serial} {
4055 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4057 set isdiff 1
4058 if {[gets $fd line] < 0} {
4059 if {![eof $fd]} {
4060 return 1
4062 set isdiff 0
4064 # we only need to see one line and we don't really care what it says...
4065 close $fd
4067 if {$serial != $lserial} {
4068 return 0
4071 # now see if there are any local changes not checked in to the index
4072 set fd [open "|git diff-files" r]
4073 fconfigure $fd -blocking 0
4074 filerun $fd [list readdifffiles $fd $serial]
4076 if {$isdiff && ![commitinview $nullid2 $curview]} {
4077 # add the line for the changes in the index to the graph
4078 set hl [mc "Local changes checked in to index but not committed"]
4079 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4080 set commitdata($nullid2) "\n $hl\n"
4081 if {[commitinview $nullid $curview]} {
4082 removefakerow $nullid
4084 insertfakerow $nullid2 $mainheadid
4085 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4086 removefakerow $nullid2
4088 return 0
4091 proc readdifffiles {fd serial} {
4092 global mainheadid nullid nullid2 curview
4093 global commitinfo commitdata lserial
4095 set isdiff 1
4096 if {[gets $fd line] < 0} {
4097 if {![eof $fd]} {
4098 return 1
4100 set isdiff 0
4102 # we only need to see one line and we don't really care what it says...
4103 close $fd
4105 if {$serial != $lserial} {
4106 return 0
4109 if {$isdiff && ![commitinview $nullid $curview]} {
4110 # add the line for the local diff to the graph
4111 set hl [mc "Local uncommitted changes, not checked in to index"]
4112 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4113 set commitdata($nullid) "\n $hl\n"
4114 if {[commitinview $nullid2 $curview]} {
4115 set p $nullid2
4116 } else {
4117 set p $mainheadid
4119 insertfakerow $nullid $p
4120 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4121 removefakerow $nullid
4123 return 0
4126 proc nextuse {id row} {
4127 global curview children
4129 if {[info exists children($curview,$id)]} {
4130 foreach kid $children($curview,$id) {
4131 if {![commitinview $kid $curview]} {
4132 return -1
4134 if {[rowofcommit $kid] > $row} {
4135 return [rowofcommit $kid]
4139 if {[commitinview $id $curview]} {
4140 return [rowofcommit $id]
4142 return -1
4145 proc prevuse {id row} {
4146 global curview children
4148 set ret -1
4149 if {[info exists children($curview,$id)]} {
4150 foreach kid $children($curview,$id) {
4151 if {![commitinview $kid $curview]} break
4152 if {[rowofcommit $kid] < $row} {
4153 set ret [rowofcommit $kid]
4157 return $ret
4160 proc make_idlist {row} {
4161 global displayorder parentlist uparrowlen downarrowlen mingaplen
4162 global commitidx curview children
4164 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4165 if {$r < 0} {
4166 set r 0
4168 set ra [expr {$row - $downarrowlen}]
4169 if {$ra < 0} {
4170 set ra 0
4172 set rb [expr {$row + $uparrowlen}]
4173 if {$rb > $commitidx($curview)} {
4174 set rb $commitidx($curview)
4176 make_disporder $r [expr {$rb + 1}]
4177 set ids {}
4178 for {} {$r < $ra} {incr r} {
4179 set nextid [lindex $displayorder [expr {$r + 1}]]
4180 foreach p [lindex $parentlist $r] {
4181 if {$p eq $nextid} continue
4182 set rn [nextuse $p $r]
4183 if {$rn >= $row &&
4184 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4185 lappend ids [list [ordertoken $p] $p]
4189 for {} {$r < $row} {incr r} {
4190 set nextid [lindex $displayorder [expr {$r + 1}]]
4191 foreach p [lindex $parentlist $r] {
4192 if {$p eq $nextid} continue
4193 set rn [nextuse $p $r]
4194 if {$rn < 0 || $rn >= $row} {
4195 lappend ids [list [ordertoken $p] $p]
4199 set id [lindex $displayorder $row]
4200 lappend ids [list [ordertoken $id] $id]
4201 while {$r < $rb} {
4202 foreach p [lindex $parentlist $r] {
4203 set firstkid [lindex $children($curview,$p) 0]
4204 if {[rowofcommit $firstkid] < $row} {
4205 lappend ids [list [ordertoken $p] $p]
4208 incr r
4209 set id [lindex $displayorder $r]
4210 if {$id ne {}} {
4211 set firstkid [lindex $children($curview,$id) 0]
4212 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4213 lappend ids [list [ordertoken $id] $id]
4217 set idlist {}
4218 foreach idx [lsort -unique $ids] {
4219 lappend idlist [lindex $idx 1]
4221 return $idlist
4224 proc rowsequal {a b} {
4225 while {[set i [lsearch -exact $a {}]] >= 0} {
4226 set a [lreplace $a $i $i]
4228 while {[set i [lsearch -exact $b {}]] >= 0} {
4229 set b [lreplace $b $i $i]
4231 return [expr {$a eq $b}]
4234 proc makeupline {id row rend col} {
4235 global rowidlist uparrowlen downarrowlen mingaplen
4237 for {set r $rend} {1} {set r $rstart} {
4238 set rstart [prevuse $id $r]
4239 if {$rstart < 0} return
4240 if {$rstart < $row} break
4242 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4243 set rstart [expr {$rend - $uparrowlen - 1}]
4245 for {set r $rstart} {[incr r] <= $row} {} {
4246 set idlist [lindex $rowidlist $r]
4247 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4248 set col [idcol $idlist $id $col]
4249 lset rowidlist $r [linsert $idlist $col $id]
4250 changedrow $r
4255 proc layoutrows {row endrow} {
4256 global rowidlist rowisopt rowfinal displayorder
4257 global uparrowlen downarrowlen maxwidth mingaplen
4258 global children parentlist
4259 global commitidx viewcomplete curview
4261 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4262 set idlist {}
4263 if {$row > 0} {
4264 set rm1 [expr {$row - 1}]
4265 foreach id [lindex $rowidlist $rm1] {
4266 if {$id ne {}} {
4267 lappend idlist $id
4270 set final [lindex $rowfinal $rm1]
4272 for {} {$row < $endrow} {incr row} {
4273 set rm1 [expr {$row - 1}]
4274 if {$rm1 < 0 || $idlist eq {}} {
4275 set idlist [make_idlist $row]
4276 set final 1
4277 } else {
4278 set id [lindex $displayorder $rm1]
4279 set col [lsearch -exact $idlist $id]
4280 set idlist [lreplace $idlist $col $col]
4281 foreach p [lindex $parentlist $rm1] {
4282 if {[lsearch -exact $idlist $p] < 0} {
4283 set col [idcol $idlist $p $col]
4284 set idlist [linsert $idlist $col $p]
4285 # if not the first child, we have to insert a line going up
4286 if {$id ne [lindex $children($curview,$p) 0]} {
4287 makeupline $p $rm1 $row $col
4291 set id [lindex $displayorder $row]
4292 if {$row > $downarrowlen} {
4293 set termrow [expr {$row - $downarrowlen - 1}]
4294 foreach p [lindex $parentlist $termrow] {
4295 set i [lsearch -exact $idlist $p]
4296 if {$i < 0} continue
4297 set nr [nextuse $p $termrow]
4298 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4299 set idlist [lreplace $idlist $i $i]
4303 set col [lsearch -exact $idlist $id]
4304 if {$col < 0} {
4305 set col [idcol $idlist $id]
4306 set idlist [linsert $idlist $col $id]
4307 if {$children($curview,$id) ne {}} {
4308 makeupline $id $rm1 $row $col
4311 set r [expr {$row + $uparrowlen - 1}]
4312 if {$r < $commitidx($curview)} {
4313 set x $col
4314 foreach p [lindex $parentlist $r] {
4315 if {[lsearch -exact $idlist $p] >= 0} continue
4316 set fk [lindex $children($curview,$p) 0]
4317 if {[rowofcommit $fk] < $row} {
4318 set x [idcol $idlist $p $x]
4319 set idlist [linsert $idlist $x $p]
4322 if {[incr r] < $commitidx($curview)} {
4323 set p [lindex $displayorder $r]
4324 if {[lsearch -exact $idlist $p] < 0} {
4325 set fk [lindex $children($curview,$p) 0]
4326 if {$fk ne {} && [rowofcommit $fk] < $row} {
4327 set x [idcol $idlist $p $x]
4328 set idlist [linsert $idlist $x $p]
4334 if {$final && !$viewcomplete($curview) &&
4335 $row + $uparrowlen + $mingaplen + $downarrowlen
4336 >= $commitidx($curview)} {
4337 set final 0
4339 set l [llength $rowidlist]
4340 if {$row == $l} {
4341 lappend rowidlist $idlist
4342 lappend rowisopt 0
4343 lappend rowfinal $final
4344 } elseif {$row < $l} {
4345 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4346 lset rowidlist $row $idlist
4347 changedrow $row
4349 lset rowfinal $row $final
4350 } else {
4351 set pad [ntimes [expr {$row - $l}] {}]
4352 set rowidlist [concat $rowidlist $pad]
4353 lappend rowidlist $idlist
4354 set rowfinal [concat $rowfinal $pad]
4355 lappend rowfinal $final
4356 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4359 return $row
4362 proc changedrow {row} {
4363 global displayorder iddrawn rowisopt need_redisplay
4365 set l [llength $rowisopt]
4366 if {$row < $l} {
4367 lset rowisopt $row 0
4368 if {$row + 1 < $l} {
4369 lset rowisopt [expr {$row + 1}] 0
4370 if {$row + 2 < $l} {
4371 lset rowisopt [expr {$row + 2}] 0
4375 set id [lindex $displayorder $row]
4376 if {[info exists iddrawn($id)]} {
4377 set need_redisplay 1
4381 proc insert_pad {row col npad} {
4382 global rowidlist
4384 set pad [ntimes $npad {}]
4385 set idlist [lindex $rowidlist $row]
4386 set bef [lrange $idlist 0 [expr {$col - 1}]]
4387 set aft [lrange $idlist $col end]
4388 set i [lsearch -exact $aft {}]
4389 if {$i > 0} {
4390 set aft [lreplace $aft $i $i]
4392 lset rowidlist $row [concat $bef $pad $aft]
4393 changedrow $row
4396 proc optimize_rows {row col endrow} {
4397 global rowidlist rowisopt displayorder curview children
4399 if {$row < 1} {
4400 set row 1
4402 for {} {$row < $endrow} {incr row; set col 0} {
4403 if {[lindex $rowisopt $row]} continue
4404 set haspad 0
4405 set y0 [expr {$row - 1}]
4406 set ym [expr {$row - 2}]
4407 set idlist [lindex $rowidlist $row]
4408 set previdlist [lindex $rowidlist $y0]
4409 if {$idlist eq {} || $previdlist eq {}} continue
4410 if {$ym >= 0} {
4411 set pprevidlist [lindex $rowidlist $ym]
4412 if {$pprevidlist eq {}} continue
4413 } else {
4414 set pprevidlist {}
4416 set x0 -1
4417 set xm -1
4418 for {} {$col < [llength $idlist]} {incr col} {
4419 set id [lindex $idlist $col]
4420 if {[lindex $previdlist $col] eq $id} continue
4421 if {$id eq {}} {
4422 set haspad 1
4423 continue
4425 set x0 [lsearch -exact $previdlist $id]
4426 if {$x0 < 0} continue
4427 set z [expr {$x0 - $col}]
4428 set isarrow 0
4429 set z0 {}
4430 if {$ym >= 0} {
4431 set xm [lsearch -exact $pprevidlist $id]
4432 if {$xm >= 0} {
4433 set z0 [expr {$xm - $x0}]
4436 if {$z0 eq {}} {
4437 # if row y0 is the first child of $id then it's not an arrow
4438 if {[lindex $children($curview,$id) 0] ne
4439 [lindex $displayorder $y0]} {
4440 set isarrow 1
4443 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4444 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4445 set isarrow 1
4447 # Looking at lines from this row to the previous row,
4448 # make them go straight up if they end in an arrow on
4449 # the previous row; otherwise make them go straight up
4450 # or at 45 degrees.
4451 if {$z < -1 || ($z < 0 && $isarrow)} {
4452 # Line currently goes left too much;
4453 # insert pads in the previous row, then optimize it
4454 set npad [expr {-1 - $z + $isarrow}]
4455 insert_pad $y0 $x0 $npad
4456 if {$y0 > 0} {
4457 optimize_rows $y0 $x0 $row
4459 set previdlist [lindex $rowidlist $y0]
4460 set x0 [lsearch -exact $previdlist $id]
4461 set z [expr {$x0 - $col}]
4462 if {$z0 ne {}} {
4463 set pprevidlist [lindex $rowidlist $ym]
4464 set xm [lsearch -exact $pprevidlist $id]
4465 set z0 [expr {$xm - $x0}]
4467 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4468 # Line currently goes right too much;
4469 # insert pads in this line
4470 set npad [expr {$z - 1 + $isarrow}]
4471 insert_pad $row $col $npad
4472 set idlist [lindex $rowidlist $row]
4473 incr col $npad
4474 set z [expr {$x0 - $col}]
4475 set haspad 1
4477 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4478 # this line links to its first child on row $row-2
4479 set id [lindex $displayorder $ym]
4480 set xc [lsearch -exact $pprevidlist $id]
4481 if {$xc >= 0} {
4482 set z0 [expr {$xc - $x0}]
4485 # avoid lines jigging left then immediately right
4486 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4487 insert_pad $y0 $x0 1
4488 incr x0
4489 optimize_rows $y0 $x0 $row
4490 set previdlist [lindex $rowidlist $y0]
4493 if {!$haspad} {
4494 # Find the first column that doesn't have a line going right
4495 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4496 set id [lindex $idlist $col]
4497 if {$id eq {}} break
4498 set x0 [lsearch -exact $previdlist $id]
4499 if {$x0 < 0} {
4500 # check if this is the link to the first child
4501 set kid [lindex $displayorder $y0]
4502 if {[lindex $children($curview,$id) 0] eq $kid} {
4503 # it is, work out offset to child
4504 set x0 [lsearch -exact $previdlist $kid]
4507 if {$x0 <= $col} break
4509 # Insert a pad at that column as long as it has a line and
4510 # isn't the last column
4511 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4512 set idlist [linsert $idlist $col {}]
4513 lset rowidlist $row $idlist
4514 changedrow $row
4520 proc xc {row col} {
4521 global canvx0 linespc
4522 return [expr {$canvx0 + $col * $linespc}]
4525 proc yc {row} {
4526 global canvy0 linespc
4527 return [expr {$canvy0 + $row * $linespc}]
4530 proc linewidth {id} {
4531 global thickerline lthickness
4533 set wid $lthickness
4534 if {[info exists thickerline] && $id eq $thickerline} {
4535 set wid [expr {2 * $lthickness}]
4537 return $wid
4540 proc rowranges {id} {
4541 global curview children uparrowlen downarrowlen
4542 global rowidlist
4544 set kids $children($curview,$id)
4545 if {$kids eq {}} {
4546 return {}
4548 set ret {}
4549 lappend kids $id
4550 foreach child $kids {
4551 if {![commitinview $child $curview]} break
4552 set row [rowofcommit $child]
4553 if {![info exists prev]} {
4554 lappend ret [expr {$row + 1}]
4555 } else {
4556 if {$row <= $prevrow} {
4557 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4559 # see if the line extends the whole way from prevrow to row
4560 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4561 [lsearch -exact [lindex $rowidlist \
4562 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4563 # it doesn't, see where it ends
4564 set r [expr {$prevrow + $downarrowlen}]
4565 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4566 while {[incr r -1] > $prevrow &&
4567 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4568 } else {
4569 while {[incr r] <= $row &&
4570 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4571 incr r -1
4573 lappend ret $r
4574 # see where it starts up again
4575 set r [expr {$row - $uparrowlen}]
4576 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4577 while {[incr r] < $row &&
4578 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4579 } else {
4580 while {[incr r -1] >= $prevrow &&
4581 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4582 incr r
4584 lappend ret $r
4587 if {$child eq $id} {
4588 lappend ret $row
4590 set prev $child
4591 set prevrow $row
4593 return $ret
4596 proc drawlineseg {id row endrow arrowlow} {
4597 global rowidlist displayorder iddrawn linesegs
4598 global canv colormap linespc curview maxlinelen parentlist
4600 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4601 set le [expr {$row + 1}]
4602 set arrowhigh 1
4603 while {1} {
4604 set c [lsearch -exact [lindex $rowidlist $le] $id]
4605 if {$c < 0} {
4606 incr le -1
4607 break
4609 lappend cols $c
4610 set x [lindex $displayorder $le]
4611 if {$x eq $id} {
4612 set arrowhigh 0
4613 break
4615 if {[info exists iddrawn($x)] || $le == $endrow} {
4616 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4617 if {$c >= 0} {
4618 lappend cols $c
4619 set arrowhigh 0
4621 break
4623 incr le
4625 if {$le <= $row} {
4626 return $row
4629 set lines {}
4630 set i 0
4631 set joinhigh 0
4632 if {[info exists linesegs($id)]} {
4633 set lines $linesegs($id)
4634 foreach li $lines {
4635 set r0 [lindex $li 0]
4636 if {$r0 > $row} {
4637 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4638 set joinhigh 1
4640 break
4642 incr i
4645 set joinlow 0
4646 if {$i > 0} {
4647 set li [lindex $lines [expr {$i-1}]]
4648 set r1 [lindex $li 1]
4649 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4650 set joinlow 1
4654 set x [lindex $cols [expr {$le - $row}]]
4655 set xp [lindex $cols [expr {$le - 1 - $row}]]
4656 set dir [expr {$xp - $x}]
4657 if {$joinhigh} {
4658 set ith [lindex $lines $i 2]
4659 set coords [$canv coords $ith]
4660 set ah [$canv itemcget $ith -arrow]
4661 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4662 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4663 if {$x2 ne {} && $x - $x2 == $dir} {
4664 set coords [lrange $coords 0 end-2]
4666 } else {
4667 set coords [list [xc $le $x] [yc $le]]
4669 if {$joinlow} {
4670 set itl [lindex $lines [expr {$i-1}] 2]
4671 set al [$canv itemcget $itl -arrow]
4672 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4673 } elseif {$arrowlow} {
4674 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4675 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4676 set arrowlow 0
4679 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4680 for {set y $le} {[incr y -1] > $row} {} {
4681 set x $xp
4682 set xp [lindex $cols [expr {$y - 1 - $row}]]
4683 set ndir [expr {$xp - $x}]
4684 if {$dir != $ndir || $xp < 0} {
4685 lappend coords [xc $y $x] [yc $y]
4687 set dir $ndir
4689 if {!$joinlow} {
4690 if {$xp < 0} {
4691 # join parent line to first child
4692 set ch [lindex $displayorder $row]
4693 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4694 if {$xc < 0} {
4695 puts "oops: drawlineseg: child $ch not on row $row"
4696 } elseif {$xc != $x} {
4697 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4698 set d [expr {int(0.5 * $linespc)}]
4699 set x1 [xc $row $x]
4700 if {$xc < $x} {
4701 set x2 [expr {$x1 - $d}]
4702 } else {
4703 set x2 [expr {$x1 + $d}]
4705 set y2 [yc $row]
4706 set y1 [expr {$y2 + $d}]
4707 lappend coords $x1 $y1 $x2 $y2
4708 } elseif {$xc < $x - 1} {
4709 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4710 } elseif {$xc > $x + 1} {
4711 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4713 set x $xc
4715 lappend coords [xc $row $x] [yc $row]
4716 } else {
4717 set xn [xc $row $xp]
4718 set yn [yc $row]
4719 lappend coords $xn $yn
4721 if {!$joinhigh} {
4722 assigncolor $id
4723 set t [$canv create line $coords -width [linewidth $id] \
4724 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4725 $canv lower $t
4726 bindline $t $id
4727 set lines [linsert $lines $i [list $row $le $t]]
4728 } else {
4729 $canv coords $ith $coords
4730 if {$arrow ne $ah} {
4731 $canv itemconf $ith -arrow $arrow
4733 lset lines $i 0 $row
4735 } else {
4736 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4737 set ndir [expr {$xo - $xp}]
4738 set clow [$canv coords $itl]
4739 if {$dir == $ndir} {
4740 set clow [lrange $clow 2 end]
4742 set coords [concat $coords $clow]
4743 if {!$joinhigh} {
4744 lset lines [expr {$i-1}] 1 $le
4745 } else {
4746 # coalesce two pieces
4747 $canv delete $ith
4748 set b [lindex $lines [expr {$i-1}] 0]
4749 set e [lindex $lines $i 1]
4750 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4752 $canv coords $itl $coords
4753 if {$arrow ne $al} {
4754 $canv itemconf $itl -arrow $arrow
4758 set linesegs($id) $lines
4759 return $le
4762 proc drawparentlinks {id row} {
4763 global rowidlist canv colormap curview parentlist
4764 global idpos linespc
4766 set rowids [lindex $rowidlist $row]
4767 set col [lsearch -exact $rowids $id]
4768 if {$col < 0} return
4769 set olds [lindex $parentlist $row]
4770 set row2 [expr {$row + 1}]
4771 set x [xc $row $col]
4772 set y [yc $row]
4773 set y2 [yc $row2]
4774 set d [expr {int(0.5 * $linespc)}]
4775 set ymid [expr {$y + $d}]
4776 set ids [lindex $rowidlist $row2]
4777 # rmx = right-most X coord used
4778 set rmx 0
4779 foreach p $olds {
4780 set i [lsearch -exact $ids $p]
4781 if {$i < 0} {
4782 puts "oops, parent $p of $id not in list"
4783 continue
4785 set x2 [xc $row2 $i]
4786 if {$x2 > $rmx} {
4787 set rmx $x2
4789 set j [lsearch -exact $rowids $p]
4790 if {$j < 0} {
4791 # drawlineseg will do this one for us
4792 continue
4794 assigncolor $p
4795 # should handle duplicated parents here...
4796 set coords [list $x $y]
4797 if {$i != $col} {
4798 # if attaching to a vertical segment, draw a smaller
4799 # slant for visual distinctness
4800 if {$i == $j} {
4801 if {$i < $col} {
4802 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4803 } else {
4804 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4806 } elseif {$i < $col && $i < $j} {
4807 # segment slants towards us already
4808 lappend coords [xc $row $j] $y
4809 } else {
4810 if {$i < $col - 1} {
4811 lappend coords [expr {$x2 + $linespc}] $y
4812 } elseif {$i > $col + 1} {
4813 lappend coords [expr {$x2 - $linespc}] $y
4815 lappend coords $x2 $y2
4817 } else {
4818 lappend coords $x2 $y2
4820 set t [$canv create line $coords -width [linewidth $p] \
4821 -fill $colormap($p) -tags lines.$p]
4822 $canv lower $t
4823 bindline $t $p
4825 if {$rmx > [lindex $idpos($id) 1]} {
4826 lset idpos($id) 1 $rmx
4827 redrawtags $id
4831 proc drawlines {id} {
4832 global canv
4834 $canv itemconf lines.$id -width [linewidth $id]
4837 proc drawcmittext {id row col} {
4838 global linespc canv canv2 canv3 fgcolor curview
4839 global cmitlisted commitinfo rowidlist parentlist
4840 global rowtextx idpos idtags idheads idotherrefs
4841 global linehtag linentag linedtag selectedline
4842 global canvxmax boldrows boldnamerows fgcolor
4843 global mainheadid nullid nullid2 circleitem circlecolors
4845 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4846 set listed $cmitlisted($curview,$id)
4847 if {$id eq $nullid} {
4848 set ofill red
4849 } elseif {$id eq $nullid2} {
4850 set ofill green
4851 } elseif {$id eq $mainheadid} {
4852 set ofill yellow
4853 } else {
4854 set ofill [lindex $circlecolors $listed]
4856 set x [xc $row $col]
4857 set y [yc $row]
4858 set orad [expr {$linespc / 3}]
4859 if {$listed <= 2} {
4860 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4861 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4862 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4863 } elseif {$listed == 3} {
4864 # triangle pointing left for left-side commits
4865 set t [$canv create polygon \
4866 [expr {$x - $orad}] $y \
4867 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4868 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4869 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4870 } else {
4871 # triangle pointing right for right-side commits
4872 set t [$canv create polygon \
4873 [expr {$x + $orad - 1}] $y \
4874 [expr {$x - $orad}] [expr {$y - $orad}] \
4875 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4876 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4878 set circleitem($row) $t
4879 $canv raise $t
4880 $canv bind $t <1> {selcanvline {} %x %y}
4881 set rmx [llength [lindex $rowidlist $row]]
4882 set olds [lindex $parentlist $row]
4883 if {$olds ne {}} {
4884 set nextids [lindex $rowidlist [expr {$row + 1}]]
4885 foreach p $olds {
4886 set i [lsearch -exact $nextids $p]
4887 if {$i > $rmx} {
4888 set rmx $i
4892 set xt [xc $row $rmx]
4893 set rowtextx($row) $xt
4894 set idpos($id) [list $x $xt $y]
4895 if {[info exists idtags($id)] || [info exists idheads($id)]
4896 || [info exists idotherrefs($id)]} {
4897 set xt [drawtags $id $x $xt $y]
4899 set headline [lindex $commitinfo($id) 0]
4900 set name [lindex $commitinfo($id) 1]
4901 set date [lindex $commitinfo($id) 2]
4902 set date [formatdate $date]
4903 set font mainfont
4904 set nfont mainfont
4905 set isbold [ishighlighted $id]
4906 if {$isbold > 0} {
4907 lappend boldrows $row
4908 set font mainfontbold
4909 if {$isbold > 1} {
4910 lappend boldnamerows $row
4911 set nfont mainfontbold
4914 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4915 -text $headline -font $font -tags text]
4916 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4917 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4918 -text $name -font $nfont -tags text]
4919 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4920 -text $date -font mainfont -tags text]
4921 if {$selectedline == $row} {
4922 make_secsel $row
4924 set xr [expr {$xt + [font measure $font $headline]}]
4925 if {$xr > $canvxmax} {
4926 set canvxmax $xr
4927 setcanvscroll
4931 proc drawcmitrow {row} {
4932 global displayorder rowidlist nrows_drawn
4933 global iddrawn markingmatches
4934 global commitinfo numcommits
4935 global filehighlight fhighlights findpattern nhighlights
4936 global hlview vhighlights
4937 global highlight_related rhighlights
4939 if {$row >= $numcommits} return
4941 set id [lindex $displayorder $row]
4942 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4943 askvhighlight $row $id
4945 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4946 askfilehighlight $row $id
4948 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4949 askfindhighlight $row $id
4951 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4952 askrelhighlight $row $id
4954 if {![info exists iddrawn($id)]} {
4955 set col [lsearch -exact [lindex $rowidlist $row] $id]
4956 if {$col < 0} {
4957 puts "oops, row $row id $id not in list"
4958 return
4960 if {![info exists commitinfo($id)]} {
4961 getcommit $id
4963 assigncolor $id
4964 drawcmittext $id $row $col
4965 set iddrawn($id) 1
4966 incr nrows_drawn
4968 if {$markingmatches} {
4969 markrowmatches $row $id
4973 proc drawcommits {row {endrow {}}} {
4974 global numcommits iddrawn displayorder curview need_redisplay
4975 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4977 if {$row < 0} {
4978 set row 0
4980 if {$endrow eq {}} {
4981 set endrow $row
4983 if {$endrow >= $numcommits} {
4984 set endrow [expr {$numcommits - 1}]
4987 set rl1 [expr {$row - $downarrowlen - 3}]
4988 if {$rl1 < 0} {
4989 set rl1 0
4991 set ro1 [expr {$row - 3}]
4992 if {$ro1 < 0} {
4993 set ro1 0
4995 set r2 [expr {$endrow + $uparrowlen + 3}]
4996 if {$r2 > $numcommits} {
4997 set r2 $numcommits
4999 for {set r $rl1} {$r < $r2} {incr r} {
5000 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5001 if {$rl1 < $r} {
5002 layoutrows $rl1 $r
5004 set rl1 [expr {$r + 1}]
5007 if {$rl1 < $r} {
5008 layoutrows $rl1 $r
5010 optimize_rows $ro1 0 $r2
5011 if {$need_redisplay || $nrows_drawn > 2000} {
5012 clear_display
5013 drawvisible
5016 # make the lines join to already-drawn rows either side
5017 set r [expr {$row - 1}]
5018 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5019 set r $row
5021 set er [expr {$endrow + 1}]
5022 if {$er >= $numcommits ||
5023 ![info exists iddrawn([lindex $displayorder $er])]} {
5024 set er $endrow
5026 for {} {$r <= $er} {incr r} {
5027 set id [lindex $displayorder $r]
5028 set wasdrawn [info exists iddrawn($id)]
5029 drawcmitrow $r
5030 if {$r == $er} break
5031 set nextid [lindex $displayorder [expr {$r + 1}]]
5032 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5033 drawparentlinks $id $r
5035 set rowids [lindex $rowidlist $r]
5036 foreach lid $rowids {
5037 if {$lid eq {}} continue
5038 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5039 if {$lid eq $id} {
5040 # see if this is the first child of any of its parents
5041 foreach p [lindex $parentlist $r] {
5042 if {[lsearch -exact $rowids $p] < 0} {
5043 # make this line extend up to the child
5044 set lineend($p) [drawlineseg $p $r $er 0]
5047 } else {
5048 set lineend($lid) [drawlineseg $lid $r $er 1]
5054 proc undolayout {row} {
5055 global uparrowlen mingaplen downarrowlen
5056 global rowidlist rowisopt rowfinal need_redisplay
5058 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5059 if {$r < 0} {
5060 set r 0
5062 if {[llength $rowidlist] > $r} {
5063 incr r -1
5064 set rowidlist [lrange $rowidlist 0 $r]
5065 set rowfinal [lrange $rowfinal 0 $r]
5066 set rowisopt [lrange $rowisopt 0 $r]
5067 set need_redisplay 1
5068 run drawvisible
5072 proc drawvisible {} {
5073 global canv linespc curview vrowmod selectedline targetrow targetid
5074 global need_redisplay cscroll numcommits
5076 set fs [$canv yview]
5077 set ymax [lindex [$canv cget -scrollregion] 3]
5078 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5079 set f0 [lindex $fs 0]
5080 set f1 [lindex $fs 1]
5081 set y0 [expr {int($f0 * $ymax)}]
5082 set y1 [expr {int($f1 * $ymax)}]
5084 if {[info exists targetid]} {
5085 if {[commitinview $targetid $curview]} {
5086 set r [rowofcommit $targetid]
5087 if {$r != $targetrow} {
5088 # Fix up the scrollregion and change the scrolling position
5089 # now that our target row has moved.
5090 set diff [expr {($r - $targetrow) * $linespc}]
5091 set targetrow $r
5092 setcanvscroll
5093 set ymax [lindex [$canv cget -scrollregion] 3]
5094 incr y0 $diff
5095 incr y1 $diff
5096 set f0 [expr {$y0 / $ymax}]
5097 set f1 [expr {$y1 / $ymax}]
5098 allcanvs yview moveto $f0
5099 $cscroll set $f0 $f1
5100 set need_redisplay 1
5102 } else {
5103 unset targetid
5107 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5108 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5109 if {$endrow >= $vrowmod($curview)} {
5110 update_arcrows $curview
5112 if {$selectedline ne {} &&
5113 $row <= $selectedline && $selectedline <= $endrow} {
5114 set targetrow $selectedline
5115 } elseif {[info exists targetid]} {
5116 set targetrow [expr {int(($row + $endrow) / 2)}]
5118 if {[info exists targetrow]} {
5119 if {$targetrow >= $numcommits} {
5120 set targetrow [expr {$numcommits - 1}]
5122 set targetid [commitonrow $targetrow]
5124 drawcommits $row $endrow
5127 proc clear_display {} {
5128 global iddrawn linesegs need_redisplay nrows_drawn
5129 global vhighlights fhighlights nhighlights rhighlights
5130 global linehtag linentag linedtag boldrows boldnamerows
5132 allcanvs delete all
5133 catch {unset iddrawn}
5134 catch {unset linesegs}
5135 catch {unset linehtag}
5136 catch {unset linentag}
5137 catch {unset linedtag}
5138 set boldrows {}
5139 set boldnamerows {}
5140 catch {unset vhighlights}
5141 catch {unset fhighlights}
5142 catch {unset nhighlights}
5143 catch {unset rhighlights}
5144 set need_redisplay 0
5145 set nrows_drawn 0
5148 proc findcrossings {id} {
5149 global rowidlist parentlist numcommits displayorder
5151 set cross {}
5152 set ccross {}
5153 foreach {s e} [rowranges $id] {
5154 if {$e >= $numcommits} {
5155 set e [expr {$numcommits - 1}]
5157 if {$e <= $s} continue
5158 for {set row $e} {[incr row -1] >= $s} {} {
5159 set x [lsearch -exact [lindex $rowidlist $row] $id]
5160 if {$x < 0} break
5161 set olds [lindex $parentlist $row]
5162 set kid [lindex $displayorder $row]
5163 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5164 if {$kidx < 0} continue
5165 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5166 foreach p $olds {
5167 set px [lsearch -exact $nextrow $p]
5168 if {$px < 0} continue
5169 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5170 if {[lsearch -exact $ccross $p] >= 0} continue
5171 if {$x == $px + ($kidx < $px? -1: 1)} {
5172 lappend ccross $p
5173 } elseif {[lsearch -exact $cross $p] < 0} {
5174 lappend cross $p
5180 return [concat $ccross {{}} $cross]
5183 proc assigncolor {id} {
5184 global colormap colors nextcolor
5185 global parents children children curview
5187 if {[info exists colormap($id)]} return
5188 set ncolors [llength $colors]
5189 if {[info exists children($curview,$id)]} {
5190 set kids $children($curview,$id)
5191 } else {
5192 set kids {}
5194 if {[llength $kids] == 1} {
5195 set child [lindex $kids 0]
5196 if {[info exists colormap($child)]
5197 && [llength $parents($curview,$child)] == 1} {
5198 set colormap($id) $colormap($child)
5199 return
5202 set badcolors {}
5203 set origbad {}
5204 foreach x [findcrossings $id] {
5205 if {$x eq {}} {
5206 # delimiter between corner crossings and other crossings
5207 if {[llength $badcolors] >= $ncolors - 1} break
5208 set origbad $badcolors
5210 if {[info exists colormap($x)]
5211 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5212 lappend badcolors $colormap($x)
5215 if {[llength $badcolors] >= $ncolors} {
5216 set badcolors $origbad
5218 set origbad $badcolors
5219 if {[llength $badcolors] < $ncolors - 1} {
5220 foreach child $kids {
5221 if {[info exists colormap($child)]
5222 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5223 lappend badcolors $colormap($child)
5225 foreach p $parents($curview,$child) {
5226 if {[info exists colormap($p)]
5227 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5228 lappend badcolors $colormap($p)
5232 if {[llength $badcolors] >= $ncolors} {
5233 set badcolors $origbad
5236 for {set i 0} {$i <= $ncolors} {incr i} {
5237 set c [lindex $colors $nextcolor]
5238 if {[incr nextcolor] >= $ncolors} {
5239 set nextcolor 0
5241 if {[lsearch -exact $badcolors $c]} break
5243 set colormap($id) $c
5246 proc bindline {t id} {
5247 global canv
5249 $canv bind $t <Enter> "lineenter %x %y $id"
5250 $canv bind $t <Motion> "linemotion %x %y $id"
5251 $canv bind $t <Leave> "lineleave $id"
5252 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5255 proc drawtags {id x xt y1} {
5256 global idtags idheads idotherrefs mainhead
5257 global linespc lthickness
5258 global canv rowtextx curview fgcolor bgcolor
5260 set marks {}
5261 set ntags 0
5262 set nheads 0
5263 if {[info exists idtags($id)]} {
5264 set marks $idtags($id)
5265 set ntags [llength $marks]
5267 if {[info exists idheads($id)]} {
5268 set marks [concat $marks $idheads($id)]
5269 set nheads [llength $idheads($id)]
5271 if {[info exists idotherrefs($id)]} {
5272 set marks [concat $marks $idotherrefs($id)]
5274 if {$marks eq {}} {
5275 return $xt
5278 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5279 set yt [expr {$y1 - 0.5 * $linespc}]
5280 set yb [expr {$yt + $linespc - 1}]
5281 set xvals {}
5282 set wvals {}
5283 set i -1
5284 foreach tag $marks {
5285 incr i
5286 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5287 set wid [font measure mainfontbold $tag]
5288 } else {
5289 set wid [font measure mainfont $tag]
5291 lappend xvals $xt
5292 lappend wvals $wid
5293 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5295 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5296 -width $lthickness -fill black -tags tag.$id]
5297 $canv lower $t
5298 foreach tag $marks x $xvals wid $wvals {
5299 set xl [expr {$x + $delta}]
5300 set xr [expr {$x + $delta + $wid + $lthickness}]
5301 set font mainfont
5302 if {[incr ntags -1] >= 0} {
5303 # draw a tag
5304 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5305 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5306 -width 1 -outline black -fill yellow -tags tag.$id]
5307 $canv bind $t <1> [list showtag $tag 1]
5308 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5309 } else {
5310 # draw a head or other ref
5311 if {[incr nheads -1] >= 0} {
5312 set col green
5313 if {$tag eq $mainhead} {
5314 set font mainfontbold
5316 } else {
5317 set col "#ddddff"
5319 set xl [expr {$xl - $delta/2}]
5320 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5321 -width 1 -outline black -fill $col -tags tag.$id
5322 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5323 set rwid [font measure mainfont $remoteprefix]
5324 set xi [expr {$x + 1}]
5325 set yti [expr {$yt + 1}]
5326 set xri [expr {$x + $rwid}]
5327 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5328 -width 0 -fill "#ffddaa" -tags tag.$id
5331 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5332 -font $font -tags [list tag.$id text]]
5333 if {$ntags >= 0} {
5334 $canv bind $t <1> [list showtag $tag 1]
5335 } elseif {$nheads >= 0} {
5336 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5339 return $xt
5342 proc xcoord {i level ln} {
5343 global canvx0 xspc1 xspc2
5345 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5346 if {$i > 0 && $i == $level} {
5347 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5348 } elseif {$i > $level} {
5349 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5351 return $x
5354 proc show_status {msg} {
5355 global canv fgcolor
5357 clear_display
5358 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5359 -tags text -fill $fgcolor
5362 # Don't change the text pane cursor if it is currently the hand cursor,
5363 # showing that we are over a sha1 ID link.
5364 proc settextcursor {c} {
5365 global ctext curtextcursor
5367 if {[$ctext cget -cursor] == $curtextcursor} {
5368 $ctext config -cursor $c
5370 set curtextcursor $c
5373 proc nowbusy {what {name {}}} {
5374 global isbusy busyname statusw
5376 if {[array names isbusy] eq {}} {
5377 . config -cursor watch
5378 settextcursor watch
5380 set isbusy($what) 1
5381 set busyname($what) $name
5382 if {$name ne {}} {
5383 $statusw conf -text $name
5387 proc notbusy {what} {
5388 global isbusy maincursor textcursor busyname statusw
5390 catch {
5391 unset isbusy($what)
5392 if {$busyname($what) ne {} &&
5393 [$statusw cget -text] eq $busyname($what)} {
5394 $statusw conf -text {}
5397 if {[array names isbusy] eq {}} {
5398 . config -cursor $maincursor
5399 settextcursor $textcursor
5403 proc findmatches {f} {
5404 global findtype findstring
5405 if {$findtype == [mc "Regexp"]} {
5406 set matches [regexp -indices -all -inline $findstring $f]
5407 } else {
5408 set fs $findstring
5409 if {$findtype == [mc "IgnCase"]} {
5410 set f [string tolower $f]
5411 set fs [string tolower $fs]
5413 set matches {}
5414 set i 0
5415 set l [string length $fs]
5416 while {[set j [string first $fs $f $i]] >= 0} {
5417 lappend matches [list $j [expr {$j+$l-1}]]
5418 set i [expr {$j + $l}]
5421 return $matches
5424 proc dofind {{dirn 1} {wrap 1}} {
5425 global findstring findstartline findcurline selectedline numcommits
5426 global gdttype filehighlight fh_serial find_dirn findallowwrap
5428 if {[info exists find_dirn]} {
5429 if {$find_dirn == $dirn} return
5430 stopfinding
5432 focus .
5433 if {$findstring eq {} || $numcommits == 0} return
5434 if {$selectedline eq {}} {
5435 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5436 } else {
5437 set findstartline $selectedline
5439 set findcurline $findstartline
5440 nowbusy finding [mc "Searching"]
5441 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5442 after cancel do_file_hl $fh_serial
5443 do_file_hl $fh_serial
5445 set find_dirn $dirn
5446 set findallowwrap $wrap
5447 run findmore
5450 proc stopfinding {} {
5451 global find_dirn findcurline fprogcoord
5453 if {[info exists find_dirn]} {
5454 unset find_dirn
5455 unset findcurline
5456 notbusy finding
5457 set fprogcoord 0
5458 adjustprogress
5462 proc findmore {} {
5463 global commitdata commitinfo numcommits findpattern findloc
5464 global findstartline findcurline findallowwrap
5465 global find_dirn gdttype fhighlights fprogcoord
5466 global curview varcorder vrownum varccommits vrowmod
5468 if {![info exists find_dirn]} {
5469 return 0
5471 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5472 set l $findcurline
5473 set moretodo 0
5474 if {$find_dirn > 0} {
5475 incr l
5476 if {$l >= $numcommits} {
5477 set l 0
5479 if {$l <= $findstartline} {
5480 set lim [expr {$findstartline + 1}]
5481 } else {
5482 set lim $numcommits
5483 set moretodo $findallowwrap
5485 } else {
5486 if {$l == 0} {
5487 set l $numcommits
5489 incr l -1
5490 if {$l >= $findstartline} {
5491 set lim [expr {$findstartline - 1}]
5492 } else {
5493 set lim -1
5494 set moretodo $findallowwrap
5497 set n [expr {($lim - $l) * $find_dirn}]
5498 if {$n > 500} {
5499 set n 500
5500 set moretodo 1
5502 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5503 update_arcrows $curview
5505 set found 0
5506 set domore 1
5507 set ai [bsearch $vrownum($curview) $l]
5508 set a [lindex $varcorder($curview) $ai]
5509 set arow [lindex $vrownum($curview) $ai]
5510 set ids [lindex $varccommits($curview,$a)]
5511 set arowend [expr {$arow + [llength $ids]}]
5512 if {$gdttype eq [mc "containing:"]} {
5513 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5514 if {$l < $arow || $l >= $arowend} {
5515 incr ai $find_dirn
5516 set a [lindex $varcorder($curview) $ai]
5517 set arow [lindex $vrownum($curview) $ai]
5518 set ids [lindex $varccommits($curview,$a)]
5519 set arowend [expr {$arow + [llength $ids]}]
5521 set id [lindex $ids [expr {$l - $arow}]]
5522 # shouldn't happen unless git log doesn't give all the commits...
5523 if {![info exists commitdata($id)] ||
5524 ![doesmatch $commitdata($id)]} {
5525 continue
5527 if {![info exists commitinfo($id)]} {
5528 getcommit $id
5530 set info $commitinfo($id)
5531 foreach f $info ty $fldtypes {
5532 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5533 [doesmatch $f]} {
5534 set found 1
5535 break
5538 if {$found} break
5540 } else {
5541 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5542 if {$l < $arow || $l >= $arowend} {
5543 incr ai $find_dirn
5544 set a [lindex $varcorder($curview) $ai]
5545 set arow [lindex $vrownum($curview) $ai]
5546 set ids [lindex $varccommits($curview,$a)]
5547 set arowend [expr {$arow + [llength $ids]}]
5549 set id [lindex $ids [expr {$l - $arow}]]
5550 if {![info exists fhighlights($id)]} {
5551 # this sets fhighlights($id) to -1
5552 askfilehighlight $l $id
5554 if {$fhighlights($id) > 0} {
5555 set found $domore
5556 break
5558 if {$fhighlights($id) < 0} {
5559 if {$domore} {
5560 set domore 0
5561 set findcurline [expr {$l - $find_dirn}]
5566 if {$found || ($domore && !$moretodo)} {
5567 unset findcurline
5568 unset find_dirn
5569 notbusy finding
5570 set fprogcoord 0
5571 adjustprogress
5572 if {$found} {
5573 findselectline $l
5574 } else {
5575 bell
5577 return 0
5579 if {!$domore} {
5580 flushhighlights
5581 } else {
5582 set findcurline [expr {$l - $find_dirn}]
5584 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5585 if {$n < 0} {
5586 incr n $numcommits
5588 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5589 adjustprogress
5590 return $domore
5593 proc findselectline {l} {
5594 global findloc commentend ctext findcurline markingmatches gdttype
5596 set markingmatches 1
5597 set findcurline $l
5598 selectline $l 1
5599 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5600 # highlight the matches in the comments
5601 set f [$ctext get 1.0 $commentend]
5602 set matches [findmatches $f]
5603 foreach match $matches {
5604 set start [lindex $match 0]
5605 set end [expr {[lindex $match 1] + 1}]
5606 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5609 drawvisible
5612 # mark the bits of a headline or author that match a find string
5613 proc markmatches {canv l str tag matches font row} {
5614 global selectedline
5616 set bbox [$canv bbox $tag]
5617 set x0 [lindex $bbox 0]
5618 set y0 [lindex $bbox 1]
5619 set y1 [lindex $bbox 3]
5620 foreach match $matches {
5621 set start [lindex $match 0]
5622 set end [lindex $match 1]
5623 if {$start > $end} continue
5624 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5625 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5626 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5627 [expr {$x0+$xlen+2}] $y1 \
5628 -outline {} -tags [list match$l matches] -fill yellow]
5629 $canv lower $t
5630 if {$row == $selectedline} {
5631 $canv raise $t secsel
5636 proc unmarkmatches {} {
5637 global markingmatches
5639 allcanvs delete matches
5640 set markingmatches 0
5641 stopfinding
5644 proc selcanvline {w x y} {
5645 global canv canvy0 ctext linespc
5646 global rowtextx
5647 set ymax [lindex [$canv cget -scrollregion] 3]
5648 if {$ymax == {}} return
5649 set yfrac [lindex [$canv yview] 0]
5650 set y [expr {$y + $yfrac * $ymax}]
5651 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5652 if {$l < 0} {
5653 set l 0
5655 if {$w eq $canv} {
5656 set xmax [lindex [$canv cget -scrollregion] 2]
5657 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5658 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5660 unmarkmatches
5661 selectline $l 1
5664 proc commit_descriptor {p} {
5665 global commitinfo
5666 if {![info exists commitinfo($p)]} {
5667 getcommit $p
5669 set l "..."
5670 if {[llength $commitinfo($p)] > 1} {
5671 set l [lindex $commitinfo($p) 0]
5673 return "$p ($l)\n"
5676 # append some text to the ctext widget, and make any SHA1 ID
5677 # that we know about be a clickable link.
5678 proc appendwithlinks {text tags} {
5679 global ctext linknum curview pendinglinks
5681 set start [$ctext index "end - 1c"]
5682 $ctext insert end $text $tags
5683 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5684 foreach l $links {
5685 set s [lindex $l 0]
5686 set e [lindex $l 1]
5687 set linkid [string range $text $s $e]
5688 incr e
5689 $ctext tag delete link$linknum
5690 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5691 setlink $linkid link$linknum
5692 incr linknum
5696 proc setlink {id lk} {
5697 global curview ctext pendinglinks commitinterest
5699 if {[commitinview $id $curview]} {
5700 $ctext tag conf $lk -foreground blue -underline 1
5701 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5702 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5703 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5704 } else {
5705 lappend pendinglinks($id) $lk
5706 lappend commitinterest($id) {makelink %I}
5710 proc makelink {id} {
5711 global pendinglinks
5713 if {![info exists pendinglinks($id)]} return
5714 foreach lk $pendinglinks($id) {
5715 setlink $id $lk
5717 unset pendinglinks($id)
5720 proc linkcursor {w inc} {
5721 global linkentercount curtextcursor
5723 if {[incr linkentercount $inc] > 0} {
5724 $w configure -cursor hand2
5725 } else {
5726 $w configure -cursor $curtextcursor
5727 if {$linkentercount < 0} {
5728 set linkentercount 0
5733 proc viewnextline {dir} {
5734 global canv linespc
5736 $canv delete hover
5737 set ymax [lindex [$canv cget -scrollregion] 3]
5738 set wnow [$canv yview]
5739 set wtop [expr {[lindex $wnow 0] * $ymax}]
5740 set newtop [expr {$wtop + $dir * $linespc}]
5741 if {$newtop < 0} {
5742 set newtop 0
5743 } elseif {$newtop > $ymax} {
5744 set newtop $ymax
5746 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5749 # add a list of tag or branch names at position pos
5750 # returns the number of names inserted
5751 proc appendrefs {pos ids var} {
5752 global ctext linknum curview $var maxrefs
5754 if {[catch {$ctext index $pos}]} {
5755 return 0
5757 $ctext conf -state normal
5758 $ctext delete $pos "$pos lineend"
5759 set tags {}
5760 foreach id $ids {
5761 foreach tag [set $var\($id\)] {
5762 lappend tags [list $tag $id]
5765 if {[llength $tags] > $maxrefs} {
5766 $ctext insert $pos "many ([llength $tags])"
5767 } else {
5768 set tags [lsort -index 0 -decreasing $tags]
5769 set sep {}
5770 foreach ti $tags {
5771 set id [lindex $ti 1]
5772 set lk link$linknum
5773 incr linknum
5774 $ctext tag delete $lk
5775 $ctext insert $pos $sep
5776 $ctext insert $pos [lindex $ti 0] $lk
5777 setlink $id $lk
5778 set sep ", "
5781 $ctext conf -state disabled
5782 return [llength $tags]
5785 # called when we have finished computing the nearby tags
5786 proc dispneartags {delay} {
5787 global selectedline currentid showneartags tagphase
5789 if {$selectedline eq {} || !$showneartags} return
5790 after cancel dispnexttag
5791 if {$delay} {
5792 after 200 dispnexttag
5793 set tagphase -1
5794 } else {
5795 after idle dispnexttag
5796 set tagphase 0
5800 proc dispnexttag {} {
5801 global selectedline currentid showneartags tagphase ctext
5803 if {$selectedline eq {} || !$showneartags} return
5804 switch -- $tagphase {
5806 set dtags [desctags $currentid]
5807 if {$dtags ne {}} {
5808 appendrefs precedes $dtags idtags
5812 set atags [anctags $currentid]
5813 if {$atags ne {}} {
5814 appendrefs follows $atags idtags
5818 set dheads [descheads $currentid]
5819 if {$dheads ne {}} {
5820 if {[appendrefs branch $dheads idheads] > 1
5821 && [$ctext get "branch -3c"] eq "h"} {
5822 # turn "Branch" into "Branches"
5823 $ctext conf -state normal
5824 $ctext insert "branch -2c" "es"
5825 $ctext conf -state disabled
5830 if {[incr tagphase] <= 2} {
5831 after idle dispnexttag
5835 proc make_secsel {l} {
5836 global linehtag linentag linedtag canv canv2 canv3
5838 if {![info exists linehtag($l)]} return
5839 $canv delete secsel
5840 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5841 -tags secsel -fill [$canv cget -selectbackground]]
5842 $canv lower $t
5843 $canv2 delete secsel
5844 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5845 -tags secsel -fill [$canv2 cget -selectbackground]]
5846 $canv2 lower $t
5847 $canv3 delete secsel
5848 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5849 -tags secsel -fill [$canv3 cget -selectbackground]]
5850 $canv3 lower $t
5853 proc selectline {l isnew} {
5854 global canv ctext commitinfo selectedline
5855 global canvy0 linespc parents children curview
5856 global currentid sha1entry
5857 global commentend idtags linknum
5858 global mergemax numcommits pending_select
5859 global cmitmode showneartags allcommits
5860 global targetrow targetid lastscrollrows
5861 global autoselect
5863 catch {unset pending_select}
5864 $canv delete hover
5865 normalline
5866 unsel_reflist
5867 stopfinding
5868 if {$l < 0 || $l >= $numcommits} return
5869 set id [commitonrow $l]
5870 set targetid $id
5871 set targetrow $l
5872 set selectedline $l
5873 set currentid $id
5874 if {$lastscrollrows < $numcommits} {
5875 setcanvscroll
5878 set y [expr {$canvy0 + $l * $linespc}]
5879 set ymax [lindex [$canv cget -scrollregion] 3]
5880 set ytop [expr {$y - $linespc - 1}]
5881 set ybot [expr {$y + $linespc + 1}]
5882 set wnow [$canv yview]
5883 set wtop [expr {[lindex $wnow 0] * $ymax}]
5884 set wbot [expr {[lindex $wnow 1] * $ymax}]
5885 set wh [expr {$wbot - $wtop}]
5886 set newtop $wtop
5887 if {$ytop < $wtop} {
5888 if {$ybot < $wtop} {
5889 set newtop [expr {$y - $wh / 2.0}]
5890 } else {
5891 set newtop $ytop
5892 if {$newtop > $wtop - $linespc} {
5893 set newtop [expr {$wtop - $linespc}]
5896 } elseif {$ybot > $wbot} {
5897 if {$ytop > $wbot} {
5898 set newtop [expr {$y - $wh / 2.0}]
5899 } else {
5900 set newtop [expr {$ybot - $wh}]
5901 if {$newtop < $wtop + $linespc} {
5902 set newtop [expr {$wtop + $linespc}]
5906 if {$newtop != $wtop} {
5907 if {$newtop < 0} {
5908 set newtop 0
5910 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5911 drawvisible
5914 make_secsel $l
5916 if {$isnew} {
5917 addtohistory [list selbyid $id]
5920 $sha1entry delete 0 end
5921 $sha1entry insert 0 $id
5922 if {$autoselect} {
5923 $sha1entry selection from 0
5924 $sha1entry selection to end
5926 rhighlight_sel $id
5928 $ctext conf -state normal
5929 clear_ctext
5930 set linknum 0
5931 if {![info exists commitinfo($id)]} {
5932 getcommit $id
5934 set info $commitinfo($id)
5935 set date [formatdate [lindex $info 2]]
5936 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5937 set date [formatdate [lindex $info 4]]
5938 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5939 if {[info exists idtags($id)]} {
5940 $ctext insert end [mc "Tags:"]
5941 foreach tag $idtags($id) {
5942 $ctext insert end " $tag"
5944 $ctext insert end "\n"
5947 set headers {}
5948 set olds $parents($curview,$id)
5949 if {[llength $olds] > 1} {
5950 set np 0
5951 foreach p $olds {
5952 if {$np >= $mergemax} {
5953 set tag mmax
5954 } else {
5955 set tag m$np
5957 $ctext insert end "[mc "Parent"]: " $tag
5958 appendwithlinks [commit_descriptor $p] {}
5959 incr np
5961 } else {
5962 foreach p $olds {
5963 append headers "[mc "Parent"]: [commit_descriptor $p]"
5967 foreach c $children($curview,$id) {
5968 append headers "[mc "Child"]: [commit_descriptor $c]"
5971 # make anything that looks like a SHA1 ID be a clickable link
5972 appendwithlinks $headers {}
5973 if {$showneartags} {
5974 if {![info exists allcommits]} {
5975 getallcommits
5977 $ctext insert end "[mc "Branch"]: "
5978 $ctext mark set branch "end -1c"
5979 $ctext mark gravity branch left
5980 $ctext insert end "\n[mc "Follows"]: "
5981 $ctext mark set follows "end -1c"
5982 $ctext mark gravity follows left
5983 $ctext insert end "\n[mc "Precedes"]: "
5984 $ctext mark set precedes "end -1c"
5985 $ctext mark gravity precedes left
5986 $ctext insert end "\n"
5987 dispneartags 1
5989 $ctext insert end "\n"
5990 set comment [lindex $info 5]
5991 if {[string first "\r" $comment] >= 0} {
5992 set comment [string map {"\r" "\n "} $comment]
5994 appendwithlinks $comment {comment}
5996 $ctext tag remove found 1.0 end
5997 $ctext conf -state disabled
5998 set commentend [$ctext index "end - 1c"]
6000 init_flist [mc "Comments"]
6001 if {$cmitmode eq "tree"} {
6002 gettree $id
6003 } elseif {[llength $olds] <= 1} {
6004 startdiff $id
6005 } else {
6006 mergediff $id
6010 proc selfirstline {} {
6011 unmarkmatches
6012 selectline 0 1
6015 proc sellastline {} {
6016 global numcommits
6017 unmarkmatches
6018 set l [expr {$numcommits - 1}]
6019 selectline $l 1
6022 proc selnextline {dir} {
6023 global selectedline
6024 focus .
6025 if {$selectedline eq {}} return
6026 set l [expr {$selectedline + $dir}]
6027 unmarkmatches
6028 selectline $l 1
6031 proc selnextpage {dir} {
6032 global canv linespc selectedline numcommits
6034 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6035 if {$lpp < 1} {
6036 set lpp 1
6038 allcanvs yview scroll [expr {$dir * $lpp}] units
6039 drawvisible
6040 if {$selectedline eq {}} return
6041 set l [expr {$selectedline + $dir * $lpp}]
6042 if {$l < 0} {
6043 set l 0
6044 } elseif {$l >= $numcommits} {
6045 set l [expr $numcommits - 1]
6047 unmarkmatches
6048 selectline $l 1
6051 proc unselectline {} {
6052 global selectedline currentid
6054 set selectedline {}
6055 catch {unset currentid}
6056 allcanvs delete secsel
6057 rhighlight_none
6060 proc reselectline {} {
6061 global selectedline
6063 if {$selectedline ne {}} {
6064 selectline $selectedline 0
6068 proc addtohistory {cmd} {
6069 global history historyindex curview
6071 set elt [list $curview $cmd]
6072 if {$historyindex > 0
6073 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6074 return
6077 if {$historyindex < [llength $history]} {
6078 set history [lreplace $history $historyindex end $elt]
6079 } else {
6080 lappend history $elt
6082 incr historyindex
6083 if {$historyindex > 1} {
6084 .tf.bar.leftbut conf -state normal
6085 } else {
6086 .tf.bar.leftbut conf -state disabled
6088 .tf.bar.rightbut conf -state disabled
6091 proc godo {elt} {
6092 global curview
6094 set view [lindex $elt 0]
6095 set cmd [lindex $elt 1]
6096 if {$curview != $view} {
6097 showview $view
6099 eval $cmd
6102 proc goback {} {
6103 global history historyindex
6104 focus .
6106 if {$historyindex > 1} {
6107 incr historyindex -1
6108 godo [lindex $history [expr {$historyindex - 1}]]
6109 .tf.bar.rightbut conf -state normal
6111 if {$historyindex <= 1} {
6112 .tf.bar.leftbut conf -state disabled
6116 proc goforw {} {
6117 global history historyindex
6118 focus .
6120 if {$historyindex < [llength $history]} {
6121 set cmd [lindex $history $historyindex]
6122 incr historyindex
6123 godo $cmd
6124 .tf.bar.leftbut conf -state normal
6126 if {$historyindex >= [llength $history]} {
6127 .tf.bar.rightbut conf -state disabled
6131 proc gettree {id} {
6132 global treefilelist treeidlist diffids diffmergeid treepending
6133 global nullid nullid2
6135 set diffids $id
6136 catch {unset diffmergeid}
6137 if {![info exists treefilelist($id)]} {
6138 if {![info exists treepending]} {
6139 if {$id eq $nullid} {
6140 set cmd [list | git ls-files]
6141 } elseif {$id eq $nullid2} {
6142 set cmd [list | git ls-files --stage -t]
6143 } else {
6144 set cmd [list | git ls-tree -r $id]
6146 if {[catch {set gtf [open $cmd r]}]} {
6147 return
6149 set treepending $id
6150 set treefilelist($id) {}
6151 set treeidlist($id) {}
6152 fconfigure $gtf -blocking 0
6153 filerun $gtf [list gettreeline $gtf $id]
6155 } else {
6156 setfilelist $id
6160 proc gettreeline {gtf id} {
6161 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6163 set nl 0
6164 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6165 if {$diffids eq $nullid} {
6166 set fname $line
6167 } else {
6168 set i [string first "\t" $line]
6169 if {$i < 0} continue
6170 set fname [string range $line [expr {$i+1}] end]
6171 set line [string range $line 0 [expr {$i-1}]]
6172 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6173 set sha1 [lindex $line 2]
6174 if {[string index $fname 0] eq "\""} {
6175 set fname [lindex $fname 0]
6177 lappend treeidlist($id) $sha1
6179 lappend treefilelist($id) $fname
6181 if {![eof $gtf]} {
6182 return [expr {$nl >= 1000? 2: 1}]
6184 close $gtf
6185 unset treepending
6186 if {$cmitmode ne "tree"} {
6187 if {![info exists diffmergeid]} {
6188 gettreediffs $diffids
6190 } elseif {$id ne $diffids} {
6191 gettree $diffids
6192 } else {
6193 setfilelist $id
6195 return 0
6198 proc showfile {f} {
6199 global treefilelist treeidlist diffids nullid nullid2
6200 global ctext commentend
6202 set i [lsearch -exact $treefilelist($diffids) $f]
6203 if {$i < 0} {
6204 puts "oops, $f not in list for id $diffids"
6205 return
6207 if {$diffids eq $nullid} {
6208 if {[catch {set bf [open $f r]} err]} {
6209 puts "oops, can't read $f: $err"
6210 return
6212 } else {
6213 set blob [lindex $treeidlist($diffids) $i]
6214 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6215 puts "oops, error reading blob $blob: $err"
6216 return
6219 fconfigure $bf -blocking 0
6220 filerun $bf [list getblobline $bf $diffids]
6221 $ctext config -state normal
6222 clear_ctext $commentend
6223 $ctext insert end "\n"
6224 $ctext insert end "$f\n" filesep
6225 $ctext config -state disabled
6226 $ctext yview $commentend
6227 settabs 0
6230 proc getblobline {bf id} {
6231 global diffids cmitmode ctext
6233 if {$id ne $diffids || $cmitmode ne "tree"} {
6234 catch {close $bf}
6235 return 0
6237 $ctext config -state normal
6238 set nl 0
6239 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6240 $ctext insert end "$line\n"
6242 if {[eof $bf]} {
6243 # delete last newline
6244 $ctext delete "end - 2c" "end - 1c"
6245 close $bf
6246 return 0
6248 $ctext config -state disabled
6249 return [expr {$nl >= 1000? 2: 1}]
6252 proc mergediff {id} {
6253 global diffmergeid mdifffd
6254 global diffids
6255 global parents
6256 global diffcontext
6257 global limitdiffs vfilelimit curview
6259 set diffmergeid $id
6260 set diffids $id
6261 # this doesn't seem to actually affect anything...
6262 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6263 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6264 set cmd [concat $cmd -- $vfilelimit($curview)]
6266 if {[catch {set mdf [open $cmd r]} err]} {
6267 error_popup "[mc "Error getting merge diffs:"] $err"
6268 return
6270 fconfigure $mdf -blocking 0
6271 set mdifffd($id) $mdf
6272 set np [llength $parents($curview,$id)]
6273 settabs $np
6274 filerun $mdf [list getmergediffline $mdf $id $np]
6277 proc getmergediffline {mdf id np} {
6278 global diffmergeid ctext cflist mergemax
6279 global difffilestart mdifffd
6281 $ctext conf -state normal
6282 set nr 0
6283 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6284 if {![info exists diffmergeid] || $id != $diffmergeid
6285 || $mdf != $mdifffd($id)} {
6286 close $mdf
6287 return 0
6289 if {[regexp {^diff --cc (.*)} $line match fname]} {
6290 # start of a new file
6291 $ctext insert end "\n"
6292 set here [$ctext index "end - 1c"]
6293 lappend difffilestart $here
6294 add_flist [list $fname]
6295 set l [expr {(78 - [string length $fname]) / 2}]
6296 set pad [string range "----------------------------------------" 1 $l]
6297 $ctext insert end "$pad $fname $pad\n" filesep
6298 } elseif {[regexp {^@@} $line]} {
6299 $ctext insert end "$line\n" hunksep
6300 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6301 # do nothing
6302 } else {
6303 # parse the prefix - one ' ', '-' or '+' for each parent
6304 set spaces {}
6305 set minuses {}
6306 set pluses {}
6307 set isbad 0
6308 for {set j 0} {$j < $np} {incr j} {
6309 set c [string range $line $j $j]
6310 if {$c == " "} {
6311 lappend spaces $j
6312 } elseif {$c == "-"} {
6313 lappend minuses $j
6314 } elseif {$c == "+"} {
6315 lappend pluses $j
6316 } else {
6317 set isbad 1
6318 break
6321 set tags {}
6322 set num {}
6323 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6324 # line doesn't appear in result, parents in $minuses have the line
6325 set num [lindex $minuses 0]
6326 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6327 # line appears in result, parents in $pluses don't have the line
6328 lappend tags mresult
6329 set num [lindex $spaces 0]
6331 if {$num ne {}} {
6332 if {$num >= $mergemax} {
6333 set num "max"
6335 lappend tags m$num
6337 $ctext insert end "$line\n" $tags
6340 $ctext conf -state disabled
6341 if {[eof $mdf]} {
6342 close $mdf
6343 return 0
6345 return [expr {$nr >= 1000? 2: 1}]
6348 proc startdiff {ids} {
6349 global treediffs diffids treepending diffmergeid nullid nullid2
6351 settabs 1
6352 set diffids $ids
6353 catch {unset diffmergeid}
6354 if {![info exists treediffs($ids)] ||
6355 [lsearch -exact $ids $nullid] >= 0 ||
6356 [lsearch -exact $ids $nullid2] >= 0} {
6357 if {![info exists treepending]} {
6358 gettreediffs $ids
6360 } else {
6361 addtocflist $ids
6365 proc path_filter {filter name} {
6366 foreach p $filter {
6367 set l [string length $p]
6368 if {[string index $p end] eq "/"} {
6369 if {[string compare -length $l $p $name] == 0} {
6370 return 1
6372 } else {
6373 if {[string compare -length $l $p $name] == 0 &&
6374 ([string length $name] == $l ||
6375 [string index $name $l] eq "/")} {
6376 return 1
6380 return 0
6383 proc addtocflist {ids} {
6384 global treediffs
6386 add_flist $treediffs($ids)
6387 getblobdiffs $ids
6390 proc diffcmd {ids flags} {
6391 global nullid nullid2
6393 set i [lsearch -exact $ids $nullid]
6394 set j [lsearch -exact $ids $nullid2]
6395 if {$i >= 0} {
6396 if {[llength $ids] > 1 && $j < 0} {
6397 # comparing working directory with some specific revision
6398 set cmd [concat | git diff-index $flags]
6399 if {$i == 0} {
6400 lappend cmd -R [lindex $ids 1]
6401 } else {
6402 lappend cmd [lindex $ids 0]
6404 } else {
6405 # comparing working directory with index
6406 set cmd [concat | git diff-files $flags]
6407 if {$j == 1} {
6408 lappend cmd -R
6411 } elseif {$j >= 0} {
6412 set cmd [concat | git diff-index --cached $flags]
6413 if {[llength $ids] > 1} {
6414 # comparing index with specific revision
6415 if {$i == 0} {
6416 lappend cmd -R [lindex $ids 1]
6417 } else {
6418 lappend cmd [lindex $ids 0]
6420 } else {
6421 # comparing index with HEAD
6422 lappend cmd HEAD
6424 } else {
6425 set cmd [concat | git diff-tree -r $flags $ids]
6427 return $cmd
6430 proc gettreediffs {ids} {
6431 global treediff treepending
6433 set treepending $ids
6434 set treediff {}
6435 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6436 fconfigure $gdtf -blocking 0
6437 filerun $gdtf [list gettreediffline $gdtf $ids]
6440 proc gettreediffline {gdtf ids} {
6441 global treediff treediffs treepending diffids diffmergeid
6442 global cmitmode vfilelimit curview limitdiffs
6444 set nr 0
6445 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6446 set i [string first "\t" $line]
6447 if {$i >= 0} {
6448 set file [string range $line [expr {$i+1}] end]
6449 if {[string index $file 0] eq "\""} {
6450 set file [lindex $file 0]
6452 lappend treediff $file
6455 if {![eof $gdtf]} {
6456 return [expr {$nr >= 1000? 2: 1}]
6458 close $gdtf
6459 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6460 set flist {}
6461 foreach f $treediff {
6462 if {[path_filter $vfilelimit($curview) $f]} {
6463 lappend flist $f
6466 set treediffs($ids) $flist
6467 } else {
6468 set treediffs($ids) $treediff
6470 unset treepending
6471 if {$cmitmode eq "tree"} {
6472 gettree $diffids
6473 } elseif {$ids != $diffids} {
6474 if {![info exists diffmergeid]} {
6475 gettreediffs $diffids
6477 } else {
6478 addtocflist $ids
6480 return 0
6483 # empty string or positive integer
6484 proc diffcontextvalidate {v} {
6485 return [regexp {^(|[1-9][0-9]*)$} $v]
6488 proc diffcontextchange {n1 n2 op} {
6489 global diffcontextstring diffcontext
6491 if {[string is integer -strict $diffcontextstring]} {
6492 if {$diffcontextstring > 0} {
6493 set diffcontext $diffcontextstring
6494 reselectline
6499 proc changeignorespace {} {
6500 reselectline
6503 proc getblobdiffs {ids} {
6504 global blobdifffd diffids env
6505 global diffinhdr treediffs
6506 global diffcontext
6507 global ignorespace
6508 global limitdiffs vfilelimit curview
6510 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6511 if {$ignorespace} {
6512 append cmd " -w"
6514 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6515 set cmd [concat $cmd -- $vfilelimit($curview)]
6517 if {[catch {set bdf [open $cmd r]} err]} {
6518 puts "error getting diffs: $err"
6519 return
6521 set diffinhdr 0
6522 fconfigure $bdf -blocking 0
6523 set blobdifffd($ids) $bdf
6524 filerun $bdf [list getblobdiffline $bdf $diffids]
6527 proc setinlist {var i val} {
6528 global $var
6530 while {[llength [set $var]] < $i} {
6531 lappend $var {}
6533 if {[llength [set $var]] == $i} {
6534 lappend $var $val
6535 } else {
6536 lset $var $i $val
6540 proc makediffhdr {fname ids} {
6541 global ctext curdiffstart treediffs
6543 set i [lsearch -exact $treediffs($ids) $fname]
6544 if {$i >= 0} {
6545 setinlist difffilestart $i $curdiffstart
6547 set l [expr {(78 - [string length $fname]) / 2}]
6548 set pad [string range "----------------------------------------" 1 $l]
6549 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6552 proc getblobdiffline {bdf ids} {
6553 global diffids blobdifffd ctext curdiffstart
6554 global diffnexthead diffnextnote difffilestart
6555 global diffinhdr treediffs
6557 set nr 0
6558 $ctext conf -state normal
6559 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6560 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6561 close $bdf
6562 return 0
6564 if {![string compare -length 11 "diff --git " $line]} {
6565 # trim off "diff --git "
6566 set line [string range $line 11 end]
6567 set diffinhdr 1
6568 # start of a new file
6569 $ctext insert end "\n"
6570 set curdiffstart [$ctext index "end - 1c"]
6571 $ctext insert end "\n" filesep
6572 # If the name hasn't changed the length will be odd,
6573 # the middle char will be a space, and the two bits either
6574 # side will be a/name and b/name, or "a/name" and "b/name".
6575 # If the name has changed we'll get "rename from" and
6576 # "rename to" or "copy from" and "copy to" lines following this,
6577 # and we'll use them to get the filenames.
6578 # This complexity is necessary because spaces in the filename(s)
6579 # don't get escaped.
6580 set l [string length $line]
6581 set i [expr {$l / 2}]
6582 if {!(($l & 1) && [string index $line $i] eq " " &&
6583 [string range $line 2 [expr {$i - 1}]] eq \
6584 [string range $line [expr {$i + 3}] end])} {
6585 continue
6587 # unescape if quoted and chop off the a/ from the front
6588 if {[string index $line 0] eq "\""} {
6589 set fname [string range [lindex $line 0] 2 end]
6590 } else {
6591 set fname [string range $line 2 [expr {$i - 1}]]
6593 makediffhdr $fname $ids
6595 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6596 $line match f1l f1c f2l f2c rest]} {
6597 $ctext insert end "$line\n" hunksep
6598 set diffinhdr 0
6600 } elseif {$diffinhdr} {
6601 if {![string compare -length 12 "rename from " $line]} {
6602 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6603 if {[string index $fname 0] eq "\""} {
6604 set fname [lindex $fname 0]
6606 set i [lsearch -exact $treediffs($ids) $fname]
6607 if {$i >= 0} {
6608 setinlist difffilestart $i $curdiffstart
6610 } elseif {![string compare -length 10 $line "rename to "] ||
6611 ![string compare -length 8 $line "copy to "]} {
6612 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6613 if {[string index $fname 0] eq "\""} {
6614 set fname [lindex $fname 0]
6616 makediffhdr $fname $ids
6617 } elseif {[string compare -length 3 $line "---"] == 0} {
6618 # do nothing
6619 continue
6620 } elseif {[string compare -length 3 $line "+++"] == 0} {
6621 set diffinhdr 0
6622 continue
6624 $ctext insert end "$line\n" filesep
6626 } else {
6627 set x [string range $line 0 0]
6628 if {$x == "-" || $x == "+"} {
6629 set tag [expr {$x == "+"}]
6630 $ctext insert end "$line\n" d$tag
6631 } elseif {$x == " "} {
6632 $ctext insert end "$line\n"
6633 } else {
6634 # "\ No newline at end of file",
6635 # or something else we don't recognize
6636 $ctext insert end "$line\n" hunksep
6640 $ctext conf -state disabled
6641 if {[eof $bdf]} {
6642 close $bdf
6643 return 0
6645 return [expr {$nr >= 1000? 2: 1}]
6648 proc changediffdisp {} {
6649 global ctext diffelide
6651 $ctext tag conf d0 -elide [lindex $diffelide 0]
6652 $ctext tag conf d1 -elide [lindex $diffelide 1]
6655 proc highlightfile {loc cline} {
6656 global ctext cflist cflist_top
6658 $ctext yview $loc
6659 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6660 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6661 $cflist see $cline.0
6662 set cflist_top $cline
6665 proc prevfile {} {
6666 global difffilestart ctext cmitmode
6668 if {$cmitmode eq "tree"} return
6669 set prev 0.0
6670 set prevline 1
6671 set here [$ctext index @0,0]
6672 foreach loc $difffilestart {
6673 if {[$ctext compare $loc >= $here]} {
6674 highlightfile $prev $prevline
6675 return
6677 set prev $loc
6678 incr prevline
6680 highlightfile $prev $prevline
6683 proc nextfile {} {
6684 global difffilestart ctext cmitmode
6686 if {$cmitmode eq "tree"} return
6687 set here [$ctext index @0,0]
6688 set line 1
6689 foreach loc $difffilestart {
6690 incr line
6691 if {[$ctext compare $loc > $here]} {
6692 highlightfile $loc $line
6693 return
6698 proc clear_ctext {{first 1.0}} {
6699 global ctext smarktop smarkbot
6700 global pendinglinks
6702 set l [lindex [split $first .] 0]
6703 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6704 set smarktop $l
6706 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6707 set smarkbot $l
6709 $ctext delete $first end
6710 if {$first eq "1.0"} {
6711 catch {unset pendinglinks}
6715 proc settabs {{firstab {}}} {
6716 global firsttabstop tabstop ctext have_tk85
6718 if {$firstab ne {} && $have_tk85} {
6719 set firsttabstop $firstab
6721 set w [font measure textfont "0"]
6722 if {$firsttabstop != 0} {
6723 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6724 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6725 } elseif {$have_tk85 || $tabstop != 8} {
6726 $ctext conf -tabs [expr {$tabstop * $w}]
6727 } else {
6728 $ctext conf -tabs {}
6732 proc incrsearch {name ix op} {
6733 global ctext searchstring searchdirn
6735 $ctext tag remove found 1.0 end
6736 if {[catch {$ctext index anchor}]} {
6737 # no anchor set, use start of selection, or of visible area
6738 set sel [$ctext tag ranges sel]
6739 if {$sel ne {}} {
6740 $ctext mark set anchor [lindex $sel 0]
6741 } elseif {$searchdirn eq "-forwards"} {
6742 $ctext mark set anchor @0,0
6743 } else {
6744 $ctext mark set anchor @0,[winfo height $ctext]
6747 if {$searchstring ne {}} {
6748 set here [$ctext search $searchdirn -- $searchstring anchor]
6749 if {$here ne {}} {
6750 $ctext see $here
6752 searchmarkvisible 1
6756 proc dosearch {} {
6757 global sstring ctext searchstring searchdirn
6759 focus $sstring
6760 $sstring icursor end
6761 set searchdirn -forwards
6762 if {$searchstring ne {}} {
6763 set sel [$ctext tag ranges sel]
6764 if {$sel ne {}} {
6765 set start "[lindex $sel 0] + 1c"
6766 } elseif {[catch {set start [$ctext index anchor]}]} {
6767 set start "@0,0"
6769 set match [$ctext search -count mlen -- $searchstring $start]
6770 $ctext tag remove sel 1.0 end
6771 if {$match eq {}} {
6772 bell
6773 return
6775 $ctext see $match
6776 set mend "$match + $mlen c"
6777 $ctext tag add sel $match $mend
6778 $ctext mark unset anchor
6782 proc dosearchback {} {
6783 global sstring ctext searchstring searchdirn
6785 focus $sstring
6786 $sstring icursor end
6787 set searchdirn -backwards
6788 if {$searchstring ne {}} {
6789 set sel [$ctext tag ranges sel]
6790 if {$sel ne {}} {
6791 set start [lindex $sel 0]
6792 } elseif {[catch {set start [$ctext index anchor]}]} {
6793 set start @0,[winfo height $ctext]
6795 set match [$ctext search -backwards -count ml -- $searchstring $start]
6796 $ctext tag remove sel 1.0 end
6797 if {$match eq {}} {
6798 bell
6799 return
6801 $ctext see $match
6802 set mend "$match + $ml c"
6803 $ctext tag add sel $match $mend
6804 $ctext mark unset anchor
6808 proc searchmark {first last} {
6809 global ctext searchstring
6811 set mend $first.0
6812 while {1} {
6813 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6814 if {$match eq {}} break
6815 set mend "$match + $mlen c"
6816 $ctext tag add found $match $mend
6820 proc searchmarkvisible {doall} {
6821 global ctext smarktop smarkbot
6823 set topline [lindex [split [$ctext index @0,0] .] 0]
6824 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6825 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6826 # no overlap with previous
6827 searchmark $topline $botline
6828 set smarktop $topline
6829 set smarkbot $botline
6830 } else {
6831 if {$topline < $smarktop} {
6832 searchmark $topline [expr {$smarktop-1}]
6833 set smarktop $topline
6835 if {$botline > $smarkbot} {
6836 searchmark [expr {$smarkbot+1}] $botline
6837 set smarkbot $botline
6842 proc scrolltext {f0 f1} {
6843 global searchstring
6845 .bleft.bottom.sb set $f0 $f1
6846 if {$searchstring ne {}} {
6847 searchmarkvisible 0
6851 proc setcoords {} {
6852 global linespc charspc canvx0 canvy0
6853 global xspc1 xspc2 lthickness
6855 set linespc [font metrics mainfont -linespace]
6856 set charspc [font measure mainfont "m"]
6857 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6858 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6859 set lthickness [expr {int($linespc / 9) + 1}]
6860 set xspc1(0) $linespc
6861 set xspc2 $linespc
6864 proc redisplay {} {
6865 global canv
6866 global selectedline
6868 set ymax [lindex [$canv cget -scrollregion] 3]
6869 if {$ymax eq {} || $ymax == 0} return
6870 set span [$canv yview]
6871 clear_display
6872 setcanvscroll
6873 allcanvs yview moveto [lindex $span 0]
6874 drawvisible
6875 if {$selectedline ne {}} {
6876 selectline $selectedline 0
6877 allcanvs yview moveto [lindex $span 0]
6881 proc parsefont {f n} {
6882 global fontattr
6884 set fontattr($f,family) [lindex $n 0]
6885 set s [lindex $n 1]
6886 if {$s eq {} || $s == 0} {
6887 set s 10
6888 } elseif {$s < 0} {
6889 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6891 set fontattr($f,size) $s
6892 set fontattr($f,weight) normal
6893 set fontattr($f,slant) roman
6894 foreach style [lrange $n 2 end] {
6895 switch -- $style {
6896 "normal" -
6897 "bold" {set fontattr($f,weight) $style}
6898 "roman" -
6899 "italic" {set fontattr($f,slant) $style}
6904 proc fontflags {f {isbold 0}} {
6905 global fontattr
6907 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6908 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6909 -slant $fontattr($f,slant)]
6912 proc fontname {f} {
6913 global fontattr
6915 set n [list $fontattr($f,family) $fontattr($f,size)]
6916 if {$fontattr($f,weight) eq "bold"} {
6917 lappend n "bold"
6919 if {$fontattr($f,slant) eq "italic"} {
6920 lappend n "italic"
6922 return $n
6925 proc incrfont {inc} {
6926 global mainfont textfont ctext canv cflist showrefstop
6927 global stopped entries fontattr
6929 unmarkmatches
6930 set s $fontattr(mainfont,size)
6931 incr s $inc
6932 if {$s < 1} {
6933 set s 1
6935 set fontattr(mainfont,size) $s
6936 font config mainfont -size $s
6937 font config mainfontbold -size $s
6938 set mainfont [fontname mainfont]
6939 set s $fontattr(textfont,size)
6940 incr s $inc
6941 if {$s < 1} {
6942 set s 1
6944 set fontattr(textfont,size) $s
6945 font config textfont -size $s
6946 font config textfontbold -size $s
6947 set textfont [fontname textfont]
6948 setcoords
6949 settabs
6950 redisplay
6953 proc clearsha1 {} {
6954 global sha1entry sha1string
6955 if {[string length $sha1string] == 40} {
6956 $sha1entry delete 0 end
6960 proc sha1change {n1 n2 op} {
6961 global sha1string currentid sha1but
6962 if {$sha1string == {}
6963 || ([info exists currentid] && $sha1string == $currentid)} {
6964 set state disabled
6965 } else {
6966 set state normal
6968 if {[$sha1but cget -state] == $state} return
6969 if {$state == "normal"} {
6970 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6971 } else {
6972 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6976 proc gotocommit {} {
6977 global sha1string tagids headids curview varcid
6979 if {$sha1string == {}
6980 || ([info exists currentid] && $sha1string == $currentid)} return
6981 if {[info exists tagids($sha1string)]} {
6982 set id $tagids($sha1string)
6983 } elseif {[info exists headids($sha1string)]} {
6984 set id $headids($sha1string)
6985 } else {
6986 set id [string tolower $sha1string]
6987 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6988 set matches [array names varcid "$curview,$id*"]
6989 if {$matches ne {}} {
6990 if {[llength $matches] > 1} {
6991 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6992 return
6994 set id [lindex [split [lindex $matches 0] ","] 1]
6998 if {[commitinview $id $curview]} {
6999 selectline [rowofcommit $id] 1
7000 return
7002 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7003 set msg [mc "SHA1 id %s is not known" $sha1string]
7004 } else {
7005 set msg [mc "Tag/Head %s is not known" $sha1string]
7007 error_popup $msg
7010 proc lineenter {x y id} {
7011 global hoverx hovery hoverid hovertimer
7012 global commitinfo canv
7014 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7015 set hoverx $x
7016 set hovery $y
7017 set hoverid $id
7018 if {[info exists hovertimer]} {
7019 after cancel $hovertimer
7021 set hovertimer [after 500 linehover]
7022 $canv delete hover
7025 proc linemotion {x y id} {
7026 global hoverx hovery hoverid hovertimer
7028 if {[info exists hoverid] && $id == $hoverid} {
7029 set hoverx $x
7030 set hovery $y
7031 if {[info exists hovertimer]} {
7032 after cancel $hovertimer
7034 set hovertimer [after 500 linehover]
7038 proc lineleave {id} {
7039 global hoverid hovertimer canv
7041 if {[info exists hoverid] && $id == $hoverid} {
7042 $canv delete hover
7043 if {[info exists hovertimer]} {
7044 after cancel $hovertimer
7045 unset hovertimer
7047 unset hoverid
7051 proc linehover {} {
7052 global hoverx hovery hoverid hovertimer
7053 global canv linespc lthickness
7054 global commitinfo
7056 set text [lindex $commitinfo($hoverid) 0]
7057 set ymax [lindex [$canv cget -scrollregion] 3]
7058 if {$ymax == {}} return
7059 set yfrac [lindex [$canv yview] 0]
7060 set x [expr {$hoverx + 2 * $linespc}]
7061 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7062 set x0 [expr {$x - 2 * $lthickness}]
7063 set y0 [expr {$y - 2 * $lthickness}]
7064 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7065 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7066 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7067 -fill \#ffff80 -outline black -width 1 -tags hover]
7068 $canv raise $t
7069 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7070 -font mainfont]
7071 $canv raise $t
7074 proc clickisonarrow {id y} {
7075 global lthickness
7077 set ranges [rowranges $id]
7078 set thresh [expr {2 * $lthickness + 6}]
7079 set n [expr {[llength $ranges] - 1}]
7080 for {set i 1} {$i < $n} {incr i} {
7081 set row [lindex $ranges $i]
7082 if {abs([yc $row] - $y) < $thresh} {
7083 return $i
7086 return {}
7089 proc arrowjump {id n y} {
7090 global canv
7092 # 1 <-> 2, 3 <-> 4, etc...
7093 set n [expr {(($n - 1) ^ 1) + 1}]
7094 set row [lindex [rowranges $id] $n]
7095 set yt [yc $row]
7096 set ymax [lindex [$canv cget -scrollregion] 3]
7097 if {$ymax eq {} || $ymax <= 0} return
7098 set view [$canv yview]
7099 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7100 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7101 if {$yfrac < 0} {
7102 set yfrac 0
7104 allcanvs yview moveto $yfrac
7107 proc lineclick {x y id isnew} {
7108 global ctext commitinfo children canv thickerline curview
7110 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7111 unmarkmatches
7112 unselectline
7113 normalline
7114 $canv delete hover
7115 # draw this line thicker than normal
7116 set thickerline $id
7117 drawlines $id
7118 if {$isnew} {
7119 set ymax [lindex [$canv cget -scrollregion] 3]
7120 if {$ymax eq {}} return
7121 set yfrac [lindex [$canv yview] 0]
7122 set y [expr {$y + $yfrac * $ymax}]
7124 set dirn [clickisonarrow $id $y]
7125 if {$dirn ne {}} {
7126 arrowjump $id $dirn $y
7127 return
7130 if {$isnew} {
7131 addtohistory [list lineclick $x $y $id 0]
7133 # fill the details pane with info about this line
7134 $ctext conf -state normal
7135 clear_ctext
7136 settabs 0
7137 $ctext insert end "[mc "Parent"]:\t"
7138 $ctext insert end $id link0
7139 setlink $id link0
7140 set info $commitinfo($id)
7141 $ctext insert end "\n\t[lindex $info 0]\n"
7142 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7143 set date [formatdate [lindex $info 2]]
7144 $ctext insert end "\t[mc "Date"]:\t$date\n"
7145 set kids $children($curview,$id)
7146 if {$kids ne {}} {
7147 $ctext insert end "\n[mc "Children"]:"
7148 set i 0
7149 foreach child $kids {
7150 incr i
7151 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7152 set info $commitinfo($child)
7153 $ctext insert end "\n\t"
7154 $ctext insert end $child link$i
7155 setlink $child link$i
7156 $ctext insert end "\n\t[lindex $info 0]"
7157 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7158 set date [formatdate [lindex $info 2]]
7159 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7162 $ctext conf -state disabled
7163 init_flist {}
7166 proc normalline {} {
7167 global thickerline
7168 if {[info exists thickerline]} {
7169 set id $thickerline
7170 unset thickerline
7171 drawlines $id
7175 proc selbyid {id} {
7176 global curview
7177 if {[commitinview $id $curview]} {
7178 selectline [rowofcommit $id] 1
7182 proc mstime {} {
7183 global startmstime
7184 if {![info exists startmstime]} {
7185 set startmstime [clock clicks -milliseconds]
7187 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7190 proc rowmenu {x y id} {
7191 global rowctxmenu selectedline rowmenuid curview
7192 global nullid nullid2 fakerowmenu mainhead
7194 stopfinding
7195 set rowmenuid $id
7196 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7197 set state disabled
7198 } else {
7199 set state normal
7201 if {$id ne $nullid && $id ne $nullid2} {
7202 set menu $rowctxmenu
7203 if {$mainhead ne {}} {
7204 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7205 } else {
7206 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7208 } else {
7209 set menu $fakerowmenu
7211 $menu entryconfigure [mc "Diff this -> selected"] -state $state
7212 $menu entryconfigure [mc "Diff selected -> this"] -state $state
7213 $menu entryconfigure [mc "Make patch"] -state $state
7214 tk_popup $menu $x $y
7217 proc diffvssel {dirn} {
7218 global rowmenuid selectedline
7220 if {$selectedline eq {}} return
7221 if {$dirn} {
7222 set oldid [commitonrow $selectedline]
7223 set newid $rowmenuid
7224 } else {
7225 set oldid $rowmenuid
7226 set newid [commitonrow $selectedline]
7228 addtohistory [list doseldiff $oldid $newid]
7229 doseldiff $oldid $newid
7232 proc doseldiff {oldid newid} {
7233 global ctext
7234 global commitinfo
7236 $ctext conf -state normal
7237 clear_ctext
7238 init_flist [mc "Top"]
7239 $ctext insert end "[mc "From"] "
7240 $ctext insert end $oldid link0
7241 setlink $oldid link0
7242 $ctext insert end "\n "
7243 $ctext insert end [lindex $commitinfo($oldid) 0]
7244 $ctext insert end "\n\n[mc "To"] "
7245 $ctext insert end $newid link1
7246 setlink $newid link1
7247 $ctext insert end "\n "
7248 $ctext insert end [lindex $commitinfo($newid) 0]
7249 $ctext insert end "\n"
7250 $ctext conf -state disabled
7251 $ctext tag remove found 1.0 end
7252 startdiff [list $oldid $newid]
7255 proc mkpatch {} {
7256 global rowmenuid currentid commitinfo patchtop patchnum
7258 if {![info exists currentid]} return
7259 set oldid $currentid
7260 set oldhead [lindex $commitinfo($oldid) 0]
7261 set newid $rowmenuid
7262 set newhead [lindex $commitinfo($newid) 0]
7263 set top .patch
7264 set patchtop $top
7265 catch {destroy $top}
7266 toplevel $top
7267 label $top.title -text [mc "Generate patch"]
7268 grid $top.title - -pady 10
7269 label $top.from -text [mc "From:"]
7270 entry $top.fromsha1 -width 40 -relief flat
7271 $top.fromsha1 insert 0 $oldid
7272 $top.fromsha1 conf -state readonly
7273 grid $top.from $top.fromsha1 -sticky w
7274 entry $top.fromhead -width 60 -relief flat
7275 $top.fromhead insert 0 $oldhead
7276 $top.fromhead conf -state readonly
7277 grid x $top.fromhead -sticky w
7278 label $top.to -text [mc "To:"]
7279 entry $top.tosha1 -width 40 -relief flat
7280 $top.tosha1 insert 0 $newid
7281 $top.tosha1 conf -state readonly
7282 grid $top.to $top.tosha1 -sticky w
7283 entry $top.tohead -width 60 -relief flat
7284 $top.tohead insert 0 $newhead
7285 $top.tohead conf -state readonly
7286 grid x $top.tohead -sticky w
7287 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7288 grid $top.rev x -pady 10
7289 label $top.flab -text [mc "Output file:"]
7290 entry $top.fname -width 60
7291 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7292 incr patchnum
7293 grid $top.flab $top.fname -sticky w
7294 frame $top.buts
7295 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7296 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7297 grid $top.buts.gen $top.buts.can
7298 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7299 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7300 grid $top.buts - -pady 10 -sticky ew
7301 focus $top.fname
7304 proc mkpatchrev {} {
7305 global patchtop
7307 set oldid [$patchtop.fromsha1 get]
7308 set oldhead [$patchtop.fromhead get]
7309 set newid [$patchtop.tosha1 get]
7310 set newhead [$patchtop.tohead get]
7311 foreach e [list fromsha1 fromhead tosha1 tohead] \
7312 v [list $newid $newhead $oldid $oldhead] {
7313 $patchtop.$e conf -state normal
7314 $patchtop.$e delete 0 end
7315 $patchtop.$e insert 0 $v
7316 $patchtop.$e conf -state readonly
7320 proc mkpatchgo {} {
7321 global patchtop nullid nullid2
7323 set oldid [$patchtop.fromsha1 get]
7324 set newid [$patchtop.tosha1 get]
7325 set fname [$patchtop.fname get]
7326 set cmd [diffcmd [list $oldid $newid] -p]
7327 # trim off the initial "|"
7328 set cmd [lrange $cmd 1 end]
7329 lappend cmd >$fname &
7330 if {[catch {eval exec $cmd} err]} {
7331 error_popup "[mc "Error creating patch:"] $err"
7333 catch {destroy $patchtop}
7334 unset patchtop
7337 proc mkpatchcan {} {
7338 global patchtop
7340 catch {destroy $patchtop}
7341 unset patchtop
7344 proc mktag {} {
7345 global rowmenuid mktagtop commitinfo
7347 set top .maketag
7348 set mktagtop $top
7349 catch {destroy $top}
7350 toplevel $top
7351 label $top.title -text [mc "Create tag"]
7352 grid $top.title - -pady 10
7353 label $top.id -text [mc "ID:"]
7354 entry $top.sha1 -width 40 -relief flat
7355 $top.sha1 insert 0 $rowmenuid
7356 $top.sha1 conf -state readonly
7357 grid $top.id $top.sha1 -sticky w
7358 entry $top.head -width 60 -relief flat
7359 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7360 $top.head conf -state readonly
7361 grid x $top.head -sticky w
7362 label $top.tlab -text [mc "Tag name:"]
7363 entry $top.tag -width 60
7364 grid $top.tlab $top.tag -sticky w
7365 frame $top.buts
7366 button $top.buts.gen -text [mc "Create"] -command mktaggo
7367 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7368 grid $top.buts.gen $top.buts.can
7369 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7370 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7371 grid $top.buts - -pady 10 -sticky ew
7372 focus $top.tag
7375 proc domktag {} {
7376 global mktagtop env tagids idtags
7378 set id [$mktagtop.sha1 get]
7379 set tag [$mktagtop.tag get]
7380 if {$tag == {}} {
7381 error_popup [mc "No tag name specified"]
7382 return
7384 if {[info exists tagids($tag)]} {
7385 error_popup [mc "Tag \"%s\" already exists" $tag]
7386 return
7388 if {[catch {
7389 exec git tag $tag $id
7390 } err]} {
7391 error_popup "[mc "Error creating tag:"] $err"
7392 return
7395 set tagids($tag) $id
7396 lappend idtags($id) $tag
7397 redrawtags $id
7398 addedtag $id
7399 dispneartags 0
7400 run refill_reflist
7403 proc redrawtags {id} {
7404 global canv linehtag idpos currentid curview cmitlisted
7405 global canvxmax iddrawn circleitem mainheadid circlecolors
7407 if {![commitinview $id $curview]} return
7408 if {![info exists iddrawn($id)]} return
7409 set row [rowofcommit $id]
7410 if {$id eq $mainheadid} {
7411 set ofill yellow
7412 } else {
7413 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7415 $canv itemconf $circleitem($row) -fill $ofill
7416 $canv delete tag.$id
7417 set xt [eval drawtags $id $idpos($id)]
7418 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7419 set text [$canv itemcget $linehtag($row) -text]
7420 set font [$canv itemcget $linehtag($row) -font]
7421 set xr [expr {$xt + [font measure $font $text]}]
7422 if {$xr > $canvxmax} {
7423 set canvxmax $xr
7424 setcanvscroll
7426 if {[info exists currentid] && $currentid == $id} {
7427 make_secsel $row
7431 proc mktagcan {} {
7432 global mktagtop
7434 catch {destroy $mktagtop}
7435 unset mktagtop
7438 proc mktaggo {} {
7439 domktag
7440 mktagcan
7443 proc writecommit {} {
7444 global rowmenuid wrcomtop commitinfo wrcomcmd
7446 set top .writecommit
7447 set wrcomtop $top
7448 catch {destroy $top}
7449 toplevel $top
7450 label $top.title -text [mc "Write commit to file"]
7451 grid $top.title - -pady 10
7452 label $top.id -text [mc "ID:"]
7453 entry $top.sha1 -width 40 -relief flat
7454 $top.sha1 insert 0 $rowmenuid
7455 $top.sha1 conf -state readonly
7456 grid $top.id $top.sha1 -sticky w
7457 entry $top.head -width 60 -relief flat
7458 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7459 $top.head conf -state readonly
7460 grid x $top.head -sticky w
7461 label $top.clab -text [mc "Command:"]
7462 entry $top.cmd -width 60 -textvariable wrcomcmd
7463 grid $top.clab $top.cmd -sticky w -pady 10
7464 label $top.flab -text [mc "Output file:"]
7465 entry $top.fname -width 60
7466 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7467 grid $top.flab $top.fname -sticky w
7468 frame $top.buts
7469 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7470 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7471 grid $top.buts.gen $top.buts.can
7472 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7473 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7474 grid $top.buts - -pady 10 -sticky ew
7475 focus $top.fname
7478 proc wrcomgo {} {
7479 global wrcomtop
7481 set id [$wrcomtop.sha1 get]
7482 set cmd "echo $id | [$wrcomtop.cmd get]"
7483 set fname [$wrcomtop.fname get]
7484 if {[catch {exec sh -c $cmd >$fname &} err]} {
7485 error_popup "[mc "Error writing commit:"] $err"
7487 catch {destroy $wrcomtop}
7488 unset wrcomtop
7491 proc wrcomcan {} {
7492 global wrcomtop
7494 catch {destroy $wrcomtop}
7495 unset wrcomtop
7498 proc mkbranch {} {
7499 global rowmenuid mkbrtop
7501 set top .makebranch
7502 catch {destroy $top}
7503 toplevel $top
7504 label $top.title -text [mc "Create new branch"]
7505 grid $top.title - -pady 10
7506 label $top.id -text [mc "ID:"]
7507 entry $top.sha1 -width 40 -relief flat
7508 $top.sha1 insert 0 $rowmenuid
7509 $top.sha1 conf -state readonly
7510 grid $top.id $top.sha1 -sticky w
7511 label $top.nlab -text [mc "Name:"]
7512 entry $top.name -width 40
7513 grid $top.nlab $top.name -sticky w
7514 frame $top.buts
7515 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7516 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7517 grid $top.buts.go $top.buts.can
7518 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7519 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7520 grid $top.buts - -pady 10 -sticky ew
7521 focus $top.name
7524 proc mkbrgo {top} {
7525 global headids idheads
7527 set name [$top.name get]
7528 set id [$top.sha1 get]
7529 if {$name eq {}} {
7530 error_popup [mc "Please specify a name for the new branch"]
7531 return
7533 catch {destroy $top}
7534 nowbusy newbranch
7535 update
7536 if {[catch {
7537 exec git branch $name $id
7538 } err]} {
7539 notbusy newbranch
7540 error_popup $err
7541 } else {
7542 set headids($name) $id
7543 lappend idheads($id) $name
7544 addedhead $id $name
7545 notbusy newbranch
7546 redrawtags $id
7547 dispneartags 0
7548 run refill_reflist
7552 proc cherrypick {} {
7553 global rowmenuid curview
7554 global mainhead mainheadid
7556 set oldhead [exec git rev-parse HEAD]
7557 set dheads [descheads $rowmenuid]
7558 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7559 set ok [confirm_popup [mc "Commit %s is already\
7560 included in branch %s -- really re-apply it?" \
7561 [string range $rowmenuid 0 7] $mainhead]]
7562 if {!$ok} return
7564 nowbusy cherrypick [mc "Cherry-picking"]
7565 update
7566 # Unfortunately git-cherry-pick writes stuff to stderr even when
7567 # no error occurs, and exec takes that as an indication of error...
7568 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7569 notbusy cherrypick
7570 error_popup $err
7571 return
7573 set newhead [exec git rev-parse HEAD]
7574 if {$newhead eq $oldhead} {
7575 notbusy cherrypick
7576 error_popup [mc "No changes committed"]
7577 return
7579 addnewchild $newhead $oldhead
7580 if {[commitinview $oldhead $curview]} {
7581 insertrow $newhead $oldhead $curview
7582 if {$mainhead ne {}} {
7583 movehead $newhead $mainhead
7584 movedhead $newhead $mainhead
7586 set mainheadid $newhead
7587 redrawtags $oldhead
7588 redrawtags $newhead
7589 selbyid $newhead
7591 notbusy cherrypick
7594 proc resethead {} {
7595 global mainhead rowmenuid confirm_ok resettype
7597 set confirm_ok 0
7598 set w ".confirmreset"
7599 toplevel $w
7600 wm transient $w .
7601 wm title $w [mc "Confirm reset"]
7602 message $w.m -text \
7603 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7604 -justify center -aspect 1000
7605 pack $w.m -side top -fill x -padx 20 -pady 20
7606 frame $w.f -relief sunken -border 2
7607 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7608 grid $w.f.rt -sticky w
7609 set resettype mixed
7610 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7611 -text [mc "Soft: Leave working tree and index untouched"]
7612 grid $w.f.soft -sticky w
7613 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7614 -text [mc "Mixed: Leave working tree untouched, reset index"]
7615 grid $w.f.mixed -sticky w
7616 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7617 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7618 grid $w.f.hard -sticky w
7619 pack $w.f -side top -fill x
7620 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7621 pack $w.ok -side left -fill x -padx 20 -pady 20
7622 button $w.cancel -text [mc Cancel] -command "destroy $w"
7623 pack $w.cancel -side right -fill x -padx 20 -pady 20
7624 bind $w <Visibility> "grab $w; focus $w"
7625 tkwait window $w
7626 if {!$confirm_ok} return
7627 if {[catch {set fd [open \
7628 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7629 error_popup $err
7630 } else {
7631 dohidelocalchanges
7632 filerun $fd [list readresetstat $fd]
7633 nowbusy reset [mc "Resetting"]
7634 selbyid $rowmenuid
7638 proc readresetstat {fd} {
7639 global mainhead mainheadid showlocalchanges rprogcoord
7641 if {[gets $fd line] >= 0} {
7642 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7643 set rprogcoord [expr {1.0 * $m / $n}]
7644 adjustprogress
7646 return 1
7648 set rprogcoord 0
7649 adjustprogress
7650 notbusy reset
7651 if {[catch {close $fd} err]} {
7652 error_popup $err
7654 set oldhead $mainheadid
7655 set newhead [exec git rev-parse HEAD]
7656 if {$newhead ne $oldhead} {
7657 movehead $newhead $mainhead
7658 movedhead $newhead $mainhead
7659 set mainheadid $newhead
7660 redrawtags $oldhead
7661 redrawtags $newhead
7663 if {$showlocalchanges} {
7664 doshowlocalchanges
7666 return 0
7669 # context menu for a head
7670 proc headmenu {x y id head} {
7671 global headmenuid headmenuhead headctxmenu mainhead
7673 stopfinding
7674 set headmenuid $id
7675 set headmenuhead $head
7676 set state normal
7677 if {$head eq $mainhead} {
7678 set state disabled
7680 $headctxmenu entryconfigure 0 -state $state
7681 $headctxmenu entryconfigure 1 -state $state
7682 tk_popup $headctxmenu $x $y
7685 proc cobranch {} {
7686 global headmenuid headmenuhead headids
7687 global showlocalchanges mainheadid
7689 # check the tree is clean first??
7690 nowbusy checkout [mc "Checking out"]
7691 update
7692 dohidelocalchanges
7693 if {[catch {
7694 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7695 } err]} {
7696 notbusy checkout
7697 error_popup $err
7698 if {$showlocalchanges} {
7699 dodiffindex
7701 } else {
7702 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7706 proc readcheckoutstat {fd newhead newheadid} {
7707 global mainhead mainheadid headids showlocalchanges progresscoords
7709 if {[gets $fd line] >= 0} {
7710 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7711 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7712 adjustprogress
7714 return 1
7716 set progresscoords {0 0}
7717 adjustprogress
7718 notbusy checkout
7719 if {[catch {close $fd} err]} {
7720 error_popup $err
7722 set oldmainid $mainheadid
7723 set mainhead $newhead
7724 set mainheadid $newheadid
7725 redrawtags $oldmainid
7726 redrawtags $newheadid
7727 selbyid $newheadid
7728 if {$showlocalchanges} {
7729 dodiffindex
7733 proc rmbranch {} {
7734 global headmenuid headmenuhead mainhead
7735 global idheads
7737 set head $headmenuhead
7738 set id $headmenuid
7739 # this check shouldn't be needed any more...
7740 if {$head eq $mainhead} {
7741 error_popup [mc "Cannot delete the currently checked-out branch"]
7742 return
7744 set dheads [descheads $id]
7745 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7746 # the stuff on this branch isn't on any other branch
7747 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7748 branch.\nReally delete branch %s?" $head $head]]} return
7750 nowbusy rmbranch
7751 update
7752 if {[catch {exec git branch -D $head} err]} {
7753 notbusy rmbranch
7754 error_popup $err
7755 return
7757 removehead $id $head
7758 removedhead $id $head
7759 redrawtags $id
7760 notbusy rmbranch
7761 dispneartags 0
7762 run refill_reflist
7765 # Display a list of tags and heads
7766 proc showrefs {} {
7767 global showrefstop bgcolor fgcolor selectbgcolor
7768 global bglist fglist reflistfilter reflist maincursor
7770 set top .showrefs
7771 set showrefstop $top
7772 if {[winfo exists $top]} {
7773 raise $top
7774 refill_reflist
7775 return
7777 toplevel $top
7778 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7779 text $top.list -background $bgcolor -foreground $fgcolor \
7780 -selectbackground $selectbgcolor -font mainfont \
7781 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7782 -width 30 -height 20 -cursor $maincursor \
7783 -spacing1 1 -spacing3 1 -state disabled
7784 $top.list tag configure highlight -background $selectbgcolor
7785 lappend bglist $top.list
7786 lappend fglist $top.list
7787 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7788 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7789 grid $top.list $top.ysb -sticky nsew
7790 grid $top.xsb x -sticky ew
7791 frame $top.f
7792 label $top.f.l -text "[mc "Filter"]: "
7793 entry $top.f.e -width 20 -textvariable reflistfilter
7794 set reflistfilter "*"
7795 trace add variable reflistfilter write reflistfilter_change
7796 pack $top.f.e -side right -fill x -expand 1
7797 pack $top.f.l -side left
7798 grid $top.f - -sticky ew -pady 2
7799 button $top.close -command [list destroy $top] -text [mc "Close"]
7800 grid $top.close -
7801 grid columnconfigure $top 0 -weight 1
7802 grid rowconfigure $top 0 -weight 1
7803 bind $top.list <1> {break}
7804 bind $top.list <B1-Motion> {break}
7805 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7806 set reflist {}
7807 refill_reflist
7810 proc sel_reflist {w x y} {
7811 global showrefstop reflist headids tagids otherrefids
7813 if {![winfo exists $showrefstop]} return
7814 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7815 set ref [lindex $reflist [expr {$l-1}]]
7816 set n [lindex $ref 0]
7817 switch -- [lindex $ref 1] {
7818 "H" {selbyid $headids($n)}
7819 "T" {selbyid $tagids($n)}
7820 "o" {selbyid $otherrefids($n)}
7822 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7825 proc unsel_reflist {} {
7826 global showrefstop
7828 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7829 $showrefstop.list tag remove highlight 0.0 end
7832 proc reflistfilter_change {n1 n2 op} {
7833 global reflistfilter
7835 after cancel refill_reflist
7836 after 200 refill_reflist
7839 proc refill_reflist {} {
7840 global reflist reflistfilter showrefstop headids tagids otherrefids
7841 global curview commitinterest
7843 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7844 set refs {}
7845 foreach n [array names headids] {
7846 if {[string match $reflistfilter $n]} {
7847 if {[commitinview $headids($n) $curview]} {
7848 lappend refs [list $n H]
7849 } else {
7850 set commitinterest($headids($n)) {run refill_reflist}
7854 foreach n [array names tagids] {
7855 if {[string match $reflistfilter $n]} {
7856 if {[commitinview $tagids($n) $curview]} {
7857 lappend refs [list $n T]
7858 } else {
7859 set commitinterest($tagids($n)) {run refill_reflist}
7863 foreach n [array names otherrefids] {
7864 if {[string match $reflistfilter $n]} {
7865 if {[commitinview $otherrefids($n) $curview]} {
7866 lappend refs [list $n o]
7867 } else {
7868 set commitinterest($otherrefids($n)) {run refill_reflist}
7872 set refs [lsort -index 0 $refs]
7873 if {$refs eq $reflist} return
7875 # Update the contents of $showrefstop.list according to the
7876 # differences between $reflist (old) and $refs (new)
7877 $showrefstop.list conf -state normal
7878 $showrefstop.list insert end "\n"
7879 set i 0
7880 set j 0
7881 while {$i < [llength $reflist] || $j < [llength $refs]} {
7882 if {$i < [llength $reflist]} {
7883 if {$j < [llength $refs]} {
7884 set cmp [string compare [lindex $reflist $i 0] \
7885 [lindex $refs $j 0]]
7886 if {$cmp == 0} {
7887 set cmp [string compare [lindex $reflist $i 1] \
7888 [lindex $refs $j 1]]
7890 } else {
7891 set cmp -1
7893 } else {
7894 set cmp 1
7896 switch -- $cmp {
7897 -1 {
7898 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7899 incr i
7902 incr i
7903 incr j
7906 set l [expr {$j + 1}]
7907 $showrefstop.list image create $l.0 -align baseline \
7908 -image reficon-[lindex $refs $j 1] -padx 2
7909 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7910 incr j
7914 set reflist $refs
7915 # delete last newline
7916 $showrefstop.list delete end-2c end-1c
7917 $showrefstop.list conf -state disabled
7920 # Stuff for finding nearby tags
7921 proc getallcommits {} {
7922 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7923 global idheads idtags idotherrefs allparents tagobjid
7925 if {![info exists allcommits]} {
7926 set nextarc 0
7927 set allcommits 0
7928 set seeds {}
7929 set allcwait 0
7930 set cachedarcs 0
7931 set allccache [file join [gitdir] "gitk.cache"]
7932 if {![catch {
7933 set f [open $allccache r]
7934 set allcwait 1
7935 getcache $f
7936 }]} return
7939 if {$allcwait} {
7940 return
7942 set cmd [list | git rev-list --parents]
7943 set allcupdate [expr {$seeds ne {}}]
7944 if {!$allcupdate} {
7945 set ids "--all"
7946 } else {
7947 set refs [concat [array names idheads] [array names idtags] \
7948 [array names idotherrefs]]
7949 set ids {}
7950 set tagobjs {}
7951 foreach name [array names tagobjid] {
7952 lappend tagobjs $tagobjid($name)
7954 foreach id [lsort -unique $refs] {
7955 if {![info exists allparents($id)] &&
7956 [lsearch -exact $tagobjs $id] < 0} {
7957 lappend ids $id
7960 if {$ids ne {}} {
7961 foreach id $seeds {
7962 lappend ids "^$id"
7966 if {$ids ne {}} {
7967 set fd [open [concat $cmd $ids] r]
7968 fconfigure $fd -blocking 0
7969 incr allcommits
7970 nowbusy allcommits
7971 filerun $fd [list getallclines $fd]
7972 } else {
7973 dispneartags 0
7977 # Since most commits have 1 parent and 1 child, we group strings of
7978 # such commits into "arcs" joining branch/merge points (BMPs), which
7979 # are commits that either don't have 1 parent or don't have 1 child.
7981 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7982 # arcout(id) - outgoing arcs for BMP
7983 # arcids(a) - list of IDs on arc including end but not start
7984 # arcstart(a) - BMP ID at start of arc
7985 # arcend(a) - BMP ID at end of arc
7986 # growing(a) - arc a is still growing
7987 # arctags(a) - IDs out of arcids (excluding end) that have tags
7988 # archeads(a) - IDs out of arcids (excluding end) that have heads
7989 # The start of an arc is at the descendent end, so "incoming" means
7990 # coming from descendents, and "outgoing" means going towards ancestors.
7992 proc getallclines {fd} {
7993 global allparents allchildren idtags idheads nextarc
7994 global arcnos arcids arctags arcout arcend arcstart archeads growing
7995 global seeds allcommits cachedarcs allcupdate
7997 set nid 0
7998 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7999 set id [lindex $line 0]
8000 if {[info exists allparents($id)]} {
8001 # seen it already
8002 continue
8004 set cachedarcs 0
8005 set olds [lrange $line 1 end]
8006 set allparents($id) $olds
8007 if {![info exists allchildren($id)]} {
8008 set allchildren($id) {}
8009 set arcnos($id) {}
8010 lappend seeds $id
8011 } else {
8012 set a $arcnos($id)
8013 if {[llength $olds] == 1 && [llength $a] == 1} {
8014 lappend arcids($a) $id
8015 if {[info exists idtags($id)]} {
8016 lappend arctags($a) $id
8018 if {[info exists idheads($id)]} {
8019 lappend archeads($a) $id
8021 if {[info exists allparents($olds)]} {
8022 # seen parent already
8023 if {![info exists arcout($olds)]} {
8024 splitarc $olds
8026 lappend arcids($a) $olds
8027 set arcend($a) $olds
8028 unset growing($a)
8030 lappend allchildren($olds) $id
8031 lappend arcnos($olds) $a
8032 continue
8035 foreach a $arcnos($id) {
8036 lappend arcids($a) $id
8037 set arcend($a) $id
8038 unset growing($a)
8041 set ao {}
8042 foreach p $olds {
8043 lappend allchildren($p) $id
8044 set a [incr nextarc]
8045 set arcstart($a) $id
8046 set archeads($a) {}
8047 set arctags($a) {}
8048 set archeads($a) {}
8049 set arcids($a) {}
8050 lappend ao $a
8051 set growing($a) 1
8052 if {[info exists allparents($p)]} {
8053 # seen it already, may need to make a new branch
8054 if {![info exists arcout($p)]} {
8055 splitarc $p
8057 lappend arcids($a) $p
8058 set arcend($a) $p
8059 unset growing($a)
8061 lappend arcnos($p) $a
8063 set arcout($id) $ao
8065 if {$nid > 0} {
8066 global cached_dheads cached_dtags cached_atags
8067 catch {unset cached_dheads}
8068 catch {unset cached_dtags}
8069 catch {unset cached_atags}
8071 if {![eof $fd]} {
8072 return [expr {$nid >= 1000? 2: 1}]
8074 set cacheok 1
8075 if {[catch {
8076 fconfigure $fd -blocking 1
8077 close $fd
8078 } err]} {
8079 # got an error reading the list of commits
8080 # if we were updating, try rereading the whole thing again
8081 if {$allcupdate} {
8082 incr allcommits -1
8083 dropcache $err
8084 return
8086 error_popup "[mc "Error reading commit topology information;\
8087 branch and preceding/following tag information\
8088 will be incomplete."]\n($err)"
8089 set cacheok 0
8091 if {[incr allcommits -1] == 0} {
8092 notbusy allcommits
8093 if {$cacheok} {
8094 run savecache
8097 dispneartags 0
8098 return 0
8101 proc recalcarc {a} {
8102 global arctags archeads arcids idtags idheads
8104 set at {}
8105 set ah {}
8106 foreach id [lrange $arcids($a) 0 end-1] {
8107 if {[info exists idtags($id)]} {
8108 lappend at $id
8110 if {[info exists idheads($id)]} {
8111 lappend ah $id
8114 set arctags($a) $at
8115 set archeads($a) $ah
8118 proc splitarc {p} {
8119 global arcnos arcids nextarc arctags archeads idtags idheads
8120 global arcstart arcend arcout allparents growing
8122 set a $arcnos($p)
8123 if {[llength $a] != 1} {
8124 puts "oops splitarc called but [llength $a] arcs already"
8125 return
8127 set a [lindex $a 0]
8128 set i [lsearch -exact $arcids($a) $p]
8129 if {$i < 0} {
8130 puts "oops splitarc $p not in arc $a"
8131 return
8133 set na [incr nextarc]
8134 if {[info exists arcend($a)]} {
8135 set arcend($na) $arcend($a)
8136 } else {
8137 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8138 set j [lsearch -exact $arcnos($l) $a]
8139 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8141 set tail [lrange $arcids($a) [expr {$i+1}] end]
8142 set arcids($a) [lrange $arcids($a) 0 $i]
8143 set arcend($a) $p
8144 set arcstart($na) $p
8145 set arcout($p) $na
8146 set arcids($na) $tail
8147 if {[info exists growing($a)]} {
8148 set growing($na) 1
8149 unset growing($a)
8152 foreach id $tail {
8153 if {[llength $arcnos($id)] == 1} {
8154 set arcnos($id) $na
8155 } else {
8156 set j [lsearch -exact $arcnos($id) $a]
8157 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8161 # reconstruct tags and heads lists
8162 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8163 recalcarc $a
8164 recalcarc $na
8165 } else {
8166 set arctags($na) {}
8167 set archeads($na) {}
8171 # Update things for a new commit added that is a child of one
8172 # existing commit. Used when cherry-picking.
8173 proc addnewchild {id p} {
8174 global allparents allchildren idtags nextarc
8175 global arcnos arcids arctags arcout arcend arcstart archeads growing
8176 global seeds allcommits
8178 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8179 set allparents($id) [list $p]
8180 set allchildren($id) {}
8181 set arcnos($id) {}
8182 lappend seeds $id
8183 lappend allchildren($p) $id
8184 set a [incr nextarc]
8185 set arcstart($a) $id
8186 set archeads($a) {}
8187 set arctags($a) {}
8188 set arcids($a) [list $p]
8189 set arcend($a) $p
8190 if {![info exists arcout($p)]} {
8191 splitarc $p
8193 lappend arcnos($p) $a
8194 set arcout($id) [list $a]
8197 # This implements a cache for the topology information.
8198 # The cache saves, for each arc, the start and end of the arc,
8199 # the ids on the arc, and the outgoing arcs from the end.
8200 proc readcache {f} {
8201 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8202 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8203 global allcwait
8205 set a $nextarc
8206 set lim $cachedarcs
8207 if {$lim - $a > 500} {
8208 set lim [expr {$a + 500}]
8210 if {[catch {
8211 if {$a == $lim} {
8212 # finish reading the cache and setting up arctags, etc.
8213 set line [gets $f]
8214 if {$line ne "1"} {error "bad final version"}
8215 close $f
8216 foreach id [array names idtags] {
8217 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8218 [llength $allparents($id)] == 1} {
8219 set a [lindex $arcnos($id) 0]
8220 if {$arctags($a) eq {}} {
8221 recalcarc $a
8225 foreach id [array names idheads] {
8226 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8227 [llength $allparents($id)] == 1} {
8228 set a [lindex $arcnos($id) 0]
8229 if {$archeads($a) eq {}} {
8230 recalcarc $a
8234 foreach id [lsort -unique $possible_seeds] {
8235 if {$arcnos($id) eq {}} {
8236 lappend seeds $id
8239 set allcwait 0
8240 } else {
8241 while {[incr a] <= $lim} {
8242 set line [gets $f]
8243 if {[llength $line] != 3} {error "bad line"}
8244 set s [lindex $line 0]
8245 set arcstart($a) $s
8246 lappend arcout($s) $a
8247 if {![info exists arcnos($s)]} {
8248 lappend possible_seeds $s
8249 set arcnos($s) {}
8251 set e [lindex $line 1]
8252 if {$e eq {}} {
8253 set growing($a) 1
8254 } else {
8255 set arcend($a) $e
8256 if {![info exists arcout($e)]} {
8257 set arcout($e) {}
8260 set arcids($a) [lindex $line 2]
8261 foreach id $arcids($a) {
8262 lappend allparents($s) $id
8263 set s $id
8264 lappend arcnos($id) $a
8266 if {![info exists allparents($s)]} {
8267 set allparents($s) {}
8269 set arctags($a) {}
8270 set archeads($a) {}
8272 set nextarc [expr {$a - 1}]
8274 } err]} {
8275 dropcache $err
8276 return 0
8278 if {!$allcwait} {
8279 getallcommits
8281 return $allcwait
8284 proc getcache {f} {
8285 global nextarc cachedarcs possible_seeds
8287 if {[catch {
8288 set line [gets $f]
8289 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8290 # make sure it's an integer
8291 set cachedarcs [expr {int([lindex $line 1])}]
8292 if {$cachedarcs < 0} {error "bad number of arcs"}
8293 set nextarc 0
8294 set possible_seeds {}
8295 run readcache $f
8296 } err]} {
8297 dropcache $err
8299 return 0
8302 proc dropcache {err} {
8303 global allcwait nextarc cachedarcs seeds
8305 #puts "dropping cache ($err)"
8306 foreach v {arcnos arcout arcids arcstart arcend growing \
8307 arctags archeads allparents allchildren} {
8308 global $v
8309 catch {unset $v}
8311 set allcwait 0
8312 set nextarc 0
8313 set cachedarcs 0
8314 set seeds {}
8315 getallcommits
8318 proc writecache {f} {
8319 global cachearc cachedarcs allccache
8320 global arcstart arcend arcnos arcids arcout
8322 set a $cachearc
8323 set lim $cachedarcs
8324 if {$lim - $a > 1000} {
8325 set lim [expr {$a + 1000}]
8327 if {[catch {
8328 while {[incr a] <= $lim} {
8329 if {[info exists arcend($a)]} {
8330 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8331 } else {
8332 puts $f [list $arcstart($a) {} $arcids($a)]
8335 } err]} {
8336 catch {close $f}
8337 catch {file delete $allccache}
8338 #puts "writing cache failed ($err)"
8339 return 0
8341 set cachearc [expr {$a - 1}]
8342 if {$a > $cachedarcs} {
8343 puts $f "1"
8344 close $f
8345 return 0
8347 return 1
8350 proc savecache {} {
8351 global nextarc cachedarcs cachearc allccache
8353 if {$nextarc == $cachedarcs} return
8354 set cachearc 0
8355 set cachedarcs $nextarc
8356 catch {
8357 set f [open $allccache w]
8358 puts $f [list 1 $cachedarcs]
8359 run writecache $f
8363 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8364 # or 0 if neither is true.
8365 proc anc_or_desc {a b} {
8366 global arcout arcstart arcend arcnos cached_isanc
8368 if {$arcnos($a) eq $arcnos($b)} {
8369 # Both are on the same arc(s); either both are the same BMP,
8370 # or if one is not a BMP, the other is also not a BMP or is
8371 # the BMP at end of the arc (and it only has 1 incoming arc).
8372 # Or both can be BMPs with no incoming arcs.
8373 if {$a eq $b || $arcnos($a) eq {}} {
8374 return 0
8376 # assert {[llength $arcnos($a)] == 1}
8377 set arc [lindex $arcnos($a) 0]
8378 set i [lsearch -exact $arcids($arc) $a]
8379 set j [lsearch -exact $arcids($arc) $b]
8380 if {$i < 0 || $i > $j} {
8381 return 1
8382 } else {
8383 return -1
8387 if {![info exists arcout($a)]} {
8388 set arc [lindex $arcnos($a) 0]
8389 if {[info exists arcend($arc)]} {
8390 set aend $arcend($arc)
8391 } else {
8392 set aend {}
8394 set a $arcstart($arc)
8395 } else {
8396 set aend $a
8398 if {![info exists arcout($b)]} {
8399 set arc [lindex $arcnos($b) 0]
8400 if {[info exists arcend($arc)]} {
8401 set bend $arcend($arc)
8402 } else {
8403 set bend {}
8405 set b $arcstart($arc)
8406 } else {
8407 set bend $b
8409 if {$a eq $bend} {
8410 return 1
8412 if {$b eq $aend} {
8413 return -1
8415 if {[info exists cached_isanc($a,$bend)]} {
8416 if {$cached_isanc($a,$bend)} {
8417 return 1
8420 if {[info exists cached_isanc($b,$aend)]} {
8421 if {$cached_isanc($b,$aend)} {
8422 return -1
8424 if {[info exists cached_isanc($a,$bend)]} {
8425 return 0
8429 set todo [list $a $b]
8430 set anc($a) a
8431 set anc($b) b
8432 for {set i 0} {$i < [llength $todo]} {incr i} {
8433 set x [lindex $todo $i]
8434 if {$anc($x) eq {}} {
8435 continue
8437 foreach arc $arcnos($x) {
8438 set xd $arcstart($arc)
8439 if {$xd eq $bend} {
8440 set cached_isanc($a,$bend) 1
8441 set cached_isanc($b,$aend) 0
8442 return 1
8443 } elseif {$xd eq $aend} {
8444 set cached_isanc($b,$aend) 1
8445 set cached_isanc($a,$bend) 0
8446 return -1
8448 if {![info exists anc($xd)]} {
8449 set anc($xd) $anc($x)
8450 lappend todo $xd
8451 } elseif {$anc($xd) ne $anc($x)} {
8452 set anc($xd) {}
8456 set cached_isanc($a,$bend) 0
8457 set cached_isanc($b,$aend) 0
8458 return 0
8461 # This identifies whether $desc has an ancestor that is
8462 # a growing tip of the graph and which is not an ancestor of $anc
8463 # and returns 0 if so and 1 if not.
8464 # If we subsequently discover a tag on such a growing tip, and that
8465 # turns out to be a descendent of $anc (which it could, since we
8466 # don't necessarily see children before parents), then $desc
8467 # isn't a good choice to display as a descendent tag of
8468 # $anc (since it is the descendent of another tag which is
8469 # a descendent of $anc). Similarly, $anc isn't a good choice to
8470 # display as a ancestor tag of $desc.
8472 proc is_certain {desc anc} {
8473 global arcnos arcout arcstart arcend growing problems
8475 set certain {}
8476 if {[llength $arcnos($anc)] == 1} {
8477 # tags on the same arc are certain
8478 if {$arcnos($desc) eq $arcnos($anc)} {
8479 return 1
8481 if {![info exists arcout($anc)]} {
8482 # if $anc is partway along an arc, use the start of the arc instead
8483 set a [lindex $arcnos($anc) 0]
8484 set anc $arcstart($a)
8487 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8488 set x $desc
8489 } else {
8490 set a [lindex $arcnos($desc) 0]
8491 set x $arcend($a)
8493 if {$x == $anc} {
8494 return 1
8496 set anclist [list $x]
8497 set dl($x) 1
8498 set nnh 1
8499 set ngrowanc 0
8500 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8501 set x [lindex $anclist $i]
8502 if {$dl($x)} {
8503 incr nnh -1
8505 set done($x) 1
8506 foreach a $arcout($x) {
8507 if {[info exists growing($a)]} {
8508 if {![info exists growanc($x)] && $dl($x)} {
8509 set growanc($x) 1
8510 incr ngrowanc
8512 } else {
8513 set y $arcend($a)
8514 if {[info exists dl($y)]} {
8515 if {$dl($y)} {
8516 if {!$dl($x)} {
8517 set dl($y) 0
8518 if {![info exists done($y)]} {
8519 incr nnh -1
8521 if {[info exists growanc($x)]} {
8522 incr ngrowanc -1
8524 set xl [list $y]
8525 for {set k 0} {$k < [llength $xl]} {incr k} {
8526 set z [lindex $xl $k]
8527 foreach c $arcout($z) {
8528 if {[info exists arcend($c)]} {
8529 set v $arcend($c)
8530 if {[info exists dl($v)] && $dl($v)} {
8531 set dl($v) 0
8532 if {![info exists done($v)]} {
8533 incr nnh -1
8535 if {[info exists growanc($v)]} {
8536 incr ngrowanc -1
8538 lappend xl $v
8545 } elseif {$y eq $anc || !$dl($x)} {
8546 set dl($y) 0
8547 lappend anclist $y
8548 } else {
8549 set dl($y) 1
8550 lappend anclist $y
8551 incr nnh
8556 foreach x [array names growanc] {
8557 if {$dl($x)} {
8558 return 0
8560 return 0
8562 return 1
8565 proc validate_arctags {a} {
8566 global arctags idtags
8568 set i -1
8569 set na $arctags($a)
8570 foreach id $arctags($a) {
8571 incr i
8572 if {![info exists idtags($id)]} {
8573 set na [lreplace $na $i $i]
8574 incr i -1
8577 set arctags($a) $na
8580 proc validate_archeads {a} {
8581 global archeads idheads
8583 set i -1
8584 set na $archeads($a)
8585 foreach id $archeads($a) {
8586 incr i
8587 if {![info exists idheads($id)]} {
8588 set na [lreplace $na $i $i]
8589 incr i -1
8592 set archeads($a) $na
8595 # Return the list of IDs that have tags that are descendents of id,
8596 # ignoring IDs that are descendents of IDs already reported.
8597 proc desctags {id} {
8598 global arcnos arcstart arcids arctags idtags allparents
8599 global growing cached_dtags
8601 if {![info exists allparents($id)]} {
8602 return {}
8604 set t1 [clock clicks -milliseconds]
8605 set argid $id
8606 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8607 # part-way along an arc; check that arc first
8608 set a [lindex $arcnos($id) 0]
8609 if {$arctags($a) ne {}} {
8610 validate_arctags $a
8611 set i [lsearch -exact $arcids($a) $id]
8612 set tid {}
8613 foreach t $arctags($a) {
8614 set j [lsearch -exact $arcids($a) $t]
8615 if {$j >= $i} break
8616 set tid $t
8618 if {$tid ne {}} {
8619 return $tid
8622 set id $arcstart($a)
8623 if {[info exists idtags($id)]} {
8624 return $id
8627 if {[info exists cached_dtags($id)]} {
8628 return $cached_dtags($id)
8631 set origid $id
8632 set todo [list $id]
8633 set queued($id) 1
8634 set nc 1
8635 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8636 set id [lindex $todo $i]
8637 set done($id) 1
8638 set ta [info exists hastaggedancestor($id)]
8639 if {!$ta} {
8640 incr nc -1
8642 # ignore tags on starting node
8643 if {!$ta && $i > 0} {
8644 if {[info exists idtags($id)]} {
8645 set tagloc($id) $id
8646 set ta 1
8647 } elseif {[info exists cached_dtags($id)]} {
8648 set tagloc($id) $cached_dtags($id)
8649 set ta 1
8652 foreach a $arcnos($id) {
8653 set d $arcstart($a)
8654 if {!$ta && $arctags($a) ne {}} {
8655 validate_arctags $a
8656 if {$arctags($a) ne {}} {
8657 lappend tagloc($id) [lindex $arctags($a) end]
8660 if {$ta || $arctags($a) ne {}} {
8661 set tomark [list $d]
8662 for {set j 0} {$j < [llength $tomark]} {incr j} {
8663 set dd [lindex $tomark $j]
8664 if {![info exists hastaggedancestor($dd)]} {
8665 if {[info exists done($dd)]} {
8666 foreach b $arcnos($dd) {
8667 lappend tomark $arcstart($b)
8669 if {[info exists tagloc($dd)]} {
8670 unset tagloc($dd)
8672 } elseif {[info exists queued($dd)]} {
8673 incr nc -1
8675 set hastaggedancestor($dd) 1
8679 if {![info exists queued($d)]} {
8680 lappend todo $d
8681 set queued($d) 1
8682 if {![info exists hastaggedancestor($d)]} {
8683 incr nc
8688 set tags {}
8689 foreach id [array names tagloc] {
8690 if {![info exists hastaggedancestor($id)]} {
8691 foreach t $tagloc($id) {
8692 if {[lsearch -exact $tags $t] < 0} {
8693 lappend tags $t
8698 set t2 [clock clicks -milliseconds]
8699 set loopix $i
8701 # remove tags that are descendents of other tags
8702 for {set i 0} {$i < [llength $tags]} {incr i} {
8703 set a [lindex $tags $i]
8704 for {set j 0} {$j < $i} {incr j} {
8705 set b [lindex $tags $j]
8706 set r [anc_or_desc $a $b]
8707 if {$r == 1} {
8708 set tags [lreplace $tags $j $j]
8709 incr j -1
8710 incr i -1
8711 } elseif {$r == -1} {
8712 set tags [lreplace $tags $i $i]
8713 incr i -1
8714 break
8719 if {[array names growing] ne {}} {
8720 # graph isn't finished, need to check if any tag could get
8721 # eclipsed by another tag coming later. Simply ignore any
8722 # tags that could later get eclipsed.
8723 set ctags {}
8724 foreach t $tags {
8725 if {[is_certain $t $origid]} {
8726 lappend ctags $t
8729 if {$tags eq $ctags} {
8730 set cached_dtags($origid) $tags
8731 } else {
8732 set tags $ctags
8734 } else {
8735 set cached_dtags($origid) $tags
8737 set t3 [clock clicks -milliseconds]
8738 if {0 && $t3 - $t1 >= 100} {
8739 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8740 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8742 return $tags
8745 proc anctags {id} {
8746 global arcnos arcids arcout arcend arctags idtags allparents
8747 global growing cached_atags
8749 if {![info exists allparents($id)]} {
8750 return {}
8752 set t1 [clock clicks -milliseconds]
8753 set argid $id
8754 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8755 # part-way along an arc; check that arc first
8756 set a [lindex $arcnos($id) 0]
8757 if {$arctags($a) ne {}} {
8758 validate_arctags $a
8759 set i [lsearch -exact $arcids($a) $id]
8760 foreach t $arctags($a) {
8761 set j [lsearch -exact $arcids($a) $t]
8762 if {$j > $i} {
8763 return $t
8767 if {![info exists arcend($a)]} {
8768 return {}
8770 set id $arcend($a)
8771 if {[info exists idtags($id)]} {
8772 return $id
8775 if {[info exists cached_atags($id)]} {
8776 return $cached_atags($id)
8779 set origid $id
8780 set todo [list $id]
8781 set queued($id) 1
8782 set taglist {}
8783 set nc 1
8784 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8785 set id [lindex $todo $i]
8786 set done($id) 1
8787 set td [info exists hastaggeddescendent($id)]
8788 if {!$td} {
8789 incr nc -1
8791 # ignore tags on starting node
8792 if {!$td && $i > 0} {
8793 if {[info exists idtags($id)]} {
8794 set tagloc($id) $id
8795 set td 1
8796 } elseif {[info exists cached_atags($id)]} {
8797 set tagloc($id) $cached_atags($id)
8798 set td 1
8801 foreach a $arcout($id) {
8802 if {!$td && $arctags($a) ne {}} {
8803 validate_arctags $a
8804 if {$arctags($a) ne {}} {
8805 lappend tagloc($id) [lindex $arctags($a) 0]
8808 if {![info exists arcend($a)]} continue
8809 set d $arcend($a)
8810 if {$td || $arctags($a) ne {}} {
8811 set tomark [list $d]
8812 for {set j 0} {$j < [llength $tomark]} {incr j} {
8813 set dd [lindex $tomark $j]
8814 if {![info exists hastaggeddescendent($dd)]} {
8815 if {[info exists done($dd)]} {
8816 foreach b $arcout($dd) {
8817 if {[info exists arcend($b)]} {
8818 lappend tomark $arcend($b)
8821 if {[info exists tagloc($dd)]} {
8822 unset tagloc($dd)
8824 } elseif {[info exists queued($dd)]} {
8825 incr nc -1
8827 set hastaggeddescendent($dd) 1
8831 if {![info exists queued($d)]} {
8832 lappend todo $d
8833 set queued($d) 1
8834 if {![info exists hastaggeddescendent($d)]} {
8835 incr nc
8840 set t2 [clock clicks -milliseconds]
8841 set loopix $i
8842 set tags {}
8843 foreach id [array names tagloc] {
8844 if {![info exists hastaggeddescendent($id)]} {
8845 foreach t $tagloc($id) {
8846 if {[lsearch -exact $tags $t] < 0} {
8847 lappend tags $t
8853 # remove tags that are ancestors of other tags
8854 for {set i 0} {$i < [llength $tags]} {incr i} {
8855 set a [lindex $tags $i]
8856 for {set j 0} {$j < $i} {incr j} {
8857 set b [lindex $tags $j]
8858 set r [anc_or_desc $a $b]
8859 if {$r == -1} {
8860 set tags [lreplace $tags $j $j]
8861 incr j -1
8862 incr i -1
8863 } elseif {$r == 1} {
8864 set tags [lreplace $tags $i $i]
8865 incr i -1
8866 break
8871 if {[array names growing] ne {}} {
8872 # graph isn't finished, need to check if any tag could get
8873 # eclipsed by another tag coming later. Simply ignore any
8874 # tags that could later get eclipsed.
8875 set ctags {}
8876 foreach t $tags {
8877 if {[is_certain $origid $t]} {
8878 lappend ctags $t
8881 if {$tags eq $ctags} {
8882 set cached_atags($origid) $tags
8883 } else {
8884 set tags $ctags
8886 } else {
8887 set cached_atags($origid) $tags
8889 set t3 [clock clicks -milliseconds]
8890 if {0 && $t3 - $t1 >= 100} {
8891 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8892 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8894 return $tags
8897 # Return the list of IDs that have heads that are descendents of id,
8898 # including id itself if it has a head.
8899 proc descheads {id} {
8900 global arcnos arcstart arcids archeads idheads cached_dheads
8901 global allparents
8903 if {![info exists allparents($id)]} {
8904 return {}
8906 set aret {}
8907 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8908 # part-way along an arc; check it first
8909 set a [lindex $arcnos($id) 0]
8910 if {$archeads($a) ne {}} {
8911 validate_archeads $a
8912 set i [lsearch -exact $arcids($a) $id]
8913 foreach t $archeads($a) {
8914 set j [lsearch -exact $arcids($a) $t]
8915 if {$j > $i} break
8916 lappend aret $t
8919 set id $arcstart($a)
8921 set origid $id
8922 set todo [list $id]
8923 set seen($id) 1
8924 set ret {}
8925 for {set i 0} {$i < [llength $todo]} {incr i} {
8926 set id [lindex $todo $i]
8927 if {[info exists cached_dheads($id)]} {
8928 set ret [concat $ret $cached_dheads($id)]
8929 } else {
8930 if {[info exists idheads($id)]} {
8931 lappend ret $id
8933 foreach a $arcnos($id) {
8934 if {$archeads($a) ne {}} {
8935 validate_archeads $a
8936 if {$archeads($a) ne {}} {
8937 set ret [concat $ret $archeads($a)]
8940 set d $arcstart($a)
8941 if {![info exists seen($d)]} {
8942 lappend todo $d
8943 set seen($d) 1
8948 set ret [lsort -unique $ret]
8949 set cached_dheads($origid) $ret
8950 return [concat $ret $aret]
8953 proc addedtag {id} {
8954 global arcnos arcout cached_dtags cached_atags
8956 if {![info exists arcnos($id)]} return
8957 if {![info exists arcout($id)]} {
8958 recalcarc [lindex $arcnos($id) 0]
8960 catch {unset cached_dtags}
8961 catch {unset cached_atags}
8964 proc addedhead {hid head} {
8965 global arcnos arcout cached_dheads
8967 if {![info exists arcnos($hid)]} return
8968 if {![info exists arcout($hid)]} {
8969 recalcarc [lindex $arcnos($hid) 0]
8971 catch {unset cached_dheads}
8974 proc removedhead {hid head} {
8975 global cached_dheads
8977 catch {unset cached_dheads}
8980 proc movedhead {hid head} {
8981 global arcnos arcout cached_dheads
8983 if {![info exists arcnos($hid)]} return
8984 if {![info exists arcout($hid)]} {
8985 recalcarc [lindex $arcnos($hid) 0]
8987 catch {unset cached_dheads}
8990 proc changedrefs {} {
8991 global cached_dheads cached_dtags cached_atags
8992 global arctags archeads arcnos arcout idheads idtags
8994 foreach id [concat [array names idheads] [array names idtags]] {
8995 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8996 set a [lindex $arcnos($id) 0]
8997 if {![info exists donearc($a)]} {
8998 recalcarc $a
8999 set donearc($a) 1
9003 catch {unset cached_dtags}
9004 catch {unset cached_atags}
9005 catch {unset cached_dheads}
9008 proc rereadrefs {} {
9009 global idtags idheads idotherrefs mainheadid
9011 set refids [concat [array names idtags] \
9012 [array names idheads] [array names idotherrefs]]
9013 foreach id $refids {
9014 if {![info exists ref($id)]} {
9015 set ref($id) [listrefs $id]
9018 set oldmainhead $mainheadid
9019 readrefs
9020 changedrefs
9021 set refids [lsort -unique [concat $refids [array names idtags] \
9022 [array names idheads] [array names idotherrefs]]]
9023 foreach id $refids {
9024 set v [listrefs $id]
9025 if {![info exists ref($id)] || $ref($id) != $v} {
9026 redrawtags $id
9029 if {$oldmainhead ne $mainheadid} {
9030 redrawtags $oldmainhead
9031 redrawtags $mainheadid
9033 run refill_reflist
9036 proc listrefs {id} {
9037 global idtags idheads idotherrefs
9039 set x {}
9040 if {[info exists idtags($id)]} {
9041 set x $idtags($id)
9043 set y {}
9044 if {[info exists idheads($id)]} {
9045 set y $idheads($id)
9047 set z {}
9048 if {[info exists idotherrefs($id)]} {
9049 set z $idotherrefs($id)
9051 return [list $x $y $z]
9054 proc showtag {tag isnew} {
9055 global ctext tagcontents tagids linknum tagobjid
9057 if {$isnew} {
9058 addtohistory [list showtag $tag 0]
9060 $ctext conf -state normal
9061 clear_ctext
9062 settabs 0
9063 set linknum 0
9064 if {![info exists tagcontents($tag)]} {
9065 catch {
9066 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9069 if {[info exists tagcontents($tag)]} {
9070 set text $tagcontents($tag)
9071 } else {
9072 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9074 appendwithlinks $text {}
9075 $ctext conf -state disabled
9076 init_flist {}
9079 proc doquit {} {
9080 global stopped
9081 global gitktmpdir
9083 set stopped 100
9084 savestuff .
9085 destroy .
9087 if {[info exists gitktmpdir]} {
9088 catch {file delete -force $gitktmpdir}
9092 proc mkfontdisp {font top which} {
9093 global fontattr fontpref $font
9095 set fontpref($font) [set $font]
9096 button $top.${font}but -text $which -font optionfont \
9097 -command [list choosefont $font $which]
9098 label $top.$font -relief flat -font $font \
9099 -text $fontattr($font,family) -justify left
9100 grid x $top.${font}but $top.$font -sticky w
9103 proc choosefont {font which} {
9104 global fontparam fontlist fonttop fontattr
9106 set fontparam(which) $which
9107 set fontparam(font) $font
9108 set fontparam(family) [font actual $font -family]
9109 set fontparam(size) $fontattr($font,size)
9110 set fontparam(weight) $fontattr($font,weight)
9111 set fontparam(slant) $fontattr($font,slant)
9112 set top .gitkfont
9113 set fonttop $top
9114 if {![winfo exists $top]} {
9115 font create sample
9116 eval font config sample [font actual $font]
9117 toplevel $top
9118 wm title $top [mc "Gitk font chooser"]
9119 label $top.l -textvariable fontparam(which)
9120 pack $top.l -side top
9121 set fontlist [lsort [font families]]
9122 frame $top.f
9123 listbox $top.f.fam -listvariable fontlist \
9124 -yscrollcommand [list $top.f.sb set]
9125 bind $top.f.fam <<ListboxSelect>> selfontfam
9126 scrollbar $top.f.sb -command [list $top.f.fam yview]
9127 pack $top.f.sb -side right -fill y
9128 pack $top.f.fam -side left -fill both -expand 1
9129 pack $top.f -side top -fill both -expand 1
9130 frame $top.g
9131 spinbox $top.g.size -from 4 -to 40 -width 4 \
9132 -textvariable fontparam(size) \
9133 -validatecommand {string is integer -strict %s}
9134 checkbutton $top.g.bold -padx 5 \
9135 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9136 -variable fontparam(weight) -onvalue bold -offvalue normal
9137 checkbutton $top.g.ital -padx 5 \
9138 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9139 -variable fontparam(slant) -onvalue italic -offvalue roman
9140 pack $top.g.size $top.g.bold $top.g.ital -side left
9141 pack $top.g -side top
9142 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9143 -background white
9144 $top.c create text 100 25 -anchor center -text $which -font sample \
9145 -fill black -tags text
9146 bind $top.c <Configure> [list centertext $top.c]
9147 pack $top.c -side top -fill x
9148 frame $top.buts
9149 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9150 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9151 grid $top.buts.ok $top.buts.can
9152 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9153 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9154 pack $top.buts -side bottom -fill x
9155 trace add variable fontparam write chg_fontparam
9156 } else {
9157 raise $top
9158 $top.c itemconf text -text $which
9160 set i [lsearch -exact $fontlist $fontparam(family)]
9161 if {$i >= 0} {
9162 $top.f.fam selection set $i
9163 $top.f.fam see $i
9167 proc centertext {w} {
9168 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9171 proc fontok {} {
9172 global fontparam fontpref prefstop
9174 set f $fontparam(font)
9175 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9176 if {$fontparam(weight) eq "bold"} {
9177 lappend fontpref($f) "bold"
9179 if {$fontparam(slant) eq "italic"} {
9180 lappend fontpref($f) "italic"
9182 set w $prefstop.$f
9183 $w conf -text $fontparam(family) -font $fontpref($f)
9185 fontcan
9188 proc fontcan {} {
9189 global fonttop fontparam
9191 if {[info exists fonttop]} {
9192 catch {destroy $fonttop}
9193 catch {font delete sample}
9194 unset fonttop
9195 unset fontparam
9199 proc selfontfam {} {
9200 global fonttop fontparam
9202 set i [$fonttop.f.fam curselection]
9203 if {$i ne {}} {
9204 set fontparam(family) [$fonttop.f.fam get $i]
9208 proc chg_fontparam {v sub op} {
9209 global fontparam
9211 font config sample -$sub $fontparam($sub)
9214 proc doprefs {} {
9215 global maxwidth maxgraphpct
9216 global oldprefs prefstop showneartags showlocalchanges
9217 global bgcolor fgcolor ctext diffcolors selectbgcolor
9218 global tabstop limitdiffs autoselect extdifftool
9220 set top .gitkprefs
9221 set prefstop $top
9222 if {[winfo exists $top]} {
9223 raise $top
9224 return
9226 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9227 limitdiffs tabstop} {
9228 set oldprefs($v) [set $v]
9230 toplevel $top
9231 wm title $top [mc "Gitk preferences"]
9232 label $top.ldisp -text [mc "Commit list display options"]
9233 grid $top.ldisp - -sticky w -pady 10
9234 label $top.spacer -text " "
9235 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9236 -font optionfont
9237 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9238 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9239 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9240 -font optionfont
9241 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9242 grid x $top.maxpctl $top.maxpct -sticky w
9243 frame $top.showlocal
9244 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9245 checkbutton $top.showlocal.b -variable showlocalchanges
9246 pack $top.showlocal.b $top.showlocal.l -side left
9247 grid x $top.showlocal -sticky w
9248 frame $top.autoselect
9249 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9250 checkbutton $top.autoselect.b -variable autoselect
9251 pack $top.autoselect.b $top.autoselect.l -side left
9252 grid x $top.autoselect -sticky w
9254 label $top.ddisp -text [mc "Diff display options"]
9255 grid $top.ddisp - -sticky w -pady 10
9256 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9257 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9258 grid x $top.tabstopl $top.tabstop -sticky w
9259 frame $top.ntag
9260 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9261 checkbutton $top.ntag.b -variable showneartags
9262 pack $top.ntag.b $top.ntag.l -side left
9263 grid x $top.ntag -sticky w
9264 frame $top.ldiff
9265 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9266 checkbutton $top.ldiff.b -variable limitdiffs
9267 pack $top.ldiff.b $top.ldiff.l -side left
9268 grid x $top.ldiff -sticky w
9270 entry $top.extdifft -textvariable extdifftool
9271 frame $top.extdifff
9272 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9273 -padx 10
9274 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9275 -command choose_extdiff
9276 pack $top.extdifff.l $top.extdifff.b -side left
9277 grid x $top.extdifff $top.extdifft -sticky w
9279 label $top.cdisp -text [mc "Colors: press to choose"]
9280 grid $top.cdisp - -sticky w -pady 10
9281 label $top.bg -padx 40 -relief sunk -background $bgcolor
9282 button $top.bgbut -text [mc "Background"] -font optionfont \
9283 -command [list choosecolor bgcolor {} $top.bg background setbg]
9284 grid x $top.bgbut $top.bg -sticky w
9285 label $top.fg -padx 40 -relief sunk -background $fgcolor
9286 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9287 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9288 grid x $top.fgbut $top.fg -sticky w
9289 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9290 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9291 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9292 [list $ctext tag conf d0 -foreground]]
9293 grid x $top.diffoldbut $top.diffold -sticky w
9294 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9295 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9296 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9297 [list $ctext tag conf d1 -foreground]]
9298 grid x $top.diffnewbut $top.diffnew -sticky w
9299 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9300 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9301 -command [list choosecolor diffcolors 2 $top.hunksep \
9302 "diff hunk header" \
9303 [list $ctext tag conf hunksep -foreground]]
9304 grid x $top.hunksepbut $top.hunksep -sticky w
9305 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9306 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9307 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9308 grid x $top.selbgbut $top.selbgsep -sticky w
9310 label $top.cfont -text [mc "Fonts: press to choose"]
9311 grid $top.cfont - -sticky w -pady 10
9312 mkfontdisp mainfont $top [mc "Main font"]
9313 mkfontdisp textfont $top [mc "Diff display font"]
9314 mkfontdisp uifont $top [mc "User interface font"]
9316 frame $top.buts
9317 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9318 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9319 grid $top.buts.ok $top.buts.can
9320 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9321 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9322 grid $top.buts - - -pady 10 -sticky ew
9323 bind $top <Visibility> "focus $top.buts.ok"
9326 proc choose_extdiff {} {
9327 global extdifftool
9329 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9330 if {$prog ne {}} {
9331 set extdifftool $prog
9335 proc choosecolor {v vi w x cmd} {
9336 global $v
9338 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9339 -title [mc "Gitk: choose color for %s" $x]]
9340 if {$c eq {}} return
9341 $w conf -background $c
9342 lset $v $vi $c
9343 eval $cmd $c
9346 proc setselbg {c} {
9347 global bglist cflist
9348 foreach w $bglist {
9349 $w configure -selectbackground $c
9351 $cflist tag configure highlight \
9352 -background [$cflist cget -selectbackground]
9353 allcanvs itemconf secsel -fill $c
9356 proc setbg {c} {
9357 global bglist
9359 foreach w $bglist {
9360 $w conf -background $c
9364 proc setfg {c} {
9365 global fglist canv
9367 foreach w $fglist {
9368 $w conf -foreground $c
9370 allcanvs itemconf text -fill $c
9371 $canv itemconf circle -outline $c
9374 proc prefscan {} {
9375 global oldprefs prefstop
9377 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9378 limitdiffs tabstop} {
9379 global $v
9380 set $v $oldprefs($v)
9382 catch {destroy $prefstop}
9383 unset prefstop
9384 fontcan
9387 proc prefsok {} {
9388 global maxwidth maxgraphpct
9389 global oldprefs prefstop showneartags showlocalchanges
9390 global fontpref mainfont textfont uifont
9391 global limitdiffs treediffs
9393 catch {destroy $prefstop}
9394 unset prefstop
9395 fontcan
9396 set fontchanged 0
9397 if {$mainfont ne $fontpref(mainfont)} {
9398 set mainfont $fontpref(mainfont)
9399 parsefont mainfont $mainfont
9400 eval font configure mainfont [fontflags mainfont]
9401 eval font configure mainfontbold [fontflags mainfont 1]
9402 setcoords
9403 set fontchanged 1
9405 if {$textfont ne $fontpref(textfont)} {
9406 set textfont $fontpref(textfont)
9407 parsefont textfont $textfont
9408 eval font configure textfont [fontflags textfont]
9409 eval font configure textfontbold [fontflags textfont 1]
9411 if {$uifont ne $fontpref(uifont)} {
9412 set uifont $fontpref(uifont)
9413 parsefont uifont $uifont
9414 eval font configure uifont [fontflags uifont]
9416 settabs
9417 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9418 if {$showlocalchanges} {
9419 doshowlocalchanges
9420 } else {
9421 dohidelocalchanges
9424 if {$limitdiffs != $oldprefs(limitdiffs)} {
9425 # treediffs elements are limited by path
9426 catch {unset treediffs}
9428 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9429 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9430 redisplay
9431 } elseif {$showneartags != $oldprefs(showneartags) ||
9432 $limitdiffs != $oldprefs(limitdiffs)} {
9433 reselectline
9437 proc formatdate {d} {
9438 global datetimeformat
9439 if {$d ne {}} {
9440 set d [clock format $d -format $datetimeformat]
9442 return $d
9445 # This list of encoding names and aliases is distilled from
9446 # http://www.iana.org/assignments/character-sets.
9447 # Not all of them are supported by Tcl.
9448 set encoding_aliases {
9449 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9450 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9451 { ISO-10646-UTF-1 csISO10646UTF1 }
9452 { ISO_646.basic:1983 ref csISO646basic1983 }
9453 { INVARIANT csINVARIANT }
9454 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9455 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9456 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9457 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9458 { NATS-DANO iso-ir-9-1 csNATSDANO }
9459 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9460 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9461 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9462 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9463 { ISO-2022-KR csISO2022KR }
9464 { EUC-KR csEUCKR }
9465 { ISO-2022-JP csISO2022JP }
9466 { ISO-2022-JP-2 csISO2022JP2 }
9467 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9468 csISO13JISC6220jp }
9469 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9470 { IT iso-ir-15 ISO646-IT csISO15Italian }
9471 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9472 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9473 { greek7-old iso-ir-18 csISO18Greek7Old }
9474 { latin-greek iso-ir-19 csISO19LatinGreek }
9475 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9476 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9477 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9478 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9479 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9480 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9481 { INIS iso-ir-49 csISO49INIS }
9482 { INIS-8 iso-ir-50 csISO50INIS8 }
9483 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9484 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9485 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9486 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9487 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9488 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9489 csISO60Norwegian1 }
9490 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9491 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9492 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9493 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9494 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9495 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9496 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9497 { greek7 iso-ir-88 csISO88Greek7 }
9498 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9499 { iso-ir-90 csISO90 }
9500 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9501 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9502 csISO92JISC62991984b }
9503 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9504 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9505 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9506 csISO95JIS62291984handadd }
9507 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9508 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9509 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9510 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9511 CP819 csISOLatin1 }
9512 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9513 { T.61-7bit iso-ir-102 csISO102T617bit }
9514 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9515 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9516 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9517 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9518 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9519 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9520 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9521 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9522 arabic csISOLatinArabic }
9523 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9524 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9525 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9526 greek greek8 csISOLatinGreek }
9527 { T.101-G2 iso-ir-128 csISO128T101G2 }
9528 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9529 csISOLatinHebrew }
9530 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9531 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9532 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9533 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9534 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9535 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9536 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9537 csISOLatinCyrillic }
9538 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9539 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9540 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9541 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9542 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9543 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9544 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9545 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9546 { ISO_10367-box iso-ir-155 csISO10367Box }
9547 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9548 { latin-lap lap iso-ir-158 csISO158Lap }
9549 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9550 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9551 { us-dk csUSDK }
9552 { dk-us csDKUS }
9553 { JIS_X0201 X0201 csHalfWidthKatakana }
9554 { KSC5636 ISO646-KR csKSC5636 }
9555 { ISO-10646-UCS-2 csUnicode }
9556 { ISO-10646-UCS-4 csUCS4 }
9557 { DEC-MCS dec csDECMCS }
9558 { hp-roman8 roman8 r8 csHPRoman8 }
9559 { macintosh mac csMacintosh }
9560 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9561 csIBM037 }
9562 { IBM038 EBCDIC-INT cp038 csIBM038 }
9563 { IBM273 CP273 csIBM273 }
9564 { IBM274 EBCDIC-BE CP274 csIBM274 }
9565 { IBM275 EBCDIC-BR cp275 csIBM275 }
9566 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9567 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9568 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9569 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9570 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9571 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9572 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9573 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9574 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9575 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9576 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9577 { IBM437 cp437 437 csPC8CodePage437 }
9578 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9579 { IBM775 cp775 csPC775Baltic }
9580 { IBM850 cp850 850 csPC850Multilingual }
9581 { IBM851 cp851 851 csIBM851 }
9582 { IBM852 cp852 852 csPCp852 }
9583 { IBM855 cp855 855 csIBM855 }
9584 { IBM857 cp857 857 csIBM857 }
9585 { IBM860 cp860 860 csIBM860 }
9586 { IBM861 cp861 861 cp-is csIBM861 }
9587 { IBM862 cp862 862 csPC862LatinHebrew }
9588 { IBM863 cp863 863 csIBM863 }
9589 { IBM864 cp864 csIBM864 }
9590 { IBM865 cp865 865 csIBM865 }
9591 { IBM866 cp866 866 csIBM866 }
9592 { IBM868 CP868 cp-ar csIBM868 }
9593 { IBM869 cp869 869 cp-gr csIBM869 }
9594 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9595 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9596 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9597 { IBM891 cp891 csIBM891 }
9598 { IBM903 cp903 csIBM903 }
9599 { IBM904 cp904 904 csIBBM904 }
9600 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9601 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9602 { IBM1026 CP1026 csIBM1026 }
9603 { EBCDIC-AT-DE csIBMEBCDICATDE }
9604 { EBCDIC-AT-DE-A csEBCDICATDEA }
9605 { EBCDIC-CA-FR csEBCDICCAFR }
9606 { EBCDIC-DK-NO csEBCDICDKNO }
9607 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9608 { EBCDIC-FI-SE csEBCDICFISE }
9609 { EBCDIC-FI-SE-A csEBCDICFISEA }
9610 { EBCDIC-FR csEBCDICFR }
9611 { EBCDIC-IT csEBCDICIT }
9612 { EBCDIC-PT csEBCDICPT }
9613 { EBCDIC-ES csEBCDICES }
9614 { EBCDIC-ES-A csEBCDICESA }
9615 { EBCDIC-ES-S csEBCDICESS }
9616 { EBCDIC-UK csEBCDICUK }
9617 { EBCDIC-US csEBCDICUS }
9618 { UNKNOWN-8BIT csUnknown8BiT }
9619 { MNEMONIC csMnemonic }
9620 { MNEM csMnem }
9621 { VISCII csVISCII }
9622 { VIQR csVIQR }
9623 { KOI8-R csKOI8R }
9624 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9625 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9626 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9627 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9628 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9629 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9630 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9631 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9632 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9633 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9634 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9635 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9636 { IBM1047 IBM-1047 }
9637 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9638 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9639 { UNICODE-1-1 csUnicode11 }
9640 { CESU-8 csCESU-8 }
9641 { BOCU-1 csBOCU-1 }
9642 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9643 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9644 l8 }
9645 { ISO-8859-15 ISO_8859-15 Latin-9 }
9646 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9647 { GBK CP936 MS936 windows-936 }
9648 { JIS_Encoding csJISEncoding }
9649 { Shift_JIS MS_Kanji csShiftJIS }
9650 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9651 EUC-JP }
9652 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9653 { ISO-10646-UCS-Basic csUnicodeASCII }
9654 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9655 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9656 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9657 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9658 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9659 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9660 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9661 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9662 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9663 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9664 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9665 { Ventura-US csVenturaUS }
9666 { Ventura-International csVenturaInternational }
9667 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9668 { PC8-Turkish csPC8Turkish }
9669 { IBM-Symbols csIBMSymbols }
9670 { IBM-Thai csIBMThai }
9671 { HP-Legal csHPLegal }
9672 { HP-Pi-font csHPPiFont }
9673 { HP-Math8 csHPMath8 }
9674 { Adobe-Symbol-Encoding csHPPSMath }
9675 { HP-DeskTop csHPDesktop }
9676 { Ventura-Math csVenturaMath }
9677 { Microsoft-Publishing csMicrosoftPublishing }
9678 { Windows-31J csWindows31J }
9679 { GB2312 csGB2312 }
9680 { Big5 csBig5 }
9683 proc tcl_encoding {enc} {
9684 global encoding_aliases
9685 set names [encoding names]
9686 set lcnames [string tolower $names]
9687 set enc [string tolower $enc]
9688 set i [lsearch -exact $lcnames $enc]
9689 if {$i < 0} {
9690 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9691 if {[regsub {^iso[-_]} $enc iso encx]} {
9692 set i [lsearch -exact $lcnames $encx]
9695 if {$i < 0} {
9696 foreach l $encoding_aliases {
9697 set ll [string tolower $l]
9698 if {[lsearch -exact $ll $enc] < 0} continue
9699 # look through the aliases for one that tcl knows about
9700 foreach e $ll {
9701 set i [lsearch -exact $lcnames $e]
9702 if {$i < 0} {
9703 if {[regsub {^iso[-_]} $e iso ex]} {
9704 set i [lsearch -exact $lcnames $ex]
9707 if {$i >= 0} break
9709 break
9712 if {$i >= 0} {
9713 return [lindex $names $i]
9715 return {}
9718 # First check that Tcl/Tk is recent enough
9719 if {[catch {package require Tk 8.4} err]} {
9720 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9721 Gitk requires at least Tcl/Tk 8.4."]
9722 exit 1
9725 # defaults...
9726 set wrcomcmd "git diff-tree --stdin -p --pretty"
9728 set gitencoding {}
9729 catch {
9730 set gitencoding [exec git config --get i18n.commitencoding]
9732 if {$gitencoding == ""} {
9733 set gitencoding "utf-8"
9735 set tclencoding [tcl_encoding $gitencoding]
9736 if {$tclencoding == {}} {
9737 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9740 set mainfont {Helvetica 9}
9741 set textfont {Courier 9}
9742 set uifont {Helvetica 9 bold}
9743 set tabstop 8
9744 set findmergefiles 0
9745 set maxgraphpct 50
9746 set maxwidth 16
9747 set revlistorder 0
9748 set fastdate 0
9749 set uparrowlen 5
9750 set downarrowlen 5
9751 set mingaplen 100
9752 set cmitmode "patch"
9753 set wrapcomment "none"
9754 set showneartags 1
9755 set maxrefs 20
9756 set maxlinelen 200
9757 set showlocalchanges 1
9758 set limitdiffs 1
9759 set datetimeformat "%Y-%m-%d %H:%M:%S"
9760 set autoselect 1
9762 set extdifftool "meld"
9764 set colors {green red blue magenta darkgrey brown orange}
9765 set bgcolor white
9766 set fgcolor black
9767 set diffcolors {red "#00a000" blue}
9768 set diffcontext 3
9769 set ignorespace 0
9770 set selectbgcolor gray85
9772 set circlecolors {white blue gray blue blue}
9774 ## For msgcat loading, first locate the installation location.
9775 if { [info exists ::env(GITK_MSGSDIR)] } {
9776 ## Msgsdir was manually set in the environment.
9777 set gitk_msgsdir $::env(GITK_MSGSDIR)
9778 } else {
9779 ## Let's guess the prefix from argv0.
9780 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9781 set gitk_libdir [file join $gitk_prefix share gitk lib]
9782 set gitk_msgsdir [file join $gitk_libdir msgs]
9783 unset gitk_prefix
9786 ## Internationalization (i18n) through msgcat and gettext. See
9787 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9788 package require msgcat
9789 namespace import ::msgcat::mc
9790 ## And eventually load the actual message catalog
9791 ::msgcat::mcload $gitk_msgsdir
9793 catch {source ~/.gitk}
9795 font create optionfont -family sans-serif -size -12
9797 parsefont mainfont $mainfont
9798 eval font create mainfont [fontflags mainfont]
9799 eval font create mainfontbold [fontflags mainfont 1]
9801 parsefont textfont $textfont
9802 eval font create textfont [fontflags textfont]
9803 eval font create textfontbold [fontflags textfont 1]
9805 parsefont uifont $uifont
9806 eval font create uifont [fontflags uifont]
9808 setoptions
9810 # check that we can find a .git directory somewhere...
9811 if {[catch {set gitdir [gitdir]}]} {
9812 show_error {} . [mc "Cannot find a git repository here."]
9813 exit 1
9815 if {![file isdirectory $gitdir]} {
9816 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9817 exit 1
9820 set revtreeargs {}
9821 set cmdline_files {}
9822 set i 0
9823 set revtreeargscmd {}
9824 foreach arg $argv {
9825 switch -glob -- $arg {
9826 "" { }
9827 "--" {
9828 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9829 break
9831 "--argscmd=*" {
9832 set revtreeargscmd [string range $arg 10 end]
9834 default {
9835 lappend revtreeargs $arg
9838 incr i
9841 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9842 # no -- on command line, but some arguments (other than --argscmd)
9843 if {[catch {
9844 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9845 set cmdline_files [split $f "\n"]
9846 set n [llength $cmdline_files]
9847 set revtreeargs [lrange $revtreeargs 0 end-$n]
9848 # Unfortunately git rev-parse doesn't produce an error when
9849 # something is both a revision and a filename. To be consistent
9850 # with git log and git rev-list, check revtreeargs for filenames.
9851 foreach arg $revtreeargs {
9852 if {[file exists $arg]} {
9853 show_error {} . [mc "Ambiguous argument '%s': both revision\
9854 and filename" $arg]
9855 exit 1
9858 } err]} {
9859 # unfortunately we get both stdout and stderr in $err,
9860 # so look for "fatal:".
9861 set i [string first "fatal:" $err]
9862 if {$i > 0} {
9863 set err [string range $err [expr {$i + 6}] end]
9865 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9866 exit 1
9870 set nullid "0000000000000000000000000000000000000000"
9871 set nullid2 "0000000000000000000000000000000000000001"
9872 set nullfile "/dev/null"
9874 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9876 set runq {}
9877 set history {}
9878 set historyindex 0
9879 set fh_serial 0
9880 set nhl_names {}
9881 set highlight_paths {}
9882 set findpattern {}
9883 set searchdirn -forwards
9884 set boldrows {}
9885 set boldnamerows {}
9886 set diffelide {0 0}
9887 set markingmatches 0
9888 set linkentercount 0
9889 set need_redisplay 0
9890 set nrows_drawn 0
9891 set firsttabstop 0
9893 set nextviewnum 1
9894 set curview 0
9895 set selectedview 0
9896 set selectedhlview [mc "None"]
9897 set highlight_related [mc "None"]
9898 set highlight_files {}
9899 set viewfiles(0) {}
9900 set viewperm(0) 0
9901 set viewargs(0) {}
9902 set viewargscmd(0) {}
9904 set selectedline {}
9905 set numcommits 0
9906 set loginstance 0
9907 set cmdlineok 0
9908 set stopped 0
9909 set stuffsaved 0
9910 set patchnum 0
9911 set lserial 0
9912 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9913 setcoords
9914 makewindow
9915 # wait for the window to become visible
9916 tkwait visibility .
9917 wm title . "[file tail $argv0]: [file tail [pwd]]"
9918 readrefs
9920 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9921 # create a view for the files/dirs specified on the command line
9922 set curview 1
9923 set selectedview 1
9924 set nextviewnum 2
9925 set viewname(1) [mc "Command line"]
9926 set viewfiles(1) $cmdline_files
9927 set viewargs(1) $revtreeargs
9928 set viewargscmd(1) $revtreeargscmd
9929 set viewperm(1) 0
9930 set vdatemode(1) 0
9931 addviewmenu 1
9932 .bar.view entryconf [mc "Edit view..."] -state normal
9933 .bar.view entryconf [mc "Delete view"] -state normal
9936 if {[info exists permviews]} {
9937 foreach v $permviews {
9938 set n $nextviewnum
9939 incr nextviewnum
9940 set viewname($n) [lindex $v 0]
9941 set viewfiles($n) [lindex $v 1]
9942 set viewargs($n) [lindex $v 2]
9943 set viewargscmd($n) [lindex $v 3]
9944 set viewperm($n) 1
9945 addviewmenu $n
9948 getcommits