gitk: Kill back-end processes on window close
[git/jnareb-git.git] / gitk
blob29d79d63db8d50416e2e841a7fee03f660100e70
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_instance {inst} {
379 global commfd leftover
381 set fd $commfd($inst)
382 catch {
383 set pid [pid $fd]
384 exec kill $pid
386 catch {close $fd}
387 nukefile $fd
388 unset commfd($inst)
389 unset leftover($inst)
392 proc stop_backends {} {
393 global commfd
395 foreach inst [array names commfd] {
396 stop_instance $inst
400 proc stop_rev_list {view} {
401 global viewinstances
403 foreach inst $viewinstances($view) {
404 stop_instance $inst
406 set viewinstances($view) {}
409 proc getcommits {} {
410 global canv curview need_redisplay viewactive
412 initlayout
413 if {[start_rev_list $curview]} {
414 show_status [mc "Reading commits..."]
415 set need_redisplay 1
416 } else {
417 show_status [mc "No commits selected"]
421 proc updatecommits {} {
422 global curview vcanopt vorigargs vfilelimit viewinstances
423 global viewactive viewcomplete loginstance tclencoding
424 global startmsecs commfd showneartags showlocalchanges leftover
425 global mainheadid pending_select
426 global isworktree
427 global varcid vposids vnegids vflags vrevs
429 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
430 set oldmainid $mainheadid
431 rereadrefs
432 if {$showlocalchanges} {
433 if {$mainheadid ne $oldmainid} {
434 dohidelocalchanges
436 if {[commitinview $mainheadid $curview]} {
437 dodiffindex
440 set view $curview
441 if {$vcanopt($view)} {
442 set oldpos $vposids($view)
443 set oldneg $vnegids($view)
444 set revs [parseviewrevs $view $vrevs($view)]
445 if {$revs eq {}} {
446 return
448 # note: getting the delta when negative refs change is hard,
449 # and could require multiple git log invocations, so in that
450 # case we ask git log for all the commits (not just the delta)
451 if {$oldneg eq $vnegids($view)} {
452 set newrevs {}
453 set npos 0
454 # take out positive refs that we asked for before or
455 # that we have already seen
456 foreach rev $revs {
457 if {[string length $rev] == 40} {
458 if {[lsearch -exact $oldpos $rev] < 0
459 && ![info exists varcid($view,$rev)]} {
460 lappend newrevs $rev
461 incr npos
463 } else {
464 lappend $newrevs $rev
467 if {$npos == 0} return
468 set revs $newrevs
469 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
471 set args [concat $vflags($view) $revs --not $oldpos]
472 } else {
473 set args $vorigargs($view)
475 if {[catch {
476 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
477 --boundary $args "--" $vfilelimit($view)] r]
478 } err]} {
479 error_popup "Error executing git log: $err"
480 return
482 if {$viewactive($view) == 0} {
483 set startmsecs [clock clicks -milliseconds]
485 set i [incr loginstance]
486 lappend viewinstances($view) $i
487 set commfd($i) $fd
488 set leftover($i) {}
489 fconfigure $fd -blocking 0 -translation lf -eofchar {}
490 if {$tclencoding != {}} {
491 fconfigure $fd -encoding $tclencoding
493 filerun $fd [list getcommitlines $fd $i $view 1]
494 incr viewactive($view)
495 set viewcomplete($view) 0
496 set pending_select $mainheadid
497 nowbusy $view "Reading"
498 if {$showneartags} {
499 getallcommits
503 proc reloadcommits {} {
504 global curview viewcomplete selectedline currentid thickerline
505 global showneartags treediffs commitinterest cached_commitrow
506 global targetid
508 if {!$viewcomplete($curview)} {
509 stop_rev_list $curview
511 resetvarcs $curview
512 set selectedline {}
513 catch {unset currentid}
514 catch {unset thickerline}
515 catch {unset treediffs}
516 readrefs
517 changedrefs
518 if {$showneartags} {
519 getallcommits
521 clear_display
522 catch {unset commitinterest}
523 catch {unset cached_commitrow}
524 catch {unset targetid}
525 setcanvscroll
526 getcommits
527 return 0
530 # This makes a string representation of a positive integer which
531 # sorts as a string in numerical order
532 proc strrep {n} {
533 if {$n < 16} {
534 return [format "%x" $n]
535 } elseif {$n < 256} {
536 return [format "x%.2x" $n]
537 } elseif {$n < 65536} {
538 return [format "y%.4x" $n]
540 return [format "z%.8x" $n]
543 # Procedures used in reordering commits from git log (without
544 # --topo-order) into the order for display.
546 proc varcinit {view} {
547 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
548 global vtokmod varcmod vrowmod varcix vlastins
550 set varcstart($view) {{}}
551 set vupptr($view) {0}
552 set vdownptr($view) {0}
553 set vleftptr($view) {0}
554 set vbackptr($view) {0}
555 set varctok($view) {{}}
556 set varcrow($view) {{}}
557 set vtokmod($view) {}
558 set varcmod($view) 0
559 set vrowmod($view) 0
560 set varcix($view) {{}}
561 set vlastins($view) {0}
564 proc resetvarcs {view} {
565 global varcid varccommits parents children vseedcount ordertok
567 foreach vid [array names varcid $view,*] {
568 unset varcid($vid)
569 unset children($vid)
570 unset parents($vid)
572 # some commits might have children but haven't been seen yet
573 foreach vid [array names children $view,*] {
574 unset children($vid)
576 foreach va [array names varccommits $view,*] {
577 unset varccommits($va)
579 foreach vd [array names vseedcount $view,*] {
580 unset vseedcount($vd)
582 catch {unset ordertok}
585 # returns a list of the commits with no children
586 proc seeds {v} {
587 global vdownptr vleftptr varcstart
589 set ret {}
590 set a [lindex $vdownptr($v) 0]
591 while {$a != 0} {
592 lappend ret [lindex $varcstart($v) $a]
593 set a [lindex $vleftptr($v) $a]
595 return $ret
598 proc newvarc {view id} {
599 global varcid varctok parents children vdatemode
600 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
601 global commitdata commitinfo vseedcount varccommits vlastins
603 set a [llength $varctok($view)]
604 set vid $view,$id
605 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
606 if {![info exists commitinfo($id)]} {
607 parsecommit $id $commitdata($id) 1
609 set cdate [lindex $commitinfo($id) 4]
610 if {![string is integer -strict $cdate]} {
611 set cdate 0
613 if {![info exists vseedcount($view,$cdate)]} {
614 set vseedcount($view,$cdate) -1
616 set c [incr vseedcount($view,$cdate)]
617 set cdate [expr {$cdate ^ 0xffffffff}]
618 set tok "s[strrep $cdate][strrep $c]"
619 } else {
620 set tok {}
622 set ka 0
623 if {[llength $children($vid)] > 0} {
624 set kid [lindex $children($vid) end]
625 set k $varcid($view,$kid)
626 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
627 set ki $kid
628 set ka $k
629 set tok [lindex $varctok($view) $k]
632 if {$ka != 0} {
633 set i [lsearch -exact $parents($view,$ki) $id]
634 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
635 append tok [strrep $j]
637 set c [lindex $vlastins($view) $ka]
638 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
639 set c $ka
640 set b [lindex $vdownptr($view) $ka]
641 } else {
642 set b [lindex $vleftptr($view) $c]
644 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
645 set c $b
646 set b [lindex $vleftptr($view) $c]
648 if {$c == $ka} {
649 lset vdownptr($view) $ka $a
650 lappend vbackptr($view) 0
651 } else {
652 lset vleftptr($view) $c $a
653 lappend vbackptr($view) $c
655 lset vlastins($view) $ka $a
656 lappend vupptr($view) $ka
657 lappend vleftptr($view) $b
658 if {$b != 0} {
659 lset vbackptr($view) $b $a
661 lappend varctok($view) $tok
662 lappend varcstart($view) $id
663 lappend vdownptr($view) 0
664 lappend varcrow($view) {}
665 lappend varcix($view) {}
666 set varccommits($view,$a) {}
667 lappend vlastins($view) 0
668 return $a
671 proc splitvarc {p v} {
672 global varcid varcstart varccommits varctok
673 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
675 set oa $varcid($v,$p)
676 set ac $varccommits($v,$oa)
677 set i [lsearch -exact $varccommits($v,$oa) $p]
678 if {$i <= 0} return
679 set na [llength $varctok($v)]
680 # "%" sorts before "0"...
681 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
682 lappend varctok($v) $tok
683 lappend varcrow($v) {}
684 lappend varcix($v) {}
685 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
686 set varccommits($v,$na) [lrange $ac $i end]
687 lappend varcstart($v) $p
688 foreach id $varccommits($v,$na) {
689 set varcid($v,$id) $na
691 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
692 lappend vlastins($v) [lindex $vlastins($v) $oa]
693 lset vdownptr($v) $oa $na
694 lset vlastins($v) $oa 0
695 lappend vupptr($v) $oa
696 lappend vleftptr($v) 0
697 lappend vbackptr($v) 0
698 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
699 lset vupptr($v) $b $na
703 proc renumbervarc {a v} {
704 global parents children varctok varcstart varccommits
705 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
707 set t1 [clock clicks -milliseconds]
708 set todo {}
709 set isrelated($a) 1
710 set kidchanged($a) 1
711 set ntot 0
712 while {$a != 0} {
713 if {[info exists isrelated($a)]} {
714 lappend todo $a
715 set id [lindex $varccommits($v,$a) end]
716 foreach p $parents($v,$id) {
717 if {[info exists varcid($v,$p)]} {
718 set isrelated($varcid($v,$p)) 1
722 incr ntot
723 set b [lindex $vdownptr($v) $a]
724 if {$b == 0} {
725 while {$a != 0} {
726 set b [lindex $vleftptr($v) $a]
727 if {$b != 0} break
728 set a [lindex $vupptr($v) $a]
731 set a $b
733 foreach a $todo {
734 if {![info exists kidchanged($a)]} continue
735 set id [lindex $varcstart($v) $a]
736 if {[llength $children($v,$id)] > 1} {
737 set children($v,$id) [lsort -command [list vtokcmp $v] \
738 $children($v,$id)]
740 set oldtok [lindex $varctok($v) $a]
741 if {!$vdatemode($v)} {
742 set tok {}
743 } else {
744 set tok $oldtok
746 set ka 0
747 set kid [last_real_child $v,$id]
748 if {$kid ne {}} {
749 set k $varcid($v,$kid)
750 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
751 set ki $kid
752 set ka $k
753 set tok [lindex $varctok($v) $k]
756 if {$ka != 0} {
757 set i [lsearch -exact $parents($v,$ki) $id]
758 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
759 append tok [strrep $j]
761 if {$tok eq $oldtok} {
762 continue
764 set id [lindex $varccommits($v,$a) end]
765 foreach p $parents($v,$id) {
766 if {[info exists varcid($v,$p)]} {
767 set kidchanged($varcid($v,$p)) 1
768 } else {
769 set sortkids($p) 1
772 lset varctok($v) $a $tok
773 set b [lindex $vupptr($v) $a]
774 if {$b != $ka} {
775 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
776 modify_arc $v $ka
778 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
779 modify_arc $v $b
781 set c [lindex $vbackptr($v) $a]
782 set d [lindex $vleftptr($v) $a]
783 if {$c == 0} {
784 lset vdownptr($v) $b $d
785 } else {
786 lset vleftptr($v) $c $d
788 if {$d != 0} {
789 lset vbackptr($v) $d $c
791 if {[lindex $vlastins($v) $b] == $a} {
792 lset vlastins($v) $b $c
794 lset vupptr($v) $a $ka
795 set c [lindex $vlastins($v) $ka]
796 if {$c == 0 || \
797 [string compare $tok [lindex $varctok($v) $c]] < 0} {
798 set c $ka
799 set b [lindex $vdownptr($v) $ka]
800 } else {
801 set b [lindex $vleftptr($v) $c]
803 while {$b != 0 && \
804 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
805 set c $b
806 set b [lindex $vleftptr($v) $c]
808 if {$c == $ka} {
809 lset vdownptr($v) $ka $a
810 lset vbackptr($v) $a 0
811 } else {
812 lset vleftptr($v) $c $a
813 lset vbackptr($v) $a $c
815 lset vleftptr($v) $a $b
816 if {$b != 0} {
817 lset vbackptr($v) $b $a
819 lset vlastins($v) $ka $a
822 foreach id [array names sortkids] {
823 if {[llength $children($v,$id)] > 1} {
824 set children($v,$id) [lsort -command [list vtokcmp $v] \
825 $children($v,$id)]
828 set t2 [clock clicks -milliseconds]
829 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
832 # Fix up the graph after we have found out that in view $v,
833 # $p (a commit that we have already seen) is actually the parent
834 # of the last commit in arc $a.
835 proc fix_reversal {p a v} {
836 global varcid varcstart varctok vupptr
838 set pa $varcid($v,$p)
839 if {$p ne [lindex $varcstart($v) $pa]} {
840 splitvarc $p $v
841 set pa $varcid($v,$p)
843 # seeds always need to be renumbered
844 if {[lindex $vupptr($v) $pa] == 0 ||
845 [string compare [lindex $varctok($v) $a] \
846 [lindex $varctok($v) $pa]] > 0} {
847 renumbervarc $pa $v
851 proc insertrow {id p v} {
852 global cmitlisted children parents varcid varctok vtokmod
853 global varccommits ordertok commitidx numcommits curview
854 global targetid targetrow
856 readcommit $id
857 set vid $v,$id
858 set cmitlisted($vid) 1
859 set children($vid) {}
860 set parents($vid) [list $p]
861 set a [newvarc $v $id]
862 set varcid($vid) $a
863 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
864 modify_arc $v $a
866 lappend varccommits($v,$a) $id
867 set vp $v,$p
868 if {[llength [lappend children($vp) $id]] > 1} {
869 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
870 catch {unset ordertok}
872 fix_reversal $p $a $v
873 incr commitidx($v)
874 if {$v == $curview} {
875 set numcommits $commitidx($v)
876 setcanvscroll
877 if {[info exists targetid]} {
878 if {![comes_before $targetid $p]} {
879 incr targetrow
885 proc insertfakerow {id p} {
886 global varcid varccommits parents children cmitlisted
887 global commitidx varctok vtokmod targetid targetrow curview numcommits
889 set v $curview
890 set a $varcid($v,$p)
891 set i [lsearch -exact $varccommits($v,$a) $p]
892 if {$i < 0} {
893 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
894 return
896 set children($v,$id) {}
897 set parents($v,$id) [list $p]
898 set varcid($v,$id) $a
899 lappend children($v,$p) $id
900 set cmitlisted($v,$id) 1
901 set numcommits [incr commitidx($v)]
902 # note we deliberately don't update varcstart($v) even if $i == 0
903 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
904 modify_arc $v $a $i
905 if {[info exists targetid]} {
906 if {![comes_before $targetid $p]} {
907 incr targetrow
910 setcanvscroll
911 drawvisible
914 proc removefakerow {id} {
915 global varcid varccommits parents children commitidx
916 global varctok vtokmod cmitlisted currentid selectedline
917 global targetid curview numcommits
919 set v $curview
920 if {[llength $parents($v,$id)] != 1} {
921 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
922 return
924 set p [lindex $parents($v,$id) 0]
925 set a $varcid($v,$id)
926 set i [lsearch -exact $varccommits($v,$a) $id]
927 if {$i < 0} {
928 puts "oops: removefakerow can't find [shortids $id] on arc $a"
929 return
931 unset varcid($v,$id)
932 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
933 unset parents($v,$id)
934 unset children($v,$id)
935 unset cmitlisted($v,$id)
936 set numcommits [incr commitidx($v) -1]
937 set j [lsearch -exact $children($v,$p) $id]
938 if {$j >= 0} {
939 set children($v,$p) [lreplace $children($v,$p) $j $j]
941 modify_arc $v $a $i
942 if {[info exist currentid] && $id eq $currentid} {
943 unset currentid
944 set selectedline {}
946 if {[info exists targetid] && $targetid eq $id} {
947 set targetid $p
949 setcanvscroll
950 drawvisible
953 proc first_real_child {vp} {
954 global children nullid nullid2
956 foreach id $children($vp) {
957 if {$id ne $nullid && $id ne $nullid2} {
958 return $id
961 return {}
964 proc last_real_child {vp} {
965 global children nullid nullid2
967 set kids $children($vp)
968 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
969 set id [lindex $kids $i]
970 if {$id ne $nullid && $id ne $nullid2} {
971 return $id
974 return {}
977 proc vtokcmp {v a b} {
978 global varctok varcid
980 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
981 [lindex $varctok($v) $varcid($v,$b)]]
984 # This assumes that if lim is not given, the caller has checked that
985 # arc a's token is less than $vtokmod($v)
986 proc modify_arc {v a {lim {}}} {
987 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
989 if {$lim ne {}} {
990 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
991 if {$c > 0} return
992 if {$c == 0} {
993 set r [lindex $varcrow($v) $a]
994 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
997 set vtokmod($v) [lindex $varctok($v) $a]
998 set varcmod($v) $a
999 if {$v == $curview} {
1000 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1001 set a [lindex $vupptr($v) $a]
1002 set lim {}
1004 set r 0
1005 if {$a != 0} {
1006 if {$lim eq {}} {
1007 set lim [llength $varccommits($v,$a)]
1009 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1011 set vrowmod($v) $r
1012 undolayout $r
1016 proc update_arcrows {v} {
1017 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1018 global varcid vrownum varcorder varcix varccommits
1019 global vupptr vdownptr vleftptr varctok
1020 global displayorder parentlist curview cached_commitrow
1022 if {$vrowmod($v) == $commitidx($v)} return
1023 if {$v == $curview} {
1024 if {[llength $displayorder] > $vrowmod($v)} {
1025 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1026 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1028 catch {unset cached_commitrow}
1030 set narctot [expr {[llength $varctok($v)] - 1}]
1031 set a $varcmod($v)
1032 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1033 # go up the tree until we find something that has a row number,
1034 # or we get to a seed
1035 set a [lindex $vupptr($v) $a]
1037 if {$a == 0} {
1038 set a [lindex $vdownptr($v) 0]
1039 if {$a == 0} return
1040 set vrownum($v) {0}
1041 set varcorder($v) [list $a]
1042 lset varcix($v) $a 0
1043 lset varcrow($v) $a 0
1044 set arcn 0
1045 set row 0
1046 } else {
1047 set arcn [lindex $varcix($v) $a]
1048 if {[llength $vrownum($v)] > $arcn + 1} {
1049 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1050 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1052 set row [lindex $varcrow($v) $a]
1054 while {1} {
1055 set p $a
1056 incr row [llength $varccommits($v,$a)]
1057 # go down if possible
1058 set b [lindex $vdownptr($v) $a]
1059 if {$b == 0} {
1060 # if not, go left, or go up until we can go left
1061 while {$a != 0} {
1062 set b [lindex $vleftptr($v) $a]
1063 if {$b != 0} break
1064 set a [lindex $vupptr($v) $a]
1066 if {$a == 0} break
1068 set a $b
1069 incr arcn
1070 lappend vrownum($v) $row
1071 lappend varcorder($v) $a
1072 lset varcix($v) $a $arcn
1073 lset varcrow($v) $a $row
1075 set vtokmod($v) [lindex $varctok($v) $p]
1076 set varcmod($v) $p
1077 set vrowmod($v) $row
1078 if {[info exists currentid]} {
1079 set selectedline [rowofcommit $currentid]
1083 # Test whether view $v contains commit $id
1084 proc commitinview {id v} {
1085 global varcid
1087 return [info exists varcid($v,$id)]
1090 # Return the row number for commit $id in the current view
1091 proc rowofcommit {id} {
1092 global varcid varccommits varcrow curview cached_commitrow
1093 global varctok vtokmod
1095 set v $curview
1096 if {![info exists varcid($v,$id)]} {
1097 puts "oops rowofcommit no arc for [shortids $id]"
1098 return {}
1100 set a $varcid($v,$id)
1101 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1102 update_arcrows $v
1104 if {[info exists cached_commitrow($id)]} {
1105 return $cached_commitrow($id)
1107 set i [lsearch -exact $varccommits($v,$a) $id]
1108 if {$i < 0} {
1109 puts "oops didn't find commit [shortids $id] in arc $a"
1110 return {}
1112 incr i [lindex $varcrow($v) $a]
1113 set cached_commitrow($id) $i
1114 return $i
1117 # Returns 1 if a is on an earlier row than b, otherwise 0
1118 proc comes_before {a b} {
1119 global varcid varctok curview
1121 set v $curview
1122 if {$a eq $b || ![info exists varcid($v,$a)] || \
1123 ![info exists varcid($v,$b)]} {
1124 return 0
1126 if {$varcid($v,$a) != $varcid($v,$b)} {
1127 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1128 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1130 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1133 proc bsearch {l elt} {
1134 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1135 return 0
1137 set lo 0
1138 set hi [llength $l]
1139 while {$hi - $lo > 1} {
1140 set mid [expr {int(($lo + $hi) / 2)}]
1141 set t [lindex $l $mid]
1142 if {$elt < $t} {
1143 set hi $mid
1144 } elseif {$elt > $t} {
1145 set lo $mid
1146 } else {
1147 return $mid
1150 return $lo
1153 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1154 proc make_disporder {start end} {
1155 global vrownum curview commitidx displayorder parentlist
1156 global varccommits varcorder parents vrowmod varcrow
1157 global d_valid_start d_valid_end
1159 if {$end > $vrowmod($curview)} {
1160 update_arcrows $curview
1162 set ai [bsearch $vrownum($curview) $start]
1163 set start [lindex $vrownum($curview) $ai]
1164 set narc [llength $vrownum($curview)]
1165 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1166 set a [lindex $varcorder($curview) $ai]
1167 set l [llength $displayorder]
1168 set al [llength $varccommits($curview,$a)]
1169 if {$l < $r + $al} {
1170 if {$l < $r} {
1171 set pad [ntimes [expr {$r - $l}] {}]
1172 set displayorder [concat $displayorder $pad]
1173 set parentlist [concat $parentlist $pad]
1174 } elseif {$l > $r} {
1175 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1176 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1178 foreach id $varccommits($curview,$a) {
1179 lappend displayorder $id
1180 lappend parentlist $parents($curview,$id)
1182 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1183 set i $r
1184 foreach id $varccommits($curview,$a) {
1185 lset displayorder $i $id
1186 lset parentlist $i $parents($curview,$id)
1187 incr i
1190 incr r $al
1194 proc commitonrow {row} {
1195 global displayorder
1197 set id [lindex $displayorder $row]
1198 if {$id eq {}} {
1199 make_disporder $row [expr {$row + 1}]
1200 set id [lindex $displayorder $row]
1202 return $id
1205 proc closevarcs {v} {
1206 global varctok varccommits varcid parents children
1207 global cmitlisted commitidx commitinterest vtokmod
1209 set missing_parents 0
1210 set scripts {}
1211 set narcs [llength $varctok($v)]
1212 for {set a 1} {$a < $narcs} {incr a} {
1213 set id [lindex $varccommits($v,$a) end]
1214 foreach p $parents($v,$id) {
1215 if {[info exists varcid($v,$p)]} continue
1216 # add p as a new commit
1217 incr missing_parents
1218 set cmitlisted($v,$p) 0
1219 set parents($v,$p) {}
1220 if {[llength $children($v,$p)] == 1 &&
1221 [llength $parents($v,$id)] == 1} {
1222 set b $a
1223 } else {
1224 set b [newvarc $v $p]
1226 set varcid($v,$p) $b
1227 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1228 modify_arc $v $b
1230 lappend varccommits($v,$b) $p
1231 incr commitidx($v)
1232 if {[info exists commitinterest($p)]} {
1233 foreach script $commitinterest($p) {
1234 lappend scripts [string map [list "%I" $p] $script]
1236 unset commitinterest($id)
1240 if {$missing_parents > 0} {
1241 foreach s $scripts {
1242 eval $s
1247 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1248 # Assumes we already have an arc for $rwid.
1249 proc rewrite_commit {v id rwid} {
1250 global children parents varcid varctok vtokmod varccommits
1252 foreach ch $children($v,$id) {
1253 # make $rwid be $ch's parent in place of $id
1254 set i [lsearch -exact $parents($v,$ch) $id]
1255 if {$i < 0} {
1256 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1258 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1259 # add $ch to $rwid's children and sort the list if necessary
1260 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1261 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1262 $children($v,$rwid)]
1264 # fix the graph after joining $id to $rwid
1265 set a $varcid($v,$ch)
1266 fix_reversal $rwid $a $v
1267 # parentlist is wrong for the last element of arc $a
1268 # even if displayorder is right, hence the 3rd arg here
1269 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1273 proc getcommitlines {fd inst view updating} {
1274 global cmitlisted commitinterest leftover
1275 global commitidx commitdata vdatemode
1276 global parents children curview hlview
1277 global idpending ordertok
1278 global varccommits varcid varctok vtokmod vfilelimit
1280 set stuff [read $fd 500000]
1281 # git log doesn't terminate the last commit with a null...
1282 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1283 set stuff "\0"
1285 if {$stuff == {}} {
1286 if {![eof $fd]} {
1287 return 1
1289 global commfd viewcomplete viewactive viewname
1290 global viewinstances
1291 unset commfd($inst)
1292 set i [lsearch -exact $viewinstances($view) $inst]
1293 if {$i >= 0} {
1294 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1296 # set it blocking so we wait for the process to terminate
1297 fconfigure $fd -blocking 1
1298 if {[catch {close $fd} err]} {
1299 set fv {}
1300 if {$view != $curview} {
1301 set fv " for the \"$viewname($view)\" view"
1303 if {[string range $err 0 4] == "usage"} {
1304 set err "Gitk: error reading commits$fv:\
1305 bad arguments to git log."
1306 if {$viewname($view) eq "Command line"} {
1307 append err \
1308 " (Note: arguments to gitk are passed to git log\
1309 to allow selection of commits to be displayed.)"
1311 } else {
1312 set err "Error reading commits$fv: $err"
1314 error_popup $err
1316 if {[incr viewactive($view) -1] <= 0} {
1317 set viewcomplete($view) 1
1318 # Check if we have seen any ids listed as parents that haven't
1319 # appeared in the list
1320 closevarcs $view
1321 notbusy $view
1323 if {$view == $curview} {
1324 run chewcommits
1326 return 0
1328 set start 0
1329 set gotsome 0
1330 set scripts {}
1331 while 1 {
1332 set i [string first "\0" $stuff $start]
1333 if {$i < 0} {
1334 append leftover($inst) [string range $stuff $start end]
1335 break
1337 if {$start == 0} {
1338 set cmit $leftover($inst)
1339 append cmit [string range $stuff 0 [expr {$i - 1}]]
1340 set leftover($inst) {}
1341 } else {
1342 set cmit [string range $stuff $start [expr {$i - 1}]]
1344 set start [expr {$i + 1}]
1345 set j [string first "\n" $cmit]
1346 set ok 0
1347 set listed 1
1348 if {$j >= 0 && [string match "commit *" $cmit]} {
1349 set ids [string range $cmit 7 [expr {$j - 1}]]
1350 if {[string match {[-^<>]*} $ids]} {
1351 switch -- [string index $ids 0] {
1352 "-" {set listed 0}
1353 "^" {set listed 2}
1354 "<" {set listed 3}
1355 ">" {set listed 4}
1357 set ids [string range $ids 1 end]
1359 set ok 1
1360 foreach id $ids {
1361 if {[string length $id] != 40} {
1362 set ok 0
1363 break
1367 if {!$ok} {
1368 set shortcmit $cmit
1369 if {[string length $shortcmit] > 80} {
1370 set shortcmit "[string range $shortcmit 0 80]..."
1372 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1373 exit 1
1375 set id [lindex $ids 0]
1376 set vid $view,$id
1378 if {!$listed && $updating && ![info exists varcid($vid)] &&
1379 $vfilelimit($view) ne {}} {
1380 # git log doesn't rewrite parents for unlisted commits
1381 # when doing path limiting, so work around that here
1382 # by working out the rewritten parent with git rev-list
1383 # and if we already know about it, using the rewritten
1384 # parent as a substitute parent for $id's children.
1385 if {![catch {
1386 set rwid [exec git rev-list --first-parent --max-count=1 \
1387 $id -- $vfilelimit($view)]
1388 }]} {
1389 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1390 # use $rwid in place of $id
1391 rewrite_commit $view $id $rwid
1392 continue
1397 set a 0
1398 if {[info exists varcid($vid)]} {
1399 if {$cmitlisted($vid) || !$listed} continue
1400 set a $varcid($vid)
1402 if {$listed} {
1403 set olds [lrange $ids 1 end]
1404 } else {
1405 set olds {}
1407 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1408 set cmitlisted($vid) $listed
1409 set parents($vid) $olds
1410 if {![info exists children($vid)]} {
1411 set children($vid) {}
1412 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1413 set k [lindex $children($vid) 0]
1414 if {[llength $parents($view,$k)] == 1 &&
1415 (!$vdatemode($view) ||
1416 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1417 set a $varcid($view,$k)
1420 if {$a == 0} {
1421 # new arc
1422 set a [newvarc $view $id]
1424 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1425 modify_arc $view $a
1427 if {![info exists varcid($vid)]} {
1428 set varcid($vid) $a
1429 lappend varccommits($view,$a) $id
1430 incr commitidx($view)
1433 set i 0
1434 foreach p $olds {
1435 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1436 set vp $view,$p
1437 if {[llength [lappend children($vp) $id]] > 1 &&
1438 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1439 set children($vp) [lsort -command [list vtokcmp $view] \
1440 $children($vp)]
1441 catch {unset ordertok}
1443 if {[info exists varcid($view,$p)]} {
1444 fix_reversal $p $a $view
1447 incr i
1450 if {[info exists commitinterest($id)]} {
1451 foreach script $commitinterest($id) {
1452 lappend scripts [string map [list "%I" $id] $script]
1454 unset commitinterest($id)
1456 set gotsome 1
1458 if {$gotsome} {
1459 global numcommits hlview
1461 if {$view == $curview} {
1462 set numcommits $commitidx($view)
1463 run chewcommits
1465 if {[info exists hlview] && $view == $hlview} {
1466 # we never actually get here...
1467 run vhighlightmore
1469 foreach s $scripts {
1470 eval $s
1473 return 2
1476 proc chewcommits {} {
1477 global curview hlview viewcomplete
1478 global pending_select
1480 layoutmore
1481 if {$viewcomplete($curview)} {
1482 global commitidx varctok
1483 global numcommits startmsecs
1485 if {[info exists pending_select]} {
1486 set row [first_real_row]
1487 selectline $row 1
1489 if {$commitidx($curview) > 0} {
1490 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1491 #puts "overall $ms ms for $numcommits commits"
1492 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1493 } else {
1494 show_status [mc "No commits selected"]
1496 notbusy layout
1498 return 0
1501 proc readcommit {id} {
1502 if {[catch {set contents [exec git cat-file commit $id]}]} return
1503 parsecommit $id $contents 0
1506 proc parsecommit {id contents listed} {
1507 global commitinfo cdate
1509 set inhdr 1
1510 set comment {}
1511 set headline {}
1512 set auname {}
1513 set audate {}
1514 set comname {}
1515 set comdate {}
1516 set hdrend [string first "\n\n" $contents]
1517 if {$hdrend < 0} {
1518 # should never happen...
1519 set hdrend [string length $contents]
1521 set header [string range $contents 0 [expr {$hdrend - 1}]]
1522 set comment [string range $contents [expr {$hdrend + 2}] end]
1523 foreach line [split $header "\n"] {
1524 set tag [lindex $line 0]
1525 if {$tag == "author"} {
1526 set audate [lindex $line end-1]
1527 set auname [lrange $line 1 end-2]
1528 } elseif {$tag == "committer"} {
1529 set comdate [lindex $line end-1]
1530 set comname [lrange $line 1 end-2]
1533 set headline {}
1534 # take the first non-blank line of the comment as the headline
1535 set headline [string trimleft $comment]
1536 set i [string first "\n" $headline]
1537 if {$i >= 0} {
1538 set headline [string range $headline 0 $i]
1540 set headline [string trimright $headline]
1541 set i [string first "\r" $headline]
1542 if {$i >= 0} {
1543 set headline [string trimright [string range $headline 0 $i]]
1545 if {!$listed} {
1546 # git log indents the comment by 4 spaces;
1547 # if we got this via git cat-file, add the indentation
1548 set newcomment {}
1549 foreach line [split $comment "\n"] {
1550 append newcomment " "
1551 append newcomment $line
1552 append newcomment "\n"
1554 set comment $newcomment
1556 if {$comdate != {}} {
1557 set cdate($id) $comdate
1559 set commitinfo($id) [list $headline $auname $audate \
1560 $comname $comdate $comment]
1563 proc getcommit {id} {
1564 global commitdata commitinfo
1566 if {[info exists commitdata($id)]} {
1567 parsecommit $id $commitdata($id) 1
1568 } else {
1569 readcommit $id
1570 if {![info exists commitinfo($id)]} {
1571 set commitinfo($id) [list [mc "No commit information available"]]
1574 return 1
1577 proc readrefs {} {
1578 global tagids idtags headids idheads tagobjid
1579 global otherrefids idotherrefs mainhead mainheadid
1581 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1582 catch {unset $v}
1584 set refd [open [list | git show-ref -d] r]
1585 while {[gets $refd line] >= 0} {
1586 if {[string index $line 40] ne " "} continue
1587 set id [string range $line 0 39]
1588 set ref [string range $line 41 end]
1589 if {![string match "refs/*" $ref]} continue
1590 set name [string range $ref 5 end]
1591 if {[string match "remotes/*" $name]} {
1592 if {![string match "*/HEAD" $name]} {
1593 set headids($name) $id
1594 lappend idheads($id) $name
1596 } elseif {[string match "heads/*" $name]} {
1597 set name [string range $name 6 end]
1598 set headids($name) $id
1599 lappend idheads($id) $name
1600 } elseif {[string match "tags/*" $name]} {
1601 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1602 # which is what we want since the former is the commit ID
1603 set name [string range $name 5 end]
1604 if {[string match "*^{}" $name]} {
1605 set name [string range $name 0 end-3]
1606 } else {
1607 set tagobjid($name) $id
1609 set tagids($name) $id
1610 lappend idtags($id) $name
1611 } else {
1612 set otherrefids($name) $id
1613 lappend idotherrefs($id) $name
1616 catch {close $refd}
1617 set mainhead {}
1618 set mainheadid {}
1619 catch {
1620 set mainheadid [exec git rev-parse HEAD]
1621 set thehead [exec git symbolic-ref HEAD]
1622 if {[string match "refs/heads/*" $thehead]} {
1623 set mainhead [string range $thehead 11 end]
1628 # skip over fake commits
1629 proc first_real_row {} {
1630 global nullid nullid2 numcommits
1632 for {set row 0} {$row < $numcommits} {incr row} {
1633 set id [commitonrow $row]
1634 if {$id ne $nullid && $id ne $nullid2} {
1635 break
1638 return $row
1641 # update things for a head moved to a child of its previous location
1642 proc movehead {id name} {
1643 global headids idheads
1645 removehead $headids($name) $name
1646 set headids($name) $id
1647 lappend idheads($id) $name
1650 # update things when a head has been removed
1651 proc removehead {id name} {
1652 global headids idheads
1654 if {$idheads($id) eq $name} {
1655 unset idheads($id)
1656 } else {
1657 set i [lsearch -exact $idheads($id) $name]
1658 if {$i >= 0} {
1659 set idheads($id) [lreplace $idheads($id) $i $i]
1662 unset headids($name)
1665 proc show_error {w top msg} {
1666 message $w.m -text $msg -justify center -aspect 400
1667 pack $w.m -side top -fill x -padx 20 -pady 20
1668 button $w.ok -text [mc OK] -command "destroy $top"
1669 pack $w.ok -side bottom -fill x
1670 bind $top <Visibility> "grab $top; focus $top"
1671 bind $top <Key-Return> "destroy $top"
1672 tkwait window $top
1675 proc error_popup msg {
1676 set w .error
1677 toplevel $w
1678 wm transient $w .
1679 show_error $w $w $msg
1682 proc confirm_popup msg {
1683 global confirm_ok
1684 set confirm_ok 0
1685 set w .confirm
1686 toplevel $w
1687 wm transient $w .
1688 message $w.m -text $msg -justify center -aspect 400
1689 pack $w.m -side top -fill x -padx 20 -pady 20
1690 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1691 pack $w.ok -side left -fill x
1692 button $w.cancel -text [mc Cancel] -command "destroy $w"
1693 pack $w.cancel -side right -fill x
1694 bind $w <Visibility> "grab $w; focus $w"
1695 tkwait window $w
1696 return $confirm_ok
1699 proc setoptions {} {
1700 option add *Panedwindow.showHandle 1 startupFile
1701 option add *Panedwindow.sashRelief raised startupFile
1702 option add *Button.font uifont startupFile
1703 option add *Checkbutton.font uifont startupFile
1704 option add *Radiobutton.font uifont startupFile
1705 option add *Menu.font uifont startupFile
1706 option add *Menubutton.font uifont startupFile
1707 option add *Label.font uifont startupFile
1708 option add *Message.font uifont startupFile
1709 option add *Entry.font uifont startupFile
1712 proc makewindow {} {
1713 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1714 global tabstop
1715 global findtype findtypemenu findloc findstring fstring geometry
1716 global entries sha1entry sha1string sha1but
1717 global diffcontextstring diffcontext
1718 global ignorespace
1719 global maincursor textcursor curtextcursor
1720 global rowctxmenu fakerowmenu mergemax wrapcomment
1721 global highlight_files gdttype
1722 global searchstring sstring
1723 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1724 global headctxmenu progresscanv progressitem progresscoords statusw
1725 global fprogitem fprogcoord lastprogupdate progupdatepending
1726 global rprogitem rprogcoord rownumsel numcommits
1727 global have_tk85
1729 menu .bar
1730 .bar add cascade -label [mc "File"] -menu .bar.file
1731 menu .bar.file
1732 .bar.file add command -label [mc "Update"] -command updatecommits
1733 .bar.file add command -label [mc "Reload"] -command reloadcommits
1734 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1735 .bar.file add command -label [mc "List references"] -command showrefs
1736 .bar.file add command -label [mc "Quit"] -command doquit
1737 menu .bar.edit
1738 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1739 .bar.edit add command -label [mc "Preferences"] -command doprefs
1741 menu .bar.view
1742 .bar add cascade -label [mc "View"] -menu .bar.view
1743 .bar.view add command -label [mc "New view..."] -command {newview 0}
1744 .bar.view add command -label [mc "Edit view..."] -command editview \
1745 -state disabled
1746 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1747 .bar.view add separator
1748 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1749 -variable selectedview -value 0
1751 menu .bar.help
1752 .bar add cascade -label [mc "Help"] -menu .bar.help
1753 .bar.help add command -label [mc "About gitk"] -command about
1754 .bar.help add command -label [mc "Key bindings"] -command keys
1755 .bar.help configure
1756 . configure -menu .bar
1758 # the gui has upper and lower half, parts of a paned window.
1759 panedwindow .ctop -orient vertical
1761 # possibly use assumed geometry
1762 if {![info exists geometry(pwsash0)]} {
1763 set geometry(topheight) [expr {15 * $linespc}]
1764 set geometry(topwidth) [expr {80 * $charspc}]
1765 set geometry(botheight) [expr {15 * $linespc}]
1766 set geometry(botwidth) [expr {50 * $charspc}]
1767 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1768 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1771 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1772 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1773 frame .tf.histframe
1774 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1776 # create three canvases
1777 set cscroll .tf.histframe.csb
1778 set canv .tf.histframe.pwclist.canv
1779 canvas $canv \
1780 -selectbackground $selectbgcolor \
1781 -background $bgcolor -bd 0 \
1782 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1783 .tf.histframe.pwclist add $canv
1784 set canv2 .tf.histframe.pwclist.canv2
1785 canvas $canv2 \
1786 -selectbackground $selectbgcolor \
1787 -background $bgcolor -bd 0 -yscrollincr $linespc
1788 .tf.histframe.pwclist add $canv2
1789 set canv3 .tf.histframe.pwclist.canv3
1790 canvas $canv3 \
1791 -selectbackground $selectbgcolor \
1792 -background $bgcolor -bd 0 -yscrollincr $linespc
1793 .tf.histframe.pwclist add $canv3
1794 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1795 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1797 # a scroll bar to rule them
1798 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1799 pack $cscroll -side right -fill y
1800 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1801 lappend bglist $canv $canv2 $canv3
1802 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1804 # we have two button bars at bottom of top frame. Bar 1
1805 frame .tf.bar
1806 frame .tf.lbar -height 15
1808 set sha1entry .tf.bar.sha1
1809 set entries $sha1entry
1810 set sha1but .tf.bar.sha1label
1811 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1812 -command gotocommit -width 8
1813 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1814 pack .tf.bar.sha1label -side left
1815 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1816 trace add variable sha1string write sha1change
1817 pack $sha1entry -side left -pady 2
1819 image create bitmap bm-left -data {
1820 #define left_width 16
1821 #define left_height 16
1822 static unsigned char left_bits[] = {
1823 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1824 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1825 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1827 image create bitmap bm-right -data {
1828 #define right_width 16
1829 #define right_height 16
1830 static unsigned char right_bits[] = {
1831 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1832 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1833 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1835 button .tf.bar.leftbut -image bm-left -command goback \
1836 -state disabled -width 26
1837 pack .tf.bar.leftbut -side left -fill y
1838 button .tf.bar.rightbut -image bm-right -command goforw \
1839 -state disabled -width 26
1840 pack .tf.bar.rightbut -side left -fill y
1842 label .tf.bar.rowlabel -text [mc "Row"]
1843 set rownumsel {}
1844 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1845 -relief sunken -anchor e
1846 label .tf.bar.rowlabel2 -text "/"
1847 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1848 -relief sunken -anchor e
1849 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1850 -side left
1851 global selectedline
1852 trace add variable selectedline write selectedline_change
1854 # Status label and progress bar
1855 set statusw .tf.bar.status
1856 label $statusw -width 15 -relief sunken
1857 pack $statusw -side left -padx 5
1858 set h [expr {[font metrics uifont -linespace] + 2}]
1859 set progresscanv .tf.bar.progress
1860 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1861 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1862 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1863 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1864 pack $progresscanv -side right -expand 1 -fill x
1865 set progresscoords {0 0}
1866 set fprogcoord 0
1867 set rprogcoord 0
1868 bind $progresscanv <Configure> adjustprogress
1869 set lastprogupdate [clock clicks -milliseconds]
1870 set progupdatepending 0
1872 # build up the bottom bar of upper window
1873 label .tf.lbar.flabel -text "[mc "Find"] "
1874 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1875 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1876 label .tf.lbar.flab2 -text " [mc "commit"] "
1877 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1878 -side left -fill y
1879 set gdttype [mc "containing:"]
1880 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1881 [mc "containing:"] \
1882 [mc "touching paths:"] \
1883 [mc "adding/removing string:"]]
1884 trace add variable gdttype write gdttype_change
1885 pack .tf.lbar.gdttype -side left -fill y
1887 set findstring {}
1888 set fstring .tf.lbar.findstring
1889 lappend entries $fstring
1890 entry $fstring -width 30 -font textfont -textvariable findstring
1891 trace add variable findstring write find_change
1892 set findtype [mc "Exact"]
1893 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1894 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1895 trace add variable findtype write findcom_change
1896 set findloc [mc "All fields"]
1897 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1898 [mc "Comments"] [mc "Author"] [mc "Committer"]
1899 trace add variable findloc write find_change
1900 pack .tf.lbar.findloc -side right
1901 pack .tf.lbar.findtype -side right
1902 pack $fstring -side left -expand 1 -fill x
1904 # Finish putting the upper half of the viewer together
1905 pack .tf.lbar -in .tf -side bottom -fill x
1906 pack .tf.bar -in .tf -side bottom -fill x
1907 pack .tf.histframe -fill both -side top -expand 1
1908 .ctop add .tf
1909 .ctop paneconfigure .tf -height $geometry(topheight)
1910 .ctop paneconfigure .tf -width $geometry(topwidth)
1912 # now build up the bottom
1913 panedwindow .pwbottom -orient horizontal
1915 # lower left, a text box over search bar, scroll bar to the right
1916 # if we know window height, then that will set the lower text height, otherwise
1917 # we set lower text height which will drive window height
1918 if {[info exists geometry(main)]} {
1919 frame .bleft -width $geometry(botwidth)
1920 } else {
1921 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1923 frame .bleft.top
1924 frame .bleft.mid
1925 frame .bleft.bottom
1927 button .bleft.top.search -text [mc "Search"] -command dosearch
1928 pack .bleft.top.search -side left -padx 5
1929 set sstring .bleft.top.sstring
1930 entry $sstring -width 20 -font textfont -textvariable searchstring
1931 lappend entries $sstring
1932 trace add variable searchstring write incrsearch
1933 pack $sstring -side left -expand 1 -fill x
1934 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1935 -command changediffdisp -variable diffelide -value {0 0}
1936 radiobutton .bleft.mid.old -text [mc "Old version"] \
1937 -command changediffdisp -variable diffelide -value {0 1}
1938 radiobutton .bleft.mid.new -text [mc "New version"] \
1939 -command changediffdisp -variable diffelide -value {1 0}
1940 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1941 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1942 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1943 -from 1 -increment 1 -to 10000000 \
1944 -validate all -validatecommand "diffcontextvalidate %P" \
1945 -textvariable diffcontextstring
1946 .bleft.mid.diffcontext set $diffcontext
1947 trace add variable diffcontextstring write diffcontextchange
1948 lappend entries .bleft.mid.diffcontext
1949 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1950 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1951 -command changeignorespace -variable ignorespace
1952 pack .bleft.mid.ignspace -side left -padx 5
1953 set ctext .bleft.bottom.ctext
1954 text $ctext -background $bgcolor -foreground $fgcolor \
1955 -state disabled -font textfont \
1956 -yscrollcommand scrolltext -wrap none \
1957 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1958 if {$have_tk85} {
1959 $ctext conf -tabstyle wordprocessor
1961 scrollbar .bleft.bottom.sb -command "$ctext yview"
1962 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
1963 -width 10
1964 pack .bleft.top -side top -fill x
1965 pack .bleft.mid -side top -fill x
1966 grid $ctext .bleft.bottom.sb -sticky nsew
1967 grid .bleft.bottom.sbhorizontal -sticky ew
1968 grid columnconfigure .bleft.bottom 0 -weight 1
1969 grid rowconfigure .bleft.bottom 0 -weight 1
1970 grid rowconfigure .bleft.bottom 1 -weight 0
1971 pack .bleft.bottom -side top -fill both -expand 1
1972 lappend bglist $ctext
1973 lappend fglist $ctext
1975 $ctext tag conf comment -wrap $wrapcomment
1976 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1977 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1978 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1979 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1980 $ctext tag conf m0 -fore red
1981 $ctext tag conf m1 -fore blue
1982 $ctext tag conf m2 -fore green
1983 $ctext tag conf m3 -fore purple
1984 $ctext tag conf m4 -fore brown
1985 $ctext tag conf m5 -fore "#009090"
1986 $ctext tag conf m6 -fore magenta
1987 $ctext tag conf m7 -fore "#808000"
1988 $ctext tag conf m8 -fore "#009000"
1989 $ctext tag conf m9 -fore "#ff0080"
1990 $ctext tag conf m10 -fore cyan
1991 $ctext tag conf m11 -fore "#b07070"
1992 $ctext tag conf m12 -fore "#70b0f0"
1993 $ctext tag conf m13 -fore "#70f0b0"
1994 $ctext tag conf m14 -fore "#f0b070"
1995 $ctext tag conf m15 -fore "#ff70b0"
1996 $ctext tag conf mmax -fore darkgrey
1997 set mergemax 16
1998 $ctext tag conf mresult -font textfontbold
1999 $ctext tag conf msep -font textfontbold
2000 $ctext tag conf found -back yellow
2002 .pwbottom add .bleft
2003 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2005 # lower right
2006 frame .bright
2007 frame .bright.mode
2008 radiobutton .bright.mode.patch -text [mc "Patch"] \
2009 -command reselectline -variable cmitmode -value "patch"
2010 radiobutton .bright.mode.tree -text [mc "Tree"] \
2011 -command reselectline -variable cmitmode -value "tree"
2012 grid .bright.mode.patch .bright.mode.tree -sticky ew
2013 pack .bright.mode -side top -fill x
2014 set cflist .bright.cfiles
2015 set indent [font measure mainfont "nn"]
2016 text $cflist \
2017 -selectbackground $selectbgcolor \
2018 -background $bgcolor -foreground $fgcolor \
2019 -font mainfont \
2020 -tabs [list $indent [expr {2 * $indent}]] \
2021 -yscrollcommand ".bright.sb set" \
2022 -cursor [. cget -cursor] \
2023 -spacing1 1 -spacing3 1
2024 lappend bglist $cflist
2025 lappend fglist $cflist
2026 scrollbar .bright.sb -command "$cflist yview"
2027 pack .bright.sb -side right -fill y
2028 pack $cflist -side left -fill both -expand 1
2029 $cflist tag configure highlight \
2030 -background [$cflist cget -selectbackground]
2031 $cflist tag configure bold -font mainfontbold
2033 .pwbottom add .bright
2034 .ctop add .pwbottom
2036 # restore window width & height if known
2037 if {[info exists geometry(main)]} {
2038 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2039 if {$w > [winfo screenwidth .]} {
2040 set w [winfo screenwidth .]
2042 if {$h > [winfo screenheight .]} {
2043 set h [winfo screenheight .]
2045 wm geometry . "${w}x$h"
2049 if {[tk windowingsystem] eq {aqua}} {
2050 set M1B M1
2051 } else {
2052 set M1B Control
2055 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2056 pack .ctop -fill both -expand 1
2057 bindall <1> {selcanvline %W %x %y}
2058 #bindall <B1-Motion> {selcanvline %W %x %y}
2059 if {[tk windowingsystem] == "win32"} {
2060 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2061 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2062 } else {
2063 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2064 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2065 if {[tk windowingsystem] eq "aqua"} {
2066 bindall <MouseWheel> {
2067 set delta [expr {- (%D)}]
2068 allcanvs yview scroll $delta units
2072 bindall <2> "canvscan mark %W %x %y"
2073 bindall <B2-Motion> "canvscan dragto %W %x %y"
2074 bindkey <Home> selfirstline
2075 bindkey <End> sellastline
2076 bind . <Key-Up> "selnextline -1"
2077 bind . <Key-Down> "selnextline 1"
2078 bind . <Shift-Key-Up> "dofind -1 0"
2079 bind . <Shift-Key-Down> "dofind 1 0"
2080 bindkey <Key-Right> "goforw"
2081 bindkey <Key-Left> "goback"
2082 bind . <Key-Prior> "selnextpage -1"
2083 bind . <Key-Next> "selnextpage 1"
2084 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2085 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2086 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2087 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2088 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2089 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2090 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2091 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2092 bindkey <Key-space> "$ctext yview scroll 1 pages"
2093 bindkey p "selnextline -1"
2094 bindkey n "selnextline 1"
2095 bindkey z "goback"
2096 bindkey x "goforw"
2097 bindkey i "selnextline -1"
2098 bindkey k "selnextline 1"
2099 bindkey j "goback"
2100 bindkey l "goforw"
2101 bindkey b prevfile
2102 bindkey d "$ctext yview scroll 18 units"
2103 bindkey u "$ctext yview scroll -18 units"
2104 bindkey / {dofind 1 1}
2105 bindkey <Key-Return> {dofind 1 1}
2106 bindkey ? {dofind -1 1}
2107 bindkey f nextfile
2108 bindkey <F5> updatecommits
2109 bind . <$M1B-q> doquit
2110 bind . <$M1B-f> {dofind 1 1}
2111 bind . <$M1B-g> {dofind 1 0}
2112 bind . <$M1B-r> dosearchback
2113 bind . <$M1B-s> dosearch
2114 bind . <$M1B-equal> {incrfont 1}
2115 bind . <$M1B-plus> {incrfont 1}
2116 bind . <$M1B-KP_Add> {incrfont 1}
2117 bind . <$M1B-minus> {incrfont -1}
2118 bind . <$M1B-KP_Subtract> {incrfont -1}
2119 wm protocol . WM_DELETE_WINDOW doquit
2120 bind . <Destroy> {stop_backends}
2121 bind . <Button-1> "click %W"
2122 bind $fstring <Key-Return> {dofind 1 1}
2123 bind $sha1entry <Key-Return> gotocommit
2124 bind $sha1entry <<PasteSelection>> clearsha1
2125 bind $cflist <1> {sel_flist %W %x %y; break}
2126 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2127 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2128 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
2130 set maincursor [. cget -cursor]
2131 set textcursor [$ctext cget -cursor]
2132 set curtextcursor $textcursor
2134 set rowctxmenu .rowctxmenu
2135 menu $rowctxmenu -tearoff 0
2136 $rowctxmenu add command -label [mc "Diff this -> selected"] \
2137 -command {diffvssel 0}
2138 $rowctxmenu add command -label [mc "Diff selected -> this"] \
2139 -command {diffvssel 1}
2140 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2141 $rowctxmenu add command -label [mc "Create tag"] -command mktag
2142 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2143 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2144 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2145 -command cherrypick
2146 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2147 -command resethead
2149 set fakerowmenu .fakerowmenu
2150 menu $fakerowmenu -tearoff 0
2151 $fakerowmenu add command -label [mc "Diff this -> selected"] \
2152 -command {diffvssel 0}
2153 $fakerowmenu add command -label [mc "Diff selected -> this"] \
2154 -command {diffvssel 1}
2155 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2156 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2157 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2158 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2160 set headctxmenu .headctxmenu
2161 menu $headctxmenu -tearoff 0
2162 $headctxmenu add command -label [mc "Check out this branch"] \
2163 -command cobranch
2164 $headctxmenu add command -label [mc "Remove this branch"] \
2165 -command rmbranch
2167 global flist_menu
2168 set flist_menu .flistctxmenu
2169 menu $flist_menu -tearoff 0
2170 $flist_menu add command -label [mc "Highlight this too"] \
2171 -command {flist_hl 0}
2172 $flist_menu add command -label [mc "Highlight this only"] \
2173 -command {flist_hl 1}
2174 $flist_menu add command -label [mc "External diff"] \
2175 -command {external_diff}
2178 # Windows sends all mouse wheel events to the current focused window, not
2179 # the one where the mouse hovers, so bind those events here and redirect
2180 # to the correct window
2181 proc windows_mousewheel_redirector {W X Y D} {
2182 global canv canv2 canv3
2183 set w [winfo containing -displayof $W $X $Y]
2184 if {$w ne ""} {
2185 set u [expr {$D < 0 ? 5 : -5}]
2186 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2187 allcanvs yview scroll $u units
2188 } else {
2189 catch {
2190 $w yview scroll $u units
2196 # Update row number label when selectedline changes
2197 proc selectedline_change {n1 n2 op} {
2198 global selectedline rownumsel
2200 if {$selectedline eq {}} {
2201 set rownumsel {}
2202 } else {
2203 set rownumsel [expr {$selectedline + 1}]
2207 # mouse-2 makes all windows scan vertically, but only the one
2208 # the cursor is in scans horizontally
2209 proc canvscan {op w x y} {
2210 global canv canv2 canv3
2211 foreach c [list $canv $canv2 $canv3] {
2212 if {$c == $w} {
2213 $c scan $op $x $y
2214 } else {
2215 $c scan $op 0 $y
2220 proc scrollcanv {cscroll f0 f1} {
2221 $cscroll set $f0 $f1
2222 drawvisible
2223 flushhighlights
2226 # when we make a key binding for the toplevel, make sure
2227 # it doesn't get triggered when that key is pressed in the
2228 # find string entry widget.
2229 proc bindkey {ev script} {
2230 global entries
2231 bind . $ev $script
2232 set escript [bind Entry $ev]
2233 if {$escript == {}} {
2234 set escript [bind Entry <Key>]
2236 foreach e $entries {
2237 bind $e $ev "$escript; break"
2241 # set the focus back to the toplevel for any click outside
2242 # the entry widgets
2243 proc click {w} {
2244 global ctext entries
2245 foreach e [concat $entries $ctext] {
2246 if {$w == $e} return
2248 focus .
2251 # Adjust the progress bar for a change in requested extent or canvas size
2252 proc adjustprogress {} {
2253 global progresscanv progressitem progresscoords
2254 global fprogitem fprogcoord lastprogupdate progupdatepending
2255 global rprogitem rprogcoord
2257 set w [expr {[winfo width $progresscanv] - 4}]
2258 set x0 [expr {$w * [lindex $progresscoords 0]}]
2259 set x1 [expr {$w * [lindex $progresscoords 1]}]
2260 set h [winfo height $progresscanv]
2261 $progresscanv coords $progressitem $x0 0 $x1 $h
2262 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2263 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2264 set now [clock clicks -milliseconds]
2265 if {$now >= $lastprogupdate + 100} {
2266 set progupdatepending 0
2267 update
2268 } elseif {!$progupdatepending} {
2269 set progupdatepending 1
2270 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2274 proc doprogupdate {} {
2275 global lastprogupdate progupdatepending
2277 if {$progupdatepending} {
2278 set progupdatepending 0
2279 set lastprogupdate [clock clicks -milliseconds]
2280 update
2284 proc savestuff {w} {
2285 global canv canv2 canv3 mainfont textfont uifont tabstop
2286 global stuffsaved findmergefiles maxgraphpct
2287 global maxwidth showneartags showlocalchanges
2288 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2289 global cmitmode wrapcomment datetimeformat limitdiffs
2290 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2291 global autoselect extdifftool
2293 if {$stuffsaved} return
2294 if {![winfo viewable .]} return
2295 catch {
2296 set f [open "~/.gitk-new" w]
2297 puts $f [list set mainfont $mainfont]
2298 puts $f [list set textfont $textfont]
2299 puts $f [list set uifont $uifont]
2300 puts $f [list set tabstop $tabstop]
2301 puts $f [list set findmergefiles $findmergefiles]
2302 puts $f [list set maxgraphpct $maxgraphpct]
2303 puts $f [list set maxwidth $maxwidth]
2304 puts $f [list set cmitmode $cmitmode]
2305 puts $f [list set wrapcomment $wrapcomment]
2306 puts $f [list set autoselect $autoselect]
2307 puts $f [list set showneartags $showneartags]
2308 puts $f [list set showlocalchanges $showlocalchanges]
2309 puts $f [list set datetimeformat $datetimeformat]
2310 puts $f [list set limitdiffs $limitdiffs]
2311 puts $f [list set bgcolor $bgcolor]
2312 puts $f [list set fgcolor $fgcolor]
2313 puts $f [list set colors $colors]
2314 puts $f [list set diffcolors $diffcolors]
2315 puts $f [list set diffcontext $diffcontext]
2316 puts $f [list set selectbgcolor $selectbgcolor]
2317 puts $f [list set extdifftool $extdifftool]
2319 puts $f "set geometry(main) [wm geometry .]"
2320 puts $f "set geometry(topwidth) [winfo width .tf]"
2321 puts $f "set geometry(topheight) [winfo height .tf]"
2322 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2323 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2324 puts $f "set geometry(botwidth) [winfo width .bleft]"
2325 puts $f "set geometry(botheight) [winfo height .bleft]"
2327 puts -nonewline $f "set permviews {"
2328 for {set v 0} {$v < $nextviewnum} {incr v} {
2329 if {$viewperm($v)} {
2330 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2333 puts $f "}"
2334 close $f
2335 file rename -force "~/.gitk-new" "~/.gitk"
2337 set stuffsaved 1
2340 proc resizeclistpanes {win w} {
2341 global oldwidth
2342 if {[info exists oldwidth($win)]} {
2343 set s0 [$win sash coord 0]
2344 set s1 [$win sash coord 1]
2345 if {$w < 60} {
2346 set sash0 [expr {int($w/2 - 2)}]
2347 set sash1 [expr {int($w*5/6 - 2)}]
2348 } else {
2349 set factor [expr {1.0 * $w / $oldwidth($win)}]
2350 set sash0 [expr {int($factor * [lindex $s0 0])}]
2351 set sash1 [expr {int($factor * [lindex $s1 0])}]
2352 if {$sash0 < 30} {
2353 set sash0 30
2355 if {$sash1 < $sash0 + 20} {
2356 set sash1 [expr {$sash0 + 20}]
2358 if {$sash1 > $w - 10} {
2359 set sash1 [expr {$w - 10}]
2360 if {$sash0 > $sash1 - 20} {
2361 set sash0 [expr {$sash1 - 20}]
2365 $win sash place 0 $sash0 [lindex $s0 1]
2366 $win sash place 1 $sash1 [lindex $s1 1]
2368 set oldwidth($win) $w
2371 proc resizecdetpanes {win w} {
2372 global oldwidth
2373 if {[info exists oldwidth($win)]} {
2374 set s0 [$win sash coord 0]
2375 if {$w < 60} {
2376 set sash0 [expr {int($w*3/4 - 2)}]
2377 } else {
2378 set factor [expr {1.0 * $w / $oldwidth($win)}]
2379 set sash0 [expr {int($factor * [lindex $s0 0])}]
2380 if {$sash0 < 45} {
2381 set sash0 45
2383 if {$sash0 > $w - 15} {
2384 set sash0 [expr {$w - 15}]
2387 $win sash place 0 $sash0 [lindex $s0 1]
2389 set oldwidth($win) $w
2392 proc allcanvs args {
2393 global canv canv2 canv3
2394 eval $canv $args
2395 eval $canv2 $args
2396 eval $canv3 $args
2399 proc bindall {event action} {
2400 global canv canv2 canv3
2401 bind $canv $event $action
2402 bind $canv2 $event $action
2403 bind $canv3 $event $action
2406 proc about {} {
2407 global uifont
2408 set w .about
2409 if {[winfo exists $w]} {
2410 raise $w
2411 return
2413 toplevel $w
2414 wm title $w [mc "About gitk"]
2415 message $w.m -text [mc "
2416 Gitk - a commit viewer for git
2418 Copyright © 2005-2008 Paul Mackerras
2420 Use and redistribute under the terms of the GNU General Public License"] \
2421 -justify center -aspect 400 -border 2 -bg white -relief groove
2422 pack $w.m -side top -fill x -padx 2 -pady 2
2423 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2424 pack $w.ok -side bottom
2425 bind $w <Visibility> "focus $w.ok"
2426 bind $w <Key-Escape> "destroy $w"
2427 bind $w <Key-Return> "destroy $w"
2430 proc keys {} {
2431 set w .keys
2432 if {[winfo exists $w]} {
2433 raise $w
2434 return
2436 if {[tk windowingsystem] eq {aqua}} {
2437 set M1T Cmd
2438 } else {
2439 set M1T Ctrl
2441 toplevel $w
2442 wm title $w [mc "Gitk key bindings"]
2443 message $w.m -text "
2444 [mc "Gitk key bindings:"]
2446 [mc "<%s-Q> Quit" $M1T]
2447 [mc "<Home> Move to first commit"]
2448 [mc "<End> Move to last commit"]
2449 [mc "<Up>, p, i Move up one commit"]
2450 [mc "<Down>, n, k Move down one commit"]
2451 [mc "<Left>, z, j Go back in history list"]
2452 [mc "<Right>, x, l Go forward in history list"]
2453 [mc "<PageUp> Move up one page in commit list"]
2454 [mc "<PageDown> Move down one page in commit list"]
2455 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2456 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2457 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2458 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2459 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2460 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2461 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2462 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2463 [mc "<Delete>, b Scroll diff view up one page"]
2464 [mc "<Backspace> Scroll diff view up one page"]
2465 [mc "<Space> Scroll diff view down one page"]
2466 [mc "u Scroll diff view up 18 lines"]
2467 [mc "d Scroll diff view down 18 lines"]
2468 [mc "<%s-F> Find" $M1T]
2469 [mc "<%s-G> Move to next find hit" $M1T]
2470 [mc "<Return> Move to next find hit"]
2471 [mc "/ Move to next find hit, or redo find"]
2472 [mc "? Move to previous find hit"]
2473 [mc "f Scroll diff view to next file"]
2474 [mc "<%s-S> Search for next hit in diff view" $M1T]
2475 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2476 [mc "<%s-KP+> Increase font size" $M1T]
2477 [mc "<%s-plus> Increase font size" $M1T]
2478 [mc "<%s-KP-> Decrease font size" $M1T]
2479 [mc "<%s-minus> Decrease font size" $M1T]
2480 [mc "<F5> Update"]
2482 -justify left -bg white -border 2 -relief groove
2483 pack $w.m -side top -fill both -padx 2 -pady 2
2484 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2485 pack $w.ok -side bottom
2486 bind $w <Visibility> "focus $w.ok"
2487 bind $w <Key-Escape> "destroy $w"
2488 bind $w <Key-Return> "destroy $w"
2491 # Procedures for manipulating the file list window at the
2492 # bottom right of the overall window.
2494 proc treeview {w l openlevs} {
2495 global treecontents treediropen treeheight treeparent treeindex
2497 set ix 0
2498 set treeindex() 0
2499 set lev 0
2500 set prefix {}
2501 set prefixend -1
2502 set prefendstack {}
2503 set htstack {}
2504 set ht 0
2505 set treecontents() {}
2506 $w conf -state normal
2507 foreach f $l {
2508 while {[string range $f 0 $prefixend] ne $prefix} {
2509 if {$lev <= $openlevs} {
2510 $w mark set e:$treeindex($prefix) "end -1c"
2511 $w mark gravity e:$treeindex($prefix) left
2513 set treeheight($prefix) $ht
2514 incr ht [lindex $htstack end]
2515 set htstack [lreplace $htstack end end]
2516 set prefixend [lindex $prefendstack end]
2517 set prefendstack [lreplace $prefendstack end end]
2518 set prefix [string range $prefix 0 $prefixend]
2519 incr lev -1
2521 set tail [string range $f [expr {$prefixend+1}] end]
2522 while {[set slash [string first "/" $tail]] >= 0} {
2523 lappend htstack $ht
2524 set ht 0
2525 lappend prefendstack $prefixend
2526 incr prefixend [expr {$slash + 1}]
2527 set d [string range $tail 0 $slash]
2528 lappend treecontents($prefix) $d
2529 set oldprefix $prefix
2530 append prefix $d
2531 set treecontents($prefix) {}
2532 set treeindex($prefix) [incr ix]
2533 set treeparent($prefix) $oldprefix
2534 set tail [string range $tail [expr {$slash+1}] end]
2535 if {$lev <= $openlevs} {
2536 set ht 1
2537 set treediropen($prefix) [expr {$lev < $openlevs}]
2538 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2539 $w mark set d:$ix "end -1c"
2540 $w mark gravity d:$ix left
2541 set str "\n"
2542 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2543 $w insert end $str
2544 $w image create end -align center -image $bm -padx 1 \
2545 -name a:$ix
2546 $w insert end $d [highlight_tag $prefix]
2547 $w mark set s:$ix "end -1c"
2548 $w mark gravity s:$ix left
2550 incr lev
2552 if {$tail ne {}} {
2553 if {$lev <= $openlevs} {
2554 incr ht
2555 set str "\n"
2556 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2557 $w insert end $str
2558 $w insert end $tail [highlight_tag $f]
2560 lappend treecontents($prefix) $tail
2563 while {$htstack ne {}} {
2564 set treeheight($prefix) $ht
2565 incr ht [lindex $htstack end]
2566 set htstack [lreplace $htstack end end]
2567 set prefixend [lindex $prefendstack end]
2568 set prefendstack [lreplace $prefendstack end end]
2569 set prefix [string range $prefix 0 $prefixend]
2571 $w conf -state disabled
2574 proc linetoelt {l} {
2575 global treeheight treecontents
2577 set y 2
2578 set prefix {}
2579 while {1} {
2580 foreach e $treecontents($prefix) {
2581 if {$y == $l} {
2582 return "$prefix$e"
2584 set n 1
2585 if {[string index $e end] eq "/"} {
2586 set n $treeheight($prefix$e)
2587 if {$y + $n > $l} {
2588 append prefix $e
2589 incr y
2590 break
2593 incr y $n
2598 proc highlight_tree {y prefix} {
2599 global treeheight treecontents cflist
2601 foreach e $treecontents($prefix) {
2602 set path $prefix$e
2603 if {[highlight_tag $path] ne {}} {
2604 $cflist tag add bold $y.0 "$y.0 lineend"
2606 incr y
2607 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2608 set y [highlight_tree $y $path]
2611 return $y
2614 proc treeclosedir {w dir} {
2615 global treediropen treeheight treeparent treeindex
2617 set ix $treeindex($dir)
2618 $w conf -state normal
2619 $w delete s:$ix e:$ix
2620 set treediropen($dir) 0
2621 $w image configure a:$ix -image tri-rt
2622 $w conf -state disabled
2623 set n [expr {1 - $treeheight($dir)}]
2624 while {$dir ne {}} {
2625 incr treeheight($dir) $n
2626 set dir $treeparent($dir)
2630 proc treeopendir {w dir} {
2631 global treediropen treeheight treeparent treecontents treeindex
2633 set ix $treeindex($dir)
2634 $w conf -state normal
2635 $w image configure a:$ix -image tri-dn
2636 $w mark set e:$ix s:$ix
2637 $w mark gravity e:$ix right
2638 set lev 0
2639 set str "\n"
2640 set n [llength $treecontents($dir)]
2641 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2642 incr lev
2643 append str "\t"
2644 incr treeheight($x) $n
2646 foreach e $treecontents($dir) {
2647 set de $dir$e
2648 if {[string index $e end] eq "/"} {
2649 set iy $treeindex($de)
2650 $w mark set d:$iy e:$ix
2651 $w mark gravity d:$iy left
2652 $w insert e:$ix $str
2653 set treediropen($de) 0
2654 $w image create e:$ix -align center -image tri-rt -padx 1 \
2655 -name a:$iy
2656 $w insert e:$ix $e [highlight_tag $de]
2657 $w mark set s:$iy e:$ix
2658 $w mark gravity s:$iy left
2659 set treeheight($de) 1
2660 } else {
2661 $w insert e:$ix $str
2662 $w insert e:$ix $e [highlight_tag $de]
2665 $w mark gravity e:$ix left
2666 $w conf -state disabled
2667 set treediropen($dir) 1
2668 set top [lindex [split [$w index @0,0] .] 0]
2669 set ht [$w cget -height]
2670 set l [lindex [split [$w index s:$ix] .] 0]
2671 if {$l < $top} {
2672 $w yview $l.0
2673 } elseif {$l + $n + 1 > $top + $ht} {
2674 set top [expr {$l + $n + 2 - $ht}]
2675 if {$l < $top} {
2676 set top $l
2678 $w yview $top.0
2682 proc treeclick {w x y} {
2683 global treediropen cmitmode ctext cflist cflist_top
2685 if {$cmitmode ne "tree"} return
2686 if {![info exists cflist_top]} return
2687 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2688 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2689 $cflist tag add highlight $l.0 "$l.0 lineend"
2690 set cflist_top $l
2691 if {$l == 1} {
2692 $ctext yview 1.0
2693 return
2695 set e [linetoelt $l]
2696 if {[string index $e end] ne "/"} {
2697 showfile $e
2698 } elseif {$treediropen($e)} {
2699 treeclosedir $w $e
2700 } else {
2701 treeopendir $w $e
2705 proc setfilelist {id} {
2706 global treefilelist cflist
2708 treeview $cflist $treefilelist($id) 0
2711 image create bitmap tri-rt -background black -foreground blue -data {
2712 #define tri-rt_width 13
2713 #define tri-rt_height 13
2714 static unsigned char tri-rt_bits[] = {
2715 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2716 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2717 0x00, 0x00};
2718 } -maskdata {
2719 #define tri-rt-mask_width 13
2720 #define tri-rt-mask_height 13
2721 static unsigned char tri-rt-mask_bits[] = {
2722 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2723 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2724 0x08, 0x00};
2726 image create bitmap tri-dn -background black -foreground blue -data {
2727 #define tri-dn_width 13
2728 #define tri-dn_height 13
2729 static unsigned char tri-dn_bits[] = {
2730 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2731 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2732 0x00, 0x00};
2733 } -maskdata {
2734 #define tri-dn-mask_width 13
2735 #define tri-dn-mask_height 13
2736 static unsigned char tri-dn-mask_bits[] = {
2737 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2738 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2739 0x00, 0x00};
2742 image create bitmap reficon-T -background black -foreground yellow -data {
2743 #define tagicon_width 13
2744 #define tagicon_height 9
2745 static unsigned char tagicon_bits[] = {
2746 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2747 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2748 } -maskdata {
2749 #define tagicon-mask_width 13
2750 #define tagicon-mask_height 9
2751 static unsigned char tagicon-mask_bits[] = {
2752 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2753 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2755 set rectdata {
2756 #define headicon_width 13
2757 #define headicon_height 9
2758 static unsigned char headicon_bits[] = {
2759 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2760 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2762 set rectmask {
2763 #define headicon-mask_width 13
2764 #define headicon-mask_height 9
2765 static unsigned char headicon-mask_bits[] = {
2766 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2767 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2769 image create bitmap reficon-H -background black -foreground green \
2770 -data $rectdata -maskdata $rectmask
2771 image create bitmap reficon-o -background black -foreground "#ddddff" \
2772 -data $rectdata -maskdata $rectmask
2774 proc init_flist {first} {
2775 global cflist cflist_top difffilestart
2777 $cflist conf -state normal
2778 $cflist delete 0.0 end
2779 if {$first ne {}} {
2780 $cflist insert end $first
2781 set cflist_top 1
2782 $cflist tag add highlight 1.0 "1.0 lineend"
2783 } else {
2784 catch {unset cflist_top}
2786 $cflist conf -state disabled
2787 set difffilestart {}
2790 proc highlight_tag {f} {
2791 global highlight_paths
2793 foreach p $highlight_paths {
2794 if {[string match $p $f]} {
2795 return "bold"
2798 return {}
2801 proc highlight_filelist {} {
2802 global cmitmode cflist
2804 $cflist conf -state normal
2805 if {$cmitmode ne "tree"} {
2806 set end [lindex [split [$cflist index end] .] 0]
2807 for {set l 2} {$l < $end} {incr l} {
2808 set line [$cflist get $l.0 "$l.0 lineend"]
2809 if {[highlight_tag $line] ne {}} {
2810 $cflist tag add bold $l.0 "$l.0 lineend"
2813 } else {
2814 highlight_tree 2 {}
2816 $cflist conf -state disabled
2819 proc unhighlight_filelist {} {
2820 global cflist
2822 $cflist conf -state normal
2823 $cflist tag remove bold 1.0 end
2824 $cflist conf -state disabled
2827 proc add_flist {fl} {
2828 global cflist
2830 $cflist conf -state normal
2831 foreach f $fl {
2832 $cflist insert end "\n"
2833 $cflist insert end $f [highlight_tag $f]
2835 $cflist conf -state disabled
2838 proc sel_flist {w x y} {
2839 global ctext difffilestart cflist cflist_top cmitmode
2841 if {$cmitmode eq "tree"} return
2842 if {![info exists cflist_top]} return
2843 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2844 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2845 $cflist tag add highlight $l.0 "$l.0 lineend"
2846 set cflist_top $l
2847 if {$l == 1} {
2848 $ctext yview 1.0
2849 } else {
2850 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2854 proc pop_flist_menu {w X Y x y} {
2855 global ctext cflist cmitmode flist_menu flist_menu_file
2856 global treediffs diffids
2858 stopfinding
2859 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2860 if {$l <= 1} return
2861 if {$cmitmode eq "tree"} {
2862 set e [linetoelt $l]
2863 if {[string index $e end] eq "/"} return
2864 } else {
2865 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2867 set flist_menu_file $e
2868 set xdiffstate "normal"
2869 if {$cmitmode eq "tree"} {
2870 set xdiffstate "disabled"
2872 # Disable "External diff" item in tree mode
2873 $flist_menu entryconf 2 -state $xdiffstate
2874 tk_popup $flist_menu $X $Y
2877 proc flist_hl {only} {
2878 global flist_menu_file findstring gdttype
2880 set x [shellquote $flist_menu_file]
2881 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2882 set findstring $x
2883 } else {
2884 append findstring " " $x
2886 set gdttype [mc "touching paths:"]
2889 proc save_file_from_commit {filename output what} {
2890 global nullfile
2892 if {[catch {exec git show $filename -- > $output} err]} {
2893 if {[string match "fatal: bad revision *" $err]} {
2894 return $nullfile
2896 error_popup "Error getting \"$filename\" from $what: $err"
2897 return {}
2899 return $output
2902 proc external_diff_get_one_file {diffid filename diffdir} {
2903 global nullid nullid2 nullfile
2904 global gitdir
2906 if {$diffid == $nullid} {
2907 set difffile [file join [file dirname $gitdir] $filename]
2908 if {[file exists $difffile]} {
2909 return $difffile
2911 return $nullfile
2913 if {$diffid == $nullid2} {
2914 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2915 return [save_file_from_commit :$filename $difffile index]
2917 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2918 return [save_file_from_commit $diffid:$filename $difffile \
2919 "revision $diffid"]
2922 proc external_diff {} {
2923 global gitktmpdir nullid nullid2
2924 global flist_menu_file
2925 global diffids
2926 global diffnum
2927 global gitdir extdifftool
2929 if {[llength $diffids] == 1} {
2930 # no reference commit given
2931 set diffidto [lindex $diffids 0]
2932 if {$diffidto eq $nullid} {
2933 # diffing working copy with index
2934 set diffidfrom $nullid2
2935 } elseif {$diffidto eq $nullid2} {
2936 # diffing index with HEAD
2937 set diffidfrom "HEAD"
2938 } else {
2939 # use first parent commit
2940 global parentlist selectedline
2941 set diffidfrom [lindex $parentlist $selectedline 0]
2943 } else {
2944 set diffidfrom [lindex $diffids 0]
2945 set diffidto [lindex $diffids 1]
2948 # make sure that several diffs wont collide
2949 if {![info exists gitktmpdir]} {
2950 set gitktmpdir [file join [file dirname $gitdir] \
2951 [format ".gitk-tmp.%s" [pid]]]
2952 if {[catch {file mkdir $gitktmpdir} err]} {
2953 error_popup "Error creating temporary directory $gitktmpdir: $err"
2954 unset gitktmpdir
2955 return
2957 set diffnum 0
2959 incr diffnum
2960 set diffdir [file join $gitktmpdir $diffnum]
2961 if {[catch {file mkdir $diffdir} err]} {
2962 error_popup "Error creating temporary directory $diffdir: $err"
2963 return
2966 # gather files to diff
2967 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
2968 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
2970 if {$difffromfile ne {} && $difftofile ne {}} {
2971 set cmd [concat | [shellsplit $extdifftool] \
2972 [list $difffromfile $difftofile]]
2973 if {[catch {set fl [open $cmd r]} err]} {
2974 file delete -force $diffdir
2975 error_popup [mc "$extdifftool: command failed: $err"]
2976 } else {
2977 fconfigure $fl -blocking 0
2978 filerun $fl [list delete_at_eof $fl $diffdir]
2983 # delete $dir when we see eof on $f (presumably because the child has exited)
2984 proc delete_at_eof {f dir} {
2985 while {[gets $f line] >= 0} {}
2986 if {[eof $f]} {
2987 if {[catch {close $f} err]} {
2988 error_popup "External diff viewer failed: $err"
2990 file delete -force $dir
2991 return 0
2993 return 1
2996 # Functions for adding and removing shell-type quoting
2998 proc shellquote {str} {
2999 if {![string match "*\['\"\\ \t]*" $str]} {
3000 return $str
3002 if {![string match "*\['\"\\]*" $str]} {
3003 return "\"$str\""
3005 if {![string match "*'*" $str]} {
3006 return "'$str'"
3008 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3011 proc shellarglist {l} {
3012 set str {}
3013 foreach a $l {
3014 if {$str ne {}} {
3015 append str " "
3017 append str [shellquote $a]
3019 return $str
3022 proc shelldequote {str} {
3023 set ret {}
3024 set used -1
3025 while {1} {
3026 incr used
3027 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3028 append ret [string range $str $used end]
3029 set used [string length $str]
3030 break
3032 set first [lindex $first 0]
3033 set ch [string index $str $first]
3034 if {$first > $used} {
3035 append ret [string range $str $used [expr {$first - 1}]]
3036 set used $first
3038 if {$ch eq " " || $ch eq "\t"} break
3039 incr used
3040 if {$ch eq "'"} {
3041 set first [string first "'" $str $used]
3042 if {$first < 0} {
3043 error "unmatched single-quote"
3045 append ret [string range $str $used [expr {$first - 1}]]
3046 set used $first
3047 continue
3049 if {$ch eq "\\"} {
3050 if {$used >= [string length $str]} {
3051 error "trailing backslash"
3053 append ret [string index $str $used]
3054 continue
3056 # here ch == "\""
3057 while {1} {
3058 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3059 error "unmatched double-quote"
3061 set first [lindex $first 0]
3062 set ch [string index $str $first]
3063 if {$first > $used} {
3064 append ret [string range $str $used [expr {$first - 1}]]
3065 set used $first
3067 if {$ch eq "\""} break
3068 incr used
3069 append ret [string index $str $used]
3070 incr used
3073 return [list $used $ret]
3076 proc shellsplit {str} {
3077 set l {}
3078 while {1} {
3079 set str [string trimleft $str]
3080 if {$str eq {}} break
3081 set dq [shelldequote $str]
3082 set n [lindex $dq 0]
3083 set word [lindex $dq 1]
3084 set str [string range $str $n end]
3085 lappend l $word
3087 return $l
3090 # Code to implement multiple views
3092 proc newview {ishighlight} {
3093 global nextviewnum newviewname newviewperm newishighlight
3094 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3096 set newishighlight $ishighlight
3097 set top .gitkview
3098 if {[winfo exists $top]} {
3099 raise $top
3100 return
3102 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3103 set newviewperm($nextviewnum) 0
3104 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3105 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3106 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3109 proc editview {} {
3110 global curview
3111 global viewname viewperm newviewname newviewperm
3112 global viewargs newviewargs viewargscmd newviewargscmd
3114 set top .gitkvedit-$curview
3115 if {[winfo exists $top]} {
3116 raise $top
3117 return
3119 set newviewname($curview) $viewname($curview)
3120 set newviewperm($curview) $viewperm($curview)
3121 set newviewargs($curview) [shellarglist $viewargs($curview)]
3122 set newviewargscmd($curview) $viewargscmd($curview)
3123 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3126 proc vieweditor {top n title} {
3127 global newviewname newviewperm viewfiles bgcolor
3129 toplevel $top
3130 wm title $top $title
3131 label $top.nl -text [mc "Name"]
3132 entry $top.name -width 20 -textvariable newviewname($n)
3133 grid $top.nl $top.name -sticky w -pady 5
3134 checkbutton $top.perm -text [mc "Remember this view"] \
3135 -variable newviewperm($n)
3136 grid $top.perm - -pady 5 -sticky w
3137 message $top.al -aspect 1000 \
3138 -text [mc "Commits to include (arguments to git log):"]
3139 grid $top.al - -sticky w -pady 5
3140 entry $top.args -width 50 -textvariable newviewargs($n) \
3141 -background $bgcolor
3142 grid $top.args - -sticky ew -padx 5
3144 message $top.ac -aspect 1000 \
3145 -text [mc "Command to generate more commits to include:"]
3146 grid $top.ac - -sticky w -pady 5
3147 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3148 -background white
3149 grid $top.argscmd - -sticky ew -padx 5
3151 message $top.l -aspect 1000 \
3152 -text [mc "Enter files and directories to include, one per line:"]
3153 grid $top.l - -sticky w
3154 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3155 if {[info exists viewfiles($n)]} {
3156 foreach f $viewfiles($n) {
3157 $top.t insert end $f
3158 $top.t insert end "\n"
3160 $top.t delete {end - 1c} end
3161 $top.t mark set insert 0.0
3163 grid $top.t - -sticky ew -padx 5
3164 frame $top.buts
3165 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3166 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3167 grid $top.buts.ok $top.buts.can
3168 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3169 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3170 grid $top.buts - -pady 10 -sticky ew
3171 focus $top.t
3174 proc doviewmenu {m first cmd op argv} {
3175 set nmenu [$m index end]
3176 for {set i $first} {$i <= $nmenu} {incr i} {
3177 if {[$m entrycget $i -command] eq $cmd} {
3178 eval $m $op $i $argv
3179 break
3184 proc allviewmenus {n op args} {
3185 # global viewhlmenu
3187 doviewmenu .bar.view 5 [list showview $n] $op $args
3188 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3191 proc newviewok {top n} {
3192 global nextviewnum newviewperm newviewname newishighlight
3193 global viewname viewfiles viewperm selectedview curview
3194 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3196 if {[catch {
3197 set newargs [shellsplit $newviewargs($n)]
3198 } err]} {
3199 error_popup "[mc "Error in commit selection arguments:"] $err"
3200 wm raise $top
3201 focus $top
3202 return
3204 set files {}
3205 foreach f [split [$top.t get 0.0 end] "\n"] {
3206 set ft [string trim $f]
3207 if {$ft ne {}} {
3208 lappend files $ft
3211 if {![info exists viewfiles($n)]} {
3212 # creating a new view
3213 incr nextviewnum
3214 set viewname($n) $newviewname($n)
3215 set viewperm($n) $newviewperm($n)
3216 set viewfiles($n) $files
3217 set viewargs($n) $newargs
3218 set viewargscmd($n) $newviewargscmd($n)
3219 addviewmenu $n
3220 if {!$newishighlight} {
3221 run showview $n
3222 } else {
3223 run addvhighlight $n
3225 } else {
3226 # editing an existing view
3227 set viewperm($n) $newviewperm($n)
3228 if {$newviewname($n) ne $viewname($n)} {
3229 set viewname($n) $newviewname($n)
3230 doviewmenu .bar.view 5 [list showview $n] \
3231 entryconf [list -label $viewname($n)]
3232 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3233 # entryconf [list -label $viewname($n) -value $viewname($n)]
3235 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3236 $newviewargscmd($n) ne $viewargscmd($n)} {
3237 set viewfiles($n) $files
3238 set viewargs($n) $newargs
3239 set viewargscmd($n) $newviewargscmd($n)
3240 if {$curview == $n} {
3241 run reloadcommits
3245 catch {destroy $top}
3248 proc delview {} {
3249 global curview viewperm hlview selectedhlview
3251 if {$curview == 0} return
3252 if {[info exists hlview] && $hlview == $curview} {
3253 set selectedhlview [mc "None"]
3254 unset hlview
3256 allviewmenus $curview delete
3257 set viewperm($curview) 0
3258 showview 0
3261 proc addviewmenu {n} {
3262 global viewname viewhlmenu
3264 .bar.view add radiobutton -label $viewname($n) \
3265 -command [list showview $n] -variable selectedview -value $n
3266 #$viewhlmenu add radiobutton -label $viewname($n) \
3267 # -command [list addvhighlight $n] -variable selectedhlview
3270 proc showview {n} {
3271 global curview cached_commitrow ordertok
3272 global displayorder parentlist rowidlist rowisopt rowfinal
3273 global colormap rowtextx nextcolor canvxmax
3274 global numcommits viewcomplete
3275 global selectedline currentid canv canvy0
3276 global treediffs
3277 global pending_select mainheadid
3278 global commitidx
3279 global selectedview
3280 global hlview selectedhlview commitinterest
3282 if {$n == $curview} return
3283 set selid {}
3284 set ymax [lindex [$canv cget -scrollregion] 3]
3285 set span [$canv yview]
3286 set ytop [expr {[lindex $span 0] * $ymax}]
3287 set ybot [expr {[lindex $span 1] * $ymax}]
3288 set yscreen [expr {($ybot - $ytop) / 2}]
3289 if {$selectedline ne {}} {
3290 set selid $currentid
3291 set y [yc $selectedline]
3292 if {$ytop < $y && $y < $ybot} {
3293 set yscreen [expr {$y - $ytop}]
3295 } elseif {[info exists pending_select]} {
3296 set selid $pending_select
3297 unset pending_select
3299 unselectline
3300 normalline
3301 catch {unset treediffs}
3302 clear_display
3303 if {[info exists hlview] && $hlview == $n} {
3304 unset hlview
3305 set selectedhlview [mc "None"]
3307 catch {unset commitinterest}
3308 catch {unset cached_commitrow}
3309 catch {unset ordertok}
3311 set curview $n
3312 set selectedview $n
3313 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3314 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3316 run refill_reflist
3317 if {![info exists viewcomplete($n)]} {
3318 if {$selid ne {}} {
3319 set pending_select $selid
3321 getcommits
3322 return
3325 set displayorder {}
3326 set parentlist {}
3327 set rowidlist {}
3328 set rowisopt {}
3329 set rowfinal {}
3330 set numcommits $commitidx($n)
3332 catch {unset colormap}
3333 catch {unset rowtextx}
3334 set nextcolor 0
3335 set canvxmax [$canv cget -width]
3336 set curview $n
3337 set row 0
3338 setcanvscroll
3339 set yf 0
3340 set row {}
3341 if {$selid ne {} && [commitinview $selid $n]} {
3342 set row [rowofcommit $selid]
3343 # try to get the selected row in the same position on the screen
3344 set ymax [lindex [$canv cget -scrollregion] 3]
3345 set ytop [expr {[yc $row] - $yscreen}]
3346 if {$ytop < 0} {
3347 set ytop 0
3349 set yf [expr {$ytop * 1.0 / $ymax}]
3351 allcanvs yview moveto $yf
3352 drawvisible
3353 if {$row ne {}} {
3354 selectline $row 0
3355 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
3356 selectline [rowofcommit $mainheadid] 1
3357 } elseif {!$viewcomplete($n)} {
3358 if {$selid ne {}} {
3359 set pending_select $selid
3360 } else {
3361 set pending_select $mainheadid
3363 } else {
3364 set row [first_real_row]
3365 if {$row < $numcommits} {
3366 selectline $row 0
3369 if {!$viewcomplete($n)} {
3370 if {$numcommits == 0} {
3371 show_status [mc "Reading commits..."]
3373 } elseif {$numcommits == 0} {
3374 show_status [mc "No commits selected"]
3378 # Stuff relating to the highlighting facility
3380 proc ishighlighted {id} {
3381 global vhighlights fhighlights nhighlights rhighlights
3383 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3384 return $nhighlights($id)
3386 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3387 return $vhighlights($id)
3389 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3390 return $fhighlights($id)
3392 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3393 return $rhighlights($id)
3395 return 0
3398 proc bolden {row font} {
3399 global canv linehtag selectedline boldrows
3401 lappend boldrows $row
3402 $canv itemconf $linehtag($row) -font $font
3403 if {$row == $selectedline} {
3404 $canv delete secsel
3405 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3406 -outline {{}} -tags secsel \
3407 -fill [$canv cget -selectbackground]]
3408 $canv lower $t
3412 proc bolden_name {row font} {
3413 global canv2 linentag selectedline boldnamerows
3415 lappend boldnamerows $row
3416 $canv2 itemconf $linentag($row) -font $font
3417 if {$row == $selectedline} {
3418 $canv2 delete secsel
3419 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3420 -outline {{}} -tags secsel \
3421 -fill [$canv2 cget -selectbackground]]
3422 $canv2 lower $t
3426 proc unbolden {} {
3427 global boldrows
3429 set stillbold {}
3430 foreach row $boldrows {
3431 if {![ishighlighted [commitonrow $row]]} {
3432 bolden $row mainfont
3433 } else {
3434 lappend stillbold $row
3437 set boldrows $stillbold
3440 proc addvhighlight {n} {
3441 global hlview viewcomplete curview vhl_done commitidx
3443 if {[info exists hlview]} {
3444 delvhighlight
3446 set hlview $n
3447 if {$n != $curview && ![info exists viewcomplete($n)]} {
3448 start_rev_list $n
3450 set vhl_done $commitidx($hlview)
3451 if {$vhl_done > 0} {
3452 drawvisible
3456 proc delvhighlight {} {
3457 global hlview vhighlights
3459 if {![info exists hlview]} return
3460 unset hlview
3461 catch {unset vhighlights}
3462 unbolden
3465 proc vhighlightmore {} {
3466 global hlview vhl_done commitidx vhighlights curview
3468 set max $commitidx($hlview)
3469 set vr [visiblerows]
3470 set r0 [lindex $vr 0]
3471 set r1 [lindex $vr 1]
3472 for {set i $vhl_done} {$i < $max} {incr i} {
3473 set id [commitonrow $i $hlview]
3474 if {[commitinview $id $curview]} {
3475 set row [rowofcommit $id]
3476 if {$r0 <= $row && $row <= $r1} {
3477 if {![highlighted $row]} {
3478 bolden $row mainfontbold
3480 set vhighlights($id) 1
3484 set vhl_done $max
3485 return 0
3488 proc askvhighlight {row id} {
3489 global hlview vhighlights iddrawn
3491 if {[commitinview $id $hlview]} {
3492 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3493 bolden $row mainfontbold
3495 set vhighlights($id) 1
3496 } else {
3497 set vhighlights($id) 0
3501 proc hfiles_change {} {
3502 global highlight_files filehighlight fhighlights fh_serial
3503 global highlight_paths gdttype
3505 if {[info exists filehighlight]} {
3506 # delete previous highlights
3507 catch {close $filehighlight}
3508 unset filehighlight
3509 catch {unset fhighlights}
3510 unbolden
3511 unhighlight_filelist
3513 set highlight_paths {}
3514 after cancel do_file_hl $fh_serial
3515 incr fh_serial
3516 if {$highlight_files ne {}} {
3517 after 300 do_file_hl $fh_serial
3521 proc gdttype_change {name ix op} {
3522 global gdttype highlight_files findstring findpattern
3524 stopfinding
3525 if {$findstring ne {}} {
3526 if {$gdttype eq [mc "containing:"]} {
3527 if {$highlight_files ne {}} {
3528 set highlight_files {}
3529 hfiles_change
3531 findcom_change
3532 } else {
3533 if {$findpattern ne {}} {
3534 set findpattern {}
3535 findcom_change
3537 set highlight_files $findstring
3538 hfiles_change
3540 drawvisible
3542 # enable/disable findtype/findloc menus too
3545 proc find_change {name ix op} {
3546 global gdttype findstring highlight_files
3548 stopfinding
3549 if {$gdttype eq [mc "containing:"]} {
3550 findcom_change
3551 } else {
3552 if {$highlight_files ne $findstring} {
3553 set highlight_files $findstring
3554 hfiles_change
3557 drawvisible
3560 proc findcom_change args {
3561 global nhighlights boldnamerows
3562 global findpattern findtype findstring gdttype
3564 stopfinding
3565 # delete previous highlights, if any
3566 foreach row $boldnamerows {
3567 bolden_name $row mainfont
3569 set boldnamerows {}
3570 catch {unset nhighlights}
3571 unbolden
3572 unmarkmatches
3573 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3574 set findpattern {}
3575 } elseif {$findtype eq [mc "Regexp"]} {
3576 set findpattern $findstring
3577 } else {
3578 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3579 $findstring]
3580 set findpattern "*$e*"
3584 proc makepatterns {l} {
3585 set ret {}
3586 foreach e $l {
3587 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3588 if {[string index $ee end] eq "/"} {
3589 lappend ret "$ee*"
3590 } else {
3591 lappend ret $ee
3592 lappend ret "$ee/*"
3595 return $ret
3598 proc do_file_hl {serial} {
3599 global highlight_files filehighlight highlight_paths gdttype fhl_list
3601 if {$gdttype eq [mc "touching paths:"]} {
3602 if {[catch {set paths [shellsplit $highlight_files]}]} return
3603 set highlight_paths [makepatterns $paths]
3604 highlight_filelist
3605 set gdtargs [concat -- $paths]
3606 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3607 set gdtargs [list "-S$highlight_files"]
3608 } else {
3609 # must be "containing:", i.e. we're searching commit info
3610 return
3612 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3613 set filehighlight [open $cmd r+]
3614 fconfigure $filehighlight -blocking 0
3615 filerun $filehighlight readfhighlight
3616 set fhl_list {}
3617 drawvisible
3618 flushhighlights
3621 proc flushhighlights {} {
3622 global filehighlight fhl_list
3624 if {[info exists filehighlight]} {
3625 lappend fhl_list {}
3626 puts $filehighlight ""
3627 flush $filehighlight
3631 proc askfilehighlight {row id} {
3632 global filehighlight fhighlights fhl_list
3634 lappend fhl_list $id
3635 set fhighlights($id) -1
3636 puts $filehighlight $id
3639 proc readfhighlight {} {
3640 global filehighlight fhighlights curview iddrawn
3641 global fhl_list find_dirn
3643 if {![info exists filehighlight]} {
3644 return 0
3646 set nr 0
3647 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3648 set line [string trim $line]
3649 set i [lsearch -exact $fhl_list $line]
3650 if {$i < 0} continue
3651 for {set j 0} {$j < $i} {incr j} {
3652 set id [lindex $fhl_list $j]
3653 set fhighlights($id) 0
3655 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3656 if {$line eq {}} continue
3657 if {![commitinview $line $curview]} continue
3658 set row [rowofcommit $line]
3659 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3660 bolden $row mainfontbold
3662 set fhighlights($line) 1
3664 if {[eof $filehighlight]} {
3665 # strange...
3666 puts "oops, git diff-tree died"
3667 catch {close $filehighlight}
3668 unset filehighlight
3669 return 0
3671 if {[info exists find_dirn]} {
3672 run findmore
3674 return 1
3677 proc doesmatch {f} {
3678 global findtype findpattern
3680 if {$findtype eq [mc "Regexp"]} {
3681 return [regexp $findpattern $f]
3682 } elseif {$findtype eq [mc "IgnCase"]} {
3683 return [string match -nocase $findpattern $f]
3684 } else {
3685 return [string match $findpattern $f]
3689 proc askfindhighlight {row id} {
3690 global nhighlights commitinfo iddrawn
3691 global findloc
3692 global markingmatches
3694 if {![info exists commitinfo($id)]} {
3695 getcommit $id
3697 set info $commitinfo($id)
3698 set isbold 0
3699 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3700 foreach f $info ty $fldtypes {
3701 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3702 [doesmatch $f]} {
3703 if {$ty eq [mc "Author"]} {
3704 set isbold 2
3705 break
3707 set isbold 1
3710 if {$isbold && [info exists iddrawn($id)]} {
3711 if {![ishighlighted $id]} {
3712 bolden $row mainfontbold
3713 if {$isbold > 1} {
3714 bolden_name $row mainfontbold
3717 if {$markingmatches} {
3718 markrowmatches $row $id
3721 set nhighlights($id) $isbold
3724 proc markrowmatches {row id} {
3725 global canv canv2 linehtag linentag commitinfo findloc
3727 set headline [lindex $commitinfo($id) 0]
3728 set author [lindex $commitinfo($id) 1]
3729 $canv delete match$row
3730 $canv2 delete match$row
3731 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3732 set m [findmatches $headline]
3733 if {$m ne {}} {
3734 markmatches $canv $row $headline $linehtag($row) $m \
3735 [$canv itemcget $linehtag($row) -font] $row
3738 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3739 set m [findmatches $author]
3740 if {$m ne {}} {
3741 markmatches $canv2 $row $author $linentag($row) $m \
3742 [$canv2 itemcget $linentag($row) -font] $row
3747 proc vrel_change {name ix op} {
3748 global highlight_related
3750 rhighlight_none
3751 if {$highlight_related ne [mc "None"]} {
3752 run drawvisible
3756 # prepare for testing whether commits are descendents or ancestors of a
3757 proc rhighlight_sel {a} {
3758 global descendent desc_todo ancestor anc_todo
3759 global highlight_related
3761 catch {unset descendent}
3762 set desc_todo [list $a]
3763 catch {unset ancestor}
3764 set anc_todo [list $a]
3765 if {$highlight_related ne [mc "None"]} {
3766 rhighlight_none
3767 run drawvisible
3771 proc rhighlight_none {} {
3772 global rhighlights
3774 catch {unset rhighlights}
3775 unbolden
3778 proc is_descendent {a} {
3779 global curview children descendent desc_todo
3781 set v $curview
3782 set la [rowofcommit $a]
3783 set todo $desc_todo
3784 set leftover {}
3785 set done 0
3786 for {set i 0} {$i < [llength $todo]} {incr i} {
3787 set do [lindex $todo $i]
3788 if {[rowofcommit $do] < $la} {
3789 lappend leftover $do
3790 continue
3792 foreach nk $children($v,$do) {
3793 if {![info exists descendent($nk)]} {
3794 set descendent($nk) 1
3795 lappend todo $nk
3796 if {$nk eq $a} {
3797 set done 1
3801 if {$done} {
3802 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3803 return
3806 set descendent($a) 0
3807 set desc_todo $leftover
3810 proc is_ancestor {a} {
3811 global curview parents ancestor anc_todo
3813 set v $curview
3814 set la [rowofcommit $a]
3815 set todo $anc_todo
3816 set leftover {}
3817 set done 0
3818 for {set i 0} {$i < [llength $todo]} {incr i} {
3819 set do [lindex $todo $i]
3820 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3821 lappend leftover $do
3822 continue
3824 foreach np $parents($v,$do) {
3825 if {![info exists ancestor($np)]} {
3826 set ancestor($np) 1
3827 lappend todo $np
3828 if {$np eq $a} {
3829 set done 1
3833 if {$done} {
3834 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3835 return
3838 set ancestor($a) 0
3839 set anc_todo $leftover
3842 proc askrelhighlight {row id} {
3843 global descendent highlight_related iddrawn rhighlights
3844 global selectedline ancestor
3846 if {$selectedline eq {}} return
3847 set isbold 0
3848 if {$highlight_related eq [mc "Descendant"] ||
3849 $highlight_related eq [mc "Not descendant"]} {
3850 if {![info exists descendent($id)]} {
3851 is_descendent $id
3853 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3854 set isbold 1
3856 } elseif {$highlight_related eq [mc "Ancestor"] ||
3857 $highlight_related eq [mc "Not ancestor"]} {
3858 if {![info exists ancestor($id)]} {
3859 is_ancestor $id
3861 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3862 set isbold 1
3865 if {[info exists iddrawn($id)]} {
3866 if {$isbold && ![ishighlighted $id]} {
3867 bolden $row mainfontbold
3870 set rhighlights($id) $isbold
3873 # Graph layout functions
3875 proc shortids {ids} {
3876 set res {}
3877 foreach id $ids {
3878 if {[llength $id] > 1} {
3879 lappend res [shortids $id]
3880 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3881 lappend res [string range $id 0 7]
3882 } else {
3883 lappend res $id
3886 return $res
3889 proc ntimes {n o} {
3890 set ret {}
3891 set o [list $o]
3892 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3893 if {($n & $mask) != 0} {
3894 set ret [concat $ret $o]
3896 set o [concat $o $o]
3898 return $ret
3901 proc ordertoken {id} {
3902 global ordertok curview varcid varcstart varctok curview parents children
3903 global nullid nullid2
3905 if {[info exists ordertok($id)]} {
3906 return $ordertok($id)
3908 set origid $id
3909 set todo {}
3910 while {1} {
3911 if {[info exists varcid($curview,$id)]} {
3912 set a $varcid($curview,$id)
3913 set p [lindex $varcstart($curview) $a]
3914 } else {
3915 set p [lindex $children($curview,$id) 0]
3917 if {[info exists ordertok($p)]} {
3918 set tok $ordertok($p)
3919 break
3921 set id [first_real_child $curview,$p]
3922 if {$id eq {}} {
3923 # it's a root
3924 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3925 break
3927 if {[llength $parents($curview,$id)] == 1} {
3928 lappend todo [list $p {}]
3929 } else {
3930 set j [lsearch -exact $parents($curview,$id) $p]
3931 if {$j < 0} {
3932 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3934 lappend todo [list $p [strrep $j]]
3937 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3938 set p [lindex $todo $i 0]
3939 append tok [lindex $todo $i 1]
3940 set ordertok($p) $tok
3942 set ordertok($origid) $tok
3943 return $tok
3946 # Work out where id should go in idlist so that order-token
3947 # values increase from left to right
3948 proc idcol {idlist id {i 0}} {
3949 set t [ordertoken $id]
3950 if {$i < 0} {
3951 set i 0
3953 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3954 if {$i > [llength $idlist]} {
3955 set i [llength $idlist]
3957 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3958 incr i
3959 } else {
3960 if {$t > [ordertoken [lindex $idlist $i]]} {
3961 while {[incr i] < [llength $idlist] &&
3962 $t >= [ordertoken [lindex $idlist $i]]} {}
3965 return $i
3968 proc initlayout {} {
3969 global rowidlist rowisopt rowfinal displayorder parentlist
3970 global numcommits canvxmax canv
3971 global nextcolor
3972 global colormap rowtextx
3974 set numcommits 0
3975 set displayorder {}
3976 set parentlist {}
3977 set nextcolor 0
3978 set rowidlist {}
3979 set rowisopt {}
3980 set rowfinal {}
3981 set canvxmax [$canv cget -width]
3982 catch {unset colormap}
3983 catch {unset rowtextx}
3984 setcanvscroll
3987 proc setcanvscroll {} {
3988 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3989 global lastscrollset lastscrollrows
3991 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3992 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3993 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3994 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3995 set lastscrollset [clock clicks -milliseconds]
3996 set lastscrollrows $numcommits
3999 proc visiblerows {} {
4000 global canv numcommits linespc
4002 set ymax [lindex [$canv cget -scrollregion] 3]
4003 if {$ymax eq {} || $ymax == 0} return
4004 set f [$canv yview]
4005 set y0 [expr {int([lindex $f 0] * $ymax)}]
4006 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4007 if {$r0 < 0} {
4008 set r0 0
4010 set y1 [expr {int([lindex $f 1] * $ymax)}]
4011 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4012 if {$r1 >= $numcommits} {
4013 set r1 [expr {$numcommits - 1}]
4015 return [list $r0 $r1]
4018 proc layoutmore {} {
4019 global commitidx viewcomplete curview
4020 global numcommits pending_select curview
4021 global lastscrollset lastscrollrows commitinterest
4023 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4024 [clock clicks -milliseconds] - $lastscrollset > 500} {
4025 setcanvscroll
4027 if {[info exists pending_select] &&
4028 [commitinview $pending_select $curview]} {
4029 selectline [rowofcommit $pending_select] 1
4031 drawvisible
4034 proc doshowlocalchanges {} {
4035 global curview mainheadid
4037 if {$mainheadid eq {}} return
4038 if {[commitinview $mainheadid $curview]} {
4039 dodiffindex
4040 } else {
4041 lappend commitinterest($mainheadid) {dodiffindex}
4045 proc dohidelocalchanges {} {
4046 global nullid nullid2 lserial curview
4048 if {[commitinview $nullid $curview]} {
4049 removefakerow $nullid
4051 if {[commitinview $nullid2 $curview]} {
4052 removefakerow $nullid2
4054 incr lserial
4057 # spawn off a process to do git diff-index --cached HEAD
4058 proc dodiffindex {} {
4059 global lserial showlocalchanges
4060 global isworktree
4062 if {!$showlocalchanges || !$isworktree} return
4063 incr lserial
4064 set fd [open "|git diff-index --cached HEAD" r]
4065 fconfigure $fd -blocking 0
4066 filerun $fd [list readdiffindex $fd $lserial]
4069 proc readdiffindex {fd serial} {
4070 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4072 set isdiff 1
4073 if {[gets $fd line] < 0} {
4074 if {![eof $fd]} {
4075 return 1
4077 set isdiff 0
4079 # we only need to see one line and we don't really care what it says...
4080 close $fd
4082 if {$serial != $lserial} {
4083 return 0
4086 # now see if there are any local changes not checked in to the index
4087 set fd [open "|git diff-files" r]
4088 fconfigure $fd -blocking 0
4089 filerun $fd [list readdifffiles $fd $serial]
4091 if {$isdiff && ![commitinview $nullid2 $curview]} {
4092 # add the line for the changes in the index to the graph
4093 set hl [mc "Local changes checked in to index but not committed"]
4094 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4095 set commitdata($nullid2) "\n $hl\n"
4096 if {[commitinview $nullid $curview]} {
4097 removefakerow $nullid
4099 insertfakerow $nullid2 $mainheadid
4100 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4101 removefakerow $nullid2
4103 return 0
4106 proc readdifffiles {fd serial} {
4107 global mainheadid nullid nullid2 curview
4108 global commitinfo commitdata lserial
4110 set isdiff 1
4111 if {[gets $fd line] < 0} {
4112 if {![eof $fd]} {
4113 return 1
4115 set isdiff 0
4117 # we only need to see one line and we don't really care what it says...
4118 close $fd
4120 if {$serial != $lserial} {
4121 return 0
4124 if {$isdiff && ![commitinview $nullid $curview]} {
4125 # add the line for the local diff to the graph
4126 set hl [mc "Local uncommitted changes, not checked in to index"]
4127 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4128 set commitdata($nullid) "\n $hl\n"
4129 if {[commitinview $nullid2 $curview]} {
4130 set p $nullid2
4131 } else {
4132 set p $mainheadid
4134 insertfakerow $nullid $p
4135 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4136 removefakerow $nullid
4138 return 0
4141 proc nextuse {id row} {
4142 global curview children
4144 if {[info exists children($curview,$id)]} {
4145 foreach kid $children($curview,$id) {
4146 if {![commitinview $kid $curview]} {
4147 return -1
4149 if {[rowofcommit $kid] > $row} {
4150 return [rowofcommit $kid]
4154 if {[commitinview $id $curview]} {
4155 return [rowofcommit $id]
4157 return -1
4160 proc prevuse {id row} {
4161 global curview children
4163 set ret -1
4164 if {[info exists children($curview,$id)]} {
4165 foreach kid $children($curview,$id) {
4166 if {![commitinview $kid $curview]} break
4167 if {[rowofcommit $kid] < $row} {
4168 set ret [rowofcommit $kid]
4172 return $ret
4175 proc make_idlist {row} {
4176 global displayorder parentlist uparrowlen downarrowlen mingaplen
4177 global commitidx curview children
4179 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4180 if {$r < 0} {
4181 set r 0
4183 set ra [expr {$row - $downarrowlen}]
4184 if {$ra < 0} {
4185 set ra 0
4187 set rb [expr {$row + $uparrowlen}]
4188 if {$rb > $commitidx($curview)} {
4189 set rb $commitidx($curview)
4191 make_disporder $r [expr {$rb + 1}]
4192 set ids {}
4193 for {} {$r < $ra} {incr r} {
4194 set nextid [lindex $displayorder [expr {$r + 1}]]
4195 foreach p [lindex $parentlist $r] {
4196 if {$p eq $nextid} continue
4197 set rn [nextuse $p $r]
4198 if {$rn >= $row &&
4199 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4200 lappend ids [list [ordertoken $p] $p]
4204 for {} {$r < $row} {incr r} {
4205 set nextid [lindex $displayorder [expr {$r + 1}]]
4206 foreach p [lindex $parentlist $r] {
4207 if {$p eq $nextid} continue
4208 set rn [nextuse $p $r]
4209 if {$rn < 0 || $rn >= $row} {
4210 lappend ids [list [ordertoken $p] $p]
4214 set id [lindex $displayorder $row]
4215 lappend ids [list [ordertoken $id] $id]
4216 while {$r < $rb} {
4217 foreach p [lindex $parentlist $r] {
4218 set firstkid [lindex $children($curview,$p) 0]
4219 if {[rowofcommit $firstkid] < $row} {
4220 lappend ids [list [ordertoken $p] $p]
4223 incr r
4224 set id [lindex $displayorder $r]
4225 if {$id ne {}} {
4226 set firstkid [lindex $children($curview,$id) 0]
4227 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4228 lappend ids [list [ordertoken $id] $id]
4232 set idlist {}
4233 foreach idx [lsort -unique $ids] {
4234 lappend idlist [lindex $idx 1]
4236 return $idlist
4239 proc rowsequal {a b} {
4240 while {[set i [lsearch -exact $a {}]] >= 0} {
4241 set a [lreplace $a $i $i]
4243 while {[set i [lsearch -exact $b {}]] >= 0} {
4244 set b [lreplace $b $i $i]
4246 return [expr {$a eq $b}]
4249 proc makeupline {id row rend col} {
4250 global rowidlist uparrowlen downarrowlen mingaplen
4252 for {set r $rend} {1} {set r $rstart} {
4253 set rstart [prevuse $id $r]
4254 if {$rstart < 0} return
4255 if {$rstart < $row} break
4257 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4258 set rstart [expr {$rend - $uparrowlen - 1}]
4260 for {set r $rstart} {[incr r] <= $row} {} {
4261 set idlist [lindex $rowidlist $r]
4262 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4263 set col [idcol $idlist $id $col]
4264 lset rowidlist $r [linsert $idlist $col $id]
4265 changedrow $r
4270 proc layoutrows {row endrow} {
4271 global rowidlist rowisopt rowfinal displayorder
4272 global uparrowlen downarrowlen maxwidth mingaplen
4273 global children parentlist
4274 global commitidx viewcomplete curview
4276 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4277 set idlist {}
4278 if {$row > 0} {
4279 set rm1 [expr {$row - 1}]
4280 foreach id [lindex $rowidlist $rm1] {
4281 if {$id ne {}} {
4282 lappend idlist $id
4285 set final [lindex $rowfinal $rm1]
4287 for {} {$row < $endrow} {incr row} {
4288 set rm1 [expr {$row - 1}]
4289 if {$rm1 < 0 || $idlist eq {}} {
4290 set idlist [make_idlist $row]
4291 set final 1
4292 } else {
4293 set id [lindex $displayorder $rm1]
4294 set col [lsearch -exact $idlist $id]
4295 set idlist [lreplace $idlist $col $col]
4296 foreach p [lindex $parentlist $rm1] {
4297 if {[lsearch -exact $idlist $p] < 0} {
4298 set col [idcol $idlist $p $col]
4299 set idlist [linsert $idlist $col $p]
4300 # if not the first child, we have to insert a line going up
4301 if {$id ne [lindex $children($curview,$p) 0]} {
4302 makeupline $p $rm1 $row $col
4306 set id [lindex $displayorder $row]
4307 if {$row > $downarrowlen} {
4308 set termrow [expr {$row - $downarrowlen - 1}]
4309 foreach p [lindex $parentlist $termrow] {
4310 set i [lsearch -exact $idlist $p]
4311 if {$i < 0} continue
4312 set nr [nextuse $p $termrow]
4313 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4314 set idlist [lreplace $idlist $i $i]
4318 set col [lsearch -exact $idlist $id]
4319 if {$col < 0} {
4320 set col [idcol $idlist $id]
4321 set idlist [linsert $idlist $col $id]
4322 if {$children($curview,$id) ne {}} {
4323 makeupline $id $rm1 $row $col
4326 set r [expr {$row + $uparrowlen - 1}]
4327 if {$r < $commitidx($curview)} {
4328 set x $col
4329 foreach p [lindex $parentlist $r] {
4330 if {[lsearch -exact $idlist $p] >= 0} continue
4331 set fk [lindex $children($curview,$p) 0]
4332 if {[rowofcommit $fk] < $row} {
4333 set x [idcol $idlist $p $x]
4334 set idlist [linsert $idlist $x $p]
4337 if {[incr r] < $commitidx($curview)} {
4338 set p [lindex $displayorder $r]
4339 if {[lsearch -exact $idlist $p] < 0} {
4340 set fk [lindex $children($curview,$p) 0]
4341 if {$fk ne {} && [rowofcommit $fk] < $row} {
4342 set x [idcol $idlist $p $x]
4343 set idlist [linsert $idlist $x $p]
4349 if {$final && !$viewcomplete($curview) &&
4350 $row + $uparrowlen + $mingaplen + $downarrowlen
4351 >= $commitidx($curview)} {
4352 set final 0
4354 set l [llength $rowidlist]
4355 if {$row == $l} {
4356 lappend rowidlist $idlist
4357 lappend rowisopt 0
4358 lappend rowfinal $final
4359 } elseif {$row < $l} {
4360 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4361 lset rowidlist $row $idlist
4362 changedrow $row
4364 lset rowfinal $row $final
4365 } else {
4366 set pad [ntimes [expr {$row - $l}] {}]
4367 set rowidlist [concat $rowidlist $pad]
4368 lappend rowidlist $idlist
4369 set rowfinal [concat $rowfinal $pad]
4370 lappend rowfinal $final
4371 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4374 return $row
4377 proc changedrow {row} {
4378 global displayorder iddrawn rowisopt need_redisplay
4380 set l [llength $rowisopt]
4381 if {$row < $l} {
4382 lset rowisopt $row 0
4383 if {$row + 1 < $l} {
4384 lset rowisopt [expr {$row + 1}] 0
4385 if {$row + 2 < $l} {
4386 lset rowisopt [expr {$row + 2}] 0
4390 set id [lindex $displayorder $row]
4391 if {[info exists iddrawn($id)]} {
4392 set need_redisplay 1
4396 proc insert_pad {row col npad} {
4397 global rowidlist
4399 set pad [ntimes $npad {}]
4400 set idlist [lindex $rowidlist $row]
4401 set bef [lrange $idlist 0 [expr {$col - 1}]]
4402 set aft [lrange $idlist $col end]
4403 set i [lsearch -exact $aft {}]
4404 if {$i > 0} {
4405 set aft [lreplace $aft $i $i]
4407 lset rowidlist $row [concat $bef $pad $aft]
4408 changedrow $row
4411 proc optimize_rows {row col endrow} {
4412 global rowidlist rowisopt displayorder curview children
4414 if {$row < 1} {
4415 set row 1
4417 for {} {$row < $endrow} {incr row; set col 0} {
4418 if {[lindex $rowisopt $row]} continue
4419 set haspad 0
4420 set y0 [expr {$row - 1}]
4421 set ym [expr {$row - 2}]
4422 set idlist [lindex $rowidlist $row]
4423 set previdlist [lindex $rowidlist $y0]
4424 if {$idlist eq {} || $previdlist eq {}} continue
4425 if {$ym >= 0} {
4426 set pprevidlist [lindex $rowidlist $ym]
4427 if {$pprevidlist eq {}} continue
4428 } else {
4429 set pprevidlist {}
4431 set x0 -1
4432 set xm -1
4433 for {} {$col < [llength $idlist]} {incr col} {
4434 set id [lindex $idlist $col]
4435 if {[lindex $previdlist $col] eq $id} continue
4436 if {$id eq {}} {
4437 set haspad 1
4438 continue
4440 set x0 [lsearch -exact $previdlist $id]
4441 if {$x0 < 0} continue
4442 set z [expr {$x0 - $col}]
4443 set isarrow 0
4444 set z0 {}
4445 if {$ym >= 0} {
4446 set xm [lsearch -exact $pprevidlist $id]
4447 if {$xm >= 0} {
4448 set z0 [expr {$xm - $x0}]
4451 if {$z0 eq {}} {
4452 # if row y0 is the first child of $id then it's not an arrow
4453 if {[lindex $children($curview,$id) 0] ne
4454 [lindex $displayorder $y0]} {
4455 set isarrow 1
4458 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4459 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4460 set isarrow 1
4462 # Looking at lines from this row to the previous row,
4463 # make them go straight up if they end in an arrow on
4464 # the previous row; otherwise make them go straight up
4465 # or at 45 degrees.
4466 if {$z < -1 || ($z < 0 && $isarrow)} {
4467 # Line currently goes left too much;
4468 # insert pads in the previous row, then optimize it
4469 set npad [expr {-1 - $z + $isarrow}]
4470 insert_pad $y0 $x0 $npad
4471 if {$y0 > 0} {
4472 optimize_rows $y0 $x0 $row
4474 set previdlist [lindex $rowidlist $y0]
4475 set x0 [lsearch -exact $previdlist $id]
4476 set z [expr {$x0 - $col}]
4477 if {$z0 ne {}} {
4478 set pprevidlist [lindex $rowidlist $ym]
4479 set xm [lsearch -exact $pprevidlist $id]
4480 set z0 [expr {$xm - $x0}]
4482 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4483 # Line currently goes right too much;
4484 # insert pads in this line
4485 set npad [expr {$z - 1 + $isarrow}]
4486 insert_pad $row $col $npad
4487 set idlist [lindex $rowidlist $row]
4488 incr col $npad
4489 set z [expr {$x0 - $col}]
4490 set haspad 1
4492 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4493 # this line links to its first child on row $row-2
4494 set id [lindex $displayorder $ym]
4495 set xc [lsearch -exact $pprevidlist $id]
4496 if {$xc >= 0} {
4497 set z0 [expr {$xc - $x0}]
4500 # avoid lines jigging left then immediately right
4501 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4502 insert_pad $y0 $x0 1
4503 incr x0
4504 optimize_rows $y0 $x0 $row
4505 set previdlist [lindex $rowidlist $y0]
4508 if {!$haspad} {
4509 # Find the first column that doesn't have a line going right
4510 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4511 set id [lindex $idlist $col]
4512 if {$id eq {}} break
4513 set x0 [lsearch -exact $previdlist $id]
4514 if {$x0 < 0} {
4515 # check if this is the link to the first child
4516 set kid [lindex $displayorder $y0]
4517 if {[lindex $children($curview,$id) 0] eq $kid} {
4518 # it is, work out offset to child
4519 set x0 [lsearch -exact $previdlist $kid]
4522 if {$x0 <= $col} break
4524 # Insert a pad at that column as long as it has a line and
4525 # isn't the last column
4526 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4527 set idlist [linsert $idlist $col {}]
4528 lset rowidlist $row $idlist
4529 changedrow $row
4535 proc xc {row col} {
4536 global canvx0 linespc
4537 return [expr {$canvx0 + $col * $linespc}]
4540 proc yc {row} {
4541 global canvy0 linespc
4542 return [expr {$canvy0 + $row * $linespc}]
4545 proc linewidth {id} {
4546 global thickerline lthickness
4548 set wid $lthickness
4549 if {[info exists thickerline] && $id eq $thickerline} {
4550 set wid [expr {2 * $lthickness}]
4552 return $wid
4555 proc rowranges {id} {
4556 global curview children uparrowlen downarrowlen
4557 global rowidlist
4559 set kids $children($curview,$id)
4560 if {$kids eq {}} {
4561 return {}
4563 set ret {}
4564 lappend kids $id
4565 foreach child $kids {
4566 if {![commitinview $child $curview]} break
4567 set row [rowofcommit $child]
4568 if {![info exists prev]} {
4569 lappend ret [expr {$row + 1}]
4570 } else {
4571 if {$row <= $prevrow} {
4572 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4574 # see if the line extends the whole way from prevrow to row
4575 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4576 [lsearch -exact [lindex $rowidlist \
4577 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4578 # it doesn't, see where it ends
4579 set r [expr {$prevrow + $downarrowlen}]
4580 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4581 while {[incr r -1] > $prevrow &&
4582 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4583 } else {
4584 while {[incr r] <= $row &&
4585 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4586 incr r -1
4588 lappend ret $r
4589 # see where it starts up again
4590 set r [expr {$row - $uparrowlen}]
4591 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4592 while {[incr r] < $row &&
4593 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4594 } else {
4595 while {[incr r -1] >= $prevrow &&
4596 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4597 incr r
4599 lappend ret $r
4602 if {$child eq $id} {
4603 lappend ret $row
4605 set prev $child
4606 set prevrow $row
4608 return $ret
4611 proc drawlineseg {id row endrow arrowlow} {
4612 global rowidlist displayorder iddrawn linesegs
4613 global canv colormap linespc curview maxlinelen parentlist
4615 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4616 set le [expr {$row + 1}]
4617 set arrowhigh 1
4618 while {1} {
4619 set c [lsearch -exact [lindex $rowidlist $le] $id]
4620 if {$c < 0} {
4621 incr le -1
4622 break
4624 lappend cols $c
4625 set x [lindex $displayorder $le]
4626 if {$x eq $id} {
4627 set arrowhigh 0
4628 break
4630 if {[info exists iddrawn($x)] || $le == $endrow} {
4631 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4632 if {$c >= 0} {
4633 lappend cols $c
4634 set arrowhigh 0
4636 break
4638 incr le
4640 if {$le <= $row} {
4641 return $row
4644 set lines {}
4645 set i 0
4646 set joinhigh 0
4647 if {[info exists linesegs($id)]} {
4648 set lines $linesegs($id)
4649 foreach li $lines {
4650 set r0 [lindex $li 0]
4651 if {$r0 > $row} {
4652 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4653 set joinhigh 1
4655 break
4657 incr i
4660 set joinlow 0
4661 if {$i > 0} {
4662 set li [lindex $lines [expr {$i-1}]]
4663 set r1 [lindex $li 1]
4664 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4665 set joinlow 1
4669 set x [lindex $cols [expr {$le - $row}]]
4670 set xp [lindex $cols [expr {$le - 1 - $row}]]
4671 set dir [expr {$xp - $x}]
4672 if {$joinhigh} {
4673 set ith [lindex $lines $i 2]
4674 set coords [$canv coords $ith]
4675 set ah [$canv itemcget $ith -arrow]
4676 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4677 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4678 if {$x2 ne {} && $x - $x2 == $dir} {
4679 set coords [lrange $coords 0 end-2]
4681 } else {
4682 set coords [list [xc $le $x] [yc $le]]
4684 if {$joinlow} {
4685 set itl [lindex $lines [expr {$i-1}] 2]
4686 set al [$canv itemcget $itl -arrow]
4687 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4688 } elseif {$arrowlow} {
4689 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4690 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4691 set arrowlow 0
4694 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4695 for {set y $le} {[incr y -1] > $row} {} {
4696 set x $xp
4697 set xp [lindex $cols [expr {$y - 1 - $row}]]
4698 set ndir [expr {$xp - $x}]
4699 if {$dir != $ndir || $xp < 0} {
4700 lappend coords [xc $y $x] [yc $y]
4702 set dir $ndir
4704 if {!$joinlow} {
4705 if {$xp < 0} {
4706 # join parent line to first child
4707 set ch [lindex $displayorder $row]
4708 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4709 if {$xc < 0} {
4710 puts "oops: drawlineseg: child $ch not on row $row"
4711 } elseif {$xc != $x} {
4712 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4713 set d [expr {int(0.5 * $linespc)}]
4714 set x1 [xc $row $x]
4715 if {$xc < $x} {
4716 set x2 [expr {$x1 - $d}]
4717 } else {
4718 set x2 [expr {$x1 + $d}]
4720 set y2 [yc $row]
4721 set y1 [expr {$y2 + $d}]
4722 lappend coords $x1 $y1 $x2 $y2
4723 } elseif {$xc < $x - 1} {
4724 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4725 } elseif {$xc > $x + 1} {
4726 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4728 set x $xc
4730 lappend coords [xc $row $x] [yc $row]
4731 } else {
4732 set xn [xc $row $xp]
4733 set yn [yc $row]
4734 lappend coords $xn $yn
4736 if {!$joinhigh} {
4737 assigncolor $id
4738 set t [$canv create line $coords -width [linewidth $id] \
4739 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4740 $canv lower $t
4741 bindline $t $id
4742 set lines [linsert $lines $i [list $row $le $t]]
4743 } else {
4744 $canv coords $ith $coords
4745 if {$arrow ne $ah} {
4746 $canv itemconf $ith -arrow $arrow
4748 lset lines $i 0 $row
4750 } else {
4751 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4752 set ndir [expr {$xo - $xp}]
4753 set clow [$canv coords $itl]
4754 if {$dir == $ndir} {
4755 set clow [lrange $clow 2 end]
4757 set coords [concat $coords $clow]
4758 if {!$joinhigh} {
4759 lset lines [expr {$i-1}] 1 $le
4760 } else {
4761 # coalesce two pieces
4762 $canv delete $ith
4763 set b [lindex $lines [expr {$i-1}] 0]
4764 set e [lindex $lines $i 1]
4765 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4767 $canv coords $itl $coords
4768 if {$arrow ne $al} {
4769 $canv itemconf $itl -arrow $arrow
4773 set linesegs($id) $lines
4774 return $le
4777 proc drawparentlinks {id row} {
4778 global rowidlist canv colormap curview parentlist
4779 global idpos linespc
4781 set rowids [lindex $rowidlist $row]
4782 set col [lsearch -exact $rowids $id]
4783 if {$col < 0} return
4784 set olds [lindex $parentlist $row]
4785 set row2 [expr {$row + 1}]
4786 set x [xc $row $col]
4787 set y [yc $row]
4788 set y2 [yc $row2]
4789 set d [expr {int(0.5 * $linespc)}]
4790 set ymid [expr {$y + $d}]
4791 set ids [lindex $rowidlist $row2]
4792 # rmx = right-most X coord used
4793 set rmx 0
4794 foreach p $olds {
4795 set i [lsearch -exact $ids $p]
4796 if {$i < 0} {
4797 puts "oops, parent $p of $id not in list"
4798 continue
4800 set x2 [xc $row2 $i]
4801 if {$x2 > $rmx} {
4802 set rmx $x2
4804 set j [lsearch -exact $rowids $p]
4805 if {$j < 0} {
4806 # drawlineseg will do this one for us
4807 continue
4809 assigncolor $p
4810 # should handle duplicated parents here...
4811 set coords [list $x $y]
4812 if {$i != $col} {
4813 # if attaching to a vertical segment, draw a smaller
4814 # slant for visual distinctness
4815 if {$i == $j} {
4816 if {$i < $col} {
4817 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4818 } else {
4819 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4821 } elseif {$i < $col && $i < $j} {
4822 # segment slants towards us already
4823 lappend coords [xc $row $j] $y
4824 } else {
4825 if {$i < $col - 1} {
4826 lappend coords [expr {$x2 + $linespc}] $y
4827 } elseif {$i > $col + 1} {
4828 lappend coords [expr {$x2 - $linespc}] $y
4830 lappend coords $x2 $y2
4832 } else {
4833 lappend coords $x2 $y2
4835 set t [$canv create line $coords -width [linewidth $p] \
4836 -fill $colormap($p) -tags lines.$p]
4837 $canv lower $t
4838 bindline $t $p
4840 if {$rmx > [lindex $idpos($id) 1]} {
4841 lset idpos($id) 1 $rmx
4842 redrawtags $id
4846 proc drawlines {id} {
4847 global canv
4849 $canv itemconf lines.$id -width [linewidth $id]
4852 proc drawcmittext {id row col} {
4853 global linespc canv canv2 canv3 fgcolor curview
4854 global cmitlisted commitinfo rowidlist parentlist
4855 global rowtextx idpos idtags idheads idotherrefs
4856 global linehtag linentag linedtag selectedline
4857 global canvxmax boldrows boldnamerows fgcolor
4858 global mainheadid nullid nullid2 circleitem circlecolors
4860 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4861 set listed $cmitlisted($curview,$id)
4862 if {$id eq $nullid} {
4863 set ofill red
4864 } elseif {$id eq $nullid2} {
4865 set ofill green
4866 } elseif {$id eq $mainheadid} {
4867 set ofill yellow
4868 } else {
4869 set ofill [lindex $circlecolors $listed]
4871 set x [xc $row $col]
4872 set y [yc $row]
4873 set orad [expr {$linespc / 3}]
4874 if {$listed <= 2} {
4875 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4876 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4877 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4878 } elseif {$listed == 3} {
4879 # triangle pointing left for left-side commits
4880 set t [$canv create polygon \
4881 [expr {$x - $orad}] $y \
4882 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4883 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4884 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4885 } else {
4886 # triangle pointing right for right-side commits
4887 set t [$canv create polygon \
4888 [expr {$x + $orad - 1}] $y \
4889 [expr {$x - $orad}] [expr {$y - $orad}] \
4890 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4891 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4893 set circleitem($row) $t
4894 $canv raise $t
4895 $canv bind $t <1> {selcanvline {} %x %y}
4896 set rmx [llength [lindex $rowidlist $row]]
4897 set olds [lindex $parentlist $row]
4898 if {$olds ne {}} {
4899 set nextids [lindex $rowidlist [expr {$row + 1}]]
4900 foreach p $olds {
4901 set i [lsearch -exact $nextids $p]
4902 if {$i > $rmx} {
4903 set rmx $i
4907 set xt [xc $row $rmx]
4908 set rowtextx($row) $xt
4909 set idpos($id) [list $x $xt $y]
4910 if {[info exists idtags($id)] || [info exists idheads($id)]
4911 || [info exists idotherrefs($id)]} {
4912 set xt [drawtags $id $x $xt $y]
4914 set headline [lindex $commitinfo($id) 0]
4915 set name [lindex $commitinfo($id) 1]
4916 set date [lindex $commitinfo($id) 2]
4917 set date [formatdate $date]
4918 set font mainfont
4919 set nfont mainfont
4920 set isbold [ishighlighted $id]
4921 if {$isbold > 0} {
4922 lappend boldrows $row
4923 set font mainfontbold
4924 if {$isbold > 1} {
4925 lappend boldnamerows $row
4926 set nfont mainfontbold
4929 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4930 -text $headline -font $font -tags text]
4931 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4932 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4933 -text $name -font $nfont -tags text]
4934 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4935 -text $date -font mainfont -tags text]
4936 if {$selectedline == $row} {
4937 make_secsel $row
4939 set xr [expr {$xt + [font measure $font $headline]}]
4940 if {$xr > $canvxmax} {
4941 set canvxmax $xr
4942 setcanvscroll
4946 proc drawcmitrow {row} {
4947 global displayorder rowidlist nrows_drawn
4948 global iddrawn markingmatches
4949 global commitinfo numcommits
4950 global filehighlight fhighlights findpattern nhighlights
4951 global hlview vhighlights
4952 global highlight_related rhighlights
4954 if {$row >= $numcommits} return
4956 set id [lindex $displayorder $row]
4957 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4958 askvhighlight $row $id
4960 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4961 askfilehighlight $row $id
4963 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4964 askfindhighlight $row $id
4966 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4967 askrelhighlight $row $id
4969 if {![info exists iddrawn($id)]} {
4970 set col [lsearch -exact [lindex $rowidlist $row] $id]
4971 if {$col < 0} {
4972 puts "oops, row $row id $id not in list"
4973 return
4975 if {![info exists commitinfo($id)]} {
4976 getcommit $id
4978 assigncolor $id
4979 drawcmittext $id $row $col
4980 set iddrawn($id) 1
4981 incr nrows_drawn
4983 if {$markingmatches} {
4984 markrowmatches $row $id
4988 proc drawcommits {row {endrow {}}} {
4989 global numcommits iddrawn displayorder curview need_redisplay
4990 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4992 if {$row < 0} {
4993 set row 0
4995 if {$endrow eq {}} {
4996 set endrow $row
4998 if {$endrow >= $numcommits} {
4999 set endrow [expr {$numcommits - 1}]
5002 set rl1 [expr {$row - $downarrowlen - 3}]
5003 if {$rl1 < 0} {
5004 set rl1 0
5006 set ro1 [expr {$row - 3}]
5007 if {$ro1 < 0} {
5008 set ro1 0
5010 set r2 [expr {$endrow + $uparrowlen + 3}]
5011 if {$r2 > $numcommits} {
5012 set r2 $numcommits
5014 for {set r $rl1} {$r < $r2} {incr r} {
5015 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5016 if {$rl1 < $r} {
5017 layoutrows $rl1 $r
5019 set rl1 [expr {$r + 1}]
5022 if {$rl1 < $r} {
5023 layoutrows $rl1 $r
5025 optimize_rows $ro1 0 $r2
5026 if {$need_redisplay || $nrows_drawn > 2000} {
5027 clear_display
5028 drawvisible
5031 # make the lines join to already-drawn rows either side
5032 set r [expr {$row - 1}]
5033 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5034 set r $row
5036 set er [expr {$endrow + 1}]
5037 if {$er >= $numcommits ||
5038 ![info exists iddrawn([lindex $displayorder $er])]} {
5039 set er $endrow
5041 for {} {$r <= $er} {incr r} {
5042 set id [lindex $displayorder $r]
5043 set wasdrawn [info exists iddrawn($id)]
5044 drawcmitrow $r
5045 if {$r == $er} break
5046 set nextid [lindex $displayorder [expr {$r + 1}]]
5047 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5048 drawparentlinks $id $r
5050 set rowids [lindex $rowidlist $r]
5051 foreach lid $rowids {
5052 if {$lid eq {}} continue
5053 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5054 if {$lid eq $id} {
5055 # see if this is the first child of any of its parents
5056 foreach p [lindex $parentlist $r] {
5057 if {[lsearch -exact $rowids $p] < 0} {
5058 # make this line extend up to the child
5059 set lineend($p) [drawlineseg $p $r $er 0]
5062 } else {
5063 set lineend($lid) [drawlineseg $lid $r $er 1]
5069 proc undolayout {row} {
5070 global uparrowlen mingaplen downarrowlen
5071 global rowidlist rowisopt rowfinal need_redisplay
5073 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5074 if {$r < 0} {
5075 set r 0
5077 if {[llength $rowidlist] > $r} {
5078 incr r -1
5079 set rowidlist [lrange $rowidlist 0 $r]
5080 set rowfinal [lrange $rowfinal 0 $r]
5081 set rowisopt [lrange $rowisopt 0 $r]
5082 set need_redisplay 1
5083 run drawvisible
5087 proc drawvisible {} {
5088 global canv linespc curview vrowmod selectedline targetrow targetid
5089 global need_redisplay cscroll numcommits
5091 set fs [$canv yview]
5092 set ymax [lindex [$canv cget -scrollregion] 3]
5093 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5094 set f0 [lindex $fs 0]
5095 set f1 [lindex $fs 1]
5096 set y0 [expr {int($f0 * $ymax)}]
5097 set y1 [expr {int($f1 * $ymax)}]
5099 if {[info exists targetid]} {
5100 if {[commitinview $targetid $curview]} {
5101 set r [rowofcommit $targetid]
5102 if {$r != $targetrow} {
5103 # Fix up the scrollregion and change the scrolling position
5104 # now that our target row has moved.
5105 set diff [expr {($r - $targetrow) * $linespc}]
5106 set targetrow $r
5107 setcanvscroll
5108 set ymax [lindex [$canv cget -scrollregion] 3]
5109 incr y0 $diff
5110 incr y1 $diff
5111 set f0 [expr {$y0 / $ymax}]
5112 set f1 [expr {$y1 / $ymax}]
5113 allcanvs yview moveto $f0
5114 $cscroll set $f0 $f1
5115 set need_redisplay 1
5117 } else {
5118 unset targetid
5122 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5123 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5124 if {$endrow >= $vrowmod($curview)} {
5125 update_arcrows $curview
5127 if {$selectedline ne {} &&
5128 $row <= $selectedline && $selectedline <= $endrow} {
5129 set targetrow $selectedline
5130 } elseif {[info exists targetid]} {
5131 set targetrow [expr {int(($row + $endrow) / 2)}]
5133 if {[info exists targetrow]} {
5134 if {$targetrow >= $numcommits} {
5135 set targetrow [expr {$numcommits - 1}]
5137 set targetid [commitonrow $targetrow]
5139 drawcommits $row $endrow
5142 proc clear_display {} {
5143 global iddrawn linesegs need_redisplay nrows_drawn
5144 global vhighlights fhighlights nhighlights rhighlights
5145 global linehtag linentag linedtag boldrows boldnamerows
5147 allcanvs delete all
5148 catch {unset iddrawn}
5149 catch {unset linesegs}
5150 catch {unset linehtag}
5151 catch {unset linentag}
5152 catch {unset linedtag}
5153 set boldrows {}
5154 set boldnamerows {}
5155 catch {unset vhighlights}
5156 catch {unset fhighlights}
5157 catch {unset nhighlights}
5158 catch {unset rhighlights}
5159 set need_redisplay 0
5160 set nrows_drawn 0
5163 proc findcrossings {id} {
5164 global rowidlist parentlist numcommits displayorder
5166 set cross {}
5167 set ccross {}
5168 foreach {s e} [rowranges $id] {
5169 if {$e >= $numcommits} {
5170 set e [expr {$numcommits - 1}]
5172 if {$e <= $s} continue
5173 for {set row $e} {[incr row -1] >= $s} {} {
5174 set x [lsearch -exact [lindex $rowidlist $row] $id]
5175 if {$x < 0} break
5176 set olds [lindex $parentlist $row]
5177 set kid [lindex $displayorder $row]
5178 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5179 if {$kidx < 0} continue
5180 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5181 foreach p $olds {
5182 set px [lsearch -exact $nextrow $p]
5183 if {$px < 0} continue
5184 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5185 if {[lsearch -exact $ccross $p] >= 0} continue
5186 if {$x == $px + ($kidx < $px? -1: 1)} {
5187 lappend ccross $p
5188 } elseif {[lsearch -exact $cross $p] < 0} {
5189 lappend cross $p
5195 return [concat $ccross {{}} $cross]
5198 proc assigncolor {id} {
5199 global colormap colors nextcolor
5200 global parents children children curview
5202 if {[info exists colormap($id)]} return
5203 set ncolors [llength $colors]
5204 if {[info exists children($curview,$id)]} {
5205 set kids $children($curview,$id)
5206 } else {
5207 set kids {}
5209 if {[llength $kids] == 1} {
5210 set child [lindex $kids 0]
5211 if {[info exists colormap($child)]
5212 && [llength $parents($curview,$child)] == 1} {
5213 set colormap($id) $colormap($child)
5214 return
5217 set badcolors {}
5218 set origbad {}
5219 foreach x [findcrossings $id] {
5220 if {$x eq {}} {
5221 # delimiter between corner crossings and other crossings
5222 if {[llength $badcolors] >= $ncolors - 1} break
5223 set origbad $badcolors
5225 if {[info exists colormap($x)]
5226 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5227 lappend badcolors $colormap($x)
5230 if {[llength $badcolors] >= $ncolors} {
5231 set badcolors $origbad
5233 set origbad $badcolors
5234 if {[llength $badcolors] < $ncolors - 1} {
5235 foreach child $kids {
5236 if {[info exists colormap($child)]
5237 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5238 lappend badcolors $colormap($child)
5240 foreach p $parents($curview,$child) {
5241 if {[info exists colormap($p)]
5242 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5243 lappend badcolors $colormap($p)
5247 if {[llength $badcolors] >= $ncolors} {
5248 set badcolors $origbad
5251 for {set i 0} {$i <= $ncolors} {incr i} {
5252 set c [lindex $colors $nextcolor]
5253 if {[incr nextcolor] >= $ncolors} {
5254 set nextcolor 0
5256 if {[lsearch -exact $badcolors $c]} break
5258 set colormap($id) $c
5261 proc bindline {t id} {
5262 global canv
5264 $canv bind $t <Enter> "lineenter %x %y $id"
5265 $canv bind $t <Motion> "linemotion %x %y $id"
5266 $canv bind $t <Leave> "lineleave $id"
5267 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5270 proc drawtags {id x xt y1} {
5271 global idtags idheads idotherrefs mainhead
5272 global linespc lthickness
5273 global canv rowtextx curview fgcolor bgcolor
5275 set marks {}
5276 set ntags 0
5277 set nheads 0
5278 if {[info exists idtags($id)]} {
5279 set marks $idtags($id)
5280 set ntags [llength $marks]
5282 if {[info exists idheads($id)]} {
5283 set marks [concat $marks $idheads($id)]
5284 set nheads [llength $idheads($id)]
5286 if {[info exists idotherrefs($id)]} {
5287 set marks [concat $marks $idotherrefs($id)]
5289 if {$marks eq {}} {
5290 return $xt
5293 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5294 set yt [expr {$y1 - 0.5 * $linespc}]
5295 set yb [expr {$yt + $linespc - 1}]
5296 set xvals {}
5297 set wvals {}
5298 set i -1
5299 foreach tag $marks {
5300 incr i
5301 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5302 set wid [font measure mainfontbold $tag]
5303 } else {
5304 set wid [font measure mainfont $tag]
5306 lappend xvals $xt
5307 lappend wvals $wid
5308 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5310 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5311 -width $lthickness -fill black -tags tag.$id]
5312 $canv lower $t
5313 foreach tag $marks x $xvals wid $wvals {
5314 set xl [expr {$x + $delta}]
5315 set xr [expr {$x + $delta + $wid + $lthickness}]
5316 set font mainfont
5317 if {[incr ntags -1] >= 0} {
5318 # draw a tag
5319 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5320 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5321 -width 1 -outline black -fill yellow -tags tag.$id]
5322 $canv bind $t <1> [list showtag $tag 1]
5323 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5324 } else {
5325 # draw a head or other ref
5326 if {[incr nheads -1] >= 0} {
5327 set col green
5328 if {$tag eq $mainhead} {
5329 set font mainfontbold
5331 } else {
5332 set col "#ddddff"
5334 set xl [expr {$xl - $delta/2}]
5335 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5336 -width 1 -outline black -fill $col -tags tag.$id
5337 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5338 set rwid [font measure mainfont $remoteprefix]
5339 set xi [expr {$x + 1}]
5340 set yti [expr {$yt + 1}]
5341 set xri [expr {$x + $rwid}]
5342 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5343 -width 0 -fill "#ffddaa" -tags tag.$id
5346 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5347 -font $font -tags [list tag.$id text]]
5348 if {$ntags >= 0} {
5349 $canv bind $t <1> [list showtag $tag 1]
5350 } elseif {$nheads >= 0} {
5351 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5354 return $xt
5357 proc xcoord {i level ln} {
5358 global canvx0 xspc1 xspc2
5360 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5361 if {$i > 0 && $i == $level} {
5362 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5363 } elseif {$i > $level} {
5364 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5366 return $x
5369 proc show_status {msg} {
5370 global canv fgcolor
5372 clear_display
5373 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5374 -tags text -fill $fgcolor
5377 # Don't change the text pane cursor if it is currently the hand cursor,
5378 # showing that we are over a sha1 ID link.
5379 proc settextcursor {c} {
5380 global ctext curtextcursor
5382 if {[$ctext cget -cursor] == $curtextcursor} {
5383 $ctext config -cursor $c
5385 set curtextcursor $c
5388 proc nowbusy {what {name {}}} {
5389 global isbusy busyname statusw
5391 if {[array names isbusy] eq {}} {
5392 . config -cursor watch
5393 settextcursor watch
5395 set isbusy($what) 1
5396 set busyname($what) $name
5397 if {$name ne {}} {
5398 $statusw conf -text $name
5402 proc notbusy {what} {
5403 global isbusy maincursor textcursor busyname statusw
5405 catch {
5406 unset isbusy($what)
5407 if {$busyname($what) ne {} &&
5408 [$statusw cget -text] eq $busyname($what)} {
5409 $statusw conf -text {}
5412 if {[array names isbusy] eq {}} {
5413 . config -cursor $maincursor
5414 settextcursor $textcursor
5418 proc findmatches {f} {
5419 global findtype findstring
5420 if {$findtype == [mc "Regexp"]} {
5421 set matches [regexp -indices -all -inline $findstring $f]
5422 } else {
5423 set fs $findstring
5424 if {$findtype == [mc "IgnCase"]} {
5425 set f [string tolower $f]
5426 set fs [string tolower $fs]
5428 set matches {}
5429 set i 0
5430 set l [string length $fs]
5431 while {[set j [string first $fs $f $i]] >= 0} {
5432 lappend matches [list $j [expr {$j+$l-1}]]
5433 set i [expr {$j + $l}]
5436 return $matches
5439 proc dofind {{dirn 1} {wrap 1}} {
5440 global findstring findstartline findcurline selectedline numcommits
5441 global gdttype filehighlight fh_serial find_dirn findallowwrap
5443 if {[info exists find_dirn]} {
5444 if {$find_dirn == $dirn} return
5445 stopfinding
5447 focus .
5448 if {$findstring eq {} || $numcommits == 0} return
5449 if {$selectedline eq {}} {
5450 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5451 } else {
5452 set findstartline $selectedline
5454 set findcurline $findstartline
5455 nowbusy finding [mc "Searching"]
5456 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5457 after cancel do_file_hl $fh_serial
5458 do_file_hl $fh_serial
5460 set find_dirn $dirn
5461 set findallowwrap $wrap
5462 run findmore
5465 proc stopfinding {} {
5466 global find_dirn findcurline fprogcoord
5468 if {[info exists find_dirn]} {
5469 unset find_dirn
5470 unset findcurline
5471 notbusy finding
5472 set fprogcoord 0
5473 adjustprogress
5477 proc findmore {} {
5478 global commitdata commitinfo numcommits findpattern findloc
5479 global findstartline findcurline findallowwrap
5480 global find_dirn gdttype fhighlights fprogcoord
5481 global curview varcorder vrownum varccommits vrowmod
5483 if {![info exists find_dirn]} {
5484 return 0
5486 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5487 set l $findcurline
5488 set moretodo 0
5489 if {$find_dirn > 0} {
5490 incr l
5491 if {$l >= $numcommits} {
5492 set l 0
5494 if {$l <= $findstartline} {
5495 set lim [expr {$findstartline + 1}]
5496 } else {
5497 set lim $numcommits
5498 set moretodo $findallowwrap
5500 } else {
5501 if {$l == 0} {
5502 set l $numcommits
5504 incr l -1
5505 if {$l >= $findstartline} {
5506 set lim [expr {$findstartline - 1}]
5507 } else {
5508 set lim -1
5509 set moretodo $findallowwrap
5512 set n [expr {($lim - $l) * $find_dirn}]
5513 if {$n > 500} {
5514 set n 500
5515 set moretodo 1
5517 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5518 update_arcrows $curview
5520 set found 0
5521 set domore 1
5522 set ai [bsearch $vrownum($curview) $l]
5523 set a [lindex $varcorder($curview) $ai]
5524 set arow [lindex $vrownum($curview) $ai]
5525 set ids [lindex $varccommits($curview,$a)]
5526 set arowend [expr {$arow + [llength $ids]}]
5527 if {$gdttype eq [mc "containing:"]} {
5528 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5529 if {$l < $arow || $l >= $arowend} {
5530 incr ai $find_dirn
5531 set a [lindex $varcorder($curview) $ai]
5532 set arow [lindex $vrownum($curview) $ai]
5533 set ids [lindex $varccommits($curview,$a)]
5534 set arowend [expr {$arow + [llength $ids]}]
5536 set id [lindex $ids [expr {$l - $arow}]]
5537 # shouldn't happen unless git log doesn't give all the commits...
5538 if {![info exists commitdata($id)] ||
5539 ![doesmatch $commitdata($id)]} {
5540 continue
5542 if {![info exists commitinfo($id)]} {
5543 getcommit $id
5545 set info $commitinfo($id)
5546 foreach f $info ty $fldtypes {
5547 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5548 [doesmatch $f]} {
5549 set found 1
5550 break
5553 if {$found} break
5555 } else {
5556 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5557 if {$l < $arow || $l >= $arowend} {
5558 incr ai $find_dirn
5559 set a [lindex $varcorder($curview) $ai]
5560 set arow [lindex $vrownum($curview) $ai]
5561 set ids [lindex $varccommits($curview,$a)]
5562 set arowend [expr {$arow + [llength $ids]}]
5564 set id [lindex $ids [expr {$l - $arow}]]
5565 if {![info exists fhighlights($id)]} {
5566 # this sets fhighlights($id) to -1
5567 askfilehighlight $l $id
5569 if {$fhighlights($id) > 0} {
5570 set found $domore
5571 break
5573 if {$fhighlights($id) < 0} {
5574 if {$domore} {
5575 set domore 0
5576 set findcurline [expr {$l - $find_dirn}]
5581 if {$found || ($domore && !$moretodo)} {
5582 unset findcurline
5583 unset find_dirn
5584 notbusy finding
5585 set fprogcoord 0
5586 adjustprogress
5587 if {$found} {
5588 findselectline $l
5589 } else {
5590 bell
5592 return 0
5594 if {!$domore} {
5595 flushhighlights
5596 } else {
5597 set findcurline [expr {$l - $find_dirn}]
5599 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5600 if {$n < 0} {
5601 incr n $numcommits
5603 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5604 adjustprogress
5605 return $domore
5608 proc findselectline {l} {
5609 global findloc commentend ctext findcurline markingmatches gdttype
5611 set markingmatches 1
5612 set findcurline $l
5613 selectline $l 1
5614 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5615 # highlight the matches in the comments
5616 set f [$ctext get 1.0 $commentend]
5617 set matches [findmatches $f]
5618 foreach match $matches {
5619 set start [lindex $match 0]
5620 set end [expr {[lindex $match 1] + 1}]
5621 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5624 drawvisible
5627 # mark the bits of a headline or author that match a find string
5628 proc markmatches {canv l str tag matches font row} {
5629 global selectedline
5631 set bbox [$canv bbox $tag]
5632 set x0 [lindex $bbox 0]
5633 set y0 [lindex $bbox 1]
5634 set y1 [lindex $bbox 3]
5635 foreach match $matches {
5636 set start [lindex $match 0]
5637 set end [lindex $match 1]
5638 if {$start > $end} continue
5639 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5640 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5641 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5642 [expr {$x0+$xlen+2}] $y1 \
5643 -outline {} -tags [list match$l matches] -fill yellow]
5644 $canv lower $t
5645 if {$row == $selectedline} {
5646 $canv raise $t secsel
5651 proc unmarkmatches {} {
5652 global markingmatches
5654 allcanvs delete matches
5655 set markingmatches 0
5656 stopfinding
5659 proc selcanvline {w x y} {
5660 global canv canvy0 ctext linespc
5661 global rowtextx
5662 set ymax [lindex [$canv cget -scrollregion] 3]
5663 if {$ymax == {}} return
5664 set yfrac [lindex [$canv yview] 0]
5665 set y [expr {$y + $yfrac * $ymax}]
5666 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5667 if {$l < 0} {
5668 set l 0
5670 if {$w eq $canv} {
5671 set xmax [lindex [$canv cget -scrollregion] 2]
5672 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5673 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5675 unmarkmatches
5676 selectline $l 1
5679 proc commit_descriptor {p} {
5680 global commitinfo
5681 if {![info exists commitinfo($p)]} {
5682 getcommit $p
5684 set l "..."
5685 if {[llength $commitinfo($p)] > 1} {
5686 set l [lindex $commitinfo($p) 0]
5688 return "$p ($l)\n"
5691 # append some text to the ctext widget, and make any SHA1 ID
5692 # that we know about be a clickable link.
5693 proc appendwithlinks {text tags} {
5694 global ctext linknum curview pendinglinks
5696 set start [$ctext index "end - 1c"]
5697 $ctext insert end $text $tags
5698 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5699 foreach l $links {
5700 set s [lindex $l 0]
5701 set e [lindex $l 1]
5702 set linkid [string range $text $s $e]
5703 incr e
5704 $ctext tag delete link$linknum
5705 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5706 setlink $linkid link$linknum
5707 incr linknum
5711 proc setlink {id lk} {
5712 global curview ctext pendinglinks commitinterest
5714 if {[commitinview $id $curview]} {
5715 $ctext tag conf $lk -foreground blue -underline 1
5716 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5717 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5718 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5719 } else {
5720 lappend pendinglinks($id) $lk
5721 lappend commitinterest($id) {makelink %I}
5725 proc makelink {id} {
5726 global pendinglinks
5728 if {![info exists pendinglinks($id)]} return
5729 foreach lk $pendinglinks($id) {
5730 setlink $id $lk
5732 unset pendinglinks($id)
5735 proc linkcursor {w inc} {
5736 global linkentercount curtextcursor
5738 if {[incr linkentercount $inc] > 0} {
5739 $w configure -cursor hand2
5740 } else {
5741 $w configure -cursor $curtextcursor
5742 if {$linkentercount < 0} {
5743 set linkentercount 0
5748 proc viewnextline {dir} {
5749 global canv linespc
5751 $canv delete hover
5752 set ymax [lindex [$canv cget -scrollregion] 3]
5753 set wnow [$canv yview]
5754 set wtop [expr {[lindex $wnow 0] * $ymax}]
5755 set newtop [expr {$wtop + $dir * $linespc}]
5756 if {$newtop < 0} {
5757 set newtop 0
5758 } elseif {$newtop > $ymax} {
5759 set newtop $ymax
5761 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5764 # add a list of tag or branch names at position pos
5765 # returns the number of names inserted
5766 proc appendrefs {pos ids var} {
5767 global ctext linknum curview $var maxrefs
5769 if {[catch {$ctext index $pos}]} {
5770 return 0
5772 $ctext conf -state normal
5773 $ctext delete $pos "$pos lineend"
5774 set tags {}
5775 foreach id $ids {
5776 foreach tag [set $var\($id\)] {
5777 lappend tags [list $tag $id]
5780 if {[llength $tags] > $maxrefs} {
5781 $ctext insert $pos "many ([llength $tags])"
5782 } else {
5783 set tags [lsort -index 0 -decreasing $tags]
5784 set sep {}
5785 foreach ti $tags {
5786 set id [lindex $ti 1]
5787 set lk link$linknum
5788 incr linknum
5789 $ctext tag delete $lk
5790 $ctext insert $pos $sep
5791 $ctext insert $pos [lindex $ti 0] $lk
5792 setlink $id $lk
5793 set sep ", "
5796 $ctext conf -state disabled
5797 return [llength $tags]
5800 # called when we have finished computing the nearby tags
5801 proc dispneartags {delay} {
5802 global selectedline currentid showneartags tagphase
5804 if {$selectedline eq {} || !$showneartags} return
5805 after cancel dispnexttag
5806 if {$delay} {
5807 after 200 dispnexttag
5808 set tagphase -1
5809 } else {
5810 after idle dispnexttag
5811 set tagphase 0
5815 proc dispnexttag {} {
5816 global selectedline currentid showneartags tagphase ctext
5818 if {$selectedline eq {} || !$showneartags} return
5819 switch -- $tagphase {
5821 set dtags [desctags $currentid]
5822 if {$dtags ne {}} {
5823 appendrefs precedes $dtags idtags
5827 set atags [anctags $currentid]
5828 if {$atags ne {}} {
5829 appendrefs follows $atags idtags
5833 set dheads [descheads $currentid]
5834 if {$dheads ne {}} {
5835 if {[appendrefs branch $dheads idheads] > 1
5836 && [$ctext get "branch -3c"] eq "h"} {
5837 # turn "Branch" into "Branches"
5838 $ctext conf -state normal
5839 $ctext insert "branch -2c" "es"
5840 $ctext conf -state disabled
5845 if {[incr tagphase] <= 2} {
5846 after idle dispnexttag
5850 proc make_secsel {l} {
5851 global linehtag linentag linedtag canv canv2 canv3
5853 if {![info exists linehtag($l)]} return
5854 $canv delete secsel
5855 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5856 -tags secsel -fill [$canv cget -selectbackground]]
5857 $canv lower $t
5858 $canv2 delete secsel
5859 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5860 -tags secsel -fill [$canv2 cget -selectbackground]]
5861 $canv2 lower $t
5862 $canv3 delete secsel
5863 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5864 -tags secsel -fill [$canv3 cget -selectbackground]]
5865 $canv3 lower $t
5868 proc selectline {l isnew} {
5869 global canv ctext commitinfo selectedline
5870 global canvy0 linespc parents children curview
5871 global currentid sha1entry
5872 global commentend idtags linknum
5873 global mergemax numcommits pending_select
5874 global cmitmode showneartags allcommits
5875 global targetrow targetid lastscrollrows
5876 global autoselect
5878 catch {unset pending_select}
5879 $canv delete hover
5880 normalline
5881 unsel_reflist
5882 stopfinding
5883 if {$l < 0 || $l >= $numcommits} return
5884 set id [commitonrow $l]
5885 set targetid $id
5886 set targetrow $l
5887 set selectedline $l
5888 set currentid $id
5889 if {$lastscrollrows < $numcommits} {
5890 setcanvscroll
5893 set y [expr {$canvy0 + $l * $linespc}]
5894 set ymax [lindex [$canv cget -scrollregion] 3]
5895 set ytop [expr {$y - $linespc - 1}]
5896 set ybot [expr {$y + $linespc + 1}]
5897 set wnow [$canv yview]
5898 set wtop [expr {[lindex $wnow 0] * $ymax}]
5899 set wbot [expr {[lindex $wnow 1] * $ymax}]
5900 set wh [expr {$wbot - $wtop}]
5901 set newtop $wtop
5902 if {$ytop < $wtop} {
5903 if {$ybot < $wtop} {
5904 set newtop [expr {$y - $wh / 2.0}]
5905 } else {
5906 set newtop $ytop
5907 if {$newtop > $wtop - $linespc} {
5908 set newtop [expr {$wtop - $linespc}]
5911 } elseif {$ybot > $wbot} {
5912 if {$ytop > $wbot} {
5913 set newtop [expr {$y - $wh / 2.0}]
5914 } else {
5915 set newtop [expr {$ybot - $wh}]
5916 if {$newtop < $wtop + $linespc} {
5917 set newtop [expr {$wtop + $linespc}]
5921 if {$newtop != $wtop} {
5922 if {$newtop < 0} {
5923 set newtop 0
5925 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5926 drawvisible
5929 make_secsel $l
5931 if {$isnew} {
5932 addtohistory [list selbyid $id]
5935 $sha1entry delete 0 end
5936 $sha1entry insert 0 $id
5937 if {$autoselect} {
5938 $sha1entry selection from 0
5939 $sha1entry selection to end
5941 rhighlight_sel $id
5943 $ctext conf -state normal
5944 clear_ctext
5945 set linknum 0
5946 if {![info exists commitinfo($id)]} {
5947 getcommit $id
5949 set info $commitinfo($id)
5950 set date [formatdate [lindex $info 2]]
5951 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5952 set date [formatdate [lindex $info 4]]
5953 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5954 if {[info exists idtags($id)]} {
5955 $ctext insert end [mc "Tags:"]
5956 foreach tag $idtags($id) {
5957 $ctext insert end " $tag"
5959 $ctext insert end "\n"
5962 set headers {}
5963 set olds $parents($curview,$id)
5964 if {[llength $olds] > 1} {
5965 set np 0
5966 foreach p $olds {
5967 if {$np >= $mergemax} {
5968 set tag mmax
5969 } else {
5970 set tag m$np
5972 $ctext insert end "[mc "Parent"]: " $tag
5973 appendwithlinks [commit_descriptor $p] {}
5974 incr np
5976 } else {
5977 foreach p $olds {
5978 append headers "[mc "Parent"]: [commit_descriptor $p]"
5982 foreach c $children($curview,$id) {
5983 append headers "[mc "Child"]: [commit_descriptor $c]"
5986 # make anything that looks like a SHA1 ID be a clickable link
5987 appendwithlinks $headers {}
5988 if {$showneartags} {
5989 if {![info exists allcommits]} {
5990 getallcommits
5992 $ctext insert end "[mc "Branch"]: "
5993 $ctext mark set branch "end -1c"
5994 $ctext mark gravity branch left
5995 $ctext insert end "\n[mc "Follows"]: "
5996 $ctext mark set follows "end -1c"
5997 $ctext mark gravity follows left
5998 $ctext insert end "\n[mc "Precedes"]: "
5999 $ctext mark set precedes "end -1c"
6000 $ctext mark gravity precedes left
6001 $ctext insert end "\n"
6002 dispneartags 1
6004 $ctext insert end "\n"
6005 set comment [lindex $info 5]
6006 if {[string first "\r" $comment] >= 0} {
6007 set comment [string map {"\r" "\n "} $comment]
6009 appendwithlinks $comment {comment}
6011 $ctext tag remove found 1.0 end
6012 $ctext conf -state disabled
6013 set commentend [$ctext index "end - 1c"]
6015 init_flist [mc "Comments"]
6016 if {$cmitmode eq "tree"} {
6017 gettree $id
6018 } elseif {[llength $olds] <= 1} {
6019 startdiff $id
6020 } else {
6021 mergediff $id
6025 proc selfirstline {} {
6026 unmarkmatches
6027 selectline 0 1
6030 proc sellastline {} {
6031 global numcommits
6032 unmarkmatches
6033 set l [expr {$numcommits - 1}]
6034 selectline $l 1
6037 proc selnextline {dir} {
6038 global selectedline
6039 focus .
6040 if {$selectedline eq {}} return
6041 set l [expr {$selectedline + $dir}]
6042 unmarkmatches
6043 selectline $l 1
6046 proc selnextpage {dir} {
6047 global canv linespc selectedline numcommits
6049 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6050 if {$lpp < 1} {
6051 set lpp 1
6053 allcanvs yview scroll [expr {$dir * $lpp}] units
6054 drawvisible
6055 if {$selectedline eq {}} return
6056 set l [expr {$selectedline + $dir * $lpp}]
6057 if {$l < 0} {
6058 set l 0
6059 } elseif {$l >= $numcommits} {
6060 set l [expr $numcommits - 1]
6062 unmarkmatches
6063 selectline $l 1
6066 proc unselectline {} {
6067 global selectedline currentid
6069 set selectedline {}
6070 catch {unset currentid}
6071 allcanvs delete secsel
6072 rhighlight_none
6075 proc reselectline {} {
6076 global selectedline
6078 if {$selectedline ne {}} {
6079 selectline $selectedline 0
6083 proc addtohistory {cmd} {
6084 global history historyindex curview
6086 set elt [list $curview $cmd]
6087 if {$historyindex > 0
6088 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6089 return
6092 if {$historyindex < [llength $history]} {
6093 set history [lreplace $history $historyindex end $elt]
6094 } else {
6095 lappend history $elt
6097 incr historyindex
6098 if {$historyindex > 1} {
6099 .tf.bar.leftbut conf -state normal
6100 } else {
6101 .tf.bar.leftbut conf -state disabled
6103 .tf.bar.rightbut conf -state disabled
6106 proc godo {elt} {
6107 global curview
6109 set view [lindex $elt 0]
6110 set cmd [lindex $elt 1]
6111 if {$curview != $view} {
6112 showview $view
6114 eval $cmd
6117 proc goback {} {
6118 global history historyindex
6119 focus .
6121 if {$historyindex > 1} {
6122 incr historyindex -1
6123 godo [lindex $history [expr {$historyindex - 1}]]
6124 .tf.bar.rightbut conf -state normal
6126 if {$historyindex <= 1} {
6127 .tf.bar.leftbut conf -state disabled
6131 proc goforw {} {
6132 global history historyindex
6133 focus .
6135 if {$historyindex < [llength $history]} {
6136 set cmd [lindex $history $historyindex]
6137 incr historyindex
6138 godo $cmd
6139 .tf.bar.leftbut conf -state normal
6141 if {$historyindex >= [llength $history]} {
6142 .tf.bar.rightbut conf -state disabled
6146 proc gettree {id} {
6147 global treefilelist treeidlist diffids diffmergeid treepending
6148 global nullid nullid2
6150 set diffids $id
6151 catch {unset diffmergeid}
6152 if {![info exists treefilelist($id)]} {
6153 if {![info exists treepending]} {
6154 if {$id eq $nullid} {
6155 set cmd [list | git ls-files]
6156 } elseif {$id eq $nullid2} {
6157 set cmd [list | git ls-files --stage -t]
6158 } else {
6159 set cmd [list | git ls-tree -r $id]
6161 if {[catch {set gtf [open $cmd r]}]} {
6162 return
6164 set treepending $id
6165 set treefilelist($id) {}
6166 set treeidlist($id) {}
6167 fconfigure $gtf -blocking 0
6168 filerun $gtf [list gettreeline $gtf $id]
6170 } else {
6171 setfilelist $id
6175 proc gettreeline {gtf id} {
6176 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6178 set nl 0
6179 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6180 if {$diffids eq $nullid} {
6181 set fname $line
6182 } else {
6183 set i [string first "\t" $line]
6184 if {$i < 0} continue
6185 set fname [string range $line [expr {$i+1}] end]
6186 set line [string range $line 0 [expr {$i-1}]]
6187 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6188 set sha1 [lindex $line 2]
6189 if {[string index $fname 0] eq "\""} {
6190 set fname [lindex $fname 0]
6192 lappend treeidlist($id) $sha1
6194 lappend treefilelist($id) $fname
6196 if {![eof $gtf]} {
6197 return [expr {$nl >= 1000? 2: 1}]
6199 close $gtf
6200 unset treepending
6201 if {$cmitmode ne "tree"} {
6202 if {![info exists diffmergeid]} {
6203 gettreediffs $diffids
6205 } elseif {$id ne $diffids} {
6206 gettree $diffids
6207 } else {
6208 setfilelist $id
6210 return 0
6213 proc showfile {f} {
6214 global treefilelist treeidlist diffids nullid nullid2
6215 global ctext commentend
6217 set i [lsearch -exact $treefilelist($diffids) $f]
6218 if {$i < 0} {
6219 puts "oops, $f not in list for id $diffids"
6220 return
6222 if {$diffids eq $nullid} {
6223 if {[catch {set bf [open $f r]} err]} {
6224 puts "oops, can't read $f: $err"
6225 return
6227 } else {
6228 set blob [lindex $treeidlist($diffids) $i]
6229 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6230 puts "oops, error reading blob $blob: $err"
6231 return
6234 fconfigure $bf -blocking 0
6235 filerun $bf [list getblobline $bf $diffids]
6236 $ctext config -state normal
6237 clear_ctext $commentend
6238 $ctext insert end "\n"
6239 $ctext insert end "$f\n" filesep
6240 $ctext config -state disabled
6241 $ctext yview $commentend
6242 settabs 0
6245 proc getblobline {bf id} {
6246 global diffids cmitmode ctext
6248 if {$id ne $diffids || $cmitmode ne "tree"} {
6249 catch {close $bf}
6250 return 0
6252 $ctext config -state normal
6253 set nl 0
6254 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6255 $ctext insert end "$line\n"
6257 if {[eof $bf]} {
6258 # delete last newline
6259 $ctext delete "end - 2c" "end - 1c"
6260 close $bf
6261 return 0
6263 $ctext config -state disabled
6264 return [expr {$nl >= 1000? 2: 1}]
6267 proc mergediff {id} {
6268 global diffmergeid mdifffd
6269 global diffids
6270 global parents
6271 global diffcontext
6272 global limitdiffs vfilelimit curview
6274 set diffmergeid $id
6275 set diffids $id
6276 # this doesn't seem to actually affect anything...
6277 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6278 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6279 set cmd [concat $cmd -- $vfilelimit($curview)]
6281 if {[catch {set mdf [open $cmd r]} err]} {
6282 error_popup "[mc "Error getting merge diffs:"] $err"
6283 return
6285 fconfigure $mdf -blocking 0
6286 set mdifffd($id) $mdf
6287 set np [llength $parents($curview,$id)]
6288 settabs $np
6289 filerun $mdf [list getmergediffline $mdf $id $np]
6292 proc getmergediffline {mdf id np} {
6293 global diffmergeid ctext cflist mergemax
6294 global difffilestart mdifffd
6296 $ctext conf -state normal
6297 set nr 0
6298 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6299 if {![info exists diffmergeid] || $id != $diffmergeid
6300 || $mdf != $mdifffd($id)} {
6301 close $mdf
6302 return 0
6304 if {[regexp {^diff --cc (.*)} $line match fname]} {
6305 # start of a new file
6306 $ctext insert end "\n"
6307 set here [$ctext index "end - 1c"]
6308 lappend difffilestart $here
6309 add_flist [list $fname]
6310 set l [expr {(78 - [string length $fname]) / 2}]
6311 set pad [string range "----------------------------------------" 1 $l]
6312 $ctext insert end "$pad $fname $pad\n" filesep
6313 } elseif {[regexp {^@@} $line]} {
6314 $ctext insert end "$line\n" hunksep
6315 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6316 # do nothing
6317 } else {
6318 # parse the prefix - one ' ', '-' or '+' for each parent
6319 set spaces {}
6320 set minuses {}
6321 set pluses {}
6322 set isbad 0
6323 for {set j 0} {$j < $np} {incr j} {
6324 set c [string range $line $j $j]
6325 if {$c == " "} {
6326 lappend spaces $j
6327 } elseif {$c == "-"} {
6328 lappend minuses $j
6329 } elseif {$c == "+"} {
6330 lappend pluses $j
6331 } else {
6332 set isbad 1
6333 break
6336 set tags {}
6337 set num {}
6338 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6339 # line doesn't appear in result, parents in $minuses have the line
6340 set num [lindex $minuses 0]
6341 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6342 # line appears in result, parents in $pluses don't have the line
6343 lappend tags mresult
6344 set num [lindex $spaces 0]
6346 if {$num ne {}} {
6347 if {$num >= $mergemax} {
6348 set num "max"
6350 lappend tags m$num
6352 $ctext insert end "$line\n" $tags
6355 $ctext conf -state disabled
6356 if {[eof $mdf]} {
6357 close $mdf
6358 return 0
6360 return [expr {$nr >= 1000? 2: 1}]
6363 proc startdiff {ids} {
6364 global treediffs diffids treepending diffmergeid nullid nullid2
6366 settabs 1
6367 set diffids $ids
6368 catch {unset diffmergeid}
6369 if {![info exists treediffs($ids)] ||
6370 [lsearch -exact $ids $nullid] >= 0 ||
6371 [lsearch -exact $ids $nullid2] >= 0} {
6372 if {![info exists treepending]} {
6373 gettreediffs $ids
6375 } else {
6376 addtocflist $ids
6380 proc path_filter {filter name} {
6381 foreach p $filter {
6382 set l [string length $p]
6383 if {[string index $p end] eq "/"} {
6384 if {[string compare -length $l $p $name] == 0} {
6385 return 1
6387 } else {
6388 if {[string compare -length $l $p $name] == 0 &&
6389 ([string length $name] == $l ||
6390 [string index $name $l] eq "/")} {
6391 return 1
6395 return 0
6398 proc addtocflist {ids} {
6399 global treediffs
6401 add_flist $treediffs($ids)
6402 getblobdiffs $ids
6405 proc diffcmd {ids flags} {
6406 global nullid nullid2
6408 set i [lsearch -exact $ids $nullid]
6409 set j [lsearch -exact $ids $nullid2]
6410 if {$i >= 0} {
6411 if {[llength $ids] > 1 && $j < 0} {
6412 # comparing working directory with some specific revision
6413 set cmd [concat | git diff-index $flags]
6414 if {$i == 0} {
6415 lappend cmd -R [lindex $ids 1]
6416 } else {
6417 lappend cmd [lindex $ids 0]
6419 } else {
6420 # comparing working directory with index
6421 set cmd [concat | git diff-files $flags]
6422 if {$j == 1} {
6423 lappend cmd -R
6426 } elseif {$j >= 0} {
6427 set cmd [concat | git diff-index --cached $flags]
6428 if {[llength $ids] > 1} {
6429 # comparing index with specific revision
6430 if {$i == 0} {
6431 lappend cmd -R [lindex $ids 1]
6432 } else {
6433 lappend cmd [lindex $ids 0]
6435 } else {
6436 # comparing index with HEAD
6437 lappend cmd HEAD
6439 } else {
6440 set cmd [concat | git diff-tree -r $flags $ids]
6442 return $cmd
6445 proc gettreediffs {ids} {
6446 global treediff treepending
6448 set treepending $ids
6449 set treediff {}
6450 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6451 fconfigure $gdtf -blocking 0
6452 filerun $gdtf [list gettreediffline $gdtf $ids]
6455 proc gettreediffline {gdtf ids} {
6456 global treediff treediffs treepending diffids diffmergeid
6457 global cmitmode vfilelimit curview limitdiffs
6459 set nr 0
6460 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6461 set i [string first "\t" $line]
6462 if {$i >= 0} {
6463 set file [string range $line [expr {$i+1}] end]
6464 if {[string index $file 0] eq "\""} {
6465 set file [lindex $file 0]
6467 lappend treediff $file
6470 if {![eof $gdtf]} {
6471 return [expr {$nr >= 1000? 2: 1}]
6473 close $gdtf
6474 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6475 set flist {}
6476 foreach f $treediff {
6477 if {[path_filter $vfilelimit($curview) $f]} {
6478 lappend flist $f
6481 set treediffs($ids) $flist
6482 } else {
6483 set treediffs($ids) $treediff
6485 unset treepending
6486 if {$cmitmode eq "tree"} {
6487 gettree $diffids
6488 } elseif {$ids != $diffids} {
6489 if {![info exists diffmergeid]} {
6490 gettreediffs $diffids
6492 } else {
6493 addtocflist $ids
6495 return 0
6498 # empty string or positive integer
6499 proc diffcontextvalidate {v} {
6500 return [regexp {^(|[1-9][0-9]*)$} $v]
6503 proc diffcontextchange {n1 n2 op} {
6504 global diffcontextstring diffcontext
6506 if {[string is integer -strict $diffcontextstring]} {
6507 if {$diffcontextstring > 0} {
6508 set diffcontext $diffcontextstring
6509 reselectline
6514 proc changeignorespace {} {
6515 reselectline
6518 proc getblobdiffs {ids} {
6519 global blobdifffd diffids env
6520 global diffinhdr treediffs
6521 global diffcontext
6522 global ignorespace
6523 global limitdiffs vfilelimit curview
6525 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6526 if {$ignorespace} {
6527 append cmd " -w"
6529 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6530 set cmd [concat $cmd -- $vfilelimit($curview)]
6532 if {[catch {set bdf [open $cmd r]} err]} {
6533 puts "error getting diffs: $err"
6534 return
6536 set diffinhdr 0
6537 fconfigure $bdf -blocking 0
6538 set blobdifffd($ids) $bdf
6539 filerun $bdf [list getblobdiffline $bdf $diffids]
6542 proc setinlist {var i val} {
6543 global $var
6545 while {[llength [set $var]] < $i} {
6546 lappend $var {}
6548 if {[llength [set $var]] == $i} {
6549 lappend $var $val
6550 } else {
6551 lset $var $i $val
6555 proc makediffhdr {fname ids} {
6556 global ctext curdiffstart treediffs
6558 set i [lsearch -exact $treediffs($ids) $fname]
6559 if {$i >= 0} {
6560 setinlist difffilestart $i $curdiffstart
6562 set l [expr {(78 - [string length $fname]) / 2}]
6563 set pad [string range "----------------------------------------" 1 $l]
6564 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6567 proc getblobdiffline {bdf ids} {
6568 global diffids blobdifffd ctext curdiffstart
6569 global diffnexthead diffnextnote difffilestart
6570 global diffinhdr treediffs
6572 set nr 0
6573 $ctext conf -state normal
6574 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6575 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6576 close $bdf
6577 return 0
6579 if {![string compare -length 11 "diff --git " $line]} {
6580 # trim off "diff --git "
6581 set line [string range $line 11 end]
6582 set diffinhdr 1
6583 # start of a new file
6584 $ctext insert end "\n"
6585 set curdiffstart [$ctext index "end - 1c"]
6586 $ctext insert end "\n" filesep
6587 # If the name hasn't changed the length will be odd,
6588 # the middle char will be a space, and the two bits either
6589 # side will be a/name and b/name, or "a/name" and "b/name".
6590 # If the name has changed we'll get "rename from" and
6591 # "rename to" or "copy from" and "copy to" lines following this,
6592 # and we'll use them to get the filenames.
6593 # This complexity is necessary because spaces in the filename(s)
6594 # don't get escaped.
6595 set l [string length $line]
6596 set i [expr {$l / 2}]
6597 if {!(($l & 1) && [string index $line $i] eq " " &&
6598 [string range $line 2 [expr {$i - 1}]] eq \
6599 [string range $line [expr {$i + 3}] end])} {
6600 continue
6602 # unescape if quoted and chop off the a/ from the front
6603 if {[string index $line 0] eq "\""} {
6604 set fname [string range [lindex $line 0] 2 end]
6605 } else {
6606 set fname [string range $line 2 [expr {$i - 1}]]
6608 makediffhdr $fname $ids
6610 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6611 $line match f1l f1c f2l f2c rest]} {
6612 $ctext insert end "$line\n" hunksep
6613 set diffinhdr 0
6615 } elseif {$diffinhdr} {
6616 if {![string compare -length 12 "rename from " $line]} {
6617 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6618 if {[string index $fname 0] eq "\""} {
6619 set fname [lindex $fname 0]
6621 set i [lsearch -exact $treediffs($ids) $fname]
6622 if {$i >= 0} {
6623 setinlist difffilestart $i $curdiffstart
6625 } elseif {![string compare -length 10 $line "rename to "] ||
6626 ![string compare -length 8 $line "copy to "]} {
6627 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6628 if {[string index $fname 0] eq "\""} {
6629 set fname [lindex $fname 0]
6631 makediffhdr $fname $ids
6632 } elseif {[string compare -length 3 $line "---"] == 0} {
6633 # do nothing
6634 continue
6635 } elseif {[string compare -length 3 $line "+++"] == 0} {
6636 set diffinhdr 0
6637 continue
6639 $ctext insert end "$line\n" filesep
6641 } else {
6642 set x [string range $line 0 0]
6643 if {$x == "-" || $x == "+"} {
6644 set tag [expr {$x == "+"}]
6645 $ctext insert end "$line\n" d$tag
6646 } elseif {$x == " "} {
6647 $ctext insert end "$line\n"
6648 } else {
6649 # "\ No newline at end of file",
6650 # or something else we don't recognize
6651 $ctext insert end "$line\n" hunksep
6655 $ctext conf -state disabled
6656 if {[eof $bdf]} {
6657 close $bdf
6658 return 0
6660 return [expr {$nr >= 1000? 2: 1}]
6663 proc changediffdisp {} {
6664 global ctext diffelide
6666 $ctext tag conf d0 -elide [lindex $diffelide 0]
6667 $ctext tag conf d1 -elide [lindex $diffelide 1]
6670 proc highlightfile {loc cline} {
6671 global ctext cflist cflist_top
6673 $ctext yview $loc
6674 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6675 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6676 $cflist see $cline.0
6677 set cflist_top $cline
6680 proc prevfile {} {
6681 global difffilestart ctext cmitmode
6683 if {$cmitmode eq "tree"} return
6684 set prev 0.0
6685 set prevline 1
6686 set here [$ctext index @0,0]
6687 foreach loc $difffilestart {
6688 if {[$ctext compare $loc >= $here]} {
6689 highlightfile $prev $prevline
6690 return
6692 set prev $loc
6693 incr prevline
6695 highlightfile $prev $prevline
6698 proc nextfile {} {
6699 global difffilestart ctext cmitmode
6701 if {$cmitmode eq "tree"} return
6702 set here [$ctext index @0,0]
6703 set line 1
6704 foreach loc $difffilestart {
6705 incr line
6706 if {[$ctext compare $loc > $here]} {
6707 highlightfile $loc $line
6708 return
6713 proc clear_ctext {{first 1.0}} {
6714 global ctext smarktop smarkbot
6715 global pendinglinks
6717 set l [lindex [split $first .] 0]
6718 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6719 set smarktop $l
6721 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6722 set smarkbot $l
6724 $ctext delete $first end
6725 if {$first eq "1.0"} {
6726 catch {unset pendinglinks}
6730 proc settabs {{firstab {}}} {
6731 global firsttabstop tabstop ctext have_tk85
6733 if {$firstab ne {} && $have_tk85} {
6734 set firsttabstop $firstab
6736 set w [font measure textfont "0"]
6737 if {$firsttabstop != 0} {
6738 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6739 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6740 } elseif {$have_tk85 || $tabstop != 8} {
6741 $ctext conf -tabs [expr {$tabstop * $w}]
6742 } else {
6743 $ctext conf -tabs {}
6747 proc incrsearch {name ix op} {
6748 global ctext searchstring searchdirn
6750 $ctext tag remove found 1.0 end
6751 if {[catch {$ctext index anchor}]} {
6752 # no anchor set, use start of selection, or of visible area
6753 set sel [$ctext tag ranges sel]
6754 if {$sel ne {}} {
6755 $ctext mark set anchor [lindex $sel 0]
6756 } elseif {$searchdirn eq "-forwards"} {
6757 $ctext mark set anchor @0,0
6758 } else {
6759 $ctext mark set anchor @0,[winfo height $ctext]
6762 if {$searchstring ne {}} {
6763 set here [$ctext search $searchdirn -- $searchstring anchor]
6764 if {$here ne {}} {
6765 $ctext see $here
6767 searchmarkvisible 1
6771 proc dosearch {} {
6772 global sstring ctext searchstring searchdirn
6774 focus $sstring
6775 $sstring icursor end
6776 set searchdirn -forwards
6777 if {$searchstring ne {}} {
6778 set sel [$ctext tag ranges sel]
6779 if {$sel ne {}} {
6780 set start "[lindex $sel 0] + 1c"
6781 } elseif {[catch {set start [$ctext index anchor]}]} {
6782 set start "@0,0"
6784 set match [$ctext search -count mlen -- $searchstring $start]
6785 $ctext tag remove sel 1.0 end
6786 if {$match eq {}} {
6787 bell
6788 return
6790 $ctext see $match
6791 set mend "$match + $mlen c"
6792 $ctext tag add sel $match $mend
6793 $ctext mark unset anchor
6797 proc dosearchback {} {
6798 global sstring ctext searchstring searchdirn
6800 focus $sstring
6801 $sstring icursor end
6802 set searchdirn -backwards
6803 if {$searchstring ne {}} {
6804 set sel [$ctext tag ranges sel]
6805 if {$sel ne {}} {
6806 set start [lindex $sel 0]
6807 } elseif {[catch {set start [$ctext index anchor]}]} {
6808 set start @0,[winfo height $ctext]
6810 set match [$ctext search -backwards -count ml -- $searchstring $start]
6811 $ctext tag remove sel 1.0 end
6812 if {$match eq {}} {
6813 bell
6814 return
6816 $ctext see $match
6817 set mend "$match + $ml c"
6818 $ctext tag add sel $match $mend
6819 $ctext mark unset anchor
6823 proc searchmark {first last} {
6824 global ctext searchstring
6826 set mend $first.0
6827 while {1} {
6828 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6829 if {$match eq {}} break
6830 set mend "$match + $mlen c"
6831 $ctext tag add found $match $mend
6835 proc searchmarkvisible {doall} {
6836 global ctext smarktop smarkbot
6838 set topline [lindex [split [$ctext index @0,0] .] 0]
6839 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6840 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6841 # no overlap with previous
6842 searchmark $topline $botline
6843 set smarktop $topline
6844 set smarkbot $botline
6845 } else {
6846 if {$topline < $smarktop} {
6847 searchmark $topline [expr {$smarktop-1}]
6848 set smarktop $topline
6850 if {$botline > $smarkbot} {
6851 searchmark [expr {$smarkbot+1}] $botline
6852 set smarkbot $botline
6857 proc scrolltext {f0 f1} {
6858 global searchstring
6860 .bleft.bottom.sb set $f0 $f1
6861 if {$searchstring ne {}} {
6862 searchmarkvisible 0
6866 proc setcoords {} {
6867 global linespc charspc canvx0 canvy0
6868 global xspc1 xspc2 lthickness
6870 set linespc [font metrics mainfont -linespace]
6871 set charspc [font measure mainfont "m"]
6872 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6873 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6874 set lthickness [expr {int($linespc / 9) + 1}]
6875 set xspc1(0) $linespc
6876 set xspc2 $linespc
6879 proc redisplay {} {
6880 global canv
6881 global selectedline
6883 set ymax [lindex [$canv cget -scrollregion] 3]
6884 if {$ymax eq {} || $ymax == 0} return
6885 set span [$canv yview]
6886 clear_display
6887 setcanvscroll
6888 allcanvs yview moveto [lindex $span 0]
6889 drawvisible
6890 if {$selectedline ne {}} {
6891 selectline $selectedline 0
6892 allcanvs yview moveto [lindex $span 0]
6896 proc parsefont {f n} {
6897 global fontattr
6899 set fontattr($f,family) [lindex $n 0]
6900 set s [lindex $n 1]
6901 if {$s eq {} || $s == 0} {
6902 set s 10
6903 } elseif {$s < 0} {
6904 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6906 set fontattr($f,size) $s
6907 set fontattr($f,weight) normal
6908 set fontattr($f,slant) roman
6909 foreach style [lrange $n 2 end] {
6910 switch -- $style {
6911 "normal" -
6912 "bold" {set fontattr($f,weight) $style}
6913 "roman" -
6914 "italic" {set fontattr($f,slant) $style}
6919 proc fontflags {f {isbold 0}} {
6920 global fontattr
6922 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6923 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6924 -slant $fontattr($f,slant)]
6927 proc fontname {f} {
6928 global fontattr
6930 set n [list $fontattr($f,family) $fontattr($f,size)]
6931 if {$fontattr($f,weight) eq "bold"} {
6932 lappend n "bold"
6934 if {$fontattr($f,slant) eq "italic"} {
6935 lappend n "italic"
6937 return $n
6940 proc incrfont {inc} {
6941 global mainfont textfont ctext canv cflist showrefstop
6942 global stopped entries fontattr
6944 unmarkmatches
6945 set s $fontattr(mainfont,size)
6946 incr s $inc
6947 if {$s < 1} {
6948 set s 1
6950 set fontattr(mainfont,size) $s
6951 font config mainfont -size $s
6952 font config mainfontbold -size $s
6953 set mainfont [fontname mainfont]
6954 set s $fontattr(textfont,size)
6955 incr s $inc
6956 if {$s < 1} {
6957 set s 1
6959 set fontattr(textfont,size) $s
6960 font config textfont -size $s
6961 font config textfontbold -size $s
6962 set textfont [fontname textfont]
6963 setcoords
6964 settabs
6965 redisplay
6968 proc clearsha1 {} {
6969 global sha1entry sha1string
6970 if {[string length $sha1string] == 40} {
6971 $sha1entry delete 0 end
6975 proc sha1change {n1 n2 op} {
6976 global sha1string currentid sha1but
6977 if {$sha1string == {}
6978 || ([info exists currentid] && $sha1string == $currentid)} {
6979 set state disabled
6980 } else {
6981 set state normal
6983 if {[$sha1but cget -state] == $state} return
6984 if {$state == "normal"} {
6985 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6986 } else {
6987 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6991 proc gotocommit {} {
6992 global sha1string tagids headids curview varcid
6994 if {$sha1string == {}
6995 || ([info exists currentid] && $sha1string == $currentid)} return
6996 if {[info exists tagids($sha1string)]} {
6997 set id $tagids($sha1string)
6998 } elseif {[info exists headids($sha1string)]} {
6999 set id $headids($sha1string)
7000 } else {
7001 set id [string tolower $sha1string]
7002 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7003 set matches [array names varcid "$curview,$id*"]
7004 if {$matches ne {}} {
7005 if {[llength $matches] > 1} {
7006 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7007 return
7009 set id [lindex [split [lindex $matches 0] ","] 1]
7013 if {[commitinview $id $curview]} {
7014 selectline [rowofcommit $id] 1
7015 return
7017 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7018 set msg [mc "SHA1 id %s is not known" $sha1string]
7019 } else {
7020 set msg [mc "Tag/Head %s is not known" $sha1string]
7022 error_popup $msg
7025 proc lineenter {x y id} {
7026 global hoverx hovery hoverid hovertimer
7027 global commitinfo canv
7029 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7030 set hoverx $x
7031 set hovery $y
7032 set hoverid $id
7033 if {[info exists hovertimer]} {
7034 after cancel $hovertimer
7036 set hovertimer [after 500 linehover]
7037 $canv delete hover
7040 proc linemotion {x y id} {
7041 global hoverx hovery hoverid hovertimer
7043 if {[info exists hoverid] && $id == $hoverid} {
7044 set hoverx $x
7045 set hovery $y
7046 if {[info exists hovertimer]} {
7047 after cancel $hovertimer
7049 set hovertimer [after 500 linehover]
7053 proc lineleave {id} {
7054 global hoverid hovertimer canv
7056 if {[info exists hoverid] && $id == $hoverid} {
7057 $canv delete hover
7058 if {[info exists hovertimer]} {
7059 after cancel $hovertimer
7060 unset hovertimer
7062 unset hoverid
7066 proc linehover {} {
7067 global hoverx hovery hoverid hovertimer
7068 global canv linespc lthickness
7069 global commitinfo
7071 set text [lindex $commitinfo($hoverid) 0]
7072 set ymax [lindex [$canv cget -scrollregion] 3]
7073 if {$ymax == {}} return
7074 set yfrac [lindex [$canv yview] 0]
7075 set x [expr {$hoverx + 2 * $linespc}]
7076 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7077 set x0 [expr {$x - 2 * $lthickness}]
7078 set y0 [expr {$y - 2 * $lthickness}]
7079 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7080 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7081 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7082 -fill \#ffff80 -outline black -width 1 -tags hover]
7083 $canv raise $t
7084 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7085 -font mainfont]
7086 $canv raise $t
7089 proc clickisonarrow {id y} {
7090 global lthickness
7092 set ranges [rowranges $id]
7093 set thresh [expr {2 * $lthickness + 6}]
7094 set n [expr {[llength $ranges] - 1}]
7095 for {set i 1} {$i < $n} {incr i} {
7096 set row [lindex $ranges $i]
7097 if {abs([yc $row] - $y) < $thresh} {
7098 return $i
7101 return {}
7104 proc arrowjump {id n y} {
7105 global canv
7107 # 1 <-> 2, 3 <-> 4, etc...
7108 set n [expr {(($n - 1) ^ 1) + 1}]
7109 set row [lindex [rowranges $id] $n]
7110 set yt [yc $row]
7111 set ymax [lindex [$canv cget -scrollregion] 3]
7112 if {$ymax eq {} || $ymax <= 0} return
7113 set view [$canv yview]
7114 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7115 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7116 if {$yfrac < 0} {
7117 set yfrac 0
7119 allcanvs yview moveto $yfrac
7122 proc lineclick {x y id isnew} {
7123 global ctext commitinfo children canv thickerline curview
7125 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7126 unmarkmatches
7127 unselectline
7128 normalline
7129 $canv delete hover
7130 # draw this line thicker than normal
7131 set thickerline $id
7132 drawlines $id
7133 if {$isnew} {
7134 set ymax [lindex [$canv cget -scrollregion] 3]
7135 if {$ymax eq {}} return
7136 set yfrac [lindex [$canv yview] 0]
7137 set y [expr {$y + $yfrac * $ymax}]
7139 set dirn [clickisonarrow $id $y]
7140 if {$dirn ne {}} {
7141 arrowjump $id $dirn $y
7142 return
7145 if {$isnew} {
7146 addtohistory [list lineclick $x $y $id 0]
7148 # fill the details pane with info about this line
7149 $ctext conf -state normal
7150 clear_ctext
7151 settabs 0
7152 $ctext insert end "[mc "Parent"]:\t"
7153 $ctext insert end $id link0
7154 setlink $id link0
7155 set info $commitinfo($id)
7156 $ctext insert end "\n\t[lindex $info 0]\n"
7157 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7158 set date [formatdate [lindex $info 2]]
7159 $ctext insert end "\t[mc "Date"]:\t$date\n"
7160 set kids $children($curview,$id)
7161 if {$kids ne {}} {
7162 $ctext insert end "\n[mc "Children"]:"
7163 set i 0
7164 foreach child $kids {
7165 incr i
7166 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7167 set info $commitinfo($child)
7168 $ctext insert end "\n\t"
7169 $ctext insert end $child link$i
7170 setlink $child link$i
7171 $ctext insert end "\n\t[lindex $info 0]"
7172 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7173 set date [formatdate [lindex $info 2]]
7174 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7177 $ctext conf -state disabled
7178 init_flist {}
7181 proc normalline {} {
7182 global thickerline
7183 if {[info exists thickerline]} {
7184 set id $thickerline
7185 unset thickerline
7186 drawlines $id
7190 proc selbyid {id} {
7191 global curview
7192 if {[commitinview $id $curview]} {
7193 selectline [rowofcommit $id] 1
7197 proc mstime {} {
7198 global startmstime
7199 if {![info exists startmstime]} {
7200 set startmstime [clock clicks -milliseconds]
7202 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7205 proc rowmenu {x y id} {
7206 global rowctxmenu selectedline rowmenuid curview
7207 global nullid nullid2 fakerowmenu mainhead
7209 stopfinding
7210 set rowmenuid $id
7211 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7212 set state disabled
7213 } else {
7214 set state normal
7216 if {$id ne $nullid && $id ne $nullid2} {
7217 set menu $rowctxmenu
7218 if {$mainhead ne {}} {
7219 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7220 } else {
7221 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7223 } else {
7224 set menu $fakerowmenu
7226 $menu entryconfigure [mc "Diff this -> selected"] -state $state
7227 $menu entryconfigure [mc "Diff selected -> this"] -state $state
7228 $menu entryconfigure [mc "Make patch"] -state $state
7229 tk_popup $menu $x $y
7232 proc diffvssel {dirn} {
7233 global rowmenuid selectedline
7235 if {$selectedline eq {}} return
7236 if {$dirn} {
7237 set oldid [commitonrow $selectedline]
7238 set newid $rowmenuid
7239 } else {
7240 set oldid $rowmenuid
7241 set newid [commitonrow $selectedline]
7243 addtohistory [list doseldiff $oldid $newid]
7244 doseldiff $oldid $newid
7247 proc doseldiff {oldid newid} {
7248 global ctext
7249 global commitinfo
7251 $ctext conf -state normal
7252 clear_ctext
7253 init_flist [mc "Top"]
7254 $ctext insert end "[mc "From"] "
7255 $ctext insert end $oldid link0
7256 setlink $oldid link0
7257 $ctext insert end "\n "
7258 $ctext insert end [lindex $commitinfo($oldid) 0]
7259 $ctext insert end "\n\n[mc "To"] "
7260 $ctext insert end $newid link1
7261 setlink $newid link1
7262 $ctext insert end "\n "
7263 $ctext insert end [lindex $commitinfo($newid) 0]
7264 $ctext insert end "\n"
7265 $ctext conf -state disabled
7266 $ctext tag remove found 1.0 end
7267 startdiff [list $oldid $newid]
7270 proc mkpatch {} {
7271 global rowmenuid currentid commitinfo patchtop patchnum
7273 if {![info exists currentid]} return
7274 set oldid $currentid
7275 set oldhead [lindex $commitinfo($oldid) 0]
7276 set newid $rowmenuid
7277 set newhead [lindex $commitinfo($newid) 0]
7278 set top .patch
7279 set patchtop $top
7280 catch {destroy $top}
7281 toplevel $top
7282 label $top.title -text [mc "Generate patch"]
7283 grid $top.title - -pady 10
7284 label $top.from -text [mc "From:"]
7285 entry $top.fromsha1 -width 40 -relief flat
7286 $top.fromsha1 insert 0 $oldid
7287 $top.fromsha1 conf -state readonly
7288 grid $top.from $top.fromsha1 -sticky w
7289 entry $top.fromhead -width 60 -relief flat
7290 $top.fromhead insert 0 $oldhead
7291 $top.fromhead conf -state readonly
7292 grid x $top.fromhead -sticky w
7293 label $top.to -text [mc "To:"]
7294 entry $top.tosha1 -width 40 -relief flat
7295 $top.tosha1 insert 0 $newid
7296 $top.tosha1 conf -state readonly
7297 grid $top.to $top.tosha1 -sticky w
7298 entry $top.tohead -width 60 -relief flat
7299 $top.tohead insert 0 $newhead
7300 $top.tohead conf -state readonly
7301 grid x $top.tohead -sticky w
7302 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7303 grid $top.rev x -pady 10
7304 label $top.flab -text [mc "Output file:"]
7305 entry $top.fname -width 60
7306 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7307 incr patchnum
7308 grid $top.flab $top.fname -sticky w
7309 frame $top.buts
7310 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7311 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7312 grid $top.buts.gen $top.buts.can
7313 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7314 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7315 grid $top.buts - -pady 10 -sticky ew
7316 focus $top.fname
7319 proc mkpatchrev {} {
7320 global patchtop
7322 set oldid [$patchtop.fromsha1 get]
7323 set oldhead [$patchtop.fromhead get]
7324 set newid [$patchtop.tosha1 get]
7325 set newhead [$patchtop.tohead get]
7326 foreach e [list fromsha1 fromhead tosha1 tohead] \
7327 v [list $newid $newhead $oldid $oldhead] {
7328 $patchtop.$e conf -state normal
7329 $patchtop.$e delete 0 end
7330 $patchtop.$e insert 0 $v
7331 $patchtop.$e conf -state readonly
7335 proc mkpatchgo {} {
7336 global patchtop nullid nullid2
7338 set oldid [$patchtop.fromsha1 get]
7339 set newid [$patchtop.tosha1 get]
7340 set fname [$patchtop.fname get]
7341 set cmd [diffcmd [list $oldid $newid] -p]
7342 # trim off the initial "|"
7343 set cmd [lrange $cmd 1 end]
7344 lappend cmd >$fname &
7345 if {[catch {eval exec $cmd} err]} {
7346 error_popup "[mc "Error creating patch:"] $err"
7348 catch {destroy $patchtop}
7349 unset patchtop
7352 proc mkpatchcan {} {
7353 global patchtop
7355 catch {destroy $patchtop}
7356 unset patchtop
7359 proc mktag {} {
7360 global rowmenuid mktagtop commitinfo
7362 set top .maketag
7363 set mktagtop $top
7364 catch {destroy $top}
7365 toplevel $top
7366 label $top.title -text [mc "Create tag"]
7367 grid $top.title - -pady 10
7368 label $top.id -text [mc "ID:"]
7369 entry $top.sha1 -width 40 -relief flat
7370 $top.sha1 insert 0 $rowmenuid
7371 $top.sha1 conf -state readonly
7372 grid $top.id $top.sha1 -sticky w
7373 entry $top.head -width 60 -relief flat
7374 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7375 $top.head conf -state readonly
7376 grid x $top.head -sticky w
7377 label $top.tlab -text [mc "Tag name:"]
7378 entry $top.tag -width 60
7379 grid $top.tlab $top.tag -sticky w
7380 frame $top.buts
7381 button $top.buts.gen -text [mc "Create"] -command mktaggo
7382 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7383 grid $top.buts.gen $top.buts.can
7384 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7385 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7386 grid $top.buts - -pady 10 -sticky ew
7387 focus $top.tag
7390 proc domktag {} {
7391 global mktagtop env tagids idtags
7393 set id [$mktagtop.sha1 get]
7394 set tag [$mktagtop.tag get]
7395 if {$tag == {}} {
7396 error_popup [mc "No tag name specified"]
7397 return
7399 if {[info exists tagids($tag)]} {
7400 error_popup [mc "Tag \"%s\" already exists" $tag]
7401 return
7403 if {[catch {
7404 exec git tag $tag $id
7405 } err]} {
7406 error_popup "[mc "Error creating tag:"] $err"
7407 return
7410 set tagids($tag) $id
7411 lappend idtags($id) $tag
7412 redrawtags $id
7413 addedtag $id
7414 dispneartags 0
7415 run refill_reflist
7418 proc redrawtags {id} {
7419 global canv linehtag idpos currentid curview cmitlisted
7420 global canvxmax iddrawn circleitem mainheadid circlecolors
7422 if {![commitinview $id $curview]} return
7423 if {![info exists iddrawn($id)]} return
7424 set row [rowofcommit $id]
7425 if {$id eq $mainheadid} {
7426 set ofill yellow
7427 } else {
7428 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7430 $canv itemconf $circleitem($row) -fill $ofill
7431 $canv delete tag.$id
7432 set xt [eval drawtags $id $idpos($id)]
7433 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7434 set text [$canv itemcget $linehtag($row) -text]
7435 set font [$canv itemcget $linehtag($row) -font]
7436 set xr [expr {$xt + [font measure $font $text]}]
7437 if {$xr > $canvxmax} {
7438 set canvxmax $xr
7439 setcanvscroll
7441 if {[info exists currentid] && $currentid == $id} {
7442 make_secsel $row
7446 proc mktagcan {} {
7447 global mktagtop
7449 catch {destroy $mktagtop}
7450 unset mktagtop
7453 proc mktaggo {} {
7454 domktag
7455 mktagcan
7458 proc writecommit {} {
7459 global rowmenuid wrcomtop commitinfo wrcomcmd
7461 set top .writecommit
7462 set wrcomtop $top
7463 catch {destroy $top}
7464 toplevel $top
7465 label $top.title -text [mc "Write commit to file"]
7466 grid $top.title - -pady 10
7467 label $top.id -text [mc "ID:"]
7468 entry $top.sha1 -width 40 -relief flat
7469 $top.sha1 insert 0 $rowmenuid
7470 $top.sha1 conf -state readonly
7471 grid $top.id $top.sha1 -sticky w
7472 entry $top.head -width 60 -relief flat
7473 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7474 $top.head conf -state readonly
7475 grid x $top.head -sticky w
7476 label $top.clab -text [mc "Command:"]
7477 entry $top.cmd -width 60 -textvariable wrcomcmd
7478 grid $top.clab $top.cmd -sticky w -pady 10
7479 label $top.flab -text [mc "Output file:"]
7480 entry $top.fname -width 60
7481 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7482 grid $top.flab $top.fname -sticky w
7483 frame $top.buts
7484 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7485 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7486 grid $top.buts.gen $top.buts.can
7487 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7488 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7489 grid $top.buts - -pady 10 -sticky ew
7490 focus $top.fname
7493 proc wrcomgo {} {
7494 global wrcomtop
7496 set id [$wrcomtop.sha1 get]
7497 set cmd "echo $id | [$wrcomtop.cmd get]"
7498 set fname [$wrcomtop.fname get]
7499 if {[catch {exec sh -c $cmd >$fname &} err]} {
7500 error_popup "[mc "Error writing commit:"] $err"
7502 catch {destroy $wrcomtop}
7503 unset wrcomtop
7506 proc wrcomcan {} {
7507 global wrcomtop
7509 catch {destroy $wrcomtop}
7510 unset wrcomtop
7513 proc mkbranch {} {
7514 global rowmenuid mkbrtop
7516 set top .makebranch
7517 catch {destroy $top}
7518 toplevel $top
7519 label $top.title -text [mc "Create new branch"]
7520 grid $top.title - -pady 10
7521 label $top.id -text [mc "ID:"]
7522 entry $top.sha1 -width 40 -relief flat
7523 $top.sha1 insert 0 $rowmenuid
7524 $top.sha1 conf -state readonly
7525 grid $top.id $top.sha1 -sticky w
7526 label $top.nlab -text [mc "Name:"]
7527 entry $top.name -width 40
7528 grid $top.nlab $top.name -sticky w
7529 frame $top.buts
7530 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7531 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7532 grid $top.buts.go $top.buts.can
7533 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7534 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7535 grid $top.buts - -pady 10 -sticky ew
7536 focus $top.name
7539 proc mkbrgo {top} {
7540 global headids idheads
7542 set name [$top.name get]
7543 set id [$top.sha1 get]
7544 if {$name eq {}} {
7545 error_popup [mc "Please specify a name for the new branch"]
7546 return
7548 catch {destroy $top}
7549 nowbusy newbranch
7550 update
7551 if {[catch {
7552 exec git branch $name $id
7553 } err]} {
7554 notbusy newbranch
7555 error_popup $err
7556 } else {
7557 set headids($name) $id
7558 lappend idheads($id) $name
7559 addedhead $id $name
7560 notbusy newbranch
7561 redrawtags $id
7562 dispneartags 0
7563 run refill_reflist
7567 proc cherrypick {} {
7568 global rowmenuid curview
7569 global mainhead mainheadid
7571 set oldhead [exec git rev-parse HEAD]
7572 set dheads [descheads $rowmenuid]
7573 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7574 set ok [confirm_popup [mc "Commit %s is already\
7575 included in branch %s -- really re-apply it?" \
7576 [string range $rowmenuid 0 7] $mainhead]]
7577 if {!$ok} return
7579 nowbusy cherrypick [mc "Cherry-picking"]
7580 update
7581 # Unfortunately git-cherry-pick writes stuff to stderr even when
7582 # no error occurs, and exec takes that as an indication of error...
7583 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7584 notbusy cherrypick
7585 error_popup $err
7586 return
7588 set newhead [exec git rev-parse HEAD]
7589 if {$newhead eq $oldhead} {
7590 notbusy cherrypick
7591 error_popup [mc "No changes committed"]
7592 return
7594 addnewchild $newhead $oldhead
7595 if {[commitinview $oldhead $curview]} {
7596 insertrow $newhead $oldhead $curview
7597 if {$mainhead ne {}} {
7598 movehead $newhead $mainhead
7599 movedhead $newhead $mainhead
7601 set mainheadid $newhead
7602 redrawtags $oldhead
7603 redrawtags $newhead
7604 selbyid $newhead
7606 notbusy cherrypick
7609 proc resethead {} {
7610 global mainhead rowmenuid confirm_ok resettype
7612 set confirm_ok 0
7613 set w ".confirmreset"
7614 toplevel $w
7615 wm transient $w .
7616 wm title $w [mc "Confirm reset"]
7617 message $w.m -text \
7618 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7619 -justify center -aspect 1000
7620 pack $w.m -side top -fill x -padx 20 -pady 20
7621 frame $w.f -relief sunken -border 2
7622 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7623 grid $w.f.rt -sticky w
7624 set resettype mixed
7625 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7626 -text [mc "Soft: Leave working tree and index untouched"]
7627 grid $w.f.soft -sticky w
7628 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7629 -text [mc "Mixed: Leave working tree untouched, reset index"]
7630 grid $w.f.mixed -sticky w
7631 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7632 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7633 grid $w.f.hard -sticky w
7634 pack $w.f -side top -fill x
7635 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7636 pack $w.ok -side left -fill x -padx 20 -pady 20
7637 button $w.cancel -text [mc Cancel] -command "destroy $w"
7638 pack $w.cancel -side right -fill x -padx 20 -pady 20
7639 bind $w <Visibility> "grab $w; focus $w"
7640 tkwait window $w
7641 if {!$confirm_ok} return
7642 if {[catch {set fd [open \
7643 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7644 error_popup $err
7645 } else {
7646 dohidelocalchanges
7647 filerun $fd [list readresetstat $fd]
7648 nowbusy reset [mc "Resetting"]
7649 selbyid $rowmenuid
7653 proc readresetstat {fd} {
7654 global mainhead mainheadid showlocalchanges rprogcoord
7656 if {[gets $fd line] >= 0} {
7657 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7658 set rprogcoord [expr {1.0 * $m / $n}]
7659 adjustprogress
7661 return 1
7663 set rprogcoord 0
7664 adjustprogress
7665 notbusy reset
7666 if {[catch {close $fd} err]} {
7667 error_popup $err
7669 set oldhead $mainheadid
7670 set newhead [exec git rev-parse HEAD]
7671 if {$newhead ne $oldhead} {
7672 movehead $newhead $mainhead
7673 movedhead $newhead $mainhead
7674 set mainheadid $newhead
7675 redrawtags $oldhead
7676 redrawtags $newhead
7678 if {$showlocalchanges} {
7679 doshowlocalchanges
7681 return 0
7684 # context menu for a head
7685 proc headmenu {x y id head} {
7686 global headmenuid headmenuhead headctxmenu mainhead
7688 stopfinding
7689 set headmenuid $id
7690 set headmenuhead $head
7691 set state normal
7692 if {$head eq $mainhead} {
7693 set state disabled
7695 $headctxmenu entryconfigure 0 -state $state
7696 $headctxmenu entryconfigure 1 -state $state
7697 tk_popup $headctxmenu $x $y
7700 proc cobranch {} {
7701 global headmenuid headmenuhead headids
7702 global showlocalchanges mainheadid
7704 # check the tree is clean first??
7705 nowbusy checkout [mc "Checking out"]
7706 update
7707 dohidelocalchanges
7708 if {[catch {
7709 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7710 } err]} {
7711 notbusy checkout
7712 error_popup $err
7713 if {$showlocalchanges} {
7714 dodiffindex
7716 } else {
7717 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7721 proc readcheckoutstat {fd newhead newheadid} {
7722 global mainhead mainheadid headids showlocalchanges progresscoords
7724 if {[gets $fd line] >= 0} {
7725 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7726 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7727 adjustprogress
7729 return 1
7731 set progresscoords {0 0}
7732 adjustprogress
7733 notbusy checkout
7734 if {[catch {close $fd} err]} {
7735 error_popup $err
7737 set oldmainid $mainheadid
7738 set mainhead $newhead
7739 set mainheadid $newheadid
7740 redrawtags $oldmainid
7741 redrawtags $newheadid
7742 selbyid $newheadid
7743 if {$showlocalchanges} {
7744 dodiffindex
7748 proc rmbranch {} {
7749 global headmenuid headmenuhead mainhead
7750 global idheads
7752 set head $headmenuhead
7753 set id $headmenuid
7754 # this check shouldn't be needed any more...
7755 if {$head eq $mainhead} {
7756 error_popup [mc "Cannot delete the currently checked-out branch"]
7757 return
7759 set dheads [descheads $id]
7760 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7761 # the stuff on this branch isn't on any other branch
7762 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7763 branch.\nReally delete branch %s?" $head $head]]} return
7765 nowbusy rmbranch
7766 update
7767 if {[catch {exec git branch -D $head} err]} {
7768 notbusy rmbranch
7769 error_popup $err
7770 return
7772 removehead $id $head
7773 removedhead $id $head
7774 redrawtags $id
7775 notbusy rmbranch
7776 dispneartags 0
7777 run refill_reflist
7780 # Display a list of tags and heads
7781 proc showrefs {} {
7782 global showrefstop bgcolor fgcolor selectbgcolor
7783 global bglist fglist reflistfilter reflist maincursor
7785 set top .showrefs
7786 set showrefstop $top
7787 if {[winfo exists $top]} {
7788 raise $top
7789 refill_reflist
7790 return
7792 toplevel $top
7793 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7794 text $top.list -background $bgcolor -foreground $fgcolor \
7795 -selectbackground $selectbgcolor -font mainfont \
7796 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7797 -width 30 -height 20 -cursor $maincursor \
7798 -spacing1 1 -spacing3 1 -state disabled
7799 $top.list tag configure highlight -background $selectbgcolor
7800 lappend bglist $top.list
7801 lappend fglist $top.list
7802 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7803 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7804 grid $top.list $top.ysb -sticky nsew
7805 grid $top.xsb x -sticky ew
7806 frame $top.f
7807 label $top.f.l -text "[mc "Filter"]: "
7808 entry $top.f.e -width 20 -textvariable reflistfilter
7809 set reflistfilter "*"
7810 trace add variable reflistfilter write reflistfilter_change
7811 pack $top.f.e -side right -fill x -expand 1
7812 pack $top.f.l -side left
7813 grid $top.f - -sticky ew -pady 2
7814 button $top.close -command [list destroy $top] -text [mc "Close"]
7815 grid $top.close -
7816 grid columnconfigure $top 0 -weight 1
7817 grid rowconfigure $top 0 -weight 1
7818 bind $top.list <1> {break}
7819 bind $top.list <B1-Motion> {break}
7820 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7821 set reflist {}
7822 refill_reflist
7825 proc sel_reflist {w x y} {
7826 global showrefstop reflist headids tagids otherrefids
7828 if {![winfo exists $showrefstop]} return
7829 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7830 set ref [lindex $reflist [expr {$l-1}]]
7831 set n [lindex $ref 0]
7832 switch -- [lindex $ref 1] {
7833 "H" {selbyid $headids($n)}
7834 "T" {selbyid $tagids($n)}
7835 "o" {selbyid $otherrefids($n)}
7837 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7840 proc unsel_reflist {} {
7841 global showrefstop
7843 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7844 $showrefstop.list tag remove highlight 0.0 end
7847 proc reflistfilter_change {n1 n2 op} {
7848 global reflistfilter
7850 after cancel refill_reflist
7851 after 200 refill_reflist
7854 proc refill_reflist {} {
7855 global reflist reflistfilter showrefstop headids tagids otherrefids
7856 global curview commitinterest
7858 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7859 set refs {}
7860 foreach n [array names headids] {
7861 if {[string match $reflistfilter $n]} {
7862 if {[commitinview $headids($n) $curview]} {
7863 lappend refs [list $n H]
7864 } else {
7865 set commitinterest($headids($n)) {run refill_reflist}
7869 foreach n [array names tagids] {
7870 if {[string match $reflistfilter $n]} {
7871 if {[commitinview $tagids($n) $curview]} {
7872 lappend refs [list $n T]
7873 } else {
7874 set commitinterest($tagids($n)) {run refill_reflist}
7878 foreach n [array names otherrefids] {
7879 if {[string match $reflistfilter $n]} {
7880 if {[commitinview $otherrefids($n) $curview]} {
7881 lappend refs [list $n o]
7882 } else {
7883 set commitinterest($otherrefids($n)) {run refill_reflist}
7887 set refs [lsort -index 0 $refs]
7888 if {$refs eq $reflist} return
7890 # Update the contents of $showrefstop.list according to the
7891 # differences between $reflist (old) and $refs (new)
7892 $showrefstop.list conf -state normal
7893 $showrefstop.list insert end "\n"
7894 set i 0
7895 set j 0
7896 while {$i < [llength $reflist] || $j < [llength $refs]} {
7897 if {$i < [llength $reflist]} {
7898 if {$j < [llength $refs]} {
7899 set cmp [string compare [lindex $reflist $i 0] \
7900 [lindex $refs $j 0]]
7901 if {$cmp == 0} {
7902 set cmp [string compare [lindex $reflist $i 1] \
7903 [lindex $refs $j 1]]
7905 } else {
7906 set cmp -1
7908 } else {
7909 set cmp 1
7911 switch -- $cmp {
7912 -1 {
7913 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7914 incr i
7917 incr i
7918 incr j
7921 set l [expr {$j + 1}]
7922 $showrefstop.list image create $l.0 -align baseline \
7923 -image reficon-[lindex $refs $j 1] -padx 2
7924 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7925 incr j
7929 set reflist $refs
7930 # delete last newline
7931 $showrefstop.list delete end-2c end-1c
7932 $showrefstop.list conf -state disabled
7935 # Stuff for finding nearby tags
7936 proc getallcommits {} {
7937 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7938 global idheads idtags idotherrefs allparents tagobjid
7940 if {![info exists allcommits]} {
7941 set nextarc 0
7942 set allcommits 0
7943 set seeds {}
7944 set allcwait 0
7945 set cachedarcs 0
7946 set allccache [file join [gitdir] "gitk.cache"]
7947 if {![catch {
7948 set f [open $allccache r]
7949 set allcwait 1
7950 getcache $f
7951 }]} return
7954 if {$allcwait} {
7955 return
7957 set cmd [list | git rev-list --parents]
7958 set allcupdate [expr {$seeds ne {}}]
7959 if {!$allcupdate} {
7960 set ids "--all"
7961 } else {
7962 set refs [concat [array names idheads] [array names idtags] \
7963 [array names idotherrefs]]
7964 set ids {}
7965 set tagobjs {}
7966 foreach name [array names tagobjid] {
7967 lappend tagobjs $tagobjid($name)
7969 foreach id [lsort -unique $refs] {
7970 if {![info exists allparents($id)] &&
7971 [lsearch -exact $tagobjs $id] < 0} {
7972 lappend ids $id
7975 if {$ids ne {}} {
7976 foreach id $seeds {
7977 lappend ids "^$id"
7981 if {$ids ne {}} {
7982 set fd [open [concat $cmd $ids] r]
7983 fconfigure $fd -blocking 0
7984 incr allcommits
7985 nowbusy allcommits
7986 filerun $fd [list getallclines $fd]
7987 } else {
7988 dispneartags 0
7992 # Since most commits have 1 parent and 1 child, we group strings of
7993 # such commits into "arcs" joining branch/merge points (BMPs), which
7994 # are commits that either don't have 1 parent or don't have 1 child.
7996 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7997 # arcout(id) - outgoing arcs for BMP
7998 # arcids(a) - list of IDs on arc including end but not start
7999 # arcstart(a) - BMP ID at start of arc
8000 # arcend(a) - BMP ID at end of arc
8001 # growing(a) - arc a is still growing
8002 # arctags(a) - IDs out of arcids (excluding end) that have tags
8003 # archeads(a) - IDs out of arcids (excluding end) that have heads
8004 # The start of an arc is at the descendent end, so "incoming" means
8005 # coming from descendents, and "outgoing" means going towards ancestors.
8007 proc getallclines {fd} {
8008 global allparents allchildren idtags idheads nextarc
8009 global arcnos arcids arctags arcout arcend arcstart archeads growing
8010 global seeds allcommits cachedarcs allcupdate
8012 set nid 0
8013 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8014 set id [lindex $line 0]
8015 if {[info exists allparents($id)]} {
8016 # seen it already
8017 continue
8019 set cachedarcs 0
8020 set olds [lrange $line 1 end]
8021 set allparents($id) $olds
8022 if {![info exists allchildren($id)]} {
8023 set allchildren($id) {}
8024 set arcnos($id) {}
8025 lappend seeds $id
8026 } else {
8027 set a $arcnos($id)
8028 if {[llength $olds] == 1 && [llength $a] == 1} {
8029 lappend arcids($a) $id
8030 if {[info exists idtags($id)]} {
8031 lappend arctags($a) $id
8033 if {[info exists idheads($id)]} {
8034 lappend archeads($a) $id
8036 if {[info exists allparents($olds)]} {
8037 # seen parent already
8038 if {![info exists arcout($olds)]} {
8039 splitarc $olds
8041 lappend arcids($a) $olds
8042 set arcend($a) $olds
8043 unset growing($a)
8045 lappend allchildren($olds) $id
8046 lappend arcnos($olds) $a
8047 continue
8050 foreach a $arcnos($id) {
8051 lappend arcids($a) $id
8052 set arcend($a) $id
8053 unset growing($a)
8056 set ao {}
8057 foreach p $olds {
8058 lappend allchildren($p) $id
8059 set a [incr nextarc]
8060 set arcstart($a) $id
8061 set archeads($a) {}
8062 set arctags($a) {}
8063 set archeads($a) {}
8064 set arcids($a) {}
8065 lappend ao $a
8066 set growing($a) 1
8067 if {[info exists allparents($p)]} {
8068 # seen it already, may need to make a new branch
8069 if {![info exists arcout($p)]} {
8070 splitarc $p
8072 lappend arcids($a) $p
8073 set arcend($a) $p
8074 unset growing($a)
8076 lappend arcnos($p) $a
8078 set arcout($id) $ao
8080 if {$nid > 0} {
8081 global cached_dheads cached_dtags cached_atags
8082 catch {unset cached_dheads}
8083 catch {unset cached_dtags}
8084 catch {unset cached_atags}
8086 if {![eof $fd]} {
8087 return [expr {$nid >= 1000? 2: 1}]
8089 set cacheok 1
8090 if {[catch {
8091 fconfigure $fd -blocking 1
8092 close $fd
8093 } err]} {
8094 # got an error reading the list of commits
8095 # if we were updating, try rereading the whole thing again
8096 if {$allcupdate} {
8097 incr allcommits -1
8098 dropcache $err
8099 return
8101 error_popup "[mc "Error reading commit topology information;\
8102 branch and preceding/following tag information\
8103 will be incomplete."]\n($err)"
8104 set cacheok 0
8106 if {[incr allcommits -1] == 0} {
8107 notbusy allcommits
8108 if {$cacheok} {
8109 run savecache
8112 dispneartags 0
8113 return 0
8116 proc recalcarc {a} {
8117 global arctags archeads arcids idtags idheads
8119 set at {}
8120 set ah {}
8121 foreach id [lrange $arcids($a) 0 end-1] {
8122 if {[info exists idtags($id)]} {
8123 lappend at $id
8125 if {[info exists idheads($id)]} {
8126 lappend ah $id
8129 set arctags($a) $at
8130 set archeads($a) $ah
8133 proc splitarc {p} {
8134 global arcnos arcids nextarc arctags archeads idtags idheads
8135 global arcstart arcend arcout allparents growing
8137 set a $arcnos($p)
8138 if {[llength $a] != 1} {
8139 puts "oops splitarc called but [llength $a] arcs already"
8140 return
8142 set a [lindex $a 0]
8143 set i [lsearch -exact $arcids($a) $p]
8144 if {$i < 0} {
8145 puts "oops splitarc $p not in arc $a"
8146 return
8148 set na [incr nextarc]
8149 if {[info exists arcend($a)]} {
8150 set arcend($na) $arcend($a)
8151 } else {
8152 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8153 set j [lsearch -exact $arcnos($l) $a]
8154 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8156 set tail [lrange $arcids($a) [expr {$i+1}] end]
8157 set arcids($a) [lrange $arcids($a) 0 $i]
8158 set arcend($a) $p
8159 set arcstart($na) $p
8160 set arcout($p) $na
8161 set arcids($na) $tail
8162 if {[info exists growing($a)]} {
8163 set growing($na) 1
8164 unset growing($a)
8167 foreach id $tail {
8168 if {[llength $arcnos($id)] == 1} {
8169 set arcnos($id) $na
8170 } else {
8171 set j [lsearch -exact $arcnos($id) $a]
8172 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8176 # reconstruct tags and heads lists
8177 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8178 recalcarc $a
8179 recalcarc $na
8180 } else {
8181 set arctags($na) {}
8182 set archeads($na) {}
8186 # Update things for a new commit added that is a child of one
8187 # existing commit. Used when cherry-picking.
8188 proc addnewchild {id p} {
8189 global allparents allchildren idtags nextarc
8190 global arcnos arcids arctags arcout arcend arcstart archeads growing
8191 global seeds allcommits
8193 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8194 set allparents($id) [list $p]
8195 set allchildren($id) {}
8196 set arcnos($id) {}
8197 lappend seeds $id
8198 lappend allchildren($p) $id
8199 set a [incr nextarc]
8200 set arcstart($a) $id
8201 set archeads($a) {}
8202 set arctags($a) {}
8203 set arcids($a) [list $p]
8204 set arcend($a) $p
8205 if {![info exists arcout($p)]} {
8206 splitarc $p
8208 lappend arcnos($p) $a
8209 set arcout($id) [list $a]
8212 # This implements a cache for the topology information.
8213 # The cache saves, for each arc, the start and end of the arc,
8214 # the ids on the arc, and the outgoing arcs from the end.
8215 proc readcache {f} {
8216 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8217 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8218 global allcwait
8220 set a $nextarc
8221 set lim $cachedarcs
8222 if {$lim - $a > 500} {
8223 set lim [expr {$a + 500}]
8225 if {[catch {
8226 if {$a == $lim} {
8227 # finish reading the cache and setting up arctags, etc.
8228 set line [gets $f]
8229 if {$line ne "1"} {error "bad final version"}
8230 close $f
8231 foreach id [array names idtags] {
8232 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8233 [llength $allparents($id)] == 1} {
8234 set a [lindex $arcnos($id) 0]
8235 if {$arctags($a) eq {}} {
8236 recalcarc $a
8240 foreach id [array names idheads] {
8241 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8242 [llength $allparents($id)] == 1} {
8243 set a [lindex $arcnos($id) 0]
8244 if {$archeads($a) eq {}} {
8245 recalcarc $a
8249 foreach id [lsort -unique $possible_seeds] {
8250 if {$arcnos($id) eq {}} {
8251 lappend seeds $id
8254 set allcwait 0
8255 } else {
8256 while {[incr a] <= $lim} {
8257 set line [gets $f]
8258 if {[llength $line] != 3} {error "bad line"}
8259 set s [lindex $line 0]
8260 set arcstart($a) $s
8261 lappend arcout($s) $a
8262 if {![info exists arcnos($s)]} {
8263 lappend possible_seeds $s
8264 set arcnos($s) {}
8266 set e [lindex $line 1]
8267 if {$e eq {}} {
8268 set growing($a) 1
8269 } else {
8270 set arcend($a) $e
8271 if {![info exists arcout($e)]} {
8272 set arcout($e) {}
8275 set arcids($a) [lindex $line 2]
8276 foreach id $arcids($a) {
8277 lappend allparents($s) $id
8278 set s $id
8279 lappend arcnos($id) $a
8281 if {![info exists allparents($s)]} {
8282 set allparents($s) {}
8284 set arctags($a) {}
8285 set archeads($a) {}
8287 set nextarc [expr {$a - 1}]
8289 } err]} {
8290 dropcache $err
8291 return 0
8293 if {!$allcwait} {
8294 getallcommits
8296 return $allcwait
8299 proc getcache {f} {
8300 global nextarc cachedarcs possible_seeds
8302 if {[catch {
8303 set line [gets $f]
8304 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8305 # make sure it's an integer
8306 set cachedarcs [expr {int([lindex $line 1])}]
8307 if {$cachedarcs < 0} {error "bad number of arcs"}
8308 set nextarc 0
8309 set possible_seeds {}
8310 run readcache $f
8311 } err]} {
8312 dropcache $err
8314 return 0
8317 proc dropcache {err} {
8318 global allcwait nextarc cachedarcs seeds
8320 #puts "dropping cache ($err)"
8321 foreach v {arcnos arcout arcids arcstart arcend growing \
8322 arctags archeads allparents allchildren} {
8323 global $v
8324 catch {unset $v}
8326 set allcwait 0
8327 set nextarc 0
8328 set cachedarcs 0
8329 set seeds {}
8330 getallcommits
8333 proc writecache {f} {
8334 global cachearc cachedarcs allccache
8335 global arcstart arcend arcnos arcids arcout
8337 set a $cachearc
8338 set lim $cachedarcs
8339 if {$lim - $a > 1000} {
8340 set lim [expr {$a + 1000}]
8342 if {[catch {
8343 while {[incr a] <= $lim} {
8344 if {[info exists arcend($a)]} {
8345 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8346 } else {
8347 puts $f [list $arcstart($a) {} $arcids($a)]
8350 } err]} {
8351 catch {close $f}
8352 catch {file delete $allccache}
8353 #puts "writing cache failed ($err)"
8354 return 0
8356 set cachearc [expr {$a - 1}]
8357 if {$a > $cachedarcs} {
8358 puts $f "1"
8359 close $f
8360 return 0
8362 return 1
8365 proc savecache {} {
8366 global nextarc cachedarcs cachearc allccache
8368 if {$nextarc == $cachedarcs} return
8369 set cachearc 0
8370 set cachedarcs $nextarc
8371 catch {
8372 set f [open $allccache w]
8373 puts $f [list 1 $cachedarcs]
8374 run writecache $f
8378 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8379 # or 0 if neither is true.
8380 proc anc_or_desc {a b} {
8381 global arcout arcstart arcend arcnos cached_isanc
8383 if {$arcnos($a) eq $arcnos($b)} {
8384 # Both are on the same arc(s); either both are the same BMP,
8385 # or if one is not a BMP, the other is also not a BMP or is
8386 # the BMP at end of the arc (and it only has 1 incoming arc).
8387 # Or both can be BMPs with no incoming arcs.
8388 if {$a eq $b || $arcnos($a) eq {}} {
8389 return 0
8391 # assert {[llength $arcnos($a)] == 1}
8392 set arc [lindex $arcnos($a) 0]
8393 set i [lsearch -exact $arcids($arc) $a]
8394 set j [lsearch -exact $arcids($arc) $b]
8395 if {$i < 0 || $i > $j} {
8396 return 1
8397 } else {
8398 return -1
8402 if {![info exists arcout($a)]} {
8403 set arc [lindex $arcnos($a) 0]
8404 if {[info exists arcend($arc)]} {
8405 set aend $arcend($arc)
8406 } else {
8407 set aend {}
8409 set a $arcstart($arc)
8410 } else {
8411 set aend $a
8413 if {![info exists arcout($b)]} {
8414 set arc [lindex $arcnos($b) 0]
8415 if {[info exists arcend($arc)]} {
8416 set bend $arcend($arc)
8417 } else {
8418 set bend {}
8420 set b $arcstart($arc)
8421 } else {
8422 set bend $b
8424 if {$a eq $bend} {
8425 return 1
8427 if {$b eq $aend} {
8428 return -1
8430 if {[info exists cached_isanc($a,$bend)]} {
8431 if {$cached_isanc($a,$bend)} {
8432 return 1
8435 if {[info exists cached_isanc($b,$aend)]} {
8436 if {$cached_isanc($b,$aend)} {
8437 return -1
8439 if {[info exists cached_isanc($a,$bend)]} {
8440 return 0
8444 set todo [list $a $b]
8445 set anc($a) a
8446 set anc($b) b
8447 for {set i 0} {$i < [llength $todo]} {incr i} {
8448 set x [lindex $todo $i]
8449 if {$anc($x) eq {}} {
8450 continue
8452 foreach arc $arcnos($x) {
8453 set xd $arcstart($arc)
8454 if {$xd eq $bend} {
8455 set cached_isanc($a,$bend) 1
8456 set cached_isanc($b,$aend) 0
8457 return 1
8458 } elseif {$xd eq $aend} {
8459 set cached_isanc($b,$aend) 1
8460 set cached_isanc($a,$bend) 0
8461 return -1
8463 if {![info exists anc($xd)]} {
8464 set anc($xd) $anc($x)
8465 lappend todo $xd
8466 } elseif {$anc($xd) ne $anc($x)} {
8467 set anc($xd) {}
8471 set cached_isanc($a,$bend) 0
8472 set cached_isanc($b,$aend) 0
8473 return 0
8476 # This identifies whether $desc has an ancestor that is
8477 # a growing tip of the graph and which is not an ancestor of $anc
8478 # and returns 0 if so and 1 if not.
8479 # If we subsequently discover a tag on such a growing tip, and that
8480 # turns out to be a descendent of $anc (which it could, since we
8481 # don't necessarily see children before parents), then $desc
8482 # isn't a good choice to display as a descendent tag of
8483 # $anc (since it is the descendent of another tag which is
8484 # a descendent of $anc). Similarly, $anc isn't a good choice to
8485 # display as a ancestor tag of $desc.
8487 proc is_certain {desc anc} {
8488 global arcnos arcout arcstart arcend growing problems
8490 set certain {}
8491 if {[llength $arcnos($anc)] == 1} {
8492 # tags on the same arc are certain
8493 if {$arcnos($desc) eq $arcnos($anc)} {
8494 return 1
8496 if {![info exists arcout($anc)]} {
8497 # if $anc is partway along an arc, use the start of the arc instead
8498 set a [lindex $arcnos($anc) 0]
8499 set anc $arcstart($a)
8502 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8503 set x $desc
8504 } else {
8505 set a [lindex $arcnos($desc) 0]
8506 set x $arcend($a)
8508 if {$x == $anc} {
8509 return 1
8511 set anclist [list $x]
8512 set dl($x) 1
8513 set nnh 1
8514 set ngrowanc 0
8515 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8516 set x [lindex $anclist $i]
8517 if {$dl($x)} {
8518 incr nnh -1
8520 set done($x) 1
8521 foreach a $arcout($x) {
8522 if {[info exists growing($a)]} {
8523 if {![info exists growanc($x)] && $dl($x)} {
8524 set growanc($x) 1
8525 incr ngrowanc
8527 } else {
8528 set y $arcend($a)
8529 if {[info exists dl($y)]} {
8530 if {$dl($y)} {
8531 if {!$dl($x)} {
8532 set dl($y) 0
8533 if {![info exists done($y)]} {
8534 incr nnh -1
8536 if {[info exists growanc($x)]} {
8537 incr ngrowanc -1
8539 set xl [list $y]
8540 for {set k 0} {$k < [llength $xl]} {incr k} {
8541 set z [lindex $xl $k]
8542 foreach c $arcout($z) {
8543 if {[info exists arcend($c)]} {
8544 set v $arcend($c)
8545 if {[info exists dl($v)] && $dl($v)} {
8546 set dl($v) 0
8547 if {![info exists done($v)]} {
8548 incr nnh -1
8550 if {[info exists growanc($v)]} {
8551 incr ngrowanc -1
8553 lappend xl $v
8560 } elseif {$y eq $anc || !$dl($x)} {
8561 set dl($y) 0
8562 lappend anclist $y
8563 } else {
8564 set dl($y) 1
8565 lappend anclist $y
8566 incr nnh
8571 foreach x [array names growanc] {
8572 if {$dl($x)} {
8573 return 0
8575 return 0
8577 return 1
8580 proc validate_arctags {a} {
8581 global arctags idtags
8583 set i -1
8584 set na $arctags($a)
8585 foreach id $arctags($a) {
8586 incr i
8587 if {![info exists idtags($id)]} {
8588 set na [lreplace $na $i $i]
8589 incr i -1
8592 set arctags($a) $na
8595 proc validate_archeads {a} {
8596 global archeads idheads
8598 set i -1
8599 set na $archeads($a)
8600 foreach id $archeads($a) {
8601 incr i
8602 if {![info exists idheads($id)]} {
8603 set na [lreplace $na $i $i]
8604 incr i -1
8607 set archeads($a) $na
8610 # Return the list of IDs that have tags that are descendents of id,
8611 # ignoring IDs that are descendents of IDs already reported.
8612 proc desctags {id} {
8613 global arcnos arcstart arcids arctags idtags allparents
8614 global growing cached_dtags
8616 if {![info exists allparents($id)]} {
8617 return {}
8619 set t1 [clock clicks -milliseconds]
8620 set argid $id
8621 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8622 # part-way along an arc; check that arc first
8623 set a [lindex $arcnos($id) 0]
8624 if {$arctags($a) ne {}} {
8625 validate_arctags $a
8626 set i [lsearch -exact $arcids($a) $id]
8627 set tid {}
8628 foreach t $arctags($a) {
8629 set j [lsearch -exact $arcids($a) $t]
8630 if {$j >= $i} break
8631 set tid $t
8633 if {$tid ne {}} {
8634 return $tid
8637 set id $arcstart($a)
8638 if {[info exists idtags($id)]} {
8639 return $id
8642 if {[info exists cached_dtags($id)]} {
8643 return $cached_dtags($id)
8646 set origid $id
8647 set todo [list $id]
8648 set queued($id) 1
8649 set nc 1
8650 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8651 set id [lindex $todo $i]
8652 set done($id) 1
8653 set ta [info exists hastaggedancestor($id)]
8654 if {!$ta} {
8655 incr nc -1
8657 # ignore tags on starting node
8658 if {!$ta && $i > 0} {
8659 if {[info exists idtags($id)]} {
8660 set tagloc($id) $id
8661 set ta 1
8662 } elseif {[info exists cached_dtags($id)]} {
8663 set tagloc($id) $cached_dtags($id)
8664 set ta 1
8667 foreach a $arcnos($id) {
8668 set d $arcstart($a)
8669 if {!$ta && $arctags($a) ne {}} {
8670 validate_arctags $a
8671 if {$arctags($a) ne {}} {
8672 lappend tagloc($id) [lindex $arctags($a) end]
8675 if {$ta || $arctags($a) ne {}} {
8676 set tomark [list $d]
8677 for {set j 0} {$j < [llength $tomark]} {incr j} {
8678 set dd [lindex $tomark $j]
8679 if {![info exists hastaggedancestor($dd)]} {
8680 if {[info exists done($dd)]} {
8681 foreach b $arcnos($dd) {
8682 lappend tomark $arcstart($b)
8684 if {[info exists tagloc($dd)]} {
8685 unset tagloc($dd)
8687 } elseif {[info exists queued($dd)]} {
8688 incr nc -1
8690 set hastaggedancestor($dd) 1
8694 if {![info exists queued($d)]} {
8695 lappend todo $d
8696 set queued($d) 1
8697 if {![info exists hastaggedancestor($d)]} {
8698 incr nc
8703 set tags {}
8704 foreach id [array names tagloc] {
8705 if {![info exists hastaggedancestor($id)]} {
8706 foreach t $tagloc($id) {
8707 if {[lsearch -exact $tags $t] < 0} {
8708 lappend tags $t
8713 set t2 [clock clicks -milliseconds]
8714 set loopix $i
8716 # remove tags that are descendents of other tags
8717 for {set i 0} {$i < [llength $tags]} {incr i} {
8718 set a [lindex $tags $i]
8719 for {set j 0} {$j < $i} {incr j} {
8720 set b [lindex $tags $j]
8721 set r [anc_or_desc $a $b]
8722 if {$r == 1} {
8723 set tags [lreplace $tags $j $j]
8724 incr j -1
8725 incr i -1
8726 } elseif {$r == -1} {
8727 set tags [lreplace $tags $i $i]
8728 incr i -1
8729 break
8734 if {[array names growing] ne {}} {
8735 # graph isn't finished, need to check if any tag could get
8736 # eclipsed by another tag coming later. Simply ignore any
8737 # tags that could later get eclipsed.
8738 set ctags {}
8739 foreach t $tags {
8740 if {[is_certain $t $origid]} {
8741 lappend ctags $t
8744 if {$tags eq $ctags} {
8745 set cached_dtags($origid) $tags
8746 } else {
8747 set tags $ctags
8749 } else {
8750 set cached_dtags($origid) $tags
8752 set t3 [clock clicks -milliseconds]
8753 if {0 && $t3 - $t1 >= 100} {
8754 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8755 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8757 return $tags
8760 proc anctags {id} {
8761 global arcnos arcids arcout arcend arctags idtags allparents
8762 global growing cached_atags
8764 if {![info exists allparents($id)]} {
8765 return {}
8767 set t1 [clock clicks -milliseconds]
8768 set argid $id
8769 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8770 # part-way along an arc; check that arc first
8771 set a [lindex $arcnos($id) 0]
8772 if {$arctags($a) ne {}} {
8773 validate_arctags $a
8774 set i [lsearch -exact $arcids($a) $id]
8775 foreach t $arctags($a) {
8776 set j [lsearch -exact $arcids($a) $t]
8777 if {$j > $i} {
8778 return $t
8782 if {![info exists arcend($a)]} {
8783 return {}
8785 set id $arcend($a)
8786 if {[info exists idtags($id)]} {
8787 return $id
8790 if {[info exists cached_atags($id)]} {
8791 return $cached_atags($id)
8794 set origid $id
8795 set todo [list $id]
8796 set queued($id) 1
8797 set taglist {}
8798 set nc 1
8799 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8800 set id [lindex $todo $i]
8801 set done($id) 1
8802 set td [info exists hastaggeddescendent($id)]
8803 if {!$td} {
8804 incr nc -1
8806 # ignore tags on starting node
8807 if {!$td && $i > 0} {
8808 if {[info exists idtags($id)]} {
8809 set tagloc($id) $id
8810 set td 1
8811 } elseif {[info exists cached_atags($id)]} {
8812 set tagloc($id) $cached_atags($id)
8813 set td 1
8816 foreach a $arcout($id) {
8817 if {!$td && $arctags($a) ne {}} {
8818 validate_arctags $a
8819 if {$arctags($a) ne {}} {
8820 lappend tagloc($id) [lindex $arctags($a) 0]
8823 if {![info exists arcend($a)]} continue
8824 set d $arcend($a)
8825 if {$td || $arctags($a) ne {}} {
8826 set tomark [list $d]
8827 for {set j 0} {$j < [llength $tomark]} {incr j} {
8828 set dd [lindex $tomark $j]
8829 if {![info exists hastaggeddescendent($dd)]} {
8830 if {[info exists done($dd)]} {
8831 foreach b $arcout($dd) {
8832 if {[info exists arcend($b)]} {
8833 lappend tomark $arcend($b)
8836 if {[info exists tagloc($dd)]} {
8837 unset tagloc($dd)
8839 } elseif {[info exists queued($dd)]} {
8840 incr nc -1
8842 set hastaggeddescendent($dd) 1
8846 if {![info exists queued($d)]} {
8847 lappend todo $d
8848 set queued($d) 1
8849 if {![info exists hastaggeddescendent($d)]} {
8850 incr nc
8855 set t2 [clock clicks -milliseconds]
8856 set loopix $i
8857 set tags {}
8858 foreach id [array names tagloc] {
8859 if {![info exists hastaggeddescendent($id)]} {
8860 foreach t $tagloc($id) {
8861 if {[lsearch -exact $tags $t] < 0} {
8862 lappend tags $t
8868 # remove tags that are ancestors of other tags
8869 for {set i 0} {$i < [llength $tags]} {incr i} {
8870 set a [lindex $tags $i]
8871 for {set j 0} {$j < $i} {incr j} {
8872 set b [lindex $tags $j]
8873 set r [anc_or_desc $a $b]
8874 if {$r == -1} {
8875 set tags [lreplace $tags $j $j]
8876 incr j -1
8877 incr i -1
8878 } elseif {$r == 1} {
8879 set tags [lreplace $tags $i $i]
8880 incr i -1
8881 break
8886 if {[array names growing] ne {}} {
8887 # graph isn't finished, need to check if any tag could get
8888 # eclipsed by another tag coming later. Simply ignore any
8889 # tags that could later get eclipsed.
8890 set ctags {}
8891 foreach t $tags {
8892 if {[is_certain $origid $t]} {
8893 lappend ctags $t
8896 if {$tags eq $ctags} {
8897 set cached_atags($origid) $tags
8898 } else {
8899 set tags $ctags
8901 } else {
8902 set cached_atags($origid) $tags
8904 set t3 [clock clicks -milliseconds]
8905 if {0 && $t3 - $t1 >= 100} {
8906 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8907 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8909 return $tags
8912 # Return the list of IDs that have heads that are descendents of id,
8913 # including id itself if it has a head.
8914 proc descheads {id} {
8915 global arcnos arcstart arcids archeads idheads cached_dheads
8916 global allparents
8918 if {![info exists allparents($id)]} {
8919 return {}
8921 set aret {}
8922 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8923 # part-way along an arc; check it first
8924 set a [lindex $arcnos($id) 0]
8925 if {$archeads($a) ne {}} {
8926 validate_archeads $a
8927 set i [lsearch -exact $arcids($a) $id]
8928 foreach t $archeads($a) {
8929 set j [lsearch -exact $arcids($a) $t]
8930 if {$j > $i} break
8931 lappend aret $t
8934 set id $arcstart($a)
8936 set origid $id
8937 set todo [list $id]
8938 set seen($id) 1
8939 set ret {}
8940 for {set i 0} {$i < [llength $todo]} {incr i} {
8941 set id [lindex $todo $i]
8942 if {[info exists cached_dheads($id)]} {
8943 set ret [concat $ret $cached_dheads($id)]
8944 } else {
8945 if {[info exists idheads($id)]} {
8946 lappend ret $id
8948 foreach a $arcnos($id) {
8949 if {$archeads($a) ne {}} {
8950 validate_archeads $a
8951 if {$archeads($a) ne {}} {
8952 set ret [concat $ret $archeads($a)]
8955 set d $arcstart($a)
8956 if {![info exists seen($d)]} {
8957 lappend todo $d
8958 set seen($d) 1
8963 set ret [lsort -unique $ret]
8964 set cached_dheads($origid) $ret
8965 return [concat $ret $aret]
8968 proc addedtag {id} {
8969 global arcnos arcout cached_dtags cached_atags
8971 if {![info exists arcnos($id)]} return
8972 if {![info exists arcout($id)]} {
8973 recalcarc [lindex $arcnos($id) 0]
8975 catch {unset cached_dtags}
8976 catch {unset cached_atags}
8979 proc addedhead {hid head} {
8980 global arcnos arcout cached_dheads
8982 if {![info exists arcnos($hid)]} return
8983 if {![info exists arcout($hid)]} {
8984 recalcarc [lindex $arcnos($hid) 0]
8986 catch {unset cached_dheads}
8989 proc removedhead {hid head} {
8990 global cached_dheads
8992 catch {unset cached_dheads}
8995 proc movedhead {hid head} {
8996 global arcnos arcout cached_dheads
8998 if {![info exists arcnos($hid)]} return
8999 if {![info exists arcout($hid)]} {
9000 recalcarc [lindex $arcnos($hid) 0]
9002 catch {unset cached_dheads}
9005 proc changedrefs {} {
9006 global cached_dheads cached_dtags cached_atags
9007 global arctags archeads arcnos arcout idheads idtags
9009 foreach id [concat [array names idheads] [array names idtags]] {
9010 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9011 set a [lindex $arcnos($id) 0]
9012 if {![info exists donearc($a)]} {
9013 recalcarc $a
9014 set donearc($a) 1
9018 catch {unset cached_dtags}
9019 catch {unset cached_atags}
9020 catch {unset cached_dheads}
9023 proc rereadrefs {} {
9024 global idtags idheads idotherrefs mainheadid
9026 set refids [concat [array names idtags] \
9027 [array names idheads] [array names idotherrefs]]
9028 foreach id $refids {
9029 if {![info exists ref($id)]} {
9030 set ref($id) [listrefs $id]
9033 set oldmainhead $mainheadid
9034 readrefs
9035 changedrefs
9036 set refids [lsort -unique [concat $refids [array names idtags] \
9037 [array names idheads] [array names idotherrefs]]]
9038 foreach id $refids {
9039 set v [listrefs $id]
9040 if {![info exists ref($id)] || $ref($id) != $v} {
9041 redrawtags $id
9044 if {$oldmainhead ne $mainheadid} {
9045 redrawtags $oldmainhead
9046 redrawtags $mainheadid
9048 run refill_reflist
9051 proc listrefs {id} {
9052 global idtags idheads idotherrefs
9054 set x {}
9055 if {[info exists idtags($id)]} {
9056 set x $idtags($id)
9058 set y {}
9059 if {[info exists idheads($id)]} {
9060 set y $idheads($id)
9062 set z {}
9063 if {[info exists idotherrefs($id)]} {
9064 set z $idotherrefs($id)
9066 return [list $x $y $z]
9069 proc showtag {tag isnew} {
9070 global ctext tagcontents tagids linknum tagobjid
9072 if {$isnew} {
9073 addtohistory [list showtag $tag 0]
9075 $ctext conf -state normal
9076 clear_ctext
9077 settabs 0
9078 set linknum 0
9079 if {![info exists tagcontents($tag)]} {
9080 catch {
9081 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9084 if {[info exists tagcontents($tag)]} {
9085 set text $tagcontents($tag)
9086 } else {
9087 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9089 appendwithlinks $text {}
9090 $ctext conf -state disabled
9091 init_flist {}
9094 proc doquit {} {
9095 global stopped
9096 global gitktmpdir
9098 set stopped 100
9099 savestuff .
9100 destroy .
9102 if {[info exists gitktmpdir]} {
9103 catch {file delete -force $gitktmpdir}
9107 proc mkfontdisp {font top which} {
9108 global fontattr fontpref $font
9110 set fontpref($font) [set $font]
9111 button $top.${font}but -text $which -font optionfont \
9112 -command [list choosefont $font $which]
9113 label $top.$font -relief flat -font $font \
9114 -text $fontattr($font,family) -justify left
9115 grid x $top.${font}but $top.$font -sticky w
9118 proc choosefont {font which} {
9119 global fontparam fontlist fonttop fontattr
9121 set fontparam(which) $which
9122 set fontparam(font) $font
9123 set fontparam(family) [font actual $font -family]
9124 set fontparam(size) $fontattr($font,size)
9125 set fontparam(weight) $fontattr($font,weight)
9126 set fontparam(slant) $fontattr($font,slant)
9127 set top .gitkfont
9128 set fonttop $top
9129 if {![winfo exists $top]} {
9130 font create sample
9131 eval font config sample [font actual $font]
9132 toplevel $top
9133 wm title $top [mc "Gitk font chooser"]
9134 label $top.l -textvariable fontparam(which)
9135 pack $top.l -side top
9136 set fontlist [lsort [font families]]
9137 frame $top.f
9138 listbox $top.f.fam -listvariable fontlist \
9139 -yscrollcommand [list $top.f.sb set]
9140 bind $top.f.fam <<ListboxSelect>> selfontfam
9141 scrollbar $top.f.sb -command [list $top.f.fam yview]
9142 pack $top.f.sb -side right -fill y
9143 pack $top.f.fam -side left -fill both -expand 1
9144 pack $top.f -side top -fill both -expand 1
9145 frame $top.g
9146 spinbox $top.g.size -from 4 -to 40 -width 4 \
9147 -textvariable fontparam(size) \
9148 -validatecommand {string is integer -strict %s}
9149 checkbutton $top.g.bold -padx 5 \
9150 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9151 -variable fontparam(weight) -onvalue bold -offvalue normal
9152 checkbutton $top.g.ital -padx 5 \
9153 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9154 -variable fontparam(slant) -onvalue italic -offvalue roman
9155 pack $top.g.size $top.g.bold $top.g.ital -side left
9156 pack $top.g -side top
9157 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9158 -background white
9159 $top.c create text 100 25 -anchor center -text $which -font sample \
9160 -fill black -tags text
9161 bind $top.c <Configure> [list centertext $top.c]
9162 pack $top.c -side top -fill x
9163 frame $top.buts
9164 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9165 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9166 grid $top.buts.ok $top.buts.can
9167 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9168 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9169 pack $top.buts -side bottom -fill x
9170 trace add variable fontparam write chg_fontparam
9171 } else {
9172 raise $top
9173 $top.c itemconf text -text $which
9175 set i [lsearch -exact $fontlist $fontparam(family)]
9176 if {$i >= 0} {
9177 $top.f.fam selection set $i
9178 $top.f.fam see $i
9182 proc centertext {w} {
9183 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9186 proc fontok {} {
9187 global fontparam fontpref prefstop
9189 set f $fontparam(font)
9190 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9191 if {$fontparam(weight) eq "bold"} {
9192 lappend fontpref($f) "bold"
9194 if {$fontparam(slant) eq "italic"} {
9195 lappend fontpref($f) "italic"
9197 set w $prefstop.$f
9198 $w conf -text $fontparam(family) -font $fontpref($f)
9200 fontcan
9203 proc fontcan {} {
9204 global fonttop fontparam
9206 if {[info exists fonttop]} {
9207 catch {destroy $fonttop}
9208 catch {font delete sample}
9209 unset fonttop
9210 unset fontparam
9214 proc selfontfam {} {
9215 global fonttop fontparam
9217 set i [$fonttop.f.fam curselection]
9218 if {$i ne {}} {
9219 set fontparam(family) [$fonttop.f.fam get $i]
9223 proc chg_fontparam {v sub op} {
9224 global fontparam
9226 font config sample -$sub $fontparam($sub)
9229 proc doprefs {} {
9230 global maxwidth maxgraphpct
9231 global oldprefs prefstop showneartags showlocalchanges
9232 global bgcolor fgcolor ctext diffcolors selectbgcolor
9233 global tabstop limitdiffs autoselect extdifftool
9235 set top .gitkprefs
9236 set prefstop $top
9237 if {[winfo exists $top]} {
9238 raise $top
9239 return
9241 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9242 limitdiffs tabstop} {
9243 set oldprefs($v) [set $v]
9245 toplevel $top
9246 wm title $top [mc "Gitk preferences"]
9247 label $top.ldisp -text [mc "Commit list display options"]
9248 grid $top.ldisp - -sticky w -pady 10
9249 label $top.spacer -text " "
9250 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9251 -font optionfont
9252 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9253 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9254 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9255 -font optionfont
9256 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9257 grid x $top.maxpctl $top.maxpct -sticky w
9258 frame $top.showlocal
9259 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9260 checkbutton $top.showlocal.b -variable showlocalchanges
9261 pack $top.showlocal.b $top.showlocal.l -side left
9262 grid x $top.showlocal -sticky w
9263 frame $top.autoselect
9264 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9265 checkbutton $top.autoselect.b -variable autoselect
9266 pack $top.autoselect.b $top.autoselect.l -side left
9267 grid x $top.autoselect -sticky w
9269 label $top.ddisp -text [mc "Diff display options"]
9270 grid $top.ddisp - -sticky w -pady 10
9271 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9272 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9273 grid x $top.tabstopl $top.tabstop -sticky w
9274 frame $top.ntag
9275 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9276 checkbutton $top.ntag.b -variable showneartags
9277 pack $top.ntag.b $top.ntag.l -side left
9278 grid x $top.ntag -sticky w
9279 frame $top.ldiff
9280 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9281 checkbutton $top.ldiff.b -variable limitdiffs
9282 pack $top.ldiff.b $top.ldiff.l -side left
9283 grid x $top.ldiff -sticky w
9285 entry $top.extdifft -textvariable extdifftool
9286 frame $top.extdifff
9287 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9288 -padx 10
9289 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9290 -command choose_extdiff
9291 pack $top.extdifff.l $top.extdifff.b -side left
9292 grid x $top.extdifff $top.extdifft -sticky w
9294 label $top.cdisp -text [mc "Colors: press to choose"]
9295 grid $top.cdisp - -sticky w -pady 10
9296 label $top.bg -padx 40 -relief sunk -background $bgcolor
9297 button $top.bgbut -text [mc "Background"] -font optionfont \
9298 -command [list choosecolor bgcolor {} $top.bg background setbg]
9299 grid x $top.bgbut $top.bg -sticky w
9300 label $top.fg -padx 40 -relief sunk -background $fgcolor
9301 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9302 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9303 grid x $top.fgbut $top.fg -sticky w
9304 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9305 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9306 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9307 [list $ctext tag conf d0 -foreground]]
9308 grid x $top.diffoldbut $top.diffold -sticky w
9309 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9310 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9311 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9312 [list $ctext tag conf d1 -foreground]]
9313 grid x $top.diffnewbut $top.diffnew -sticky w
9314 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9315 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9316 -command [list choosecolor diffcolors 2 $top.hunksep \
9317 "diff hunk header" \
9318 [list $ctext tag conf hunksep -foreground]]
9319 grid x $top.hunksepbut $top.hunksep -sticky w
9320 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9321 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9322 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9323 grid x $top.selbgbut $top.selbgsep -sticky w
9325 label $top.cfont -text [mc "Fonts: press to choose"]
9326 grid $top.cfont - -sticky w -pady 10
9327 mkfontdisp mainfont $top [mc "Main font"]
9328 mkfontdisp textfont $top [mc "Diff display font"]
9329 mkfontdisp uifont $top [mc "User interface font"]
9331 frame $top.buts
9332 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9333 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9334 grid $top.buts.ok $top.buts.can
9335 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9336 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9337 grid $top.buts - - -pady 10 -sticky ew
9338 bind $top <Visibility> "focus $top.buts.ok"
9341 proc choose_extdiff {} {
9342 global extdifftool
9344 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9345 if {$prog ne {}} {
9346 set extdifftool $prog
9350 proc choosecolor {v vi w x cmd} {
9351 global $v
9353 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9354 -title [mc "Gitk: choose color for %s" $x]]
9355 if {$c eq {}} return
9356 $w conf -background $c
9357 lset $v $vi $c
9358 eval $cmd $c
9361 proc setselbg {c} {
9362 global bglist cflist
9363 foreach w $bglist {
9364 $w configure -selectbackground $c
9366 $cflist tag configure highlight \
9367 -background [$cflist cget -selectbackground]
9368 allcanvs itemconf secsel -fill $c
9371 proc setbg {c} {
9372 global bglist
9374 foreach w $bglist {
9375 $w conf -background $c
9379 proc setfg {c} {
9380 global fglist canv
9382 foreach w $fglist {
9383 $w conf -foreground $c
9385 allcanvs itemconf text -fill $c
9386 $canv itemconf circle -outline $c
9389 proc prefscan {} {
9390 global oldprefs prefstop
9392 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9393 limitdiffs tabstop} {
9394 global $v
9395 set $v $oldprefs($v)
9397 catch {destroy $prefstop}
9398 unset prefstop
9399 fontcan
9402 proc prefsok {} {
9403 global maxwidth maxgraphpct
9404 global oldprefs prefstop showneartags showlocalchanges
9405 global fontpref mainfont textfont uifont
9406 global limitdiffs treediffs
9408 catch {destroy $prefstop}
9409 unset prefstop
9410 fontcan
9411 set fontchanged 0
9412 if {$mainfont ne $fontpref(mainfont)} {
9413 set mainfont $fontpref(mainfont)
9414 parsefont mainfont $mainfont
9415 eval font configure mainfont [fontflags mainfont]
9416 eval font configure mainfontbold [fontflags mainfont 1]
9417 setcoords
9418 set fontchanged 1
9420 if {$textfont ne $fontpref(textfont)} {
9421 set textfont $fontpref(textfont)
9422 parsefont textfont $textfont
9423 eval font configure textfont [fontflags textfont]
9424 eval font configure textfontbold [fontflags textfont 1]
9426 if {$uifont ne $fontpref(uifont)} {
9427 set uifont $fontpref(uifont)
9428 parsefont uifont $uifont
9429 eval font configure uifont [fontflags uifont]
9431 settabs
9432 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9433 if {$showlocalchanges} {
9434 doshowlocalchanges
9435 } else {
9436 dohidelocalchanges
9439 if {$limitdiffs != $oldprefs(limitdiffs)} {
9440 # treediffs elements are limited by path
9441 catch {unset treediffs}
9443 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9444 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9445 redisplay
9446 } elseif {$showneartags != $oldprefs(showneartags) ||
9447 $limitdiffs != $oldprefs(limitdiffs)} {
9448 reselectline
9452 proc formatdate {d} {
9453 global datetimeformat
9454 if {$d ne {}} {
9455 set d [clock format $d -format $datetimeformat]
9457 return $d
9460 # This list of encoding names and aliases is distilled from
9461 # http://www.iana.org/assignments/character-sets.
9462 # Not all of them are supported by Tcl.
9463 set encoding_aliases {
9464 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9465 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9466 { ISO-10646-UTF-1 csISO10646UTF1 }
9467 { ISO_646.basic:1983 ref csISO646basic1983 }
9468 { INVARIANT csINVARIANT }
9469 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9470 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9471 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9472 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9473 { NATS-DANO iso-ir-9-1 csNATSDANO }
9474 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9475 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9476 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9477 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9478 { ISO-2022-KR csISO2022KR }
9479 { EUC-KR csEUCKR }
9480 { ISO-2022-JP csISO2022JP }
9481 { ISO-2022-JP-2 csISO2022JP2 }
9482 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9483 csISO13JISC6220jp }
9484 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9485 { IT iso-ir-15 ISO646-IT csISO15Italian }
9486 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9487 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9488 { greek7-old iso-ir-18 csISO18Greek7Old }
9489 { latin-greek iso-ir-19 csISO19LatinGreek }
9490 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9491 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9492 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9493 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9494 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9495 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9496 { INIS iso-ir-49 csISO49INIS }
9497 { INIS-8 iso-ir-50 csISO50INIS8 }
9498 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9499 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9500 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9501 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9502 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9503 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9504 csISO60Norwegian1 }
9505 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9506 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9507 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9508 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9509 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9510 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9511 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9512 { greek7 iso-ir-88 csISO88Greek7 }
9513 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9514 { iso-ir-90 csISO90 }
9515 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9516 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9517 csISO92JISC62991984b }
9518 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9519 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9520 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9521 csISO95JIS62291984handadd }
9522 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9523 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9524 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9525 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9526 CP819 csISOLatin1 }
9527 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9528 { T.61-7bit iso-ir-102 csISO102T617bit }
9529 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9530 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9531 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9532 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9533 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9534 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9535 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9536 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9537 arabic csISOLatinArabic }
9538 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9539 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9540 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9541 greek greek8 csISOLatinGreek }
9542 { T.101-G2 iso-ir-128 csISO128T101G2 }
9543 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9544 csISOLatinHebrew }
9545 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9546 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9547 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9548 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9549 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9550 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9551 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9552 csISOLatinCyrillic }
9553 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9554 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9555 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9556 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9557 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9558 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9559 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9560 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9561 { ISO_10367-box iso-ir-155 csISO10367Box }
9562 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9563 { latin-lap lap iso-ir-158 csISO158Lap }
9564 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9565 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9566 { us-dk csUSDK }
9567 { dk-us csDKUS }
9568 { JIS_X0201 X0201 csHalfWidthKatakana }
9569 { KSC5636 ISO646-KR csKSC5636 }
9570 { ISO-10646-UCS-2 csUnicode }
9571 { ISO-10646-UCS-4 csUCS4 }
9572 { DEC-MCS dec csDECMCS }
9573 { hp-roman8 roman8 r8 csHPRoman8 }
9574 { macintosh mac csMacintosh }
9575 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9576 csIBM037 }
9577 { IBM038 EBCDIC-INT cp038 csIBM038 }
9578 { IBM273 CP273 csIBM273 }
9579 { IBM274 EBCDIC-BE CP274 csIBM274 }
9580 { IBM275 EBCDIC-BR cp275 csIBM275 }
9581 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9582 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9583 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9584 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9585 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9586 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9587 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9588 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9589 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9590 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9591 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9592 { IBM437 cp437 437 csPC8CodePage437 }
9593 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9594 { IBM775 cp775 csPC775Baltic }
9595 { IBM850 cp850 850 csPC850Multilingual }
9596 { IBM851 cp851 851 csIBM851 }
9597 { IBM852 cp852 852 csPCp852 }
9598 { IBM855 cp855 855 csIBM855 }
9599 { IBM857 cp857 857 csIBM857 }
9600 { IBM860 cp860 860 csIBM860 }
9601 { IBM861 cp861 861 cp-is csIBM861 }
9602 { IBM862 cp862 862 csPC862LatinHebrew }
9603 { IBM863 cp863 863 csIBM863 }
9604 { IBM864 cp864 csIBM864 }
9605 { IBM865 cp865 865 csIBM865 }
9606 { IBM866 cp866 866 csIBM866 }
9607 { IBM868 CP868 cp-ar csIBM868 }
9608 { IBM869 cp869 869 cp-gr csIBM869 }
9609 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9610 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9611 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9612 { IBM891 cp891 csIBM891 }
9613 { IBM903 cp903 csIBM903 }
9614 { IBM904 cp904 904 csIBBM904 }
9615 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9616 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9617 { IBM1026 CP1026 csIBM1026 }
9618 { EBCDIC-AT-DE csIBMEBCDICATDE }
9619 { EBCDIC-AT-DE-A csEBCDICATDEA }
9620 { EBCDIC-CA-FR csEBCDICCAFR }
9621 { EBCDIC-DK-NO csEBCDICDKNO }
9622 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9623 { EBCDIC-FI-SE csEBCDICFISE }
9624 { EBCDIC-FI-SE-A csEBCDICFISEA }
9625 { EBCDIC-FR csEBCDICFR }
9626 { EBCDIC-IT csEBCDICIT }
9627 { EBCDIC-PT csEBCDICPT }
9628 { EBCDIC-ES csEBCDICES }
9629 { EBCDIC-ES-A csEBCDICESA }
9630 { EBCDIC-ES-S csEBCDICESS }
9631 { EBCDIC-UK csEBCDICUK }
9632 { EBCDIC-US csEBCDICUS }
9633 { UNKNOWN-8BIT csUnknown8BiT }
9634 { MNEMONIC csMnemonic }
9635 { MNEM csMnem }
9636 { VISCII csVISCII }
9637 { VIQR csVIQR }
9638 { KOI8-R csKOI8R }
9639 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9640 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9641 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9642 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9643 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9644 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9645 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9646 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9647 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9648 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9649 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9650 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9651 { IBM1047 IBM-1047 }
9652 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9653 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9654 { UNICODE-1-1 csUnicode11 }
9655 { CESU-8 csCESU-8 }
9656 { BOCU-1 csBOCU-1 }
9657 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9658 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9659 l8 }
9660 { ISO-8859-15 ISO_8859-15 Latin-9 }
9661 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9662 { GBK CP936 MS936 windows-936 }
9663 { JIS_Encoding csJISEncoding }
9664 { Shift_JIS MS_Kanji csShiftJIS }
9665 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9666 EUC-JP }
9667 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9668 { ISO-10646-UCS-Basic csUnicodeASCII }
9669 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9670 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9671 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9672 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9673 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9674 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9675 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9676 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9677 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9678 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9679 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9680 { Ventura-US csVenturaUS }
9681 { Ventura-International csVenturaInternational }
9682 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9683 { PC8-Turkish csPC8Turkish }
9684 { IBM-Symbols csIBMSymbols }
9685 { IBM-Thai csIBMThai }
9686 { HP-Legal csHPLegal }
9687 { HP-Pi-font csHPPiFont }
9688 { HP-Math8 csHPMath8 }
9689 { Adobe-Symbol-Encoding csHPPSMath }
9690 { HP-DeskTop csHPDesktop }
9691 { Ventura-Math csVenturaMath }
9692 { Microsoft-Publishing csMicrosoftPublishing }
9693 { Windows-31J csWindows31J }
9694 { GB2312 csGB2312 }
9695 { Big5 csBig5 }
9698 proc tcl_encoding {enc} {
9699 global encoding_aliases
9700 set names [encoding names]
9701 set lcnames [string tolower $names]
9702 set enc [string tolower $enc]
9703 set i [lsearch -exact $lcnames $enc]
9704 if {$i < 0} {
9705 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9706 if {[regsub {^iso[-_]} $enc iso encx]} {
9707 set i [lsearch -exact $lcnames $encx]
9710 if {$i < 0} {
9711 foreach l $encoding_aliases {
9712 set ll [string tolower $l]
9713 if {[lsearch -exact $ll $enc] < 0} continue
9714 # look through the aliases for one that tcl knows about
9715 foreach e $ll {
9716 set i [lsearch -exact $lcnames $e]
9717 if {$i < 0} {
9718 if {[regsub {^iso[-_]} $e iso ex]} {
9719 set i [lsearch -exact $lcnames $ex]
9722 if {$i >= 0} break
9724 break
9727 if {$i >= 0} {
9728 return [lindex $names $i]
9730 return {}
9733 # First check that Tcl/Tk is recent enough
9734 if {[catch {package require Tk 8.4} err]} {
9735 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9736 Gitk requires at least Tcl/Tk 8.4."]
9737 exit 1
9740 # defaults...
9741 set wrcomcmd "git diff-tree --stdin -p --pretty"
9743 set gitencoding {}
9744 catch {
9745 set gitencoding [exec git config --get i18n.commitencoding]
9747 if {$gitencoding == ""} {
9748 set gitencoding "utf-8"
9750 set tclencoding [tcl_encoding $gitencoding]
9751 if {$tclencoding == {}} {
9752 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9755 set mainfont {Helvetica 9}
9756 set textfont {Courier 9}
9757 set uifont {Helvetica 9 bold}
9758 set tabstop 8
9759 set findmergefiles 0
9760 set maxgraphpct 50
9761 set maxwidth 16
9762 set revlistorder 0
9763 set fastdate 0
9764 set uparrowlen 5
9765 set downarrowlen 5
9766 set mingaplen 100
9767 set cmitmode "patch"
9768 set wrapcomment "none"
9769 set showneartags 1
9770 set maxrefs 20
9771 set maxlinelen 200
9772 set showlocalchanges 1
9773 set limitdiffs 1
9774 set datetimeformat "%Y-%m-%d %H:%M:%S"
9775 set autoselect 1
9777 set extdifftool "meld"
9779 set colors {green red blue magenta darkgrey brown orange}
9780 set bgcolor white
9781 set fgcolor black
9782 set diffcolors {red "#00a000" blue}
9783 set diffcontext 3
9784 set ignorespace 0
9785 set selectbgcolor gray85
9787 set circlecolors {white blue gray blue blue}
9789 ## For msgcat loading, first locate the installation location.
9790 if { [info exists ::env(GITK_MSGSDIR)] } {
9791 ## Msgsdir was manually set in the environment.
9792 set gitk_msgsdir $::env(GITK_MSGSDIR)
9793 } else {
9794 ## Let's guess the prefix from argv0.
9795 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9796 set gitk_libdir [file join $gitk_prefix share gitk lib]
9797 set gitk_msgsdir [file join $gitk_libdir msgs]
9798 unset gitk_prefix
9801 ## Internationalization (i18n) through msgcat and gettext. See
9802 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9803 package require msgcat
9804 namespace import ::msgcat::mc
9805 ## And eventually load the actual message catalog
9806 ::msgcat::mcload $gitk_msgsdir
9808 catch {source ~/.gitk}
9810 font create optionfont -family sans-serif -size -12
9812 parsefont mainfont $mainfont
9813 eval font create mainfont [fontflags mainfont]
9814 eval font create mainfontbold [fontflags mainfont 1]
9816 parsefont textfont $textfont
9817 eval font create textfont [fontflags textfont]
9818 eval font create textfontbold [fontflags textfont 1]
9820 parsefont uifont $uifont
9821 eval font create uifont [fontflags uifont]
9823 setoptions
9825 # check that we can find a .git directory somewhere...
9826 if {[catch {set gitdir [gitdir]}]} {
9827 show_error {} . [mc "Cannot find a git repository here."]
9828 exit 1
9830 if {![file isdirectory $gitdir]} {
9831 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9832 exit 1
9835 set revtreeargs {}
9836 set cmdline_files {}
9837 set i 0
9838 set revtreeargscmd {}
9839 foreach arg $argv {
9840 switch -glob -- $arg {
9841 "" { }
9842 "--" {
9843 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9844 break
9846 "--argscmd=*" {
9847 set revtreeargscmd [string range $arg 10 end]
9849 default {
9850 lappend revtreeargs $arg
9853 incr i
9856 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9857 # no -- on command line, but some arguments (other than --argscmd)
9858 if {[catch {
9859 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9860 set cmdline_files [split $f "\n"]
9861 set n [llength $cmdline_files]
9862 set revtreeargs [lrange $revtreeargs 0 end-$n]
9863 # Unfortunately git rev-parse doesn't produce an error when
9864 # something is both a revision and a filename. To be consistent
9865 # with git log and git rev-list, check revtreeargs for filenames.
9866 foreach arg $revtreeargs {
9867 if {[file exists $arg]} {
9868 show_error {} . [mc "Ambiguous argument '%s': both revision\
9869 and filename" $arg]
9870 exit 1
9873 } err]} {
9874 # unfortunately we get both stdout and stderr in $err,
9875 # so look for "fatal:".
9876 set i [string first "fatal:" $err]
9877 if {$i > 0} {
9878 set err [string range $err [expr {$i + 6}] end]
9880 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9881 exit 1
9885 set nullid "0000000000000000000000000000000000000000"
9886 set nullid2 "0000000000000000000000000000000000000001"
9887 set nullfile "/dev/null"
9889 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9891 set runq {}
9892 set history {}
9893 set historyindex 0
9894 set fh_serial 0
9895 set nhl_names {}
9896 set highlight_paths {}
9897 set findpattern {}
9898 set searchdirn -forwards
9899 set boldrows {}
9900 set boldnamerows {}
9901 set diffelide {0 0}
9902 set markingmatches 0
9903 set linkentercount 0
9904 set need_redisplay 0
9905 set nrows_drawn 0
9906 set firsttabstop 0
9908 set nextviewnum 1
9909 set curview 0
9910 set selectedview 0
9911 set selectedhlview [mc "None"]
9912 set highlight_related [mc "None"]
9913 set highlight_files {}
9914 set viewfiles(0) {}
9915 set viewperm(0) 0
9916 set viewargs(0) {}
9917 set viewargscmd(0) {}
9919 set selectedline {}
9920 set numcommits 0
9921 set loginstance 0
9922 set cmdlineok 0
9923 set stopped 0
9924 set stuffsaved 0
9925 set patchnum 0
9926 set lserial 0
9927 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9928 setcoords
9929 makewindow
9930 # wait for the window to become visible
9931 tkwait visibility .
9932 wm title . "[file tail $argv0]: [file tail [pwd]]"
9933 readrefs
9935 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9936 # create a view for the files/dirs specified on the command line
9937 set curview 1
9938 set selectedview 1
9939 set nextviewnum 2
9940 set viewname(1) [mc "Command line"]
9941 set viewfiles(1) $cmdline_files
9942 set viewargs(1) $revtreeargs
9943 set viewargscmd(1) $revtreeargscmd
9944 set viewperm(1) 0
9945 set vdatemode(1) 0
9946 addviewmenu 1
9947 .bar.view entryconf [mc "Edit view..."] -state normal
9948 .bar.view entryconf [mc "Delete view"] -state normal
9951 if {[info exists permviews]} {
9952 foreach v $permviews {
9953 set n $nextviewnum
9954 incr nextviewnum
9955 set viewname($n) [lindex $v 0]
9956 set viewfiles($n) [lindex $v 1]
9957 set viewargs($n) [lindex $v 2]
9958 set viewargscmd($n) [lindex $v 3]
9959 set viewperm($n) 1
9960 addviewmenu $n
9963 getcommits