gitk: Fix file list context menu for merge commits
[git/gitweb.git] / gitk
blobf6a3e10d8ee6084c81d284234c61cb92b830e523
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq currunq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {} && ![info exists currunq]} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq currunq
43 fileevent $fd readable {}
44 if {$runq eq {} && ![info exists currunq]} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq currunq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set currunq [lindex $runq 0]
71 set runq [lrange $runq 1 end]
72 set repeat [eval $script]
73 unset currunq
74 set t1 [clock clicks -milliseconds]
75 set t [expr {$t1 - $t0}]
76 if {$repeat ne {} && $repeat} {
77 if {$fd eq {} || $repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq [list $fd $script]
81 } else {
82 fileevent $fd readable [list filereadable $fd $script]
84 } elseif {$fd eq {}} {
85 unset isonrunq($script)
87 set t0 $t1
88 if {$t1 - $tstart >= 80} break
90 if {$runq ne {}} {
91 after idle dorunq
95 proc reg_instance {fd} {
96 global commfd leftover loginstance
98 set i [incr loginstance]
99 set commfd($i) $fd
100 set leftover($i) {}
101 return $i
104 proc unmerged_files {files} {
105 global nr_unmerged
107 # find the list of unmerged files
108 set mlist {}
109 set nr_unmerged 0
110 if {[catch {
111 set fd [open "| git ls-files -u" r]
112 } err]} {
113 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
114 exit 1
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
118 if {$i < 0} continue
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
121 incr nr_unmerged
122 if {$files eq {} || [path_filter $files $fname]} {
123 lappend mlist $fname
126 catch {close $fd}
127 return $mlist
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
133 set vdatemode($n) 0
134 set vmergeonly($n) 0
135 set glflags {}
136 set diffargs {}
137 set nextisval 0
138 set revargs {}
139 set origargs $arglist
140 set allknown 1
141 set filtered 0
142 set i -1
143 foreach arg $arglist {
144 incr i
145 if {$nextisval} {
146 lappend glflags $arg
147 set nextisval 0
148 continue
150 switch -glob -- $arg {
151 "-d" -
152 "--date-order" {
153 set vdatemode($n) 1
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
156 incr i -1
158 # These request or affect diff output, which we don't want.
159 # Some could be used to set our defaults for diff display.
160 "-[puabwcrRBMC]" -
161 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165 "--ignore-space-change" - "-U*" - "--unified=*" {
166 lappend diffargs $arg
168 # These cause our parsing of git log's output to fail, or else
169 # they're options we want to set ourselves, so ignore them.
170 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171 "--name-only" - "--name-status" - "--color" - "--color-words" -
172 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176 "--objects" - "--objects-edge" - "--reverse" {
178 # These are harmless, and some are even useful
179 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
180 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
181 "--full-history" - "--dense" - "--sparse" -
182 "--follow" - "--left-right" - "--encoding=*" {
183 lappend glflags $arg
185 # These mean that we get a subset of the commits
186 "--diff-filter=*" - "--no-merges" - "--unpacked" -
187 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
188 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
189 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
190 "--remove-empty" - "--first-parent" - "--cherry-pick" -
191 "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
192 set filtered 1
193 lappend glflags $arg
195 # This appears to be the only one that has a value as a
196 # separate word following it
197 "-n" {
198 set filtered 1
199 set nextisval 1
200 lappend glflags $arg
202 "--not" {
203 set notflag [expr {!$notflag}]
204 lappend revargs $arg
206 "--all" {
207 lappend revargs $arg
209 "--merge" {
210 set vmergeonly($n) 1
211 # git rev-parse doesn't understand --merge
212 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
214 # Other flag arguments including -<n>
215 "-*" {
216 if {[string is digit -strict [string range $arg 1 end]]} {
217 set filtered 1
218 } else {
219 # a flag argument that we don't recognize;
220 # that means we can't optimize
221 set allknown 0
223 lappend glflags $arg
225 # Non-flag arguments specify commits or ranges of commits
226 default {
227 if {[string match "*...*" $arg]} {
228 lappend revargs --gitk-symmetric-diff-marker
230 lappend revargs $arg
234 set vdflags($n) $diffargs
235 set vflags($n) $glflags
236 set vrevs($n) $revargs
237 set vfiltered($n) $filtered
238 set vorigargs($n) $origargs
239 return $allknown
242 proc parseviewrevs {view revs} {
243 global vposids vnegids
245 if {$revs eq {}} {
246 set revs HEAD
248 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
249 # we get stdout followed by stderr in $err
250 # for an unknown rev, git rev-parse echoes it and then errors out
251 set errlines [split $err "\n"]
252 set badrev {}
253 for {set l 0} {$l < [llength $errlines]} {incr l} {
254 set line [lindex $errlines $l]
255 if {!([string length $line] == 40 && [string is xdigit $line])} {
256 if {[string match "fatal:*" $line]} {
257 if {[string match "fatal: ambiguous argument*" $line]
258 && $badrev ne {}} {
259 if {[llength $badrev] == 1} {
260 set err "unknown revision $badrev"
261 } else {
262 set err "unknown revisions: [join $badrev ", "]"
264 } else {
265 set err [join [lrange $errlines $l end] "\n"]
267 break
269 lappend badrev $line
272 error_popup "[mc "Error parsing revisions:"] $err"
273 return {}
275 set ret {}
276 set pos {}
277 set neg {}
278 set sdm 0
279 foreach id [split $ids "\n"] {
280 if {$id eq "--gitk-symmetric-diff-marker"} {
281 set sdm 4
282 } elseif {[string match "^*" $id]} {
283 if {$sdm != 1} {
284 lappend ret $id
285 if {$sdm == 3} {
286 set sdm 0
289 lappend neg [string range $id 1 end]
290 } else {
291 if {$sdm != 2} {
292 lappend ret $id
293 } else {
294 lset ret end [lindex $ret end]...$id
296 lappend pos $id
298 incr sdm -1
300 set vposids($view) $pos
301 set vnegids($view) $neg
302 return $ret
305 # Start off a git log process and arrange to read its output
306 proc start_rev_list {view} {
307 global startmsecs commitidx viewcomplete curview
308 global tclencoding
309 global viewargs viewargscmd viewfiles vfilelimit
310 global showlocalchanges
311 global viewactive viewinstances vmergeonly
312 global mainheadid
313 global vcanopt vflags vrevs vorigargs
315 set startmsecs [clock clicks -milliseconds]
316 set commitidx($view) 0
317 # these are set this way for the error exits
318 set viewcomplete($view) 1
319 set viewactive($view) 0
320 varcinit $view
322 set args $viewargs($view)
323 if {$viewargscmd($view) ne {}} {
324 if {[catch {
325 set str [exec sh -c $viewargscmd($view)]
326 } err]} {
327 error_popup "[mc "Error executing --argscmd command:"] $err"
328 return 0
330 set args [concat $args [split $str "\n"]]
332 set vcanopt($view) [parseviewargs $view $args]
334 set files $viewfiles($view)
335 if {$vmergeonly($view)} {
336 set files [unmerged_files $files]
337 if {$files eq {}} {
338 global nr_unmerged
339 if {$nr_unmerged == 0} {
340 error_popup [mc "No files selected: --merge specified but\
341 no files are unmerged."]
342 } else {
343 error_popup [mc "No files selected: --merge specified but\
344 no unmerged files are within file limit."]
346 return 0
349 set vfilelimit($view) $files
351 if {$vcanopt($view)} {
352 set revs [parseviewrevs $view $vrevs($view)]
353 if {$revs eq {}} {
354 return 0
356 set args [concat $vflags($view) $revs]
357 } else {
358 set args $vorigargs($view)
361 if {[catch {
362 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
363 --boundary $args "--" $files] r]
364 } err]} {
365 error_popup "[mc "Error executing git log:"] $err"
366 return 0
368 set i [reg_instance $fd]
369 set viewinstances($view) [list $i]
370 if {$showlocalchanges && $mainheadid ne {}} {
371 interestedin $mainheadid dodiffindex
373 fconfigure $fd -blocking 0 -translation lf -eofchar {}
374 if {$tclencoding != {}} {
375 fconfigure $fd -encoding $tclencoding
377 filerun $fd [list getcommitlines $fd $i $view 0]
378 nowbusy $view [mc "Reading"]
379 set viewcomplete($view) 0
380 set viewactive($view) 1
381 return 1
384 proc stop_instance {inst} {
385 global commfd leftover
387 set fd $commfd($inst)
388 catch {
389 set pid [pid $fd]
391 if {$::tcl_platform(platform) eq {windows}} {
392 exec kill -f $pid
393 } else {
394 exec kill $pid
397 catch {close $fd}
398 nukefile $fd
399 unset commfd($inst)
400 unset leftover($inst)
403 proc stop_backends {} {
404 global commfd
406 foreach inst [array names commfd] {
407 stop_instance $inst
411 proc stop_rev_list {view} {
412 global viewinstances
414 foreach inst $viewinstances($view) {
415 stop_instance $inst
417 set viewinstances($view) {}
420 proc reset_pending_select {selid} {
421 global pending_select mainheadid selectheadid
423 if {$selid ne {}} {
424 set pending_select $selid
425 } elseif {$selectheadid ne {}} {
426 set pending_select $selectheadid
427 } else {
428 set pending_select $mainheadid
432 proc getcommits {selid} {
433 global canv curview need_redisplay viewactive
435 initlayout
436 if {[start_rev_list $curview]} {
437 reset_pending_select $selid
438 show_status [mc "Reading commits..."]
439 set need_redisplay 1
440 } else {
441 show_status [mc "No commits selected"]
445 proc updatecommits {} {
446 global curview vcanopt vorigargs vfilelimit viewinstances
447 global viewactive viewcomplete tclencoding
448 global startmsecs showneartags showlocalchanges
449 global mainheadid pending_select
450 global isworktree
451 global varcid vposids vnegids vflags vrevs
453 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
454 set oldmainid $mainheadid
455 rereadrefs
456 if {$showlocalchanges} {
457 if {$mainheadid ne $oldmainid} {
458 dohidelocalchanges
460 if {[commitinview $mainheadid $curview]} {
461 dodiffindex
464 set view $curview
465 if {$vcanopt($view)} {
466 set oldpos $vposids($view)
467 set oldneg $vnegids($view)
468 set revs [parseviewrevs $view $vrevs($view)]
469 if {$revs eq {}} {
470 return
472 # note: getting the delta when negative refs change is hard,
473 # and could require multiple git log invocations, so in that
474 # case we ask git log for all the commits (not just the delta)
475 if {$oldneg eq $vnegids($view)} {
476 set newrevs {}
477 set npos 0
478 # take out positive refs that we asked for before or
479 # that we have already seen
480 foreach rev $revs {
481 if {[string length $rev] == 40} {
482 if {[lsearch -exact $oldpos $rev] < 0
483 && ![info exists varcid($view,$rev)]} {
484 lappend newrevs $rev
485 incr npos
487 } else {
488 lappend $newrevs $rev
491 if {$npos == 0} return
492 set revs $newrevs
493 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
495 set args [concat $vflags($view) $revs --not $oldpos]
496 } else {
497 set args $vorigargs($view)
499 if {[catch {
500 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
501 --boundary $args "--" $vfilelimit($view)] r]
502 } err]} {
503 error_popup "[mc "Error executing git log:"] $err"
504 return
506 if {$viewactive($view) == 0} {
507 set startmsecs [clock clicks -milliseconds]
509 set i [reg_instance $fd]
510 lappend viewinstances($view) $i
511 fconfigure $fd -blocking 0 -translation lf -eofchar {}
512 if {$tclencoding != {}} {
513 fconfigure $fd -encoding $tclencoding
515 filerun $fd [list getcommitlines $fd $i $view 1]
516 incr viewactive($view)
517 set viewcomplete($view) 0
518 reset_pending_select {}
519 nowbusy $view "Reading"
520 if {$showneartags} {
521 getallcommits
525 proc reloadcommits {} {
526 global curview viewcomplete selectedline currentid thickerline
527 global showneartags treediffs commitinterest cached_commitrow
528 global targetid
530 set selid {}
531 if {$selectedline ne {}} {
532 set selid $currentid
535 if {!$viewcomplete($curview)} {
536 stop_rev_list $curview
538 resetvarcs $curview
539 set selectedline {}
540 catch {unset currentid}
541 catch {unset thickerline}
542 catch {unset treediffs}
543 readrefs
544 changedrefs
545 if {$showneartags} {
546 getallcommits
548 clear_display
549 catch {unset commitinterest}
550 catch {unset cached_commitrow}
551 catch {unset targetid}
552 setcanvscroll
553 getcommits $selid
554 return 0
557 # This makes a string representation of a positive integer which
558 # sorts as a string in numerical order
559 proc strrep {n} {
560 if {$n < 16} {
561 return [format "%x" $n]
562 } elseif {$n < 256} {
563 return [format "x%.2x" $n]
564 } elseif {$n < 65536} {
565 return [format "y%.4x" $n]
567 return [format "z%.8x" $n]
570 # Procedures used in reordering commits from git log (without
571 # --topo-order) into the order for display.
573 proc varcinit {view} {
574 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
575 global vtokmod varcmod vrowmod varcix vlastins
577 set varcstart($view) {{}}
578 set vupptr($view) {0}
579 set vdownptr($view) {0}
580 set vleftptr($view) {0}
581 set vbackptr($view) {0}
582 set varctok($view) {{}}
583 set varcrow($view) {{}}
584 set vtokmod($view) {}
585 set varcmod($view) 0
586 set vrowmod($view) 0
587 set varcix($view) {{}}
588 set vlastins($view) {0}
591 proc resetvarcs {view} {
592 global varcid varccommits parents children vseedcount ordertok
594 foreach vid [array names varcid $view,*] {
595 unset varcid($vid)
596 unset children($vid)
597 unset parents($vid)
599 # some commits might have children but haven't been seen yet
600 foreach vid [array names children $view,*] {
601 unset children($vid)
603 foreach va [array names varccommits $view,*] {
604 unset varccommits($va)
606 foreach vd [array names vseedcount $view,*] {
607 unset vseedcount($vd)
609 catch {unset ordertok}
612 # returns a list of the commits with no children
613 proc seeds {v} {
614 global vdownptr vleftptr varcstart
616 set ret {}
617 set a [lindex $vdownptr($v) 0]
618 while {$a != 0} {
619 lappend ret [lindex $varcstart($v) $a]
620 set a [lindex $vleftptr($v) $a]
622 return $ret
625 proc newvarc {view id} {
626 global varcid varctok parents children vdatemode
627 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
628 global commitdata commitinfo vseedcount varccommits vlastins
630 set a [llength $varctok($view)]
631 set vid $view,$id
632 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
633 if {![info exists commitinfo($id)]} {
634 parsecommit $id $commitdata($id) 1
636 set cdate [lindex $commitinfo($id) 4]
637 if {![string is integer -strict $cdate]} {
638 set cdate 0
640 if {![info exists vseedcount($view,$cdate)]} {
641 set vseedcount($view,$cdate) -1
643 set c [incr vseedcount($view,$cdate)]
644 set cdate [expr {$cdate ^ 0xffffffff}]
645 set tok "s[strrep $cdate][strrep $c]"
646 } else {
647 set tok {}
649 set ka 0
650 if {[llength $children($vid)] > 0} {
651 set kid [lindex $children($vid) end]
652 set k $varcid($view,$kid)
653 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
654 set ki $kid
655 set ka $k
656 set tok [lindex $varctok($view) $k]
659 if {$ka != 0} {
660 set i [lsearch -exact $parents($view,$ki) $id]
661 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
662 append tok [strrep $j]
664 set c [lindex $vlastins($view) $ka]
665 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
666 set c $ka
667 set b [lindex $vdownptr($view) $ka]
668 } else {
669 set b [lindex $vleftptr($view) $c]
671 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
672 set c $b
673 set b [lindex $vleftptr($view) $c]
675 if {$c == $ka} {
676 lset vdownptr($view) $ka $a
677 lappend vbackptr($view) 0
678 } else {
679 lset vleftptr($view) $c $a
680 lappend vbackptr($view) $c
682 lset vlastins($view) $ka $a
683 lappend vupptr($view) $ka
684 lappend vleftptr($view) $b
685 if {$b != 0} {
686 lset vbackptr($view) $b $a
688 lappend varctok($view) $tok
689 lappend varcstart($view) $id
690 lappend vdownptr($view) 0
691 lappend varcrow($view) {}
692 lappend varcix($view) {}
693 set varccommits($view,$a) {}
694 lappend vlastins($view) 0
695 return $a
698 proc splitvarc {p v} {
699 global varcid varcstart varccommits varctok
700 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
702 set oa $varcid($v,$p)
703 set ac $varccommits($v,$oa)
704 set i [lsearch -exact $varccommits($v,$oa) $p]
705 if {$i <= 0} return
706 set na [llength $varctok($v)]
707 # "%" sorts before "0"...
708 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
709 lappend varctok($v) $tok
710 lappend varcrow($v) {}
711 lappend varcix($v) {}
712 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
713 set varccommits($v,$na) [lrange $ac $i end]
714 lappend varcstart($v) $p
715 foreach id $varccommits($v,$na) {
716 set varcid($v,$id) $na
718 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
719 lappend vlastins($v) [lindex $vlastins($v) $oa]
720 lset vdownptr($v) $oa $na
721 lset vlastins($v) $oa 0
722 lappend vupptr($v) $oa
723 lappend vleftptr($v) 0
724 lappend vbackptr($v) 0
725 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
726 lset vupptr($v) $b $na
730 proc renumbervarc {a v} {
731 global parents children varctok varcstart varccommits
732 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
734 set t1 [clock clicks -milliseconds]
735 set todo {}
736 set isrelated($a) 1
737 set kidchanged($a) 1
738 set ntot 0
739 while {$a != 0} {
740 if {[info exists isrelated($a)]} {
741 lappend todo $a
742 set id [lindex $varccommits($v,$a) end]
743 foreach p $parents($v,$id) {
744 if {[info exists varcid($v,$p)]} {
745 set isrelated($varcid($v,$p)) 1
749 incr ntot
750 set b [lindex $vdownptr($v) $a]
751 if {$b == 0} {
752 while {$a != 0} {
753 set b [lindex $vleftptr($v) $a]
754 if {$b != 0} break
755 set a [lindex $vupptr($v) $a]
758 set a $b
760 foreach a $todo {
761 if {![info exists kidchanged($a)]} continue
762 set id [lindex $varcstart($v) $a]
763 if {[llength $children($v,$id)] > 1} {
764 set children($v,$id) [lsort -command [list vtokcmp $v] \
765 $children($v,$id)]
767 set oldtok [lindex $varctok($v) $a]
768 if {!$vdatemode($v)} {
769 set tok {}
770 } else {
771 set tok $oldtok
773 set ka 0
774 set kid [last_real_child $v,$id]
775 if {$kid ne {}} {
776 set k $varcid($v,$kid)
777 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
778 set ki $kid
779 set ka $k
780 set tok [lindex $varctok($v) $k]
783 if {$ka != 0} {
784 set i [lsearch -exact $parents($v,$ki) $id]
785 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
786 append tok [strrep $j]
788 if {$tok eq $oldtok} {
789 continue
791 set id [lindex $varccommits($v,$a) end]
792 foreach p $parents($v,$id) {
793 if {[info exists varcid($v,$p)]} {
794 set kidchanged($varcid($v,$p)) 1
795 } else {
796 set sortkids($p) 1
799 lset varctok($v) $a $tok
800 set b [lindex $vupptr($v) $a]
801 if {$b != $ka} {
802 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
803 modify_arc $v $ka
805 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
806 modify_arc $v $b
808 set c [lindex $vbackptr($v) $a]
809 set d [lindex $vleftptr($v) $a]
810 if {$c == 0} {
811 lset vdownptr($v) $b $d
812 } else {
813 lset vleftptr($v) $c $d
815 if {$d != 0} {
816 lset vbackptr($v) $d $c
818 if {[lindex $vlastins($v) $b] == $a} {
819 lset vlastins($v) $b $c
821 lset vupptr($v) $a $ka
822 set c [lindex $vlastins($v) $ka]
823 if {$c == 0 || \
824 [string compare $tok [lindex $varctok($v) $c]] < 0} {
825 set c $ka
826 set b [lindex $vdownptr($v) $ka]
827 } else {
828 set b [lindex $vleftptr($v) $c]
830 while {$b != 0 && \
831 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
832 set c $b
833 set b [lindex $vleftptr($v) $c]
835 if {$c == $ka} {
836 lset vdownptr($v) $ka $a
837 lset vbackptr($v) $a 0
838 } else {
839 lset vleftptr($v) $c $a
840 lset vbackptr($v) $a $c
842 lset vleftptr($v) $a $b
843 if {$b != 0} {
844 lset vbackptr($v) $b $a
846 lset vlastins($v) $ka $a
849 foreach id [array names sortkids] {
850 if {[llength $children($v,$id)] > 1} {
851 set children($v,$id) [lsort -command [list vtokcmp $v] \
852 $children($v,$id)]
855 set t2 [clock clicks -milliseconds]
856 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
859 # Fix up the graph after we have found out that in view $v,
860 # $p (a commit that we have already seen) is actually the parent
861 # of the last commit in arc $a.
862 proc fix_reversal {p a v} {
863 global varcid varcstart varctok vupptr
865 set pa $varcid($v,$p)
866 if {$p ne [lindex $varcstart($v) $pa]} {
867 splitvarc $p $v
868 set pa $varcid($v,$p)
870 # seeds always need to be renumbered
871 if {[lindex $vupptr($v) $pa] == 0 ||
872 [string compare [lindex $varctok($v) $a] \
873 [lindex $varctok($v) $pa]] > 0} {
874 renumbervarc $pa $v
878 proc insertrow {id p v} {
879 global cmitlisted children parents varcid varctok vtokmod
880 global varccommits ordertok commitidx numcommits curview
881 global targetid targetrow
883 readcommit $id
884 set vid $v,$id
885 set cmitlisted($vid) 1
886 set children($vid) {}
887 set parents($vid) [list $p]
888 set a [newvarc $v $id]
889 set varcid($vid) $a
890 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
891 modify_arc $v $a
893 lappend varccommits($v,$a) $id
894 set vp $v,$p
895 if {[llength [lappend children($vp) $id]] > 1} {
896 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
897 catch {unset ordertok}
899 fix_reversal $p $a $v
900 incr commitidx($v)
901 if {$v == $curview} {
902 set numcommits $commitidx($v)
903 setcanvscroll
904 if {[info exists targetid]} {
905 if {![comes_before $targetid $p]} {
906 incr targetrow
912 proc insertfakerow {id p} {
913 global varcid varccommits parents children cmitlisted
914 global commitidx varctok vtokmod targetid targetrow curview numcommits
916 set v $curview
917 set a $varcid($v,$p)
918 set i [lsearch -exact $varccommits($v,$a) $p]
919 if {$i < 0} {
920 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
921 return
923 set children($v,$id) {}
924 set parents($v,$id) [list $p]
925 set varcid($v,$id) $a
926 lappend children($v,$p) $id
927 set cmitlisted($v,$id) 1
928 set numcommits [incr commitidx($v)]
929 # note we deliberately don't update varcstart($v) even if $i == 0
930 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
931 modify_arc $v $a $i
932 if {[info exists targetid]} {
933 if {![comes_before $targetid $p]} {
934 incr targetrow
937 setcanvscroll
938 drawvisible
941 proc removefakerow {id} {
942 global varcid varccommits parents children commitidx
943 global varctok vtokmod cmitlisted currentid selectedline
944 global targetid curview numcommits
946 set v $curview
947 if {[llength $parents($v,$id)] != 1} {
948 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
949 return
951 set p [lindex $parents($v,$id) 0]
952 set a $varcid($v,$id)
953 set i [lsearch -exact $varccommits($v,$a) $id]
954 if {$i < 0} {
955 puts "oops: removefakerow can't find [shortids $id] on arc $a"
956 return
958 unset varcid($v,$id)
959 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
960 unset parents($v,$id)
961 unset children($v,$id)
962 unset cmitlisted($v,$id)
963 set numcommits [incr commitidx($v) -1]
964 set j [lsearch -exact $children($v,$p) $id]
965 if {$j >= 0} {
966 set children($v,$p) [lreplace $children($v,$p) $j $j]
968 modify_arc $v $a $i
969 if {[info exist currentid] && $id eq $currentid} {
970 unset currentid
971 set selectedline {}
973 if {[info exists targetid] && $targetid eq $id} {
974 set targetid $p
976 setcanvscroll
977 drawvisible
980 proc first_real_child {vp} {
981 global children nullid nullid2
983 foreach id $children($vp) {
984 if {$id ne $nullid && $id ne $nullid2} {
985 return $id
988 return {}
991 proc last_real_child {vp} {
992 global children nullid nullid2
994 set kids $children($vp)
995 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
996 set id [lindex $kids $i]
997 if {$id ne $nullid && $id ne $nullid2} {
998 return $id
1001 return {}
1004 proc vtokcmp {v a b} {
1005 global varctok varcid
1007 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1008 [lindex $varctok($v) $varcid($v,$b)]]
1011 # This assumes that if lim is not given, the caller has checked that
1012 # arc a's token is less than $vtokmod($v)
1013 proc modify_arc {v a {lim {}}} {
1014 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1016 if {$lim ne {}} {
1017 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1018 if {$c > 0} return
1019 if {$c == 0} {
1020 set r [lindex $varcrow($v) $a]
1021 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1024 set vtokmod($v) [lindex $varctok($v) $a]
1025 set varcmod($v) $a
1026 if {$v == $curview} {
1027 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1028 set a [lindex $vupptr($v) $a]
1029 set lim {}
1031 set r 0
1032 if {$a != 0} {
1033 if {$lim eq {}} {
1034 set lim [llength $varccommits($v,$a)]
1036 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1038 set vrowmod($v) $r
1039 undolayout $r
1043 proc update_arcrows {v} {
1044 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1045 global varcid vrownum varcorder varcix varccommits
1046 global vupptr vdownptr vleftptr varctok
1047 global displayorder parentlist curview cached_commitrow
1049 if {$vrowmod($v) == $commitidx($v)} return
1050 if {$v == $curview} {
1051 if {[llength $displayorder] > $vrowmod($v)} {
1052 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1053 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1055 catch {unset cached_commitrow}
1057 set narctot [expr {[llength $varctok($v)] - 1}]
1058 set a $varcmod($v)
1059 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1060 # go up the tree until we find something that has a row number,
1061 # or we get to a seed
1062 set a [lindex $vupptr($v) $a]
1064 if {$a == 0} {
1065 set a [lindex $vdownptr($v) 0]
1066 if {$a == 0} return
1067 set vrownum($v) {0}
1068 set varcorder($v) [list $a]
1069 lset varcix($v) $a 0
1070 lset varcrow($v) $a 0
1071 set arcn 0
1072 set row 0
1073 } else {
1074 set arcn [lindex $varcix($v) $a]
1075 if {[llength $vrownum($v)] > $arcn + 1} {
1076 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1077 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1079 set row [lindex $varcrow($v) $a]
1081 while {1} {
1082 set p $a
1083 incr row [llength $varccommits($v,$a)]
1084 # go down if possible
1085 set b [lindex $vdownptr($v) $a]
1086 if {$b == 0} {
1087 # if not, go left, or go up until we can go left
1088 while {$a != 0} {
1089 set b [lindex $vleftptr($v) $a]
1090 if {$b != 0} break
1091 set a [lindex $vupptr($v) $a]
1093 if {$a == 0} break
1095 set a $b
1096 incr arcn
1097 lappend vrownum($v) $row
1098 lappend varcorder($v) $a
1099 lset varcix($v) $a $arcn
1100 lset varcrow($v) $a $row
1102 set vtokmod($v) [lindex $varctok($v) $p]
1103 set varcmod($v) $p
1104 set vrowmod($v) $row
1105 if {[info exists currentid]} {
1106 set selectedline [rowofcommit $currentid]
1110 # Test whether view $v contains commit $id
1111 proc commitinview {id v} {
1112 global varcid
1114 return [info exists varcid($v,$id)]
1117 # Return the row number for commit $id in the current view
1118 proc rowofcommit {id} {
1119 global varcid varccommits varcrow curview cached_commitrow
1120 global varctok vtokmod
1122 set v $curview
1123 if {![info exists varcid($v,$id)]} {
1124 puts "oops rowofcommit no arc for [shortids $id]"
1125 return {}
1127 set a $varcid($v,$id)
1128 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1129 update_arcrows $v
1131 if {[info exists cached_commitrow($id)]} {
1132 return $cached_commitrow($id)
1134 set i [lsearch -exact $varccommits($v,$a) $id]
1135 if {$i < 0} {
1136 puts "oops didn't find commit [shortids $id] in arc $a"
1137 return {}
1139 incr i [lindex $varcrow($v) $a]
1140 set cached_commitrow($id) $i
1141 return $i
1144 # Returns 1 if a is on an earlier row than b, otherwise 0
1145 proc comes_before {a b} {
1146 global varcid varctok curview
1148 set v $curview
1149 if {$a eq $b || ![info exists varcid($v,$a)] || \
1150 ![info exists varcid($v,$b)]} {
1151 return 0
1153 if {$varcid($v,$a) != $varcid($v,$b)} {
1154 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1155 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1157 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1160 proc bsearch {l elt} {
1161 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1162 return 0
1164 set lo 0
1165 set hi [llength $l]
1166 while {$hi - $lo > 1} {
1167 set mid [expr {int(($lo + $hi) / 2)}]
1168 set t [lindex $l $mid]
1169 if {$elt < $t} {
1170 set hi $mid
1171 } elseif {$elt > $t} {
1172 set lo $mid
1173 } else {
1174 return $mid
1177 return $lo
1180 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1181 proc make_disporder {start end} {
1182 global vrownum curview commitidx displayorder parentlist
1183 global varccommits varcorder parents vrowmod varcrow
1184 global d_valid_start d_valid_end
1186 if {$end > $vrowmod($curview)} {
1187 update_arcrows $curview
1189 set ai [bsearch $vrownum($curview) $start]
1190 set start [lindex $vrownum($curview) $ai]
1191 set narc [llength $vrownum($curview)]
1192 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1193 set a [lindex $varcorder($curview) $ai]
1194 set l [llength $displayorder]
1195 set al [llength $varccommits($curview,$a)]
1196 if {$l < $r + $al} {
1197 if {$l < $r} {
1198 set pad [ntimes [expr {$r - $l}] {}]
1199 set displayorder [concat $displayorder $pad]
1200 set parentlist [concat $parentlist $pad]
1201 } elseif {$l > $r} {
1202 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1203 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1205 foreach id $varccommits($curview,$a) {
1206 lappend displayorder $id
1207 lappend parentlist $parents($curview,$id)
1209 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1210 set i $r
1211 foreach id $varccommits($curview,$a) {
1212 lset displayorder $i $id
1213 lset parentlist $i $parents($curview,$id)
1214 incr i
1217 incr r $al
1221 proc commitonrow {row} {
1222 global displayorder
1224 set id [lindex $displayorder $row]
1225 if {$id eq {}} {
1226 make_disporder $row [expr {$row + 1}]
1227 set id [lindex $displayorder $row]
1229 return $id
1232 proc closevarcs {v} {
1233 global varctok varccommits varcid parents children
1234 global cmitlisted commitidx vtokmod
1236 set missing_parents 0
1237 set scripts {}
1238 set narcs [llength $varctok($v)]
1239 for {set a 1} {$a < $narcs} {incr a} {
1240 set id [lindex $varccommits($v,$a) end]
1241 foreach p $parents($v,$id) {
1242 if {[info exists varcid($v,$p)]} continue
1243 # add p as a new commit
1244 incr missing_parents
1245 set cmitlisted($v,$p) 0
1246 set parents($v,$p) {}
1247 if {[llength $children($v,$p)] == 1 &&
1248 [llength $parents($v,$id)] == 1} {
1249 set b $a
1250 } else {
1251 set b [newvarc $v $p]
1253 set varcid($v,$p) $b
1254 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1255 modify_arc $v $b
1257 lappend varccommits($v,$b) $p
1258 incr commitidx($v)
1259 set scripts [check_interest $p $scripts]
1262 if {$missing_parents > 0} {
1263 foreach s $scripts {
1264 eval $s
1269 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1270 # Assumes we already have an arc for $rwid.
1271 proc rewrite_commit {v id rwid} {
1272 global children parents varcid varctok vtokmod varccommits
1274 foreach ch $children($v,$id) {
1275 # make $rwid be $ch's parent in place of $id
1276 set i [lsearch -exact $parents($v,$ch) $id]
1277 if {$i < 0} {
1278 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1280 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1281 # add $ch to $rwid's children and sort the list if necessary
1282 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1283 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1284 $children($v,$rwid)]
1286 # fix the graph after joining $id to $rwid
1287 set a $varcid($v,$ch)
1288 fix_reversal $rwid $a $v
1289 # parentlist is wrong for the last element of arc $a
1290 # even if displayorder is right, hence the 3rd arg here
1291 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1295 # Mechanism for registering a command to be executed when we come
1296 # across a particular commit. To handle the case when only the
1297 # prefix of the commit is known, the commitinterest array is now
1298 # indexed by the first 4 characters of the ID. Each element is a
1299 # list of id, cmd pairs.
1300 proc interestedin {id cmd} {
1301 global commitinterest
1303 lappend commitinterest([string range $id 0 3]) $id $cmd
1306 proc check_interest {id scripts} {
1307 global commitinterest
1309 set prefix [string range $id 0 3]
1310 if {[info exists commitinterest($prefix)]} {
1311 set newlist {}
1312 foreach {i script} $commitinterest($prefix) {
1313 if {[string match "$i*" $id]} {
1314 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1315 } else {
1316 lappend newlist $i $script
1319 if {$newlist ne {}} {
1320 set commitinterest($prefix) $newlist
1321 } else {
1322 unset commitinterest($prefix)
1325 return $scripts
1328 proc getcommitlines {fd inst view updating} {
1329 global cmitlisted leftover
1330 global commitidx commitdata vdatemode
1331 global parents children curview hlview
1332 global idpending ordertok
1333 global varccommits varcid varctok vtokmod vfilelimit
1335 set stuff [read $fd 500000]
1336 # git log doesn't terminate the last commit with a null...
1337 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1338 set stuff "\0"
1340 if {$stuff == {}} {
1341 if {![eof $fd]} {
1342 return 1
1344 global commfd viewcomplete viewactive viewname
1345 global viewinstances
1346 unset commfd($inst)
1347 set i [lsearch -exact $viewinstances($view) $inst]
1348 if {$i >= 0} {
1349 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1351 # set it blocking so we wait for the process to terminate
1352 fconfigure $fd -blocking 1
1353 if {[catch {close $fd} err]} {
1354 set fv {}
1355 if {$view != $curview} {
1356 set fv " for the \"$viewname($view)\" view"
1358 if {[string range $err 0 4] == "usage"} {
1359 set err "Gitk: error reading commits$fv:\
1360 bad arguments to git log."
1361 if {$viewname($view) eq "Command line"} {
1362 append err \
1363 " (Note: arguments to gitk are passed to git log\
1364 to allow selection of commits to be displayed.)"
1366 } else {
1367 set err "Error reading commits$fv: $err"
1369 error_popup $err
1371 if {[incr viewactive($view) -1] <= 0} {
1372 set viewcomplete($view) 1
1373 # Check if we have seen any ids listed as parents that haven't
1374 # appeared in the list
1375 closevarcs $view
1376 notbusy $view
1378 if {$view == $curview} {
1379 run chewcommits
1381 return 0
1383 set start 0
1384 set gotsome 0
1385 set scripts {}
1386 while 1 {
1387 set i [string first "\0" $stuff $start]
1388 if {$i < 0} {
1389 append leftover($inst) [string range $stuff $start end]
1390 break
1392 if {$start == 0} {
1393 set cmit $leftover($inst)
1394 append cmit [string range $stuff 0 [expr {$i - 1}]]
1395 set leftover($inst) {}
1396 } else {
1397 set cmit [string range $stuff $start [expr {$i - 1}]]
1399 set start [expr {$i + 1}]
1400 set j [string first "\n" $cmit]
1401 set ok 0
1402 set listed 1
1403 if {$j >= 0 && [string match "commit *" $cmit]} {
1404 set ids [string range $cmit 7 [expr {$j - 1}]]
1405 if {[string match {[-^<>]*} $ids]} {
1406 switch -- [string index $ids 0] {
1407 "-" {set listed 0}
1408 "^" {set listed 2}
1409 "<" {set listed 3}
1410 ">" {set listed 4}
1412 set ids [string range $ids 1 end]
1414 set ok 1
1415 foreach id $ids {
1416 if {[string length $id] != 40} {
1417 set ok 0
1418 break
1422 if {!$ok} {
1423 set shortcmit $cmit
1424 if {[string length $shortcmit] > 80} {
1425 set shortcmit "[string range $shortcmit 0 80]..."
1427 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1428 exit 1
1430 set id [lindex $ids 0]
1431 set vid $view,$id
1433 if {!$listed && $updating && ![info exists varcid($vid)] &&
1434 $vfilelimit($view) ne {}} {
1435 # git log doesn't rewrite parents for unlisted commits
1436 # when doing path limiting, so work around that here
1437 # by working out the rewritten parent with git rev-list
1438 # and if we already know about it, using the rewritten
1439 # parent as a substitute parent for $id's children.
1440 if {![catch {
1441 set rwid [exec git rev-list --first-parent --max-count=1 \
1442 $id -- $vfilelimit($view)]
1443 }]} {
1444 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1445 # use $rwid in place of $id
1446 rewrite_commit $view $id $rwid
1447 continue
1452 set a 0
1453 if {[info exists varcid($vid)]} {
1454 if {$cmitlisted($vid) || !$listed} continue
1455 set a $varcid($vid)
1457 if {$listed} {
1458 set olds [lrange $ids 1 end]
1459 } else {
1460 set olds {}
1462 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1463 set cmitlisted($vid) $listed
1464 set parents($vid) $olds
1465 if {![info exists children($vid)]} {
1466 set children($vid) {}
1467 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1468 set k [lindex $children($vid) 0]
1469 if {[llength $parents($view,$k)] == 1 &&
1470 (!$vdatemode($view) ||
1471 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1472 set a $varcid($view,$k)
1475 if {$a == 0} {
1476 # new arc
1477 set a [newvarc $view $id]
1479 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1480 modify_arc $view $a
1482 if {![info exists varcid($vid)]} {
1483 set varcid($vid) $a
1484 lappend varccommits($view,$a) $id
1485 incr commitidx($view)
1488 set i 0
1489 foreach p $olds {
1490 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1491 set vp $view,$p
1492 if {[llength [lappend children($vp) $id]] > 1 &&
1493 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1494 set children($vp) [lsort -command [list vtokcmp $view] \
1495 $children($vp)]
1496 catch {unset ordertok}
1498 if {[info exists varcid($view,$p)]} {
1499 fix_reversal $p $a $view
1502 incr i
1505 set scripts [check_interest $id $scripts]
1506 set gotsome 1
1508 if {$gotsome} {
1509 global numcommits hlview
1511 if {$view == $curview} {
1512 set numcommits $commitidx($view)
1513 run chewcommits
1515 if {[info exists hlview] && $view == $hlview} {
1516 # we never actually get here...
1517 run vhighlightmore
1519 foreach s $scripts {
1520 eval $s
1523 return 2
1526 proc chewcommits {} {
1527 global curview hlview viewcomplete
1528 global pending_select
1530 layoutmore
1531 if {$viewcomplete($curview)} {
1532 global commitidx varctok
1533 global numcommits startmsecs
1535 if {[info exists pending_select]} {
1536 update
1537 reset_pending_select {}
1539 if {[commitinview $pending_select $curview]} {
1540 selectline [rowofcommit $pending_select] 1
1541 } else {
1542 set row [first_real_row]
1543 selectline $row 1
1546 if {$commitidx($curview) > 0} {
1547 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1548 #puts "overall $ms ms for $numcommits commits"
1549 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1550 } else {
1551 show_status [mc "No commits selected"]
1553 notbusy layout
1555 return 0
1558 proc readcommit {id} {
1559 if {[catch {set contents [exec git cat-file commit $id]}]} return
1560 parsecommit $id $contents 0
1563 proc parsecommit {id contents listed} {
1564 global commitinfo cdate
1566 set inhdr 1
1567 set comment {}
1568 set headline {}
1569 set auname {}
1570 set audate {}
1571 set comname {}
1572 set comdate {}
1573 set hdrend [string first "\n\n" $contents]
1574 if {$hdrend < 0} {
1575 # should never happen...
1576 set hdrend [string length $contents]
1578 set header [string range $contents 0 [expr {$hdrend - 1}]]
1579 set comment [string range $contents [expr {$hdrend + 2}] end]
1580 foreach line [split $header "\n"] {
1581 set tag [lindex $line 0]
1582 if {$tag == "author"} {
1583 set audate [lindex $line end-1]
1584 set auname [lrange $line 1 end-2]
1585 } elseif {$tag == "committer"} {
1586 set comdate [lindex $line end-1]
1587 set comname [lrange $line 1 end-2]
1590 set headline {}
1591 # take the first non-blank line of the comment as the headline
1592 set headline [string trimleft $comment]
1593 set i [string first "\n" $headline]
1594 if {$i >= 0} {
1595 set headline [string range $headline 0 $i]
1597 set headline [string trimright $headline]
1598 set i [string first "\r" $headline]
1599 if {$i >= 0} {
1600 set headline [string trimright [string range $headline 0 $i]]
1602 if {!$listed} {
1603 # git log indents the comment by 4 spaces;
1604 # if we got this via git cat-file, add the indentation
1605 set newcomment {}
1606 foreach line [split $comment "\n"] {
1607 append newcomment " "
1608 append newcomment $line
1609 append newcomment "\n"
1611 set comment $newcomment
1613 if {$comdate != {}} {
1614 set cdate($id) $comdate
1616 set commitinfo($id) [list $headline $auname $audate \
1617 $comname $comdate $comment]
1620 proc getcommit {id} {
1621 global commitdata commitinfo
1623 if {[info exists commitdata($id)]} {
1624 parsecommit $id $commitdata($id) 1
1625 } else {
1626 readcommit $id
1627 if {![info exists commitinfo($id)]} {
1628 set commitinfo($id) [list [mc "No commit information available"]]
1631 return 1
1634 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1635 # and are present in the current view.
1636 # This is fairly slow...
1637 proc longid {prefix} {
1638 global varcid curview
1640 set ids {}
1641 foreach match [array names varcid "$curview,$prefix*"] {
1642 lappend ids [lindex [split $match ","] 1]
1644 return $ids
1647 proc readrefs {} {
1648 global tagids idtags headids idheads tagobjid
1649 global otherrefids idotherrefs mainhead mainheadid
1650 global selecthead selectheadid
1652 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1653 catch {unset $v}
1655 set refd [open [list | git show-ref -d] r]
1656 while {[gets $refd line] >= 0} {
1657 if {[string index $line 40] ne " "} continue
1658 set id [string range $line 0 39]
1659 set ref [string range $line 41 end]
1660 if {![string match "refs/*" $ref]} continue
1661 set name [string range $ref 5 end]
1662 if {[string match "remotes/*" $name]} {
1663 if {![string match "*/HEAD" $name]} {
1664 set headids($name) $id
1665 lappend idheads($id) $name
1667 } elseif {[string match "heads/*" $name]} {
1668 set name [string range $name 6 end]
1669 set headids($name) $id
1670 lappend idheads($id) $name
1671 } elseif {[string match "tags/*" $name]} {
1672 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1673 # which is what we want since the former is the commit ID
1674 set name [string range $name 5 end]
1675 if {[string match "*^{}" $name]} {
1676 set name [string range $name 0 end-3]
1677 } else {
1678 set tagobjid($name) $id
1680 set tagids($name) $id
1681 lappend idtags($id) $name
1682 } else {
1683 set otherrefids($name) $id
1684 lappend idotherrefs($id) $name
1687 catch {close $refd}
1688 set mainhead {}
1689 set mainheadid {}
1690 catch {
1691 set mainheadid [exec git rev-parse HEAD]
1692 set thehead [exec git symbolic-ref HEAD]
1693 if {[string match "refs/heads/*" $thehead]} {
1694 set mainhead [string range $thehead 11 end]
1697 set selectheadid {}
1698 if {$selecthead ne {}} {
1699 catch {
1700 set selectheadid [exec git rev-parse --verify $selecthead]
1705 # skip over fake commits
1706 proc first_real_row {} {
1707 global nullid nullid2 numcommits
1709 for {set row 0} {$row < $numcommits} {incr row} {
1710 set id [commitonrow $row]
1711 if {$id ne $nullid && $id ne $nullid2} {
1712 break
1715 return $row
1718 # update things for a head moved to a child of its previous location
1719 proc movehead {id name} {
1720 global headids idheads
1722 removehead $headids($name) $name
1723 set headids($name) $id
1724 lappend idheads($id) $name
1727 # update things when a head has been removed
1728 proc removehead {id name} {
1729 global headids idheads
1731 if {$idheads($id) eq $name} {
1732 unset idheads($id)
1733 } else {
1734 set i [lsearch -exact $idheads($id) $name]
1735 if {$i >= 0} {
1736 set idheads($id) [lreplace $idheads($id) $i $i]
1739 unset headids($name)
1742 proc show_error {w top msg} {
1743 message $w.m -text $msg -justify center -aspect 400
1744 pack $w.m -side top -fill x -padx 20 -pady 20
1745 button $w.ok -text [mc OK] -command "destroy $top"
1746 pack $w.ok -side bottom -fill x
1747 bind $top <Visibility> "grab $top; focus $top"
1748 bind $top <Key-Return> "destroy $top"
1749 tkwait window $top
1752 proc error_popup msg {
1753 set w .error
1754 toplevel $w
1755 wm transient $w .
1756 show_error $w $w $msg
1759 proc confirm_popup msg {
1760 global confirm_ok
1761 set confirm_ok 0
1762 set w .confirm
1763 toplevel $w
1764 wm transient $w .
1765 message $w.m -text $msg -justify center -aspect 400
1766 pack $w.m -side top -fill x -padx 20 -pady 20
1767 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1768 pack $w.ok -side left -fill x
1769 button $w.cancel -text [mc Cancel] -command "destroy $w"
1770 pack $w.cancel -side right -fill x
1771 bind $w <Visibility> "grab $w; focus $w"
1772 tkwait window $w
1773 return $confirm_ok
1776 proc setoptions {} {
1777 option add *Panedwindow.showHandle 1 startupFile
1778 option add *Panedwindow.sashRelief raised startupFile
1779 option add *Button.font uifont startupFile
1780 option add *Checkbutton.font uifont startupFile
1781 option add *Radiobutton.font uifont startupFile
1782 option add *Menu.font uifont startupFile
1783 option add *Menubutton.font uifont startupFile
1784 option add *Label.font uifont startupFile
1785 option add *Message.font uifont startupFile
1786 option add *Entry.font uifont startupFile
1789 # Make a menu and submenus.
1790 # m is the window name for the menu, items is the list of menu items to add.
1791 # Each item is a list {mc label type description options...}
1792 # mc is ignored; it's so we can put mc there to alert xgettext
1793 # label is the string that appears in the menu
1794 # type is cascade, command or radiobutton (should add checkbutton)
1795 # description depends on type; it's the sublist for cascade, the
1796 # command to invoke for command, or {variable value} for radiobutton
1797 proc makemenu {m items} {
1798 menu $m
1799 foreach i $items {
1800 set name [mc [lindex $i 1]]
1801 set type [lindex $i 2]
1802 set thing [lindex $i 3]
1803 set params [list $type]
1804 if {$name ne {}} {
1805 set u [string first "&" [string map {&& x} $name]]
1806 lappend params -label [string map {&& & & {}} $name]
1807 if {$u >= 0} {
1808 lappend params -underline $u
1811 switch -- $type {
1812 "cascade" {
1813 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1814 lappend params -menu $m.$submenu
1816 "command" {
1817 lappend params -command $thing
1819 "radiobutton" {
1820 lappend params -variable [lindex $thing 0] \
1821 -value [lindex $thing 1]
1824 eval $m add $params [lrange $i 4 end]
1825 if {$type eq "cascade"} {
1826 makemenu $m.$submenu $thing
1831 # translate string and remove ampersands
1832 proc mca {str} {
1833 return [string map {&& & & {}} [mc $str]]
1836 proc makewindow {} {
1837 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1838 global tabstop
1839 global findtype findtypemenu findloc findstring fstring geometry
1840 global entries sha1entry sha1string sha1but
1841 global diffcontextstring diffcontext
1842 global ignorespace
1843 global maincursor textcursor curtextcursor
1844 global rowctxmenu fakerowmenu mergemax wrapcomment
1845 global highlight_files gdttype
1846 global searchstring sstring
1847 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1848 global headctxmenu progresscanv progressitem progresscoords statusw
1849 global fprogitem fprogcoord lastprogupdate progupdatepending
1850 global rprogitem rprogcoord rownumsel numcommits
1851 global have_tk85
1853 # The "mc" arguments here are purely so that xgettext
1854 # sees the following string as needing to be translated
1855 makemenu .bar {
1856 {mc "File" cascade {
1857 {mc "Update" command updatecommits -accelerator F5}
1858 {mc "Reload" command reloadcommits}
1859 {mc "Reread references" command rereadrefs}
1860 {mc "List references" command showrefs}
1861 {mc "Quit" command doquit}
1863 {mc "Edit" cascade {
1864 {mc "Preferences" command doprefs}
1866 {mc "View" cascade {
1867 {mc "New view..." command {newview 0}}
1868 {mc "Edit view..." command editview -state disabled}
1869 {mc "Delete view" command delview -state disabled}
1870 {xx "" separator}
1871 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1873 {mc "Help" cascade {
1874 {mc "About gitk" command about}
1875 {mc "Key bindings" command keys}
1878 . configure -menu .bar
1880 # the gui has upper and lower half, parts of a paned window.
1881 panedwindow .ctop -orient vertical
1883 # possibly use assumed geometry
1884 if {![info exists geometry(pwsash0)]} {
1885 set geometry(topheight) [expr {15 * $linespc}]
1886 set geometry(topwidth) [expr {80 * $charspc}]
1887 set geometry(botheight) [expr {15 * $linespc}]
1888 set geometry(botwidth) [expr {50 * $charspc}]
1889 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1890 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1893 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1894 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1895 frame .tf.histframe
1896 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1898 # create three canvases
1899 set cscroll .tf.histframe.csb
1900 set canv .tf.histframe.pwclist.canv
1901 canvas $canv \
1902 -selectbackground $selectbgcolor \
1903 -background $bgcolor -bd 0 \
1904 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1905 .tf.histframe.pwclist add $canv
1906 set canv2 .tf.histframe.pwclist.canv2
1907 canvas $canv2 \
1908 -selectbackground $selectbgcolor \
1909 -background $bgcolor -bd 0 -yscrollincr $linespc
1910 .tf.histframe.pwclist add $canv2
1911 set canv3 .tf.histframe.pwclist.canv3
1912 canvas $canv3 \
1913 -selectbackground $selectbgcolor \
1914 -background $bgcolor -bd 0 -yscrollincr $linespc
1915 .tf.histframe.pwclist add $canv3
1916 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1917 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1919 # a scroll bar to rule them
1920 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1921 pack $cscroll -side right -fill y
1922 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1923 lappend bglist $canv $canv2 $canv3
1924 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1926 # we have two button bars at bottom of top frame. Bar 1
1927 frame .tf.bar
1928 frame .tf.lbar -height 15
1930 set sha1entry .tf.bar.sha1
1931 set entries $sha1entry
1932 set sha1but .tf.bar.sha1label
1933 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1934 -command gotocommit -width 8
1935 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1936 pack .tf.bar.sha1label -side left
1937 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1938 trace add variable sha1string write sha1change
1939 pack $sha1entry -side left -pady 2
1941 image create bitmap bm-left -data {
1942 #define left_width 16
1943 #define left_height 16
1944 static unsigned char left_bits[] = {
1945 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1946 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1947 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1949 image create bitmap bm-right -data {
1950 #define right_width 16
1951 #define right_height 16
1952 static unsigned char right_bits[] = {
1953 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1954 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1955 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1957 button .tf.bar.leftbut -image bm-left -command goback \
1958 -state disabled -width 26
1959 pack .tf.bar.leftbut -side left -fill y
1960 button .tf.bar.rightbut -image bm-right -command goforw \
1961 -state disabled -width 26
1962 pack .tf.bar.rightbut -side left -fill y
1964 label .tf.bar.rowlabel -text [mc "Row"]
1965 set rownumsel {}
1966 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1967 -relief sunken -anchor e
1968 label .tf.bar.rowlabel2 -text "/"
1969 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1970 -relief sunken -anchor e
1971 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1972 -side left
1973 global selectedline
1974 trace add variable selectedline write selectedline_change
1976 # Status label and progress bar
1977 set statusw .tf.bar.status
1978 label $statusw -width 15 -relief sunken
1979 pack $statusw -side left -padx 5
1980 set h [expr {[font metrics uifont -linespace] + 2}]
1981 set progresscanv .tf.bar.progress
1982 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1983 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1984 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1985 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1986 pack $progresscanv -side right -expand 1 -fill x
1987 set progresscoords {0 0}
1988 set fprogcoord 0
1989 set rprogcoord 0
1990 bind $progresscanv <Configure> adjustprogress
1991 set lastprogupdate [clock clicks -milliseconds]
1992 set progupdatepending 0
1994 # build up the bottom bar of upper window
1995 label .tf.lbar.flabel -text "[mc "Find"] "
1996 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1997 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1998 label .tf.lbar.flab2 -text " [mc "commit"] "
1999 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2000 -side left -fill y
2001 set gdttype [mc "containing:"]
2002 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2003 [mc "containing:"] \
2004 [mc "touching paths:"] \
2005 [mc "adding/removing string:"]]
2006 trace add variable gdttype write gdttype_change
2007 pack .tf.lbar.gdttype -side left -fill y
2009 set findstring {}
2010 set fstring .tf.lbar.findstring
2011 lappend entries $fstring
2012 entry $fstring -width 30 -font textfont -textvariable findstring
2013 trace add variable findstring write find_change
2014 set findtype [mc "Exact"]
2015 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2016 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2017 trace add variable findtype write findcom_change
2018 set findloc [mc "All fields"]
2019 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2020 [mc "Comments"] [mc "Author"] [mc "Committer"]
2021 trace add variable findloc write find_change
2022 pack .tf.lbar.findloc -side right
2023 pack .tf.lbar.findtype -side right
2024 pack $fstring -side left -expand 1 -fill x
2026 # Finish putting the upper half of the viewer together
2027 pack .tf.lbar -in .tf -side bottom -fill x
2028 pack .tf.bar -in .tf -side bottom -fill x
2029 pack .tf.histframe -fill both -side top -expand 1
2030 .ctop add .tf
2031 .ctop paneconfigure .tf -height $geometry(topheight)
2032 .ctop paneconfigure .tf -width $geometry(topwidth)
2034 # now build up the bottom
2035 panedwindow .pwbottom -orient horizontal
2037 # lower left, a text box over search bar, scroll bar to the right
2038 # if we know window height, then that will set the lower text height, otherwise
2039 # we set lower text height which will drive window height
2040 if {[info exists geometry(main)]} {
2041 frame .bleft -width $geometry(botwidth)
2042 } else {
2043 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2045 frame .bleft.top
2046 frame .bleft.mid
2047 frame .bleft.bottom
2049 button .bleft.top.search -text [mc "Search"] -command dosearch
2050 pack .bleft.top.search -side left -padx 5
2051 set sstring .bleft.top.sstring
2052 entry $sstring -width 20 -font textfont -textvariable searchstring
2053 lappend entries $sstring
2054 trace add variable searchstring write incrsearch
2055 pack $sstring -side left -expand 1 -fill x
2056 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2057 -command changediffdisp -variable diffelide -value {0 0}
2058 radiobutton .bleft.mid.old -text [mc "Old version"] \
2059 -command changediffdisp -variable diffelide -value {0 1}
2060 radiobutton .bleft.mid.new -text [mc "New version"] \
2061 -command changediffdisp -variable diffelide -value {1 0}
2062 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2063 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2064 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2065 -from 1 -increment 1 -to 10000000 \
2066 -validate all -validatecommand "diffcontextvalidate %P" \
2067 -textvariable diffcontextstring
2068 .bleft.mid.diffcontext set $diffcontext
2069 trace add variable diffcontextstring write diffcontextchange
2070 lappend entries .bleft.mid.diffcontext
2071 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2072 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2073 -command changeignorespace -variable ignorespace
2074 pack .bleft.mid.ignspace -side left -padx 5
2075 set ctext .bleft.bottom.ctext
2076 text $ctext -background $bgcolor -foreground $fgcolor \
2077 -state disabled -font textfont \
2078 -yscrollcommand scrolltext -wrap none \
2079 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2080 if {$have_tk85} {
2081 $ctext conf -tabstyle wordprocessor
2083 scrollbar .bleft.bottom.sb -command "$ctext yview"
2084 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2085 -width 10
2086 pack .bleft.top -side top -fill x
2087 pack .bleft.mid -side top -fill x
2088 grid $ctext .bleft.bottom.sb -sticky nsew
2089 grid .bleft.bottom.sbhorizontal -sticky ew
2090 grid columnconfigure .bleft.bottom 0 -weight 1
2091 grid rowconfigure .bleft.bottom 0 -weight 1
2092 grid rowconfigure .bleft.bottom 1 -weight 0
2093 pack .bleft.bottom -side top -fill both -expand 1
2094 lappend bglist $ctext
2095 lappend fglist $ctext
2097 $ctext tag conf comment -wrap $wrapcomment
2098 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2099 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2100 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2101 $ctext tag conf d1 -fore [lindex $diffcolors 1]
2102 $ctext tag conf m0 -fore red
2103 $ctext tag conf m1 -fore blue
2104 $ctext tag conf m2 -fore green
2105 $ctext tag conf m3 -fore purple
2106 $ctext tag conf m4 -fore brown
2107 $ctext tag conf m5 -fore "#009090"
2108 $ctext tag conf m6 -fore magenta
2109 $ctext tag conf m7 -fore "#808000"
2110 $ctext tag conf m8 -fore "#009000"
2111 $ctext tag conf m9 -fore "#ff0080"
2112 $ctext tag conf m10 -fore cyan
2113 $ctext tag conf m11 -fore "#b07070"
2114 $ctext tag conf m12 -fore "#70b0f0"
2115 $ctext tag conf m13 -fore "#70f0b0"
2116 $ctext tag conf m14 -fore "#f0b070"
2117 $ctext tag conf m15 -fore "#ff70b0"
2118 $ctext tag conf mmax -fore darkgrey
2119 set mergemax 16
2120 $ctext tag conf mresult -font textfontbold
2121 $ctext tag conf msep -font textfontbold
2122 $ctext tag conf found -back yellow
2124 .pwbottom add .bleft
2125 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2127 # lower right
2128 frame .bright
2129 frame .bright.mode
2130 radiobutton .bright.mode.patch -text [mc "Patch"] \
2131 -command reselectline -variable cmitmode -value "patch"
2132 radiobutton .bright.mode.tree -text [mc "Tree"] \
2133 -command reselectline -variable cmitmode -value "tree"
2134 grid .bright.mode.patch .bright.mode.tree -sticky ew
2135 pack .bright.mode -side top -fill x
2136 set cflist .bright.cfiles
2137 set indent [font measure mainfont "nn"]
2138 text $cflist \
2139 -selectbackground $selectbgcolor \
2140 -background $bgcolor -foreground $fgcolor \
2141 -font mainfont \
2142 -tabs [list $indent [expr {2 * $indent}]] \
2143 -yscrollcommand ".bright.sb set" \
2144 -cursor [. cget -cursor] \
2145 -spacing1 1 -spacing3 1
2146 lappend bglist $cflist
2147 lappend fglist $cflist
2148 scrollbar .bright.sb -command "$cflist yview"
2149 pack .bright.sb -side right -fill y
2150 pack $cflist -side left -fill both -expand 1
2151 $cflist tag configure highlight \
2152 -background [$cflist cget -selectbackground]
2153 $cflist tag configure bold -font mainfontbold
2155 .pwbottom add .bright
2156 .ctop add .pwbottom
2158 # restore window width & height if known
2159 if {[info exists geometry(main)]} {
2160 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2161 if {$w > [winfo screenwidth .]} {
2162 set w [winfo screenwidth .]
2164 if {$h > [winfo screenheight .]} {
2165 set h [winfo screenheight .]
2167 wm geometry . "${w}x$h"
2171 if {[tk windowingsystem] eq {aqua}} {
2172 set M1B M1
2173 } else {
2174 set M1B Control
2177 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2178 pack .ctop -fill both -expand 1
2179 bindall <1> {selcanvline %W %x %y}
2180 #bindall <B1-Motion> {selcanvline %W %x %y}
2181 if {[tk windowingsystem] == "win32"} {
2182 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2183 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2184 } else {
2185 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2186 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2187 if {[tk windowingsystem] eq "aqua"} {
2188 bindall <MouseWheel> {
2189 set delta [expr {- (%D)}]
2190 allcanvs yview scroll $delta units
2194 bindall <2> "canvscan mark %W %x %y"
2195 bindall <B2-Motion> "canvscan dragto %W %x %y"
2196 bindkey <Home> selfirstline
2197 bindkey <End> sellastline
2198 bind . <Key-Up> "selnextline -1"
2199 bind . <Key-Down> "selnextline 1"
2200 bind . <Shift-Key-Up> "dofind -1 0"
2201 bind . <Shift-Key-Down> "dofind 1 0"
2202 bindkey <Key-Right> "goforw"
2203 bindkey <Key-Left> "goback"
2204 bind . <Key-Prior> "selnextpage -1"
2205 bind . <Key-Next> "selnextpage 1"
2206 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2207 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2208 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2209 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2210 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2211 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2212 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2213 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2214 bindkey <Key-space> "$ctext yview scroll 1 pages"
2215 bindkey p "selnextline -1"
2216 bindkey n "selnextline 1"
2217 bindkey z "goback"
2218 bindkey x "goforw"
2219 bindkey i "selnextline -1"
2220 bindkey k "selnextline 1"
2221 bindkey j "goback"
2222 bindkey l "goforw"
2223 bindkey b prevfile
2224 bindkey d "$ctext yview scroll 18 units"
2225 bindkey u "$ctext yview scroll -18 units"
2226 bindkey / {dofind 1 1}
2227 bindkey <Key-Return> {dofind 1 1}
2228 bindkey ? {dofind -1 1}
2229 bindkey f nextfile
2230 bindkey <F5> updatecommits
2231 bind . <$M1B-q> doquit
2232 bind . <$M1B-f> {dofind 1 1}
2233 bind . <$M1B-g> {dofind 1 0}
2234 bind . <$M1B-r> dosearchback
2235 bind . <$M1B-s> dosearch
2236 bind . <$M1B-equal> {incrfont 1}
2237 bind . <$M1B-plus> {incrfont 1}
2238 bind . <$M1B-KP_Add> {incrfont 1}
2239 bind . <$M1B-minus> {incrfont -1}
2240 bind . <$M1B-KP_Subtract> {incrfont -1}
2241 wm protocol . WM_DELETE_WINDOW doquit
2242 bind . <Destroy> {stop_backends}
2243 bind . <Button-1> "click %W"
2244 bind $fstring <Key-Return> {dofind 1 1}
2245 bind $sha1entry <Key-Return> {gotocommit; break}
2246 bind $sha1entry <<PasteSelection>> clearsha1
2247 bind $cflist <1> {sel_flist %W %x %y; break}
2248 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2249 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2250 global ctxbut
2251 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2253 set maincursor [. cget -cursor]
2254 set textcursor [$ctext cget -cursor]
2255 set curtextcursor $textcursor
2257 set rowctxmenu .rowctxmenu
2258 makemenu $rowctxmenu {
2259 {mc "Diff this -> selected" command {diffvssel 0}}
2260 {mc "Diff selected -> this" command {diffvssel 1}}
2261 {mc "Make patch" command mkpatch}
2262 {mc "Create tag" command mktag}
2263 {mc "Write commit to file" command writecommit}
2264 {mc "Create new branch" command mkbranch}
2265 {mc "Cherry-pick this commit" command cherrypick}
2266 {mc "Reset HEAD branch to here" command resethead}
2268 $rowctxmenu configure -tearoff 0
2270 set fakerowmenu .fakerowmenu
2271 makemenu $fakerowmenu {
2272 {mc "Diff this -> selected" command {diffvssel 0}}
2273 {mc "Diff selected -> this" command {diffvssel 1}}
2274 {mc "Make patch" command mkpatch}
2276 $fakerowmenu configure -tearoff 0
2278 set headctxmenu .headctxmenu
2279 makemenu $headctxmenu {
2280 {mc "Check out this branch" command cobranch}
2281 {mc "Remove this branch" command rmbranch}
2283 $headctxmenu configure -tearoff 0
2285 global flist_menu
2286 set flist_menu .flistctxmenu
2287 makemenu $flist_menu {
2288 {mc "Highlight this too" command {flist_hl 0}}
2289 {mc "Highlight this only" command {flist_hl 1}}
2290 {mc "External diff" command {external_diff}}
2291 {mc "Blame parent commit" command {external_blame 1}}
2293 $flist_menu configure -tearoff 0
2296 # Windows sends all mouse wheel events to the current focused window, not
2297 # the one where the mouse hovers, so bind those events here and redirect
2298 # to the correct window
2299 proc windows_mousewheel_redirector {W X Y D} {
2300 global canv canv2 canv3
2301 set w [winfo containing -displayof $W $X $Y]
2302 if {$w ne ""} {
2303 set u [expr {$D < 0 ? 5 : -5}]
2304 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2305 allcanvs yview scroll $u units
2306 } else {
2307 catch {
2308 $w yview scroll $u units
2314 # Update row number label when selectedline changes
2315 proc selectedline_change {n1 n2 op} {
2316 global selectedline rownumsel
2318 if {$selectedline eq {}} {
2319 set rownumsel {}
2320 } else {
2321 set rownumsel [expr {$selectedline + 1}]
2325 # mouse-2 makes all windows scan vertically, but only the one
2326 # the cursor is in scans horizontally
2327 proc canvscan {op w x y} {
2328 global canv canv2 canv3
2329 foreach c [list $canv $canv2 $canv3] {
2330 if {$c == $w} {
2331 $c scan $op $x $y
2332 } else {
2333 $c scan $op 0 $y
2338 proc scrollcanv {cscroll f0 f1} {
2339 $cscroll set $f0 $f1
2340 drawvisible
2341 flushhighlights
2344 # when we make a key binding for the toplevel, make sure
2345 # it doesn't get triggered when that key is pressed in the
2346 # find string entry widget.
2347 proc bindkey {ev script} {
2348 global entries
2349 bind . $ev $script
2350 set escript [bind Entry $ev]
2351 if {$escript == {}} {
2352 set escript [bind Entry <Key>]
2354 foreach e $entries {
2355 bind $e $ev "$escript; break"
2359 # set the focus back to the toplevel for any click outside
2360 # the entry widgets
2361 proc click {w} {
2362 global ctext entries
2363 foreach e [concat $entries $ctext] {
2364 if {$w == $e} return
2366 focus .
2369 # Adjust the progress bar for a change in requested extent or canvas size
2370 proc adjustprogress {} {
2371 global progresscanv progressitem progresscoords
2372 global fprogitem fprogcoord lastprogupdate progupdatepending
2373 global rprogitem rprogcoord
2375 set w [expr {[winfo width $progresscanv] - 4}]
2376 set x0 [expr {$w * [lindex $progresscoords 0]}]
2377 set x1 [expr {$w * [lindex $progresscoords 1]}]
2378 set h [winfo height $progresscanv]
2379 $progresscanv coords $progressitem $x0 0 $x1 $h
2380 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2381 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2382 set now [clock clicks -milliseconds]
2383 if {$now >= $lastprogupdate + 100} {
2384 set progupdatepending 0
2385 update
2386 } elseif {!$progupdatepending} {
2387 set progupdatepending 1
2388 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2392 proc doprogupdate {} {
2393 global lastprogupdate progupdatepending
2395 if {$progupdatepending} {
2396 set progupdatepending 0
2397 set lastprogupdate [clock clicks -milliseconds]
2398 update
2402 proc savestuff {w} {
2403 global canv canv2 canv3 mainfont textfont uifont tabstop
2404 global stuffsaved findmergefiles maxgraphpct
2405 global maxwidth showneartags showlocalchanges
2406 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2407 global cmitmode wrapcomment datetimeformat limitdiffs
2408 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2409 global autoselect extdifftool perfile_attrs
2411 if {$stuffsaved} return
2412 if {![winfo viewable .]} return
2413 catch {
2414 set f [open "~/.gitk-new" w]
2415 puts $f [list set mainfont $mainfont]
2416 puts $f [list set textfont $textfont]
2417 puts $f [list set uifont $uifont]
2418 puts $f [list set tabstop $tabstop]
2419 puts $f [list set findmergefiles $findmergefiles]
2420 puts $f [list set maxgraphpct $maxgraphpct]
2421 puts $f [list set maxwidth $maxwidth]
2422 puts $f [list set cmitmode $cmitmode]
2423 puts $f [list set wrapcomment $wrapcomment]
2424 puts $f [list set autoselect $autoselect]
2425 puts $f [list set showneartags $showneartags]
2426 puts $f [list set showlocalchanges $showlocalchanges]
2427 puts $f [list set datetimeformat $datetimeformat]
2428 puts $f [list set limitdiffs $limitdiffs]
2429 puts $f [list set bgcolor $bgcolor]
2430 puts $f [list set fgcolor $fgcolor]
2431 puts $f [list set colors $colors]
2432 puts $f [list set diffcolors $diffcolors]
2433 puts $f [list set diffcontext $diffcontext]
2434 puts $f [list set selectbgcolor $selectbgcolor]
2435 puts $f [list set extdifftool $extdifftool]
2436 puts $f [list set perfile_attrs $perfile_attrs]
2438 puts $f "set geometry(main) [wm geometry .]"
2439 puts $f "set geometry(topwidth) [winfo width .tf]"
2440 puts $f "set geometry(topheight) [winfo height .tf]"
2441 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2442 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2443 puts $f "set geometry(botwidth) [winfo width .bleft]"
2444 puts $f "set geometry(botheight) [winfo height .bleft]"
2446 puts -nonewline $f "set permviews {"
2447 for {set v 0} {$v < $nextviewnum} {incr v} {
2448 if {$viewperm($v)} {
2449 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2452 puts $f "}"
2453 close $f
2454 file rename -force "~/.gitk-new" "~/.gitk"
2456 set stuffsaved 1
2459 proc resizeclistpanes {win w} {
2460 global oldwidth
2461 if {[info exists oldwidth($win)]} {
2462 set s0 [$win sash coord 0]
2463 set s1 [$win sash coord 1]
2464 if {$w < 60} {
2465 set sash0 [expr {int($w/2 - 2)}]
2466 set sash1 [expr {int($w*5/6 - 2)}]
2467 } else {
2468 set factor [expr {1.0 * $w / $oldwidth($win)}]
2469 set sash0 [expr {int($factor * [lindex $s0 0])}]
2470 set sash1 [expr {int($factor * [lindex $s1 0])}]
2471 if {$sash0 < 30} {
2472 set sash0 30
2474 if {$sash1 < $sash0 + 20} {
2475 set sash1 [expr {$sash0 + 20}]
2477 if {$sash1 > $w - 10} {
2478 set sash1 [expr {$w - 10}]
2479 if {$sash0 > $sash1 - 20} {
2480 set sash0 [expr {$sash1 - 20}]
2484 $win sash place 0 $sash0 [lindex $s0 1]
2485 $win sash place 1 $sash1 [lindex $s1 1]
2487 set oldwidth($win) $w
2490 proc resizecdetpanes {win w} {
2491 global oldwidth
2492 if {[info exists oldwidth($win)]} {
2493 set s0 [$win sash coord 0]
2494 if {$w < 60} {
2495 set sash0 [expr {int($w*3/4 - 2)}]
2496 } else {
2497 set factor [expr {1.0 * $w / $oldwidth($win)}]
2498 set sash0 [expr {int($factor * [lindex $s0 0])}]
2499 if {$sash0 < 45} {
2500 set sash0 45
2502 if {$sash0 > $w - 15} {
2503 set sash0 [expr {$w - 15}]
2506 $win sash place 0 $sash0 [lindex $s0 1]
2508 set oldwidth($win) $w
2511 proc allcanvs args {
2512 global canv canv2 canv3
2513 eval $canv $args
2514 eval $canv2 $args
2515 eval $canv3 $args
2518 proc bindall {event action} {
2519 global canv canv2 canv3
2520 bind $canv $event $action
2521 bind $canv2 $event $action
2522 bind $canv3 $event $action
2525 proc about {} {
2526 global uifont
2527 set w .about
2528 if {[winfo exists $w]} {
2529 raise $w
2530 return
2532 toplevel $w
2533 wm title $w [mc "About gitk"]
2534 message $w.m -text [mc "
2535 Gitk - a commit viewer for git
2537 Copyright © 2005-2008 Paul Mackerras
2539 Use and redistribute under the terms of the GNU General Public License"] \
2540 -justify center -aspect 400 -border 2 -bg white -relief groove
2541 pack $w.m -side top -fill x -padx 2 -pady 2
2542 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2543 pack $w.ok -side bottom
2544 bind $w <Visibility> "focus $w.ok"
2545 bind $w <Key-Escape> "destroy $w"
2546 bind $w <Key-Return> "destroy $w"
2549 proc keys {} {
2550 set w .keys
2551 if {[winfo exists $w]} {
2552 raise $w
2553 return
2555 if {[tk windowingsystem] eq {aqua}} {
2556 set M1T Cmd
2557 } else {
2558 set M1T Ctrl
2560 toplevel $w
2561 wm title $w [mc "Gitk key bindings"]
2562 message $w.m -text "
2563 [mc "Gitk key bindings:"]
2565 [mc "<%s-Q> Quit" $M1T]
2566 [mc "<Home> Move to first commit"]
2567 [mc "<End> Move to last commit"]
2568 [mc "<Up>, p, i Move up one commit"]
2569 [mc "<Down>, n, k Move down one commit"]
2570 [mc "<Left>, z, j Go back in history list"]
2571 [mc "<Right>, x, l Go forward in history list"]
2572 [mc "<PageUp> Move up one page in commit list"]
2573 [mc "<PageDown> Move down one page in commit list"]
2574 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2575 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2576 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2577 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2578 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2579 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2580 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2581 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2582 [mc "<Delete>, b Scroll diff view up one page"]
2583 [mc "<Backspace> Scroll diff view up one page"]
2584 [mc "<Space> Scroll diff view down one page"]
2585 [mc "u Scroll diff view up 18 lines"]
2586 [mc "d Scroll diff view down 18 lines"]
2587 [mc "<%s-F> Find" $M1T]
2588 [mc "<%s-G> Move to next find hit" $M1T]
2589 [mc "<Return> Move to next find hit"]
2590 [mc "/ Move to next find hit, or redo find"]
2591 [mc "? Move to previous find hit"]
2592 [mc "f Scroll diff view to next file"]
2593 [mc "<%s-S> Search for next hit in diff view" $M1T]
2594 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2595 [mc "<%s-KP+> Increase font size" $M1T]
2596 [mc "<%s-plus> Increase font size" $M1T]
2597 [mc "<%s-KP-> Decrease font size" $M1T]
2598 [mc "<%s-minus> Decrease font size" $M1T]
2599 [mc "<F5> Update"]
2601 -justify left -bg white -border 2 -relief groove
2602 pack $w.m -side top -fill both -padx 2 -pady 2
2603 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2604 pack $w.ok -side bottom
2605 bind $w <Visibility> "focus $w.ok"
2606 bind $w <Key-Escape> "destroy $w"
2607 bind $w <Key-Return> "destroy $w"
2610 # Procedures for manipulating the file list window at the
2611 # bottom right of the overall window.
2613 proc treeview {w l openlevs} {
2614 global treecontents treediropen treeheight treeparent treeindex
2616 set ix 0
2617 set treeindex() 0
2618 set lev 0
2619 set prefix {}
2620 set prefixend -1
2621 set prefendstack {}
2622 set htstack {}
2623 set ht 0
2624 set treecontents() {}
2625 $w conf -state normal
2626 foreach f $l {
2627 while {[string range $f 0 $prefixend] ne $prefix} {
2628 if {$lev <= $openlevs} {
2629 $w mark set e:$treeindex($prefix) "end -1c"
2630 $w mark gravity e:$treeindex($prefix) left
2632 set treeheight($prefix) $ht
2633 incr ht [lindex $htstack end]
2634 set htstack [lreplace $htstack end end]
2635 set prefixend [lindex $prefendstack end]
2636 set prefendstack [lreplace $prefendstack end end]
2637 set prefix [string range $prefix 0 $prefixend]
2638 incr lev -1
2640 set tail [string range $f [expr {$prefixend+1}] end]
2641 while {[set slash [string first "/" $tail]] >= 0} {
2642 lappend htstack $ht
2643 set ht 0
2644 lappend prefendstack $prefixend
2645 incr prefixend [expr {$slash + 1}]
2646 set d [string range $tail 0 $slash]
2647 lappend treecontents($prefix) $d
2648 set oldprefix $prefix
2649 append prefix $d
2650 set treecontents($prefix) {}
2651 set treeindex($prefix) [incr ix]
2652 set treeparent($prefix) $oldprefix
2653 set tail [string range $tail [expr {$slash+1}] end]
2654 if {$lev <= $openlevs} {
2655 set ht 1
2656 set treediropen($prefix) [expr {$lev < $openlevs}]
2657 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2658 $w mark set d:$ix "end -1c"
2659 $w mark gravity d:$ix left
2660 set str "\n"
2661 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2662 $w insert end $str
2663 $w image create end -align center -image $bm -padx 1 \
2664 -name a:$ix
2665 $w insert end $d [highlight_tag $prefix]
2666 $w mark set s:$ix "end -1c"
2667 $w mark gravity s:$ix left
2669 incr lev
2671 if {$tail ne {}} {
2672 if {$lev <= $openlevs} {
2673 incr ht
2674 set str "\n"
2675 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2676 $w insert end $str
2677 $w insert end $tail [highlight_tag $f]
2679 lappend treecontents($prefix) $tail
2682 while {$htstack ne {}} {
2683 set treeheight($prefix) $ht
2684 incr ht [lindex $htstack end]
2685 set htstack [lreplace $htstack end end]
2686 set prefixend [lindex $prefendstack end]
2687 set prefendstack [lreplace $prefendstack end end]
2688 set prefix [string range $prefix 0 $prefixend]
2690 $w conf -state disabled
2693 proc linetoelt {l} {
2694 global treeheight treecontents
2696 set y 2
2697 set prefix {}
2698 while {1} {
2699 foreach e $treecontents($prefix) {
2700 if {$y == $l} {
2701 return "$prefix$e"
2703 set n 1
2704 if {[string index $e end] eq "/"} {
2705 set n $treeheight($prefix$e)
2706 if {$y + $n > $l} {
2707 append prefix $e
2708 incr y
2709 break
2712 incr y $n
2717 proc highlight_tree {y prefix} {
2718 global treeheight treecontents cflist
2720 foreach e $treecontents($prefix) {
2721 set path $prefix$e
2722 if {[highlight_tag $path] ne {}} {
2723 $cflist tag add bold $y.0 "$y.0 lineend"
2725 incr y
2726 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2727 set y [highlight_tree $y $path]
2730 return $y
2733 proc treeclosedir {w dir} {
2734 global treediropen treeheight treeparent treeindex
2736 set ix $treeindex($dir)
2737 $w conf -state normal
2738 $w delete s:$ix e:$ix
2739 set treediropen($dir) 0
2740 $w image configure a:$ix -image tri-rt
2741 $w conf -state disabled
2742 set n [expr {1 - $treeheight($dir)}]
2743 while {$dir ne {}} {
2744 incr treeheight($dir) $n
2745 set dir $treeparent($dir)
2749 proc treeopendir {w dir} {
2750 global treediropen treeheight treeparent treecontents treeindex
2752 set ix $treeindex($dir)
2753 $w conf -state normal
2754 $w image configure a:$ix -image tri-dn
2755 $w mark set e:$ix s:$ix
2756 $w mark gravity e:$ix right
2757 set lev 0
2758 set str "\n"
2759 set n [llength $treecontents($dir)]
2760 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2761 incr lev
2762 append str "\t"
2763 incr treeheight($x) $n
2765 foreach e $treecontents($dir) {
2766 set de $dir$e
2767 if {[string index $e end] eq "/"} {
2768 set iy $treeindex($de)
2769 $w mark set d:$iy e:$ix
2770 $w mark gravity d:$iy left
2771 $w insert e:$ix $str
2772 set treediropen($de) 0
2773 $w image create e:$ix -align center -image tri-rt -padx 1 \
2774 -name a:$iy
2775 $w insert e:$ix $e [highlight_tag $de]
2776 $w mark set s:$iy e:$ix
2777 $w mark gravity s:$iy left
2778 set treeheight($de) 1
2779 } else {
2780 $w insert e:$ix $str
2781 $w insert e:$ix $e [highlight_tag $de]
2784 $w mark gravity e:$ix right
2785 $w conf -state disabled
2786 set treediropen($dir) 1
2787 set top [lindex [split [$w index @0,0] .] 0]
2788 set ht [$w cget -height]
2789 set l [lindex [split [$w index s:$ix] .] 0]
2790 if {$l < $top} {
2791 $w yview $l.0
2792 } elseif {$l + $n + 1 > $top + $ht} {
2793 set top [expr {$l + $n + 2 - $ht}]
2794 if {$l < $top} {
2795 set top $l
2797 $w yview $top.0
2801 proc treeclick {w x y} {
2802 global treediropen cmitmode ctext cflist cflist_top
2804 if {$cmitmode ne "tree"} return
2805 if {![info exists cflist_top]} return
2806 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2807 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2808 $cflist tag add highlight $l.0 "$l.0 lineend"
2809 set cflist_top $l
2810 if {$l == 1} {
2811 $ctext yview 1.0
2812 return
2814 set e [linetoelt $l]
2815 if {[string index $e end] ne "/"} {
2816 showfile $e
2817 } elseif {$treediropen($e)} {
2818 treeclosedir $w $e
2819 } else {
2820 treeopendir $w $e
2824 proc setfilelist {id} {
2825 global treefilelist cflist
2827 treeview $cflist $treefilelist($id) 0
2830 image create bitmap tri-rt -background black -foreground blue -data {
2831 #define tri-rt_width 13
2832 #define tri-rt_height 13
2833 static unsigned char tri-rt_bits[] = {
2834 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2835 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2836 0x00, 0x00};
2837 } -maskdata {
2838 #define tri-rt-mask_width 13
2839 #define tri-rt-mask_height 13
2840 static unsigned char tri-rt-mask_bits[] = {
2841 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2842 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2843 0x08, 0x00};
2845 image create bitmap tri-dn -background black -foreground blue -data {
2846 #define tri-dn_width 13
2847 #define tri-dn_height 13
2848 static unsigned char tri-dn_bits[] = {
2849 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2850 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2851 0x00, 0x00};
2852 } -maskdata {
2853 #define tri-dn-mask_width 13
2854 #define tri-dn-mask_height 13
2855 static unsigned char tri-dn-mask_bits[] = {
2856 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2857 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2858 0x00, 0x00};
2861 image create bitmap reficon-T -background black -foreground yellow -data {
2862 #define tagicon_width 13
2863 #define tagicon_height 9
2864 static unsigned char tagicon_bits[] = {
2865 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2866 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2867 } -maskdata {
2868 #define tagicon-mask_width 13
2869 #define tagicon-mask_height 9
2870 static unsigned char tagicon-mask_bits[] = {
2871 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2872 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2874 set rectdata {
2875 #define headicon_width 13
2876 #define headicon_height 9
2877 static unsigned char headicon_bits[] = {
2878 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2879 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2881 set rectmask {
2882 #define headicon-mask_width 13
2883 #define headicon-mask_height 9
2884 static unsigned char headicon-mask_bits[] = {
2885 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2886 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2888 image create bitmap reficon-H -background black -foreground green \
2889 -data $rectdata -maskdata $rectmask
2890 image create bitmap reficon-o -background black -foreground "#ddddff" \
2891 -data $rectdata -maskdata $rectmask
2893 proc init_flist {first} {
2894 global cflist cflist_top difffilestart
2896 $cflist conf -state normal
2897 $cflist delete 0.0 end
2898 if {$first ne {}} {
2899 $cflist insert end $first
2900 set cflist_top 1
2901 $cflist tag add highlight 1.0 "1.0 lineend"
2902 } else {
2903 catch {unset cflist_top}
2905 $cflist conf -state disabled
2906 set difffilestart {}
2909 proc highlight_tag {f} {
2910 global highlight_paths
2912 foreach p $highlight_paths {
2913 if {[string match $p $f]} {
2914 return "bold"
2917 return {}
2920 proc highlight_filelist {} {
2921 global cmitmode cflist
2923 $cflist conf -state normal
2924 if {$cmitmode ne "tree"} {
2925 set end [lindex [split [$cflist index end] .] 0]
2926 for {set l 2} {$l < $end} {incr l} {
2927 set line [$cflist get $l.0 "$l.0 lineend"]
2928 if {[highlight_tag $line] ne {}} {
2929 $cflist tag add bold $l.0 "$l.0 lineend"
2932 } else {
2933 highlight_tree 2 {}
2935 $cflist conf -state disabled
2938 proc unhighlight_filelist {} {
2939 global cflist
2941 $cflist conf -state normal
2942 $cflist tag remove bold 1.0 end
2943 $cflist conf -state disabled
2946 proc add_flist {fl} {
2947 global cflist
2949 $cflist conf -state normal
2950 foreach f $fl {
2951 $cflist insert end "\n"
2952 $cflist insert end $f [highlight_tag $f]
2954 $cflist conf -state disabled
2957 proc sel_flist {w x y} {
2958 global ctext difffilestart cflist cflist_top cmitmode
2960 if {$cmitmode eq "tree"} return
2961 if {![info exists cflist_top]} return
2962 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2963 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2964 $cflist tag add highlight $l.0 "$l.0 lineend"
2965 set cflist_top $l
2966 if {$l == 1} {
2967 $ctext yview 1.0
2968 } else {
2969 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2973 proc pop_flist_menu {w X Y x y} {
2974 global ctext cflist cmitmode flist_menu flist_menu_file
2975 global treediffs diffids
2977 stopfinding
2978 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2979 if {$l <= 1} return
2980 if {$cmitmode eq "tree"} {
2981 set e [linetoelt $l]
2982 if {[string index $e end] eq "/"} return
2983 } else {
2984 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2986 set flist_menu_file $e
2987 set xdiffstate "normal"
2988 if {$cmitmode eq "tree"} {
2989 set xdiffstate "disabled"
2991 # Disable "External diff" item in tree mode
2992 $flist_menu entryconf 2 -state $xdiffstate
2993 tk_popup $flist_menu $X $Y
2996 proc flist_hl {only} {
2997 global flist_menu_file findstring gdttype
2999 set x [shellquote $flist_menu_file]
3000 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3001 set findstring $x
3002 } else {
3003 append findstring " " $x
3005 set gdttype [mc "touching paths:"]
3008 proc save_file_from_commit {filename output what} {
3009 global nullfile
3011 if {[catch {exec git show $filename -- > $output} err]} {
3012 if {[string match "fatal: bad revision *" $err]} {
3013 return $nullfile
3015 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3016 return {}
3018 return $output
3021 proc external_diff_get_one_file {diffid filename diffdir} {
3022 global nullid nullid2 nullfile
3023 global gitdir
3025 if {$diffid == $nullid} {
3026 set difffile [file join [file dirname $gitdir] $filename]
3027 if {[file exists $difffile]} {
3028 return $difffile
3030 return $nullfile
3032 if {$diffid == $nullid2} {
3033 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3034 return [save_file_from_commit :$filename $difffile index]
3036 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3037 return [save_file_from_commit $diffid:$filename $difffile \
3038 "revision $diffid"]
3041 proc external_diff {} {
3042 global gitktmpdir nullid nullid2
3043 global flist_menu_file
3044 global diffids
3045 global diffnum
3046 global gitdir extdifftool
3048 if {[llength $diffids] == 1} {
3049 # no reference commit given
3050 set diffidto [lindex $diffids 0]
3051 if {$diffidto eq $nullid} {
3052 # diffing working copy with index
3053 set diffidfrom $nullid2
3054 } elseif {$diffidto eq $nullid2} {
3055 # diffing index with HEAD
3056 set diffidfrom "HEAD"
3057 } else {
3058 # use first parent commit
3059 global parentlist selectedline
3060 set diffidfrom [lindex $parentlist $selectedline 0]
3062 } else {
3063 set diffidfrom [lindex $diffids 0]
3064 set diffidto [lindex $diffids 1]
3067 # make sure that several diffs wont collide
3068 if {![info exists gitktmpdir]} {
3069 set gitktmpdir [file join [file dirname $gitdir] \
3070 [format ".gitk-tmp.%s" [pid]]]
3071 if {[catch {file mkdir $gitktmpdir} err]} {
3072 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3073 unset gitktmpdir
3074 return
3076 set diffnum 0
3078 incr diffnum
3079 set diffdir [file join $gitktmpdir $diffnum]
3080 if {[catch {file mkdir $diffdir} err]} {
3081 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3082 return
3085 # gather files to diff
3086 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3087 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3089 if {$difffromfile ne {} && $difftofile ne {}} {
3090 set cmd [concat | [shellsplit $extdifftool] \
3091 [list $difffromfile $difftofile]]
3092 if {[catch {set fl [open $cmd r]} err]} {
3093 file delete -force $diffdir
3094 error_popup "$extdifftool: [mc "command failed:"] $err"
3095 } else {
3096 fconfigure $fl -blocking 0
3097 filerun $fl [list delete_at_eof $fl $diffdir]
3102 proc external_blame {parent_idx} {
3103 global flist_menu_file
3104 global nullid nullid2
3105 global parentlist selectedline currentid
3107 if {$parent_idx > 0} {
3108 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3109 } else {
3110 set base_commit $currentid
3113 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3114 error_popup [mc "No such commit"]
3115 return
3118 if {[catch {exec git gui blame $base_commit $flist_menu_file &} err]} {
3119 error_popup "[mc "git gui blame: command failed:"] $err"
3123 # delete $dir when we see eof on $f (presumably because the child has exited)
3124 proc delete_at_eof {f dir} {
3125 while {[gets $f line] >= 0} {}
3126 if {[eof $f]} {
3127 if {[catch {close $f} err]} {
3128 error_popup "[mc "External diff viewer failed:"] $err"
3130 file delete -force $dir
3131 return 0
3133 return 1
3136 # Functions for adding and removing shell-type quoting
3138 proc shellquote {str} {
3139 if {![string match "*\['\"\\ \t]*" $str]} {
3140 return $str
3142 if {![string match "*\['\"\\]*" $str]} {
3143 return "\"$str\""
3145 if {![string match "*'*" $str]} {
3146 return "'$str'"
3148 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3151 proc shellarglist {l} {
3152 set str {}
3153 foreach a $l {
3154 if {$str ne {}} {
3155 append str " "
3157 append str [shellquote $a]
3159 return $str
3162 proc shelldequote {str} {
3163 set ret {}
3164 set used -1
3165 while {1} {
3166 incr used
3167 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3168 append ret [string range $str $used end]
3169 set used [string length $str]
3170 break
3172 set first [lindex $first 0]
3173 set ch [string index $str $first]
3174 if {$first > $used} {
3175 append ret [string range $str $used [expr {$first - 1}]]
3176 set used $first
3178 if {$ch eq " " || $ch eq "\t"} break
3179 incr used
3180 if {$ch eq "'"} {
3181 set first [string first "'" $str $used]
3182 if {$first < 0} {
3183 error "unmatched single-quote"
3185 append ret [string range $str $used [expr {$first - 1}]]
3186 set used $first
3187 continue
3189 if {$ch eq "\\"} {
3190 if {$used >= [string length $str]} {
3191 error "trailing backslash"
3193 append ret [string index $str $used]
3194 continue
3196 # here ch == "\""
3197 while {1} {
3198 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3199 error "unmatched double-quote"
3201 set first [lindex $first 0]
3202 set ch [string index $str $first]
3203 if {$first > $used} {
3204 append ret [string range $str $used [expr {$first - 1}]]
3205 set used $first
3207 if {$ch eq "\""} break
3208 incr used
3209 append ret [string index $str $used]
3210 incr used
3213 return [list $used $ret]
3216 proc shellsplit {str} {
3217 set l {}
3218 while {1} {
3219 set str [string trimleft $str]
3220 if {$str eq {}} break
3221 set dq [shelldequote $str]
3222 set n [lindex $dq 0]
3223 set word [lindex $dq 1]
3224 set str [string range $str $n end]
3225 lappend l $word
3227 return $l
3230 # Code to implement multiple views
3232 proc newview {ishighlight} {
3233 global nextviewnum newviewname newviewperm newishighlight
3234 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3236 set newishighlight $ishighlight
3237 set top .gitkview
3238 if {[winfo exists $top]} {
3239 raise $top
3240 return
3242 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3243 set newviewperm($nextviewnum) 0
3244 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3245 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3246 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3249 proc editview {} {
3250 global curview
3251 global viewname viewperm newviewname newviewperm
3252 global viewargs newviewargs viewargscmd newviewargscmd
3254 set top .gitkvedit-$curview
3255 if {[winfo exists $top]} {
3256 raise $top
3257 return
3259 set newviewname($curview) $viewname($curview)
3260 set newviewperm($curview) $viewperm($curview)
3261 set newviewargs($curview) [shellarglist $viewargs($curview)]
3262 set newviewargscmd($curview) $viewargscmd($curview)
3263 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3266 proc vieweditor {top n title} {
3267 global newviewname newviewperm viewfiles bgcolor
3269 toplevel $top
3270 wm title $top $title
3271 label $top.nl -text [mc "Name"]
3272 entry $top.name -width 20 -textvariable newviewname($n)
3273 grid $top.nl $top.name -sticky w -pady 5
3274 checkbutton $top.perm -text [mc "Remember this view"] \
3275 -variable newviewperm($n)
3276 grid $top.perm - -pady 5 -sticky w
3277 message $top.al -aspect 1000 \
3278 -text [mc "Commits to include (arguments to git log):"]
3279 grid $top.al - -sticky w -pady 5
3280 entry $top.args -width 50 -textvariable newviewargs($n) \
3281 -background $bgcolor
3282 grid $top.args - -sticky ew -padx 5
3284 message $top.ac -aspect 1000 \
3285 -text [mc "Command to generate more commits to include:"]
3286 grid $top.ac - -sticky w -pady 5
3287 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3288 -background white
3289 grid $top.argscmd - -sticky ew -padx 5
3291 message $top.l -aspect 1000 \
3292 -text [mc "Enter files and directories to include, one per line:"]
3293 grid $top.l - -sticky w
3294 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3295 if {[info exists viewfiles($n)]} {
3296 foreach f $viewfiles($n) {
3297 $top.t insert end $f
3298 $top.t insert end "\n"
3300 $top.t delete {end - 1c} end
3301 $top.t mark set insert 0.0
3303 grid $top.t - -sticky ew -padx 5
3304 frame $top.buts
3305 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3306 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3307 grid $top.buts.ok $top.buts.can
3308 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3309 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3310 grid $top.buts - -pady 10 -sticky ew
3311 focus $top.t
3314 proc doviewmenu {m first cmd op argv} {
3315 set nmenu [$m index end]
3316 for {set i $first} {$i <= $nmenu} {incr i} {
3317 if {[$m entrycget $i -command] eq $cmd} {
3318 eval $m $op $i $argv
3319 break
3324 proc allviewmenus {n op args} {
3325 # global viewhlmenu
3327 doviewmenu .bar.view 5 [list showview $n] $op $args
3328 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3331 proc newviewok {top n} {
3332 global nextviewnum newviewperm newviewname newishighlight
3333 global viewname viewfiles viewperm selectedview curview
3334 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3336 if {[catch {
3337 set newargs [shellsplit $newviewargs($n)]
3338 } err]} {
3339 error_popup "[mc "Error in commit selection arguments:"] $err"
3340 wm raise $top
3341 focus $top
3342 return
3344 set files {}
3345 foreach f [split [$top.t get 0.0 end] "\n"] {
3346 set ft [string trim $f]
3347 if {$ft ne {}} {
3348 lappend files $ft
3351 if {![info exists viewfiles($n)]} {
3352 # creating a new view
3353 incr nextviewnum
3354 set viewname($n) $newviewname($n)
3355 set viewperm($n) $newviewperm($n)
3356 set viewfiles($n) $files
3357 set viewargs($n) $newargs
3358 set viewargscmd($n) $newviewargscmd($n)
3359 addviewmenu $n
3360 if {!$newishighlight} {
3361 run showview $n
3362 } else {
3363 run addvhighlight $n
3365 } else {
3366 # editing an existing view
3367 set viewperm($n) $newviewperm($n)
3368 if {$newviewname($n) ne $viewname($n)} {
3369 set viewname($n) $newviewname($n)
3370 doviewmenu .bar.view 5 [list showview $n] \
3371 entryconf [list -label $viewname($n)]
3372 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3373 # entryconf [list -label $viewname($n) -value $viewname($n)]
3375 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3376 $newviewargscmd($n) ne $viewargscmd($n)} {
3377 set viewfiles($n) $files
3378 set viewargs($n) $newargs
3379 set viewargscmd($n) $newviewargscmd($n)
3380 if {$curview == $n} {
3381 run reloadcommits
3385 catch {destroy $top}
3388 proc delview {} {
3389 global curview viewperm hlview selectedhlview
3391 if {$curview == 0} return
3392 if {[info exists hlview] && $hlview == $curview} {
3393 set selectedhlview [mc "None"]
3394 unset hlview
3396 allviewmenus $curview delete
3397 set viewperm($curview) 0
3398 showview 0
3401 proc addviewmenu {n} {
3402 global viewname viewhlmenu
3404 .bar.view add radiobutton -label $viewname($n) \
3405 -command [list showview $n] -variable selectedview -value $n
3406 #$viewhlmenu add radiobutton -label $viewname($n) \
3407 # -command [list addvhighlight $n] -variable selectedhlview
3410 proc showview {n} {
3411 global curview cached_commitrow ordertok
3412 global displayorder parentlist rowidlist rowisopt rowfinal
3413 global colormap rowtextx nextcolor canvxmax
3414 global numcommits viewcomplete
3415 global selectedline currentid canv canvy0
3416 global treediffs
3417 global pending_select mainheadid
3418 global commitidx
3419 global selectedview
3420 global hlview selectedhlview commitinterest
3422 if {$n == $curview} return
3423 set selid {}
3424 set ymax [lindex [$canv cget -scrollregion] 3]
3425 set span [$canv yview]
3426 set ytop [expr {[lindex $span 0] * $ymax}]
3427 set ybot [expr {[lindex $span 1] * $ymax}]
3428 set yscreen [expr {($ybot - $ytop) / 2}]
3429 if {$selectedline ne {}} {
3430 set selid $currentid
3431 set y [yc $selectedline]
3432 if {$ytop < $y && $y < $ybot} {
3433 set yscreen [expr {$y - $ytop}]
3435 } elseif {[info exists pending_select]} {
3436 set selid $pending_select
3437 unset pending_select
3439 unselectline
3440 normalline
3441 catch {unset treediffs}
3442 clear_display
3443 if {[info exists hlview] && $hlview == $n} {
3444 unset hlview
3445 set selectedhlview [mc "None"]
3447 catch {unset commitinterest}
3448 catch {unset cached_commitrow}
3449 catch {unset ordertok}
3451 set curview $n
3452 set selectedview $n
3453 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3454 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3456 run refill_reflist
3457 if {![info exists viewcomplete($n)]} {
3458 getcommits $selid
3459 return
3462 set displayorder {}
3463 set parentlist {}
3464 set rowidlist {}
3465 set rowisopt {}
3466 set rowfinal {}
3467 set numcommits $commitidx($n)
3469 catch {unset colormap}
3470 catch {unset rowtextx}
3471 set nextcolor 0
3472 set canvxmax [$canv cget -width]
3473 set curview $n
3474 set row 0
3475 setcanvscroll
3476 set yf 0
3477 set row {}
3478 if {$selid ne {} && [commitinview $selid $n]} {
3479 set row [rowofcommit $selid]
3480 # try to get the selected row in the same position on the screen
3481 set ymax [lindex [$canv cget -scrollregion] 3]
3482 set ytop [expr {[yc $row] - $yscreen}]
3483 if {$ytop < 0} {
3484 set ytop 0
3486 set yf [expr {$ytop * 1.0 / $ymax}]
3488 allcanvs yview moveto $yf
3489 drawvisible
3490 if {$row ne {}} {
3491 selectline $row 0
3492 } elseif {!$viewcomplete($n)} {
3493 reset_pending_select $selid
3494 } else {
3495 reset_pending_select {}
3497 if {[commitinview $pending_select $curview]} {
3498 selectline [rowofcommit $pending_select] 1
3499 } else {
3500 set row [first_real_row]
3501 if {$row < $numcommits} {
3502 selectline $row 0
3506 if {!$viewcomplete($n)} {
3507 if {$numcommits == 0} {
3508 show_status [mc "Reading commits..."]
3510 } elseif {$numcommits == 0} {
3511 show_status [mc "No commits selected"]
3515 # Stuff relating to the highlighting facility
3517 proc ishighlighted {id} {
3518 global vhighlights fhighlights nhighlights rhighlights
3520 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3521 return $nhighlights($id)
3523 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3524 return $vhighlights($id)
3526 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3527 return $fhighlights($id)
3529 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3530 return $rhighlights($id)
3532 return 0
3535 proc bolden {row font} {
3536 global canv linehtag selectedline boldrows
3538 lappend boldrows $row
3539 $canv itemconf $linehtag($row) -font $font
3540 if {$row == $selectedline} {
3541 $canv delete secsel
3542 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3543 -outline {{}} -tags secsel \
3544 -fill [$canv cget -selectbackground]]
3545 $canv lower $t
3549 proc bolden_name {row font} {
3550 global canv2 linentag selectedline boldnamerows
3552 lappend boldnamerows $row
3553 $canv2 itemconf $linentag($row) -font $font
3554 if {$row == $selectedline} {
3555 $canv2 delete secsel
3556 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3557 -outline {{}} -tags secsel \
3558 -fill [$canv2 cget -selectbackground]]
3559 $canv2 lower $t
3563 proc unbolden {} {
3564 global boldrows
3566 set stillbold {}
3567 foreach row $boldrows {
3568 if {![ishighlighted [commitonrow $row]]} {
3569 bolden $row mainfont
3570 } else {
3571 lappend stillbold $row
3574 set boldrows $stillbold
3577 proc addvhighlight {n} {
3578 global hlview viewcomplete curview vhl_done commitidx
3580 if {[info exists hlview]} {
3581 delvhighlight
3583 set hlview $n
3584 if {$n != $curview && ![info exists viewcomplete($n)]} {
3585 start_rev_list $n
3587 set vhl_done $commitidx($hlview)
3588 if {$vhl_done > 0} {
3589 drawvisible
3593 proc delvhighlight {} {
3594 global hlview vhighlights
3596 if {![info exists hlview]} return
3597 unset hlview
3598 catch {unset vhighlights}
3599 unbolden
3602 proc vhighlightmore {} {
3603 global hlview vhl_done commitidx vhighlights curview
3605 set max $commitidx($hlview)
3606 set vr [visiblerows]
3607 set r0 [lindex $vr 0]
3608 set r1 [lindex $vr 1]
3609 for {set i $vhl_done} {$i < $max} {incr i} {
3610 set id [commitonrow $i $hlview]
3611 if {[commitinview $id $curview]} {
3612 set row [rowofcommit $id]
3613 if {$r0 <= $row && $row <= $r1} {
3614 if {![highlighted $row]} {
3615 bolden $row mainfontbold
3617 set vhighlights($id) 1
3621 set vhl_done $max
3622 return 0
3625 proc askvhighlight {row id} {
3626 global hlview vhighlights iddrawn
3628 if {[commitinview $id $hlview]} {
3629 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3630 bolden $row mainfontbold
3632 set vhighlights($id) 1
3633 } else {
3634 set vhighlights($id) 0
3638 proc hfiles_change {} {
3639 global highlight_files filehighlight fhighlights fh_serial
3640 global highlight_paths gdttype
3642 if {[info exists filehighlight]} {
3643 # delete previous highlights
3644 catch {close $filehighlight}
3645 unset filehighlight
3646 catch {unset fhighlights}
3647 unbolden
3648 unhighlight_filelist
3650 set highlight_paths {}
3651 after cancel do_file_hl $fh_serial
3652 incr fh_serial
3653 if {$highlight_files ne {}} {
3654 after 300 do_file_hl $fh_serial
3658 proc gdttype_change {name ix op} {
3659 global gdttype highlight_files findstring findpattern
3661 stopfinding
3662 if {$findstring ne {}} {
3663 if {$gdttype eq [mc "containing:"]} {
3664 if {$highlight_files ne {}} {
3665 set highlight_files {}
3666 hfiles_change
3668 findcom_change
3669 } else {
3670 if {$findpattern ne {}} {
3671 set findpattern {}
3672 findcom_change
3674 set highlight_files $findstring
3675 hfiles_change
3677 drawvisible
3679 # enable/disable findtype/findloc menus too
3682 proc find_change {name ix op} {
3683 global gdttype findstring highlight_files
3685 stopfinding
3686 if {$gdttype eq [mc "containing:"]} {
3687 findcom_change
3688 } else {
3689 if {$highlight_files ne $findstring} {
3690 set highlight_files $findstring
3691 hfiles_change
3694 drawvisible
3697 proc findcom_change args {
3698 global nhighlights boldnamerows
3699 global findpattern findtype findstring gdttype
3701 stopfinding
3702 # delete previous highlights, if any
3703 foreach row $boldnamerows {
3704 bolden_name $row mainfont
3706 set boldnamerows {}
3707 catch {unset nhighlights}
3708 unbolden
3709 unmarkmatches
3710 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3711 set findpattern {}
3712 } elseif {$findtype eq [mc "Regexp"]} {
3713 set findpattern $findstring
3714 } else {
3715 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3716 $findstring]
3717 set findpattern "*$e*"
3721 proc makepatterns {l} {
3722 set ret {}
3723 foreach e $l {
3724 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3725 if {[string index $ee end] eq "/"} {
3726 lappend ret "$ee*"
3727 } else {
3728 lappend ret $ee
3729 lappend ret "$ee/*"
3732 return $ret
3735 proc do_file_hl {serial} {
3736 global highlight_files filehighlight highlight_paths gdttype fhl_list
3738 if {$gdttype eq [mc "touching paths:"]} {
3739 if {[catch {set paths [shellsplit $highlight_files]}]} return
3740 set highlight_paths [makepatterns $paths]
3741 highlight_filelist
3742 set gdtargs [concat -- $paths]
3743 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3744 set gdtargs [list "-S$highlight_files"]
3745 } else {
3746 # must be "containing:", i.e. we're searching commit info
3747 return
3749 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3750 set filehighlight [open $cmd r+]
3751 fconfigure $filehighlight -blocking 0
3752 filerun $filehighlight readfhighlight
3753 set fhl_list {}
3754 drawvisible
3755 flushhighlights
3758 proc flushhighlights {} {
3759 global filehighlight fhl_list
3761 if {[info exists filehighlight]} {
3762 lappend fhl_list {}
3763 puts $filehighlight ""
3764 flush $filehighlight
3768 proc askfilehighlight {row id} {
3769 global filehighlight fhighlights fhl_list
3771 lappend fhl_list $id
3772 set fhighlights($id) -1
3773 puts $filehighlight $id
3776 proc readfhighlight {} {
3777 global filehighlight fhighlights curview iddrawn
3778 global fhl_list find_dirn
3780 if {![info exists filehighlight]} {
3781 return 0
3783 set nr 0
3784 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3785 set line [string trim $line]
3786 set i [lsearch -exact $fhl_list $line]
3787 if {$i < 0} continue
3788 for {set j 0} {$j < $i} {incr j} {
3789 set id [lindex $fhl_list $j]
3790 set fhighlights($id) 0
3792 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3793 if {$line eq {}} continue
3794 if {![commitinview $line $curview]} continue
3795 set row [rowofcommit $line]
3796 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3797 bolden $row mainfontbold
3799 set fhighlights($line) 1
3801 if {[eof $filehighlight]} {
3802 # strange...
3803 puts "oops, git diff-tree died"
3804 catch {close $filehighlight}
3805 unset filehighlight
3806 return 0
3808 if {[info exists find_dirn]} {
3809 run findmore
3811 return 1
3814 proc doesmatch {f} {
3815 global findtype findpattern
3817 if {$findtype eq [mc "Regexp"]} {
3818 return [regexp $findpattern $f]
3819 } elseif {$findtype eq [mc "IgnCase"]} {
3820 return [string match -nocase $findpattern $f]
3821 } else {
3822 return [string match $findpattern $f]
3826 proc askfindhighlight {row id} {
3827 global nhighlights commitinfo iddrawn
3828 global findloc
3829 global markingmatches
3831 if {![info exists commitinfo($id)]} {
3832 getcommit $id
3834 set info $commitinfo($id)
3835 set isbold 0
3836 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3837 foreach f $info ty $fldtypes {
3838 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3839 [doesmatch $f]} {
3840 if {$ty eq [mc "Author"]} {
3841 set isbold 2
3842 break
3844 set isbold 1
3847 if {$isbold && [info exists iddrawn($id)]} {
3848 if {![ishighlighted $id]} {
3849 bolden $row mainfontbold
3850 if {$isbold > 1} {
3851 bolden_name $row mainfontbold
3854 if {$markingmatches} {
3855 markrowmatches $row $id
3858 set nhighlights($id) $isbold
3861 proc markrowmatches {row id} {
3862 global canv canv2 linehtag linentag commitinfo findloc
3864 set headline [lindex $commitinfo($id) 0]
3865 set author [lindex $commitinfo($id) 1]
3866 $canv delete match$row
3867 $canv2 delete match$row
3868 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3869 set m [findmatches $headline]
3870 if {$m ne {}} {
3871 markmatches $canv $row $headline $linehtag($row) $m \
3872 [$canv itemcget $linehtag($row) -font] $row
3875 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3876 set m [findmatches $author]
3877 if {$m ne {}} {
3878 markmatches $canv2 $row $author $linentag($row) $m \
3879 [$canv2 itemcget $linentag($row) -font] $row
3884 proc vrel_change {name ix op} {
3885 global highlight_related
3887 rhighlight_none
3888 if {$highlight_related ne [mc "None"]} {
3889 run drawvisible
3893 # prepare for testing whether commits are descendents or ancestors of a
3894 proc rhighlight_sel {a} {
3895 global descendent desc_todo ancestor anc_todo
3896 global highlight_related
3898 catch {unset descendent}
3899 set desc_todo [list $a]
3900 catch {unset ancestor}
3901 set anc_todo [list $a]
3902 if {$highlight_related ne [mc "None"]} {
3903 rhighlight_none
3904 run drawvisible
3908 proc rhighlight_none {} {
3909 global rhighlights
3911 catch {unset rhighlights}
3912 unbolden
3915 proc is_descendent {a} {
3916 global curview children descendent desc_todo
3918 set v $curview
3919 set la [rowofcommit $a]
3920 set todo $desc_todo
3921 set leftover {}
3922 set done 0
3923 for {set i 0} {$i < [llength $todo]} {incr i} {
3924 set do [lindex $todo $i]
3925 if {[rowofcommit $do] < $la} {
3926 lappend leftover $do
3927 continue
3929 foreach nk $children($v,$do) {
3930 if {![info exists descendent($nk)]} {
3931 set descendent($nk) 1
3932 lappend todo $nk
3933 if {$nk eq $a} {
3934 set done 1
3938 if {$done} {
3939 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3940 return
3943 set descendent($a) 0
3944 set desc_todo $leftover
3947 proc is_ancestor {a} {
3948 global curview parents ancestor anc_todo
3950 set v $curview
3951 set la [rowofcommit $a]
3952 set todo $anc_todo
3953 set leftover {}
3954 set done 0
3955 for {set i 0} {$i < [llength $todo]} {incr i} {
3956 set do [lindex $todo $i]
3957 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3958 lappend leftover $do
3959 continue
3961 foreach np $parents($v,$do) {
3962 if {![info exists ancestor($np)]} {
3963 set ancestor($np) 1
3964 lappend todo $np
3965 if {$np eq $a} {
3966 set done 1
3970 if {$done} {
3971 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3972 return
3975 set ancestor($a) 0
3976 set anc_todo $leftover
3979 proc askrelhighlight {row id} {
3980 global descendent highlight_related iddrawn rhighlights
3981 global selectedline ancestor
3983 if {$selectedline eq {}} return
3984 set isbold 0
3985 if {$highlight_related eq [mc "Descendant"] ||
3986 $highlight_related eq [mc "Not descendant"]} {
3987 if {![info exists descendent($id)]} {
3988 is_descendent $id
3990 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3991 set isbold 1
3993 } elseif {$highlight_related eq [mc "Ancestor"] ||
3994 $highlight_related eq [mc "Not ancestor"]} {
3995 if {![info exists ancestor($id)]} {
3996 is_ancestor $id
3998 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3999 set isbold 1
4002 if {[info exists iddrawn($id)]} {
4003 if {$isbold && ![ishighlighted $id]} {
4004 bolden $row mainfontbold
4007 set rhighlights($id) $isbold
4010 # Graph layout functions
4012 proc shortids {ids} {
4013 set res {}
4014 foreach id $ids {
4015 if {[llength $id] > 1} {
4016 lappend res [shortids $id]
4017 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4018 lappend res [string range $id 0 7]
4019 } else {
4020 lappend res $id
4023 return $res
4026 proc ntimes {n o} {
4027 set ret {}
4028 set o [list $o]
4029 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4030 if {($n & $mask) != 0} {
4031 set ret [concat $ret $o]
4033 set o [concat $o $o]
4035 return $ret
4038 proc ordertoken {id} {
4039 global ordertok curview varcid varcstart varctok curview parents children
4040 global nullid nullid2
4042 if {[info exists ordertok($id)]} {
4043 return $ordertok($id)
4045 set origid $id
4046 set todo {}
4047 while {1} {
4048 if {[info exists varcid($curview,$id)]} {
4049 set a $varcid($curview,$id)
4050 set p [lindex $varcstart($curview) $a]
4051 } else {
4052 set p [lindex $children($curview,$id) 0]
4054 if {[info exists ordertok($p)]} {
4055 set tok $ordertok($p)
4056 break
4058 set id [first_real_child $curview,$p]
4059 if {$id eq {}} {
4060 # it's a root
4061 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4062 break
4064 if {[llength $parents($curview,$id)] == 1} {
4065 lappend todo [list $p {}]
4066 } else {
4067 set j [lsearch -exact $parents($curview,$id) $p]
4068 if {$j < 0} {
4069 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4071 lappend todo [list $p [strrep $j]]
4074 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4075 set p [lindex $todo $i 0]
4076 append tok [lindex $todo $i 1]
4077 set ordertok($p) $tok
4079 set ordertok($origid) $tok
4080 return $tok
4083 # Work out where id should go in idlist so that order-token
4084 # values increase from left to right
4085 proc idcol {idlist id {i 0}} {
4086 set t [ordertoken $id]
4087 if {$i < 0} {
4088 set i 0
4090 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4091 if {$i > [llength $idlist]} {
4092 set i [llength $idlist]
4094 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4095 incr i
4096 } else {
4097 if {$t > [ordertoken [lindex $idlist $i]]} {
4098 while {[incr i] < [llength $idlist] &&
4099 $t >= [ordertoken [lindex $idlist $i]]} {}
4102 return $i
4105 proc initlayout {} {
4106 global rowidlist rowisopt rowfinal displayorder parentlist
4107 global numcommits canvxmax canv
4108 global nextcolor
4109 global colormap rowtextx
4111 set numcommits 0
4112 set displayorder {}
4113 set parentlist {}
4114 set nextcolor 0
4115 set rowidlist {}
4116 set rowisopt {}
4117 set rowfinal {}
4118 set canvxmax [$canv cget -width]
4119 catch {unset colormap}
4120 catch {unset rowtextx}
4121 setcanvscroll
4124 proc setcanvscroll {} {
4125 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4126 global lastscrollset lastscrollrows
4128 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4129 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4130 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4131 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4132 set lastscrollset [clock clicks -milliseconds]
4133 set lastscrollrows $numcommits
4136 proc visiblerows {} {
4137 global canv numcommits linespc
4139 set ymax [lindex [$canv cget -scrollregion] 3]
4140 if {$ymax eq {} || $ymax == 0} return
4141 set f [$canv yview]
4142 set y0 [expr {int([lindex $f 0] * $ymax)}]
4143 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4144 if {$r0 < 0} {
4145 set r0 0
4147 set y1 [expr {int([lindex $f 1] * $ymax)}]
4148 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4149 if {$r1 >= $numcommits} {
4150 set r1 [expr {$numcommits - 1}]
4152 return [list $r0 $r1]
4155 proc layoutmore {} {
4156 global commitidx viewcomplete curview
4157 global numcommits pending_select curview
4158 global lastscrollset lastscrollrows
4160 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4161 [clock clicks -milliseconds] - $lastscrollset > 500} {
4162 setcanvscroll
4164 if {[info exists pending_select] &&
4165 [commitinview $pending_select $curview]} {
4166 update
4167 selectline [rowofcommit $pending_select] 1
4169 drawvisible
4172 proc doshowlocalchanges {} {
4173 global curview mainheadid
4175 if {$mainheadid eq {}} return
4176 if {[commitinview $mainheadid $curview]} {
4177 dodiffindex
4178 } else {
4179 interestedin $mainheadid dodiffindex
4183 proc dohidelocalchanges {} {
4184 global nullid nullid2 lserial curview
4186 if {[commitinview $nullid $curview]} {
4187 removefakerow $nullid
4189 if {[commitinview $nullid2 $curview]} {
4190 removefakerow $nullid2
4192 incr lserial
4195 # spawn off a process to do git diff-index --cached HEAD
4196 proc dodiffindex {} {
4197 global lserial showlocalchanges
4198 global isworktree
4200 if {!$showlocalchanges || !$isworktree} return
4201 incr lserial
4202 set fd [open "|git diff-index --cached HEAD" r]
4203 fconfigure $fd -blocking 0
4204 set i [reg_instance $fd]
4205 filerun $fd [list readdiffindex $fd $lserial $i]
4208 proc readdiffindex {fd serial inst} {
4209 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4211 set isdiff 1
4212 if {[gets $fd line] < 0} {
4213 if {![eof $fd]} {
4214 return 1
4216 set isdiff 0
4218 # we only need to see one line and we don't really care what it says...
4219 stop_instance $inst
4221 if {$serial != $lserial} {
4222 return 0
4225 # now see if there are any local changes not checked in to the index
4226 set fd [open "|git diff-files" r]
4227 fconfigure $fd -blocking 0
4228 set i [reg_instance $fd]
4229 filerun $fd [list readdifffiles $fd $serial $i]
4231 if {$isdiff && ![commitinview $nullid2 $curview]} {
4232 # add the line for the changes in the index to the graph
4233 set hl [mc "Local changes checked in to index but not committed"]
4234 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4235 set commitdata($nullid2) "\n $hl\n"
4236 if {[commitinview $nullid $curview]} {
4237 removefakerow $nullid
4239 insertfakerow $nullid2 $mainheadid
4240 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4241 removefakerow $nullid2
4243 return 0
4246 proc readdifffiles {fd serial inst} {
4247 global mainheadid nullid nullid2 curview
4248 global commitinfo commitdata lserial
4250 set isdiff 1
4251 if {[gets $fd line] < 0} {
4252 if {![eof $fd]} {
4253 return 1
4255 set isdiff 0
4257 # we only need to see one line and we don't really care what it says...
4258 stop_instance $inst
4260 if {$serial != $lserial} {
4261 return 0
4264 if {$isdiff && ![commitinview $nullid $curview]} {
4265 # add the line for the local diff to the graph
4266 set hl [mc "Local uncommitted changes, not checked in to index"]
4267 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4268 set commitdata($nullid) "\n $hl\n"
4269 if {[commitinview $nullid2 $curview]} {
4270 set p $nullid2
4271 } else {
4272 set p $mainheadid
4274 insertfakerow $nullid $p
4275 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4276 removefakerow $nullid
4278 return 0
4281 proc nextuse {id row} {
4282 global curview children
4284 if {[info exists children($curview,$id)]} {
4285 foreach kid $children($curview,$id) {
4286 if {![commitinview $kid $curview]} {
4287 return -1
4289 if {[rowofcommit $kid] > $row} {
4290 return [rowofcommit $kid]
4294 if {[commitinview $id $curview]} {
4295 return [rowofcommit $id]
4297 return -1
4300 proc prevuse {id row} {
4301 global curview children
4303 set ret -1
4304 if {[info exists children($curview,$id)]} {
4305 foreach kid $children($curview,$id) {
4306 if {![commitinview $kid $curview]} break
4307 if {[rowofcommit $kid] < $row} {
4308 set ret [rowofcommit $kid]
4312 return $ret
4315 proc make_idlist {row} {
4316 global displayorder parentlist uparrowlen downarrowlen mingaplen
4317 global commitidx curview children
4319 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4320 if {$r < 0} {
4321 set r 0
4323 set ra [expr {$row - $downarrowlen}]
4324 if {$ra < 0} {
4325 set ra 0
4327 set rb [expr {$row + $uparrowlen}]
4328 if {$rb > $commitidx($curview)} {
4329 set rb $commitidx($curview)
4331 make_disporder $r [expr {$rb + 1}]
4332 set ids {}
4333 for {} {$r < $ra} {incr r} {
4334 set nextid [lindex $displayorder [expr {$r + 1}]]
4335 foreach p [lindex $parentlist $r] {
4336 if {$p eq $nextid} continue
4337 set rn [nextuse $p $r]
4338 if {$rn >= $row &&
4339 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4340 lappend ids [list [ordertoken $p] $p]
4344 for {} {$r < $row} {incr r} {
4345 set nextid [lindex $displayorder [expr {$r + 1}]]
4346 foreach p [lindex $parentlist $r] {
4347 if {$p eq $nextid} continue
4348 set rn [nextuse $p $r]
4349 if {$rn < 0 || $rn >= $row} {
4350 lappend ids [list [ordertoken $p] $p]
4354 set id [lindex $displayorder $row]
4355 lappend ids [list [ordertoken $id] $id]
4356 while {$r < $rb} {
4357 foreach p [lindex $parentlist $r] {
4358 set firstkid [lindex $children($curview,$p) 0]
4359 if {[rowofcommit $firstkid] < $row} {
4360 lappend ids [list [ordertoken $p] $p]
4363 incr r
4364 set id [lindex $displayorder $r]
4365 if {$id ne {}} {
4366 set firstkid [lindex $children($curview,$id) 0]
4367 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4368 lappend ids [list [ordertoken $id] $id]
4372 set idlist {}
4373 foreach idx [lsort -unique $ids] {
4374 lappend idlist [lindex $idx 1]
4376 return $idlist
4379 proc rowsequal {a b} {
4380 while {[set i [lsearch -exact $a {}]] >= 0} {
4381 set a [lreplace $a $i $i]
4383 while {[set i [lsearch -exact $b {}]] >= 0} {
4384 set b [lreplace $b $i $i]
4386 return [expr {$a eq $b}]
4389 proc makeupline {id row rend col} {
4390 global rowidlist uparrowlen downarrowlen mingaplen
4392 for {set r $rend} {1} {set r $rstart} {
4393 set rstart [prevuse $id $r]
4394 if {$rstart < 0} return
4395 if {$rstart < $row} break
4397 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4398 set rstart [expr {$rend - $uparrowlen - 1}]
4400 for {set r $rstart} {[incr r] <= $row} {} {
4401 set idlist [lindex $rowidlist $r]
4402 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4403 set col [idcol $idlist $id $col]
4404 lset rowidlist $r [linsert $idlist $col $id]
4405 changedrow $r
4410 proc layoutrows {row endrow} {
4411 global rowidlist rowisopt rowfinal displayorder
4412 global uparrowlen downarrowlen maxwidth mingaplen
4413 global children parentlist
4414 global commitidx viewcomplete curview
4416 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4417 set idlist {}
4418 if {$row > 0} {
4419 set rm1 [expr {$row - 1}]
4420 foreach id [lindex $rowidlist $rm1] {
4421 if {$id ne {}} {
4422 lappend idlist $id
4425 set final [lindex $rowfinal $rm1]
4427 for {} {$row < $endrow} {incr row} {
4428 set rm1 [expr {$row - 1}]
4429 if {$rm1 < 0 || $idlist eq {}} {
4430 set idlist [make_idlist $row]
4431 set final 1
4432 } else {
4433 set id [lindex $displayorder $rm1]
4434 set col [lsearch -exact $idlist $id]
4435 set idlist [lreplace $idlist $col $col]
4436 foreach p [lindex $parentlist $rm1] {
4437 if {[lsearch -exact $idlist $p] < 0} {
4438 set col [idcol $idlist $p $col]
4439 set idlist [linsert $idlist $col $p]
4440 # if not the first child, we have to insert a line going up
4441 if {$id ne [lindex $children($curview,$p) 0]} {
4442 makeupline $p $rm1 $row $col
4446 set id [lindex $displayorder $row]
4447 if {$row > $downarrowlen} {
4448 set termrow [expr {$row - $downarrowlen - 1}]
4449 foreach p [lindex $parentlist $termrow] {
4450 set i [lsearch -exact $idlist $p]
4451 if {$i < 0} continue
4452 set nr [nextuse $p $termrow]
4453 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4454 set idlist [lreplace $idlist $i $i]
4458 set col [lsearch -exact $idlist $id]
4459 if {$col < 0} {
4460 set col [idcol $idlist $id]
4461 set idlist [linsert $idlist $col $id]
4462 if {$children($curview,$id) ne {}} {
4463 makeupline $id $rm1 $row $col
4466 set r [expr {$row + $uparrowlen - 1}]
4467 if {$r < $commitidx($curview)} {
4468 set x $col
4469 foreach p [lindex $parentlist $r] {
4470 if {[lsearch -exact $idlist $p] >= 0} continue
4471 set fk [lindex $children($curview,$p) 0]
4472 if {[rowofcommit $fk] < $row} {
4473 set x [idcol $idlist $p $x]
4474 set idlist [linsert $idlist $x $p]
4477 if {[incr r] < $commitidx($curview)} {
4478 set p [lindex $displayorder $r]
4479 if {[lsearch -exact $idlist $p] < 0} {
4480 set fk [lindex $children($curview,$p) 0]
4481 if {$fk ne {} && [rowofcommit $fk] < $row} {
4482 set x [idcol $idlist $p $x]
4483 set idlist [linsert $idlist $x $p]
4489 if {$final && !$viewcomplete($curview) &&
4490 $row + $uparrowlen + $mingaplen + $downarrowlen
4491 >= $commitidx($curview)} {
4492 set final 0
4494 set l [llength $rowidlist]
4495 if {$row == $l} {
4496 lappend rowidlist $idlist
4497 lappend rowisopt 0
4498 lappend rowfinal $final
4499 } elseif {$row < $l} {
4500 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4501 lset rowidlist $row $idlist
4502 changedrow $row
4504 lset rowfinal $row $final
4505 } else {
4506 set pad [ntimes [expr {$row - $l}] {}]
4507 set rowidlist [concat $rowidlist $pad]
4508 lappend rowidlist $idlist
4509 set rowfinal [concat $rowfinal $pad]
4510 lappend rowfinal $final
4511 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4514 return $row
4517 proc changedrow {row} {
4518 global displayorder iddrawn rowisopt need_redisplay
4520 set l [llength $rowisopt]
4521 if {$row < $l} {
4522 lset rowisopt $row 0
4523 if {$row + 1 < $l} {
4524 lset rowisopt [expr {$row + 1}] 0
4525 if {$row + 2 < $l} {
4526 lset rowisopt [expr {$row + 2}] 0
4530 set id [lindex $displayorder $row]
4531 if {[info exists iddrawn($id)]} {
4532 set need_redisplay 1
4536 proc insert_pad {row col npad} {
4537 global rowidlist
4539 set pad [ntimes $npad {}]
4540 set idlist [lindex $rowidlist $row]
4541 set bef [lrange $idlist 0 [expr {$col - 1}]]
4542 set aft [lrange $idlist $col end]
4543 set i [lsearch -exact $aft {}]
4544 if {$i > 0} {
4545 set aft [lreplace $aft $i $i]
4547 lset rowidlist $row [concat $bef $pad $aft]
4548 changedrow $row
4551 proc optimize_rows {row col endrow} {
4552 global rowidlist rowisopt displayorder curview children
4554 if {$row < 1} {
4555 set row 1
4557 for {} {$row < $endrow} {incr row; set col 0} {
4558 if {[lindex $rowisopt $row]} continue
4559 set haspad 0
4560 set y0 [expr {$row - 1}]
4561 set ym [expr {$row - 2}]
4562 set idlist [lindex $rowidlist $row]
4563 set previdlist [lindex $rowidlist $y0]
4564 if {$idlist eq {} || $previdlist eq {}} continue
4565 if {$ym >= 0} {
4566 set pprevidlist [lindex $rowidlist $ym]
4567 if {$pprevidlist eq {}} continue
4568 } else {
4569 set pprevidlist {}
4571 set x0 -1
4572 set xm -1
4573 for {} {$col < [llength $idlist]} {incr col} {
4574 set id [lindex $idlist $col]
4575 if {[lindex $previdlist $col] eq $id} continue
4576 if {$id eq {}} {
4577 set haspad 1
4578 continue
4580 set x0 [lsearch -exact $previdlist $id]
4581 if {$x0 < 0} continue
4582 set z [expr {$x0 - $col}]
4583 set isarrow 0
4584 set z0 {}
4585 if {$ym >= 0} {
4586 set xm [lsearch -exact $pprevidlist $id]
4587 if {$xm >= 0} {
4588 set z0 [expr {$xm - $x0}]
4591 if {$z0 eq {}} {
4592 # if row y0 is the first child of $id then it's not an arrow
4593 if {[lindex $children($curview,$id) 0] ne
4594 [lindex $displayorder $y0]} {
4595 set isarrow 1
4598 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4599 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4600 set isarrow 1
4602 # Looking at lines from this row to the previous row,
4603 # make them go straight up if they end in an arrow on
4604 # the previous row; otherwise make them go straight up
4605 # or at 45 degrees.
4606 if {$z < -1 || ($z < 0 && $isarrow)} {
4607 # Line currently goes left too much;
4608 # insert pads in the previous row, then optimize it
4609 set npad [expr {-1 - $z + $isarrow}]
4610 insert_pad $y0 $x0 $npad
4611 if {$y0 > 0} {
4612 optimize_rows $y0 $x0 $row
4614 set previdlist [lindex $rowidlist $y0]
4615 set x0 [lsearch -exact $previdlist $id]
4616 set z [expr {$x0 - $col}]
4617 if {$z0 ne {}} {
4618 set pprevidlist [lindex $rowidlist $ym]
4619 set xm [lsearch -exact $pprevidlist $id]
4620 set z0 [expr {$xm - $x0}]
4622 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4623 # Line currently goes right too much;
4624 # insert pads in this line
4625 set npad [expr {$z - 1 + $isarrow}]
4626 insert_pad $row $col $npad
4627 set idlist [lindex $rowidlist $row]
4628 incr col $npad
4629 set z [expr {$x0 - $col}]
4630 set haspad 1
4632 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4633 # this line links to its first child on row $row-2
4634 set id [lindex $displayorder $ym]
4635 set xc [lsearch -exact $pprevidlist $id]
4636 if {$xc >= 0} {
4637 set z0 [expr {$xc - $x0}]
4640 # avoid lines jigging left then immediately right
4641 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4642 insert_pad $y0 $x0 1
4643 incr x0
4644 optimize_rows $y0 $x0 $row
4645 set previdlist [lindex $rowidlist $y0]
4648 if {!$haspad} {
4649 # Find the first column that doesn't have a line going right
4650 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4651 set id [lindex $idlist $col]
4652 if {$id eq {}} break
4653 set x0 [lsearch -exact $previdlist $id]
4654 if {$x0 < 0} {
4655 # check if this is the link to the first child
4656 set kid [lindex $displayorder $y0]
4657 if {[lindex $children($curview,$id) 0] eq $kid} {
4658 # it is, work out offset to child
4659 set x0 [lsearch -exact $previdlist $kid]
4662 if {$x0 <= $col} break
4664 # Insert a pad at that column as long as it has a line and
4665 # isn't the last column
4666 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4667 set idlist [linsert $idlist $col {}]
4668 lset rowidlist $row $idlist
4669 changedrow $row
4675 proc xc {row col} {
4676 global canvx0 linespc
4677 return [expr {$canvx0 + $col * $linespc}]
4680 proc yc {row} {
4681 global canvy0 linespc
4682 return [expr {$canvy0 + $row * $linespc}]
4685 proc linewidth {id} {
4686 global thickerline lthickness
4688 set wid $lthickness
4689 if {[info exists thickerline] && $id eq $thickerline} {
4690 set wid [expr {2 * $lthickness}]
4692 return $wid
4695 proc rowranges {id} {
4696 global curview children uparrowlen downarrowlen
4697 global rowidlist
4699 set kids $children($curview,$id)
4700 if {$kids eq {}} {
4701 return {}
4703 set ret {}
4704 lappend kids $id
4705 foreach child $kids {
4706 if {![commitinview $child $curview]} break
4707 set row [rowofcommit $child]
4708 if {![info exists prev]} {
4709 lappend ret [expr {$row + 1}]
4710 } else {
4711 if {$row <= $prevrow} {
4712 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4714 # see if the line extends the whole way from prevrow to row
4715 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4716 [lsearch -exact [lindex $rowidlist \
4717 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4718 # it doesn't, see where it ends
4719 set r [expr {$prevrow + $downarrowlen}]
4720 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4721 while {[incr r -1] > $prevrow &&
4722 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4723 } else {
4724 while {[incr r] <= $row &&
4725 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4726 incr r -1
4728 lappend ret $r
4729 # see where it starts up again
4730 set r [expr {$row - $uparrowlen}]
4731 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4732 while {[incr r] < $row &&
4733 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4734 } else {
4735 while {[incr r -1] >= $prevrow &&
4736 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4737 incr r
4739 lappend ret $r
4742 if {$child eq $id} {
4743 lappend ret $row
4745 set prev $child
4746 set prevrow $row
4748 return $ret
4751 proc drawlineseg {id row endrow arrowlow} {
4752 global rowidlist displayorder iddrawn linesegs
4753 global canv colormap linespc curview maxlinelen parentlist
4755 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4756 set le [expr {$row + 1}]
4757 set arrowhigh 1
4758 while {1} {
4759 set c [lsearch -exact [lindex $rowidlist $le] $id]
4760 if {$c < 0} {
4761 incr le -1
4762 break
4764 lappend cols $c
4765 set x [lindex $displayorder $le]
4766 if {$x eq $id} {
4767 set arrowhigh 0
4768 break
4770 if {[info exists iddrawn($x)] || $le == $endrow} {
4771 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4772 if {$c >= 0} {
4773 lappend cols $c
4774 set arrowhigh 0
4776 break
4778 incr le
4780 if {$le <= $row} {
4781 return $row
4784 set lines {}
4785 set i 0
4786 set joinhigh 0
4787 if {[info exists linesegs($id)]} {
4788 set lines $linesegs($id)
4789 foreach li $lines {
4790 set r0 [lindex $li 0]
4791 if {$r0 > $row} {
4792 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4793 set joinhigh 1
4795 break
4797 incr i
4800 set joinlow 0
4801 if {$i > 0} {
4802 set li [lindex $lines [expr {$i-1}]]
4803 set r1 [lindex $li 1]
4804 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4805 set joinlow 1
4809 set x [lindex $cols [expr {$le - $row}]]
4810 set xp [lindex $cols [expr {$le - 1 - $row}]]
4811 set dir [expr {$xp - $x}]
4812 if {$joinhigh} {
4813 set ith [lindex $lines $i 2]
4814 set coords [$canv coords $ith]
4815 set ah [$canv itemcget $ith -arrow]
4816 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4817 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4818 if {$x2 ne {} && $x - $x2 == $dir} {
4819 set coords [lrange $coords 0 end-2]
4821 } else {
4822 set coords [list [xc $le $x] [yc $le]]
4824 if {$joinlow} {
4825 set itl [lindex $lines [expr {$i-1}] 2]
4826 set al [$canv itemcget $itl -arrow]
4827 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4828 } elseif {$arrowlow} {
4829 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4830 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4831 set arrowlow 0
4834 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4835 for {set y $le} {[incr y -1] > $row} {} {
4836 set x $xp
4837 set xp [lindex $cols [expr {$y - 1 - $row}]]
4838 set ndir [expr {$xp - $x}]
4839 if {$dir != $ndir || $xp < 0} {
4840 lappend coords [xc $y $x] [yc $y]
4842 set dir $ndir
4844 if {!$joinlow} {
4845 if {$xp < 0} {
4846 # join parent line to first child
4847 set ch [lindex $displayorder $row]
4848 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4849 if {$xc < 0} {
4850 puts "oops: drawlineseg: child $ch not on row $row"
4851 } elseif {$xc != $x} {
4852 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4853 set d [expr {int(0.5 * $linespc)}]
4854 set x1 [xc $row $x]
4855 if {$xc < $x} {
4856 set x2 [expr {$x1 - $d}]
4857 } else {
4858 set x2 [expr {$x1 + $d}]
4860 set y2 [yc $row]
4861 set y1 [expr {$y2 + $d}]
4862 lappend coords $x1 $y1 $x2 $y2
4863 } elseif {$xc < $x - 1} {
4864 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4865 } elseif {$xc > $x + 1} {
4866 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4868 set x $xc
4870 lappend coords [xc $row $x] [yc $row]
4871 } else {
4872 set xn [xc $row $xp]
4873 set yn [yc $row]
4874 lappend coords $xn $yn
4876 if {!$joinhigh} {
4877 assigncolor $id
4878 set t [$canv create line $coords -width [linewidth $id] \
4879 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4880 $canv lower $t
4881 bindline $t $id
4882 set lines [linsert $lines $i [list $row $le $t]]
4883 } else {
4884 $canv coords $ith $coords
4885 if {$arrow ne $ah} {
4886 $canv itemconf $ith -arrow $arrow
4888 lset lines $i 0 $row
4890 } else {
4891 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4892 set ndir [expr {$xo - $xp}]
4893 set clow [$canv coords $itl]
4894 if {$dir == $ndir} {
4895 set clow [lrange $clow 2 end]
4897 set coords [concat $coords $clow]
4898 if {!$joinhigh} {
4899 lset lines [expr {$i-1}] 1 $le
4900 } else {
4901 # coalesce two pieces
4902 $canv delete $ith
4903 set b [lindex $lines [expr {$i-1}] 0]
4904 set e [lindex $lines $i 1]
4905 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4907 $canv coords $itl $coords
4908 if {$arrow ne $al} {
4909 $canv itemconf $itl -arrow $arrow
4913 set linesegs($id) $lines
4914 return $le
4917 proc drawparentlinks {id row} {
4918 global rowidlist canv colormap curview parentlist
4919 global idpos linespc
4921 set rowids [lindex $rowidlist $row]
4922 set col [lsearch -exact $rowids $id]
4923 if {$col < 0} return
4924 set olds [lindex $parentlist $row]
4925 set row2 [expr {$row + 1}]
4926 set x [xc $row $col]
4927 set y [yc $row]
4928 set y2 [yc $row2]
4929 set d [expr {int(0.5 * $linespc)}]
4930 set ymid [expr {$y + $d}]
4931 set ids [lindex $rowidlist $row2]
4932 # rmx = right-most X coord used
4933 set rmx 0
4934 foreach p $olds {
4935 set i [lsearch -exact $ids $p]
4936 if {$i < 0} {
4937 puts "oops, parent $p of $id not in list"
4938 continue
4940 set x2 [xc $row2 $i]
4941 if {$x2 > $rmx} {
4942 set rmx $x2
4944 set j [lsearch -exact $rowids $p]
4945 if {$j < 0} {
4946 # drawlineseg will do this one for us
4947 continue
4949 assigncolor $p
4950 # should handle duplicated parents here...
4951 set coords [list $x $y]
4952 if {$i != $col} {
4953 # if attaching to a vertical segment, draw a smaller
4954 # slant for visual distinctness
4955 if {$i == $j} {
4956 if {$i < $col} {
4957 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4958 } else {
4959 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4961 } elseif {$i < $col && $i < $j} {
4962 # segment slants towards us already
4963 lappend coords [xc $row $j] $y
4964 } else {
4965 if {$i < $col - 1} {
4966 lappend coords [expr {$x2 + $linespc}] $y
4967 } elseif {$i > $col + 1} {
4968 lappend coords [expr {$x2 - $linespc}] $y
4970 lappend coords $x2 $y2
4972 } else {
4973 lappend coords $x2 $y2
4975 set t [$canv create line $coords -width [linewidth $p] \
4976 -fill $colormap($p) -tags lines.$p]
4977 $canv lower $t
4978 bindline $t $p
4980 if {$rmx > [lindex $idpos($id) 1]} {
4981 lset idpos($id) 1 $rmx
4982 redrawtags $id
4986 proc drawlines {id} {
4987 global canv
4989 $canv itemconf lines.$id -width [linewidth $id]
4992 proc drawcmittext {id row col} {
4993 global linespc canv canv2 canv3 fgcolor curview
4994 global cmitlisted commitinfo rowidlist parentlist
4995 global rowtextx idpos idtags idheads idotherrefs
4996 global linehtag linentag linedtag selectedline
4997 global canvxmax boldrows boldnamerows fgcolor
4998 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5000 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5001 set listed $cmitlisted($curview,$id)
5002 if {$id eq $nullid} {
5003 set ofill red
5004 } elseif {$id eq $nullid2} {
5005 set ofill green
5006 } elseif {$id eq $mainheadid} {
5007 set ofill yellow
5008 } else {
5009 set ofill [lindex $circlecolors $listed]
5011 set x [xc $row $col]
5012 set y [yc $row]
5013 set orad [expr {$linespc / 3}]
5014 if {$listed <= 2} {
5015 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5016 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5017 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5018 } elseif {$listed == 3} {
5019 # triangle pointing left for left-side commits
5020 set t [$canv create polygon \
5021 [expr {$x - $orad}] $y \
5022 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5023 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5024 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5025 } else {
5026 # triangle pointing right for right-side commits
5027 set t [$canv create polygon \
5028 [expr {$x + $orad - 1}] $y \
5029 [expr {$x - $orad}] [expr {$y - $orad}] \
5030 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5031 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5033 set circleitem($row) $t
5034 $canv raise $t
5035 $canv bind $t <1> {selcanvline {} %x %y}
5036 set rmx [llength [lindex $rowidlist $row]]
5037 set olds [lindex $parentlist $row]
5038 if {$olds ne {}} {
5039 set nextids [lindex $rowidlist [expr {$row + 1}]]
5040 foreach p $olds {
5041 set i [lsearch -exact $nextids $p]
5042 if {$i > $rmx} {
5043 set rmx $i
5047 set xt [xc $row $rmx]
5048 set rowtextx($row) $xt
5049 set idpos($id) [list $x $xt $y]
5050 if {[info exists idtags($id)] || [info exists idheads($id)]
5051 || [info exists idotherrefs($id)]} {
5052 set xt [drawtags $id $x $xt $y]
5054 set headline [lindex $commitinfo($id) 0]
5055 set name [lindex $commitinfo($id) 1]
5056 set date [lindex $commitinfo($id) 2]
5057 set date [formatdate $date]
5058 set font mainfont
5059 set nfont mainfont
5060 set isbold [ishighlighted $id]
5061 if {$isbold > 0} {
5062 lappend boldrows $row
5063 set font mainfontbold
5064 if {$isbold > 1} {
5065 lappend boldnamerows $row
5066 set nfont mainfontbold
5069 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
5070 -text $headline -font $font -tags text]
5071 $canv bind $linehtag($row) $ctxbut "rowmenu %X %Y $id"
5072 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5073 -text $name -font $nfont -tags text]
5074 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5075 -text $date -font mainfont -tags text]
5076 if {$selectedline == $row} {
5077 make_secsel $row
5079 set xr [expr {$xt + [font measure $font $headline]}]
5080 if {$xr > $canvxmax} {
5081 set canvxmax $xr
5082 setcanvscroll
5086 proc drawcmitrow {row} {
5087 global displayorder rowidlist nrows_drawn
5088 global iddrawn markingmatches
5089 global commitinfo numcommits
5090 global filehighlight fhighlights findpattern nhighlights
5091 global hlview vhighlights
5092 global highlight_related rhighlights
5094 if {$row >= $numcommits} return
5096 set id [lindex $displayorder $row]
5097 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5098 askvhighlight $row $id
5100 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5101 askfilehighlight $row $id
5103 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5104 askfindhighlight $row $id
5106 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5107 askrelhighlight $row $id
5109 if {![info exists iddrawn($id)]} {
5110 set col [lsearch -exact [lindex $rowidlist $row] $id]
5111 if {$col < 0} {
5112 puts "oops, row $row id $id not in list"
5113 return
5115 if {![info exists commitinfo($id)]} {
5116 getcommit $id
5118 assigncolor $id
5119 drawcmittext $id $row $col
5120 set iddrawn($id) 1
5121 incr nrows_drawn
5123 if {$markingmatches} {
5124 markrowmatches $row $id
5128 proc drawcommits {row {endrow {}}} {
5129 global numcommits iddrawn displayorder curview need_redisplay
5130 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5132 if {$row < 0} {
5133 set row 0
5135 if {$endrow eq {}} {
5136 set endrow $row
5138 if {$endrow >= $numcommits} {
5139 set endrow [expr {$numcommits - 1}]
5142 set rl1 [expr {$row - $downarrowlen - 3}]
5143 if {$rl1 < 0} {
5144 set rl1 0
5146 set ro1 [expr {$row - 3}]
5147 if {$ro1 < 0} {
5148 set ro1 0
5150 set r2 [expr {$endrow + $uparrowlen + 3}]
5151 if {$r2 > $numcommits} {
5152 set r2 $numcommits
5154 for {set r $rl1} {$r < $r2} {incr r} {
5155 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5156 if {$rl1 < $r} {
5157 layoutrows $rl1 $r
5159 set rl1 [expr {$r + 1}]
5162 if {$rl1 < $r} {
5163 layoutrows $rl1 $r
5165 optimize_rows $ro1 0 $r2
5166 if {$need_redisplay || $nrows_drawn > 2000} {
5167 clear_display
5168 drawvisible
5171 # make the lines join to already-drawn rows either side
5172 set r [expr {$row - 1}]
5173 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5174 set r $row
5176 set er [expr {$endrow + 1}]
5177 if {$er >= $numcommits ||
5178 ![info exists iddrawn([lindex $displayorder $er])]} {
5179 set er $endrow
5181 for {} {$r <= $er} {incr r} {
5182 set id [lindex $displayorder $r]
5183 set wasdrawn [info exists iddrawn($id)]
5184 drawcmitrow $r
5185 if {$r == $er} break
5186 set nextid [lindex $displayorder [expr {$r + 1}]]
5187 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5188 drawparentlinks $id $r
5190 set rowids [lindex $rowidlist $r]
5191 foreach lid $rowids {
5192 if {$lid eq {}} continue
5193 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5194 if {$lid eq $id} {
5195 # see if this is the first child of any of its parents
5196 foreach p [lindex $parentlist $r] {
5197 if {[lsearch -exact $rowids $p] < 0} {
5198 # make this line extend up to the child
5199 set lineend($p) [drawlineseg $p $r $er 0]
5202 } else {
5203 set lineend($lid) [drawlineseg $lid $r $er 1]
5209 proc undolayout {row} {
5210 global uparrowlen mingaplen downarrowlen
5211 global rowidlist rowisopt rowfinal need_redisplay
5213 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5214 if {$r < 0} {
5215 set r 0
5217 if {[llength $rowidlist] > $r} {
5218 incr r -1
5219 set rowidlist [lrange $rowidlist 0 $r]
5220 set rowfinal [lrange $rowfinal 0 $r]
5221 set rowisopt [lrange $rowisopt 0 $r]
5222 set need_redisplay 1
5223 run drawvisible
5227 proc drawvisible {} {
5228 global canv linespc curview vrowmod selectedline targetrow targetid
5229 global need_redisplay cscroll numcommits
5231 set fs [$canv yview]
5232 set ymax [lindex [$canv cget -scrollregion] 3]
5233 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5234 set f0 [lindex $fs 0]
5235 set f1 [lindex $fs 1]
5236 set y0 [expr {int($f0 * $ymax)}]
5237 set y1 [expr {int($f1 * $ymax)}]
5239 if {[info exists targetid]} {
5240 if {[commitinview $targetid $curview]} {
5241 set r [rowofcommit $targetid]
5242 if {$r != $targetrow} {
5243 # Fix up the scrollregion and change the scrolling position
5244 # now that our target row has moved.
5245 set diff [expr {($r - $targetrow) * $linespc}]
5246 set targetrow $r
5247 setcanvscroll
5248 set ymax [lindex [$canv cget -scrollregion] 3]
5249 incr y0 $diff
5250 incr y1 $diff
5251 set f0 [expr {$y0 / $ymax}]
5252 set f1 [expr {$y1 / $ymax}]
5253 allcanvs yview moveto $f0
5254 $cscroll set $f0 $f1
5255 set need_redisplay 1
5257 } else {
5258 unset targetid
5262 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5263 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5264 if {$endrow >= $vrowmod($curview)} {
5265 update_arcrows $curview
5267 if {$selectedline ne {} &&
5268 $row <= $selectedline && $selectedline <= $endrow} {
5269 set targetrow $selectedline
5270 } elseif {[info exists targetid]} {
5271 set targetrow [expr {int(($row + $endrow) / 2)}]
5273 if {[info exists targetrow]} {
5274 if {$targetrow >= $numcommits} {
5275 set targetrow [expr {$numcommits - 1}]
5277 set targetid [commitonrow $targetrow]
5279 drawcommits $row $endrow
5282 proc clear_display {} {
5283 global iddrawn linesegs need_redisplay nrows_drawn
5284 global vhighlights fhighlights nhighlights rhighlights
5285 global linehtag linentag linedtag boldrows boldnamerows
5287 allcanvs delete all
5288 catch {unset iddrawn}
5289 catch {unset linesegs}
5290 catch {unset linehtag}
5291 catch {unset linentag}
5292 catch {unset linedtag}
5293 set boldrows {}
5294 set boldnamerows {}
5295 catch {unset vhighlights}
5296 catch {unset fhighlights}
5297 catch {unset nhighlights}
5298 catch {unset rhighlights}
5299 set need_redisplay 0
5300 set nrows_drawn 0
5303 proc findcrossings {id} {
5304 global rowidlist parentlist numcommits displayorder
5306 set cross {}
5307 set ccross {}
5308 foreach {s e} [rowranges $id] {
5309 if {$e >= $numcommits} {
5310 set e [expr {$numcommits - 1}]
5312 if {$e <= $s} continue
5313 for {set row $e} {[incr row -1] >= $s} {} {
5314 set x [lsearch -exact [lindex $rowidlist $row] $id]
5315 if {$x < 0} break
5316 set olds [lindex $parentlist $row]
5317 set kid [lindex $displayorder $row]
5318 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5319 if {$kidx < 0} continue
5320 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5321 foreach p $olds {
5322 set px [lsearch -exact $nextrow $p]
5323 if {$px < 0} continue
5324 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5325 if {[lsearch -exact $ccross $p] >= 0} continue
5326 if {$x == $px + ($kidx < $px? -1: 1)} {
5327 lappend ccross $p
5328 } elseif {[lsearch -exact $cross $p] < 0} {
5329 lappend cross $p
5335 return [concat $ccross {{}} $cross]
5338 proc assigncolor {id} {
5339 global colormap colors nextcolor
5340 global parents children children curview
5342 if {[info exists colormap($id)]} return
5343 set ncolors [llength $colors]
5344 if {[info exists children($curview,$id)]} {
5345 set kids $children($curview,$id)
5346 } else {
5347 set kids {}
5349 if {[llength $kids] == 1} {
5350 set child [lindex $kids 0]
5351 if {[info exists colormap($child)]
5352 && [llength $parents($curview,$child)] == 1} {
5353 set colormap($id) $colormap($child)
5354 return
5357 set badcolors {}
5358 set origbad {}
5359 foreach x [findcrossings $id] {
5360 if {$x eq {}} {
5361 # delimiter between corner crossings and other crossings
5362 if {[llength $badcolors] >= $ncolors - 1} break
5363 set origbad $badcolors
5365 if {[info exists colormap($x)]
5366 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5367 lappend badcolors $colormap($x)
5370 if {[llength $badcolors] >= $ncolors} {
5371 set badcolors $origbad
5373 set origbad $badcolors
5374 if {[llength $badcolors] < $ncolors - 1} {
5375 foreach child $kids {
5376 if {[info exists colormap($child)]
5377 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5378 lappend badcolors $colormap($child)
5380 foreach p $parents($curview,$child) {
5381 if {[info exists colormap($p)]
5382 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5383 lappend badcolors $colormap($p)
5387 if {[llength $badcolors] >= $ncolors} {
5388 set badcolors $origbad
5391 for {set i 0} {$i <= $ncolors} {incr i} {
5392 set c [lindex $colors $nextcolor]
5393 if {[incr nextcolor] >= $ncolors} {
5394 set nextcolor 0
5396 if {[lsearch -exact $badcolors $c]} break
5398 set colormap($id) $c
5401 proc bindline {t id} {
5402 global canv
5404 $canv bind $t <Enter> "lineenter %x %y $id"
5405 $canv bind $t <Motion> "linemotion %x %y $id"
5406 $canv bind $t <Leave> "lineleave $id"
5407 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5410 proc drawtags {id x xt y1} {
5411 global idtags idheads idotherrefs mainhead
5412 global linespc lthickness
5413 global canv rowtextx curview fgcolor bgcolor ctxbut
5415 set marks {}
5416 set ntags 0
5417 set nheads 0
5418 if {[info exists idtags($id)]} {
5419 set marks $idtags($id)
5420 set ntags [llength $marks]
5422 if {[info exists idheads($id)]} {
5423 set marks [concat $marks $idheads($id)]
5424 set nheads [llength $idheads($id)]
5426 if {[info exists idotherrefs($id)]} {
5427 set marks [concat $marks $idotherrefs($id)]
5429 if {$marks eq {}} {
5430 return $xt
5433 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5434 set yt [expr {$y1 - 0.5 * $linespc}]
5435 set yb [expr {$yt + $linespc - 1}]
5436 set xvals {}
5437 set wvals {}
5438 set i -1
5439 foreach tag $marks {
5440 incr i
5441 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5442 set wid [font measure mainfontbold $tag]
5443 } else {
5444 set wid [font measure mainfont $tag]
5446 lappend xvals $xt
5447 lappend wvals $wid
5448 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5450 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5451 -width $lthickness -fill black -tags tag.$id]
5452 $canv lower $t
5453 foreach tag $marks x $xvals wid $wvals {
5454 set xl [expr {$x + $delta}]
5455 set xr [expr {$x + $delta + $wid + $lthickness}]
5456 set font mainfont
5457 if {[incr ntags -1] >= 0} {
5458 # draw a tag
5459 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5460 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5461 -width 1 -outline black -fill yellow -tags tag.$id]
5462 $canv bind $t <1> [list showtag $tag 1]
5463 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5464 } else {
5465 # draw a head or other ref
5466 if {[incr nheads -1] >= 0} {
5467 set col green
5468 if {$tag eq $mainhead} {
5469 set font mainfontbold
5471 } else {
5472 set col "#ddddff"
5474 set xl [expr {$xl - $delta/2}]
5475 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5476 -width 1 -outline black -fill $col -tags tag.$id
5477 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5478 set rwid [font measure mainfont $remoteprefix]
5479 set xi [expr {$x + 1}]
5480 set yti [expr {$yt + 1}]
5481 set xri [expr {$x + $rwid}]
5482 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5483 -width 0 -fill "#ffddaa" -tags tag.$id
5486 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5487 -font $font -tags [list tag.$id text]]
5488 if {$ntags >= 0} {
5489 $canv bind $t <1> [list showtag $tag 1]
5490 } elseif {$nheads >= 0} {
5491 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
5494 return $xt
5497 proc xcoord {i level ln} {
5498 global canvx0 xspc1 xspc2
5500 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5501 if {$i > 0 && $i == $level} {
5502 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5503 } elseif {$i > $level} {
5504 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5506 return $x
5509 proc show_status {msg} {
5510 global canv fgcolor
5512 clear_display
5513 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5514 -tags text -fill $fgcolor
5517 # Don't change the text pane cursor if it is currently the hand cursor,
5518 # showing that we are over a sha1 ID link.
5519 proc settextcursor {c} {
5520 global ctext curtextcursor
5522 if {[$ctext cget -cursor] == $curtextcursor} {
5523 $ctext config -cursor $c
5525 set curtextcursor $c
5528 proc nowbusy {what {name {}}} {
5529 global isbusy busyname statusw
5531 if {[array names isbusy] eq {}} {
5532 . config -cursor watch
5533 settextcursor watch
5535 set isbusy($what) 1
5536 set busyname($what) $name
5537 if {$name ne {}} {
5538 $statusw conf -text $name
5542 proc notbusy {what} {
5543 global isbusy maincursor textcursor busyname statusw
5545 catch {
5546 unset isbusy($what)
5547 if {$busyname($what) ne {} &&
5548 [$statusw cget -text] eq $busyname($what)} {
5549 $statusw conf -text {}
5552 if {[array names isbusy] eq {}} {
5553 . config -cursor $maincursor
5554 settextcursor $textcursor
5558 proc findmatches {f} {
5559 global findtype findstring
5560 if {$findtype == [mc "Regexp"]} {
5561 set matches [regexp -indices -all -inline $findstring $f]
5562 } else {
5563 set fs $findstring
5564 if {$findtype == [mc "IgnCase"]} {
5565 set f [string tolower $f]
5566 set fs [string tolower $fs]
5568 set matches {}
5569 set i 0
5570 set l [string length $fs]
5571 while {[set j [string first $fs $f $i]] >= 0} {
5572 lappend matches [list $j [expr {$j+$l-1}]]
5573 set i [expr {$j + $l}]
5576 return $matches
5579 proc dofind {{dirn 1} {wrap 1}} {
5580 global findstring findstartline findcurline selectedline numcommits
5581 global gdttype filehighlight fh_serial find_dirn findallowwrap
5583 if {[info exists find_dirn]} {
5584 if {$find_dirn == $dirn} return
5585 stopfinding
5587 focus .
5588 if {$findstring eq {} || $numcommits == 0} return
5589 if {$selectedline eq {}} {
5590 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5591 } else {
5592 set findstartline $selectedline
5594 set findcurline $findstartline
5595 nowbusy finding [mc "Searching"]
5596 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5597 after cancel do_file_hl $fh_serial
5598 do_file_hl $fh_serial
5600 set find_dirn $dirn
5601 set findallowwrap $wrap
5602 run findmore
5605 proc stopfinding {} {
5606 global find_dirn findcurline fprogcoord
5608 if {[info exists find_dirn]} {
5609 unset find_dirn
5610 unset findcurline
5611 notbusy finding
5612 set fprogcoord 0
5613 adjustprogress
5617 proc findmore {} {
5618 global commitdata commitinfo numcommits findpattern findloc
5619 global findstartline findcurline findallowwrap
5620 global find_dirn gdttype fhighlights fprogcoord
5621 global curview varcorder vrownum varccommits vrowmod
5623 if {![info exists find_dirn]} {
5624 return 0
5626 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5627 set l $findcurline
5628 set moretodo 0
5629 if {$find_dirn > 0} {
5630 incr l
5631 if {$l >= $numcommits} {
5632 set l 0
5634 if {$l <= $findstartline} {
5635 set lim [expr {$findstartline + 1}]
5636 } else {
5637 set lim $numcommits
5638 set moretodo $findallowwrap
5640 } else {
5641 if {$l == 0} {
5642 set l $numcommits
5644 incr l -1
5645 if {$l >= $findstartline} {
5646 set lim [expr {$findstartline - 1}]
5647 } else {
5648 set lim -1
5649 set moretodo $findallowwrap
5652 set n [expr {($lim - $l) * $find_dirn}]
5653 if {$n > 500} {
5654 set n 500
5655 set moretodo 1
5657 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5658 update_arcrows $curview
5660 set found 0
5661 set domore 1
5662 set ai [bsearch $vrownum($curview) $l]
5663 set a [lindex $varcorder($curview) $ai]
5664 set arow [lindex $vrownum($curview) $ai]
5665 set ids [lindex $varccommits($curview,$a)]
5666 set arowend [expr {$arow + [llength $ids]}]
5667 if {$gdttype eq [mc "containing:"]} {
5668 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5669 if {$l < $arow || $l >= $arowend} {
5670 incr ai $find_dirn
5671 set a [lindex $varcorder($curview) $ai]
5672 set arow [lindex $vrownum($curview) $ai]
5673 set ids [lindex $varccommits($curview,$a)]
5674 set arowend [expr {$arow + [llength $ids]}]
5676 set id [lindex $ids [expr {$l - $arow}]]
5677 # shouldn't happen unless git log doesn't give all the commits...
5678 if {![info exists commitdata($id)] ||
5679 ![doesmatch $commitdata($id)]} {
5680 continue
5682 if {![info exists commitinfo($id)]} {
5683 getcommit $id
5685 set info $commitinfo($id)
5686 foreach f $info ty $fldtypes {
5687 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5688 [doesmatch $f]} {
5689 set found 1
5690 break
5693 if {$found} break
5695 } else {
5696 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5697 if {$l < $arow || $l >= $arowend} {
5698 incr ai $find_dirn
5699 set a [lindex $varcorder($curview) $ai]
5700 set arow [lindex $vrownum($curview) $ai]
5701 set ids [lindex $varccommits($curview,$a)]
5702 set arowend [expr {$arow + [llength $ids]}]
5704 set id [lindex $ids [expr {$l - $arow}]]
5705 if {![info exists fhighlights($id)]} {
5706 # this sets fhighlights($id) to -1
5707 askfilehighlight $l $id
5709 if {$fhighlights($id) > 0} {
5710 set found $domore
5711 break
5713 if {$fhighlights($id) < 0} {
5714 if {$domore} {
5715 set domore 0
5716 set findcurline [expr {$l - $find_dirn}]
5721 if {$found || ($domore && !$moretodo)} {
5722 unset findcurline
5723 unset find_dirn
5724 notbusy finding
5725 set fprogcoord 0
5726 adjustprogress
5727 if {$found} {
5728 findselectline $l
5729 } else {
5730 bell
5732 return 0
5734 if {!$domore} {
5735 flushhighlights
5736 } else {
5737 set findcurline [expr {$l - $find_dirn}]
5739 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5740 if {$n < 0} {
5741 incr n $numcommits
5743 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5744 adjustprogress
5745 return $domore
5748 proc findselectline {l} {
5749 global findloc commentend ctext findcurline markingmatches gdttype
5751 set markingmatches 1
5752 set findcurline $l
5753 selectline $l 1
5754 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5755 # highlight the matches in the comments
5756 set f [$ctext get 1.0 $commentend]
5757 set matches [findmatches $f]
5758 foreach match $matches {
5759 set start [lindex $match 0]
5760 set end [expr {[lindex $match 1] + 1}]
5761 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5764 drawvisible
5767 # mark the bits of a headline or author that match a find string
5768 proc markmatches {canv l str tag matches font row} {
5769 global selectedline
5771 set bbox [$canv bbox $tag]
5772 set x0 [lindex $bbox 0]
5773 set y0 [lindex $bbox 1]
5774 set y1 [lindex $bbox 3]
5775 foreach match $matches {
5776 set start [lindex $match 0]
5777 set end [lindex $match 1]
5778 if {$start > $end} continue
5779 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5780 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5781 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5782 [expr {$x0+$xlen+2}] $y1 \
5783 -outline {} -tags [list match$l matches] -fill yellow]
5784 $canv lower $t
5785 if {$row == $selectedline} {
5786 $canv raise $t secsel
5791 proc unmarkmatches {} {
5792 global markingmatches
5794 allcanvs delete matches
5795 set markingmatches 0
5796 stopfinding
5799 proc selcanvline {w x y} {
5800 global canv canvy0 ctext linespc
5801 global rowtextx
5802 set ymax [lindex [$canv cget -scrollregion] 3]
5803 if {$ymax == {}} return
5804 set yfrac [lindex [$canv yview] 0]
5805 set y [expr {$y + $yfrac * $ymax}]
5806 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5807 if {$l < 0} {
5808 set l 0
5810 if {$w eq $canv} {
5811 set xmax [lindex [$canv cget -scrollregion] 2]
5812 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5813 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5815 unmarkmatches
5816 selectline $l 1
5819 proc commit_descriptor {p} {
5820 global commitinfo
5821 if {![info exists commitinfo($p)]} {
5822 getcommit $p
5824 set l "..."
5825 if {[llength $commitinfo($p)] > 1} {
5826 set l [lindex $commitinfo($p) 0]
5828 return "$p ($l)\n"
5831 # append some text to the ctext widget, and make any SHA1 ID
5832 # that we know about be a clickable link.
5833 proc appendwithlinks {text tags} {
5834 global ctext linknum curview
5836 set start [$ctext index "end - 1c"]
5837 $ctext insert end $text $tags
5838 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
5839 foreach l $links {
5840 set s [lindex $l 0]
5841 set e [lindex $l 1]
5842 set linkid [string range $text $s $e]
5843 incr e
5844 $ctext tag delete link$linknum
5845 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5846 setlink $linkid link$linknum
5847 incr linknum
5851 proc setlink {id lk} {
5852 global curview ctext pendinglinks
5854 set known 0
5855 if {[string length $id] < 40} {
5856 set matches [longid $id]
5857 if {[llength $matches] > 0} {
5858 if {[llength $matches] > 1} return
5859 set known 1
5860 set id [lindex $matches 0]
5862 } else {
5863 set known [commitinview $id $curview]
5865 if {$known} {
5866 $ctext tag conf $lk -foreground blue -underline 1
5867 $ctext tag bind $lk <1> [list selbyid $id]
5868 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5869 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5870 } else {
5871 lappend pendinglinks($id) $lk
5872 interestedin $id {makelink %P}
5876 proc makelink {id} {
5877 global pendinglinks
5879 if {![info exists pendinglinks($id)]} return
5880 foreach lk $pendinglinks($id) {
5881 setlink $id $lk
5883 unset pendinglinks($id)
5886 proc linkcursor {w inc} {
5887 global linkentercount curtextcursor
5889 if {[incr linkentercount $inc] > 0} {
5890 $w configure -cursor hand2
5891 } else {
5892 $w configure -cursor $curtextcursor
5893 if {$linkentercount < 0} {
5894 set linkentercount 0
5899 proc viewnextline {dir} {
5900 global canv linespc
5902 $canv delete hover
5903 set ymax [lindex [$canv cget -scrollregion] 3]
5904 set wnow [$canv yview]
5905 set wtop [expr {[lindex $wnow 0] * $ymax}]
5906 set newtop [expr {$wtop + $dir * $linespc}]
5907 if {$newtop < 0} {
5908 set newtop 0
5909 } elseif {$newtop > $ymax} {
5910 set newtop $ymax
5912 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5915 # add a list of tag or branch names at position pos
5916 # returns the number of names inserted
5917 proc appendrefs {pos ids var} {
5918 global ctext linknum curview $var maxrefs
5920 if {[catch {$ctext index $pos}]} {
5921 return 0
5923 $ctext conf -state normal
5924 $ctext delete $pos "$pos lineend"
5925 set tags {}
5926 foreach id $ids {
5927 foreach tag [set $var\($id\)] {
5928 lappend tags [list $tag $id]
5931 if {[llength $tags] > $maxrefs} {
5932 $ctext insert $pos "many ([llength $tags])"
5933 } else {
5934 set tags [lsort -index 0 -decreasing $tags]
5935 set sep {}
5936 foreach ti $tags {
5937 set id [lindex $ti 1]
5938 set lk link$linknum
5939 incr linknum
5940 $ctext tag delete $lk
5941 $ctext insert $pos $sep
5942 $ctext insert $pos [lindex $ti 0] $lk
5943 setlink $id $lk
5944 set sep ", "
5947 $ctext conf -state disabled
5948 return [llength $tags]
5951 # called when we have finished computing the nearby tags
5952 proc dispneartags {delay} {
5953 global selectedline currentid showneartags tagphase
5955 if {$selectedline eq {} || !$showneartags} return
5956 after cancel dispnexttag
5957 if {$delay} {
5958 after 200 dispnexttag
5959 set tagphase -1
5960 } else {
5961 after idle dispnexttag
5962 set tagphase 0
5966 proc dispnexttag {} {
5967 global selectedline currentid showneartags tagphase ctext
5969 if {$selectedline eq {} || !$showneartags} return
5970 switch -- $tagphase {
5972 set dtags [desctags $currentid]
5973 if {$dtags ne {}} {
5974 appendrefs precedes $dtags idtags
5978 set atags [anctags $currentid]
5979 if {$atags ne {}} {
5980 appendrefs follows $atags idtags
5984 set dheads [descheads $currentid]
5985 if {$dheads ne {}} {
5986 if {[appendrefs branch $dheads idheads] > 1
5987 && [$ctext get "branch -3c"] eq "h"} {
5988 # turn "Branch" into "Branches"
5989 $ctext conf -state normal
5990 $ctext insert "branch -2c" "es"
5991 $ctext conf -state disabled
5996 if {[incr tagphase] <= 2} {
5997 after idle dispnexttag
6001 proc make_secsel {l} {
6002 global linehtag linentag linedtag canv canv2 canv3
6004 if {![info exists linehtag($l)]} return
6005 $canv delete secsel
6006 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
6007 -tags secsel -fill [$canv cget -selectbackground]]
6008 $canv lower $t
6009 $canv2 delete secsel
6010 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
6011 -tags secsel -fill [$canv2 cget -selectbackground]]
6012 $canv2 lower $t
6013 $canv3 delete secsel
6014 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
6015 -tags secsel -fill [$canv3 cget -selectbackground]]
6016 $canv3 lower $t
6019 proc selectline {l isnew} {
6020 global canv ctext commitinfo selectedline
6021 global canvy0 linespc parents children curview
6022 global currentid sha1entry
6023 global commentend idtags linknum
6024 global mergemax numcommits pending_select
6025 global cmitmode showneartags allcommits
6026 global targetrow targetid lastscrollrows
6027 global autoselect
6029 catch {unset pending_select}
6030 $canv delete hover
6031 normalline
6032 unsel_reflist
6033 stopfinding
6034 if {$l < 0 || $l >= $numcommits} return
6035 set id [commitonrow $l]
6036 set targetid $id
6037 set targetrow $l
6038 set selectedline $l
6039 set currentid $id
6040 if {$lastscrollrows < $numcommits} {
6041 setcanvscroll
6044 set y [expr {$canvy0 + $l * $linespc}]
6045 set ymax [lindex [$canv cget -scrollregion] 3]
6046 set ytop [expr {$y - $linespc - 1}]
6047 set ybot [expr {$y + $linespc + 1}]
6048 set wnow [$canv yview]
6049 set wtop [expr {[lindex $wnow 0] * $ymax}]
6050 set wbot [expr {[lindex $wnow 1] * $ymax}]
6051 set wh [expr {$wbot - $wtop}]
6052 set newtop $wtop
6053 if {$ytop < $wtop} {
6054 if {$ybot < $wtop} {
6055 set newtop [expr {$y - $wh / 2.0}]
6056 } else {
6057 set newtop $ytop
6058 if {$newtop > $wtop - $linespc} {
6059 set newtop [expr {$wtop - $linespc}]
6062 } elseif {$ybot > $wbot} {
6063 if {$ytop > $wbot} {
6064 set newtop [expr {$y - $wh / 2.0}]
6065 } else {
6066 set newtop [expr {$ybot - $wh}]
6067 if {$newtop < $wtop + $linespc} {
6068 set newtop [expr {$wtop + $linespc}]
6072 if {$newtop != $wtop} {
6073 if {$newtop < 0} {
6074 set newtop 0
6076 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6077 drawvisible
6080 make_secsel $l
6082 if {$isnew} {
6083 addtohistory [list selbyid $id]
6086 $sha1entry delete 0 end
6087 $sha1entry insert 0 $id
6088 if {$autoselect} {
6089 $sha1entry selection from 0
6090 $sha1entry selection to end
6092 rhighlight_sel $id
6094 $ctext conf -state normal
6095 clear_ctext
6096 set linknum 0
6097 if {![info exists commitinfo($id)]} {
6098 getcommit $id
6100 set info $commitinfo($id)
6101 set date [formatdate [lindex $info 2]]
6102 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6103 set date [formatdate [lindex $info 4]]
6104 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6105 if {[info exists idtags($id)]} {
6106 $ctext insert end [mc "Tags:"]
6107 foreach tag $idtags($id) {
6108 $ctext insert end " $tag"
6110 $ctext insert end "\n"
6113 set headers {}
6114 set olds $parents($curview,$id)
6115 if {[llength $olds] > 1} {
6116 set np 0
6117 foreach p $olds {
6118 if {$np >= $mergemax} {
6119 set tag mmax
6120 } else {
6121 set tag m$np
6123 $ctext insert end "[mc "Parent"]: " $tag
6124 appendwithlinks [commit_descriptor $p] {}
6125 incr np
6127 } else {
6128 foreach p $olds {
6129 append headers "[mc "Parent"]: [commit_descriptor $p]"
6133 foreach c $children($curview,$id) {
6134 append headers "[mc "Child"]: [commit_descriptor $c]"
6137 # make anything that looks like a SHA1 ID be a clickable link
6138 appendwithlinks $headers {}
6139 if {$showneartags} {
6140 if {![info exists allcommits]} {
6141 getallcommits
6143 $ctext insert end "[mc "Branch"]: "
6144 $ctext mark set branch "end -1c"
6145 $ctext mark gravity branch left
6146 $ctext insert end "\n[mc "Follows"]: "
6147 $ctext mark set follows "end -1c"
6148 $ctext mark gravity follows left
6149 $ctext insert end "\n[mc "Precedes"]: "
6150 $ctext mark set precedes "end -1c"
6151 $ctext mark gravity precedes left
6152 $ctext insert end "\n"
6153 dispneartags 1
6155 $ctext insert end "\n"
6156 set comment [lindex $info 5]
6157 if {[string first "\r" $comment] >= 0} {
6158 set comment [string map {"\r" "\n "} $comment]
6160 appendwithlinks $comment {comment}
6162 $ctext tag remove found 1.0 end
6163 $ctext conf -state disabled
6164 set commentend [$ctext index "end - 1c"]
6166 init_flist [mc "Comments"]
6167 if {$cmitmode eq "tree"} {
6168 gettree $id
6169 } elseif {[llength $olds] <= 1} {
6170 startdiff $id
6171 } else {
6172 mergediff $id
6176 proc selfirstline {} {
6177 unmarkmatches
6178 selectline 0 1
6181 proc sellastline {} {
6182 global numcommits
6183 unmarkmatches
6184 set l [expr {$numcommits - 1}]
6185 selectline $l 1
6188 proc selnextline {dir} {
6189 global selectedline
6190 focus .
6191 if {$selectedline eq {}} return
6192 set l [expr {$selectedline + $dir}]
6193 unmarkmatches
6194 selectline $l 1
6197 proc selnextpage {dir} {
6198 global canv linespc selectedline numcommits
6200 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6201 if {$lpp < 1} {
6202 set lpp 1
6204 allcanvs yview scroll [expr {$dir * $lpp}] units
6205 drawvisible
6206 if {$selectedline eq {}} return
6207 set l [expr {$selectedline + $dir * $lpp}]
6208 if {$l < 0} {
6209 set l 0
6210 } elseif {$l >= $numcommits} {
6211 set l [expr $numcommits - 1]
6213 unmarkmatches
6214 selectline $l 1
6217 proc unselectline {} {
6218 global selectedline currentid
6220 set selectedline {}
6221 catch {unset currentid}
6222 allcanvs delete secsel
6223 rhighlight_none
6226 proc reselectline {} {
6227 global selectedline
6229 if {$selectedline ne {}} {
6230 selectline $selectedline 0
6234 proc addtohistory {cmd} {
6235 global history historyindex curview
6237 set elt [list $curview $cmd]
6238 if {$historyindex > 0
6239 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6240 return
6243 if {$historyindex < [llength $history]} {
6244 set history [lreplace $history $historyindex end $elt]
6245 } else {
6246 lappend history $elt
6248 incr historyindex
6249 if {$historyindex > 1} {
6250 .tf.bar.leftbut conf -state normal
6251 } else {
6252 .tf.bar.leftbut conf -state disabled
6254 .tf.bar.rightbut conf -state disabled
6257 proc godo {elt} {
6258 global curview
6260 set view [lindex $elt 0]
6261 set cmd [lindex $elt 1]
6262 if {$curview != $view} {
6263 showview $view
6265 eval $cmd
6268 proc goback {} {
6269 global history historyindex
6270 focus .
6272 if {$historyindex > 1} {
6273 incr historyindex -1
6274 godo [lindex $history [expr {$historyindex - 1}]]
6275 .tf.bar.rightbut conf -state normal
6277 if {$historyindex <= 1} {
6278 .tf.bar.leftbut conf -state disabled
6282 proc goforw {} {
6283 global history historyindex
6284 focus .
6286 if {$historyindex < [llength $history]} {
6287 set cmd [lindex $history $historyindex]
6288 incr historyindex
6289 godo $cmd
6290 .tf.bar.leftbut conf -state normal
6292 if {$historyindex >= [llength $history]} {
6293 .tf.bar.rightbut conf -state disabled
6297 proc gettree {id} {
6298 global treefilelist treeidlist diffids diffmergeid treepending
6299 global nullid nullid2
6301 set diffids $id
6302 catch {unset diffmergeid}
6303 if {![info exists treefilelist($id)]} {
6304 if {![info exists treepending]} {
6305 if {$id eq $nullid} {
6306 set cmd [list | git ls-files]
6307 } elseif {$id eq $nullid2} {
6308 set cmd [list | git ls-files --stage -t]
6309 } else {
6310 set cmd [list | git ls-tree -r $id]
6312 if {[catch {set gtf [open $cmd r]}]} {
6313 return
6315 set treepending $id
6316 set treefilelist($id) {}
6317 set treeidlist($id) {}
6318 fconfigure $gtf -blocking 0 -encoding binary
6319 filerun $gtf [list gettreeline $gtf $id]
6321 } else {
6322 setfilelist $id
6326 proc gettreeline {gtf id} {
6327 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6329 set nl 0
6330 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6331 if {$diffids eq $nullid} {
6332 set fname $line
6333 } else {
6334 set i [string first "\t" $line]
6335 if {$i < 0} continue
6336 set fname [string range $line [expr {$i+1}] end]
6337 set line [string range $line 0 [expr {$i-1}]]
6338 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6339 set sha1 [lindex $line 2]
6340 lappend treeidlist($id) $sha1
6342 if {[string index $fname 0] eq "\""} {
6343 set fname [lindex $fname 0]
6345 set fname [encoding convertfrom $fname]
6346 lappend treefilelist($id) $fname
6348 if {![eof $gtf]} {
6349 return [expr {$nl >= 1000? 2: 1}]
6351 close $gtf
6352 unset treepending
6353 if {$cmitmode ne "tree"} {
6354 if {![info exists diffmergeid]} {
6355 gettreediffs $diffids
6357 } elseif {$id ne $diffids} {
6358 gettree $diffids
6359 } else {
6360 setfilelist $id
6362 return 0
6365 proc showfile {f} {
6366 global treefilelist treeidlist diffids nullid nullid2
6367 global ctext commentend
6369 set i [lsearch -exact $treefilelist($diffids) $f]
6370 if {$i < 0} {
6371 puts "oops, $f not in list for id $diffids"
6372 return
6374 if {$diffids eq $nullid} {
6375 if {[catch {set bf [open $f r]} err]} {
6376 puts "oops, can't read $f: $err"
6377 return
6379 } else {
6380 set blob [lindex $treeidlist($diffids) $i]
6381 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6382 puts "oops, error reading blob $blob: $err"
6383 return
6386 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6387 filerun $bf [list getblobline $bf $diffids]
6388 $ctext config -state normal
6389 clear_ctext $commentend
6390 $ctext insert end "\n"
6391 $ctext insert end "$f\n" filesep
6392 $ctext config -state disabled
6393 $ctext yview $commentend
6394 settabs 0
6397 proc getblobline {bf id} {
6398 global diffids cmitmode ctext
6400 if {$id ne $diffids || $cmitmode ne "tree"} {
6401 catch {close $bf}
6402 return 0
6404 $ctext config -state normal
6405 set nl 0
6406 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6407 $ctext insert end "$line\n"
6409 if {[eof $bf]} {
6410 # delete last newline
6411 $ctext delete "end - 2c" "end - 1c"
6412 close $bf
6413 return 0
6415 $ctext config -state disabled
6416 return [expr {$nl >= 1000? 2: 1}]
6419 proc mergediff {id} {
6420 global diffmergeid mdifffd
6421 global diffids treediffs
6422 global parents
6423 global diffcontext
6424 global diffencoding
6425 global limitdiffs vfilelimit curview
6427 set diffmergeid $id
6428 set diffids $id
6429 set treediffs($id) {}
6430 # this doesn't seem to actually affect anything...
6431 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6432 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6433 set cmd [concat $cmd -- $vfilelimit($curview)]
6435 if {[catch {set mdf [open $cmd r]} err]} {
6436 error_popup "[mc "Error getting merge diffs:"] $err"
6437 return
6439 fconfigure $mdf -blocking 0 -encoding binary
6440 set mdifffd($id) $mdf
6441 set np [llength $parents($curview,$id)]
6442 set diffencoding [get_path_encoding {}]
6443 settabs $np
6444 filerun $mdf [list getmergediffline $mdf $id $np]
6447 proc getmergediffline {mdf id np} {
6448 global diffmergeid ctext cflist mergemax
6449 global difffilestart mdifffd treediffs
6450 global diffencoding
6452 $ctext conf -state normal
6453 set nr 0
6454 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6455 if {![info exists diffmergeid] || $id != $diffmergeid
6456 || $mdf != $mdifffd($id)} {
6457 close $mdf
6458 return 0
6460 if {[regexp {^diff --cc (.*)} $line match fname]} {
6461 # start of a new file
6462 set fname [encoding convertfrom $fname]
6463 $ctext insert end "\n"
6464 set here [$ctext index "end - 1c"]
6465 lappend difffilestart $here
6466 lappend treediffs($id) $fname
6467 add_flist [list $fname]
6468 set diffencoding [get_path_encoding $fname]
6469 set l [expr {(78 - [string length $fname]) / 2}]
6470 set pad [string range "----------------------------------------" 1 $l]
6471 $ctext insert end "$pad $fname $pad\n" filesep
6472 } elseif {[regexp {^@@} $line]} {
6473 set line [encoding convertfrom $diffencoding $line]
6474 $ctext insert end "$line\n" hunksep
6475 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6476 # do nothing
6477 } else {
6478 set line [encoding convertfrom $diffencoding $line]
6479 # parse the prefix - one ' ', '-' or '+' for each parent
6480 set spaces {}
6481 set minuses {}
6482 set pluses {}
6483 set isbad 0
6484 for {set j 0} {$j < $np} {incr j} {
6485 set c [string range $line $j $j]
6486 if {$c == " "} {
6487 lappend spaces $j
6488 } elseif {$c == "-"} {
6489 lappend minuses $j
6490 } elseif {$c == "+"} {
6491 lappend pluses $j
6492 } else {
6493 set isbad 1
6494 break
6497 set tags {}
6498 set num {}
6499 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6500 # line doesn't appear in result, parents in $minuses have the line
6501 set num [lindex $minuses 0]
6502 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6503 # line appears in result, parents in $pluses don't have the line
6504 lappend tags mresult
6505 set num [lindex $spaces 0]
6507 if {$num ne {}} {
6508 if {$num >= $mergemax} {
6509 set num "max"
6511 lappend tags m$num
6513 $ctext insert end "$line\n" $tags
6516 $ctext conf -state disabled
6517 if {[eof $mdf]} {
6518 close $mdf
6519 return 0
6521 return [expr {$nr >= 1000? 2: 1}]
6524 proc startdiff {ids} {
6525 global treediffs diffids treepending diffmergeid nullid nullid2
6527 settabs 1
6528 set diffids $ids
6529 catch {unset diffmergeid}
6530 if {![info exists treediffs($ids)] ||
6531 [lsearch -exact $ids $nullid] >= 0 ||
6532 [lsearch -exact $ids $nullid2] >= 0} {
6533 if {![info exists treepending]} {
6534 gettreediffs $ids
6536 } else {
6537 addtocflist $ids
6541 proc path_filter {filter name} {
6542 foreach p $filter {
6543 set l [string length $p]
6544 if {[string index $p end] eq "/"} {
6545 if {[string compare -length $l $p $name] == 0} {
6546 return 1
6548 } else {
6549 if {[string compare -length $l $p $name] == 0 &&
6550 ([string length $name] == $l ||
6551 [string index $name $l] eq "/")} {
6552 return 1
6556 return 0
6559 proc addtocflist {ids} {
6560 global treediffs
6562 add_flist $treediffs($ids)
6563 getblobdiffs $ids
6566 proc diffcmd {ids flags} {
6567 global nullid nullid2
6569 set i [lsearch -exact $ids $nullid]
6570 set j [lsearch -exact $ids $nullid2]
6571 if {$i >= 0} {
6572 if {[llength $ids] > 1 && $j < 0} {
6573 # comparing working directory with some specific revision
6574 set cmd [concat | git diff-index $flags]
6575 if {$i == 0} {
6576 lappend cmd -R [lindex $ids 1]
6577 } else {
6578 lappend cmd [lindex $ids 0]
6580 } else {
6581 # comparing working directory with index
6582 set cmd [concat | git diff-files $flags]
6583 if {$j == 1} {
6584 lappend cmd -R
6587 } elseif {$j >= 0} {
6588 set cmd [concat | git diff-index --cached $flags]
6589 if {[llength $ids] > 1} {
6590 # comparing index with specific revision
6591 if {$i == 0} {
6592 lappend cmd -R [lindex $ids 1]
6593 } else {
6594 lappend cmd [lindex $ids 0]
6596 } else {
6597 # comparing index with HEAD
6598 lappend cmd HEAD
6600 } else {
6601 set cmd [concat | git diff-tree -r $flags $ids]
6603 return $cmd
6606 proc gettreediffs {ids} {
6607 global treediff treepending
6609 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6611 set treepending $ids
6612 set treediff {}
6613 fconfigure $gdtf -blocking 0 -encoding binary
6614 filerun $gdtf [list gettreediffline $gdtf $ids]
6617 proc gettreediffline {gdtf ids} {
6618 global treediff treediffs treepending diffids diffmergeid
6619 global cmitmode vfilelimit curview limitdiffs perfile_attrs
6621 set nr 0
6622 set sublist {}
6623 set max 1000
6624 if {$perfile_attrs} {
6625 # cache_gitattr is slow, and even slower on win32 where we
6626 # have to invoke it for only about 30 paths at a time
6627 set max 500
6628 if {[tk windowingsystem] == "win32"} {
6629 set max 120
6632 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
6633 set i [string first "\t" $line]
6634 if {$i >= 0} {
6635 set file [string range $line [expr {$i+1}] end]
6636 if {[string index $file 0] eq "\""} {
6637 set file [lindex $file 0]
6639 set file [encoding convertfrom $file]
6640 lappend treediff $file
6641 lappend sublist $file
6644 if {$perfile_attrs} {
6645 cache_gitattr encoding $sublist
6647 if {![eof $gdtf]} {
6648 return [expr {$nr >= $max? 2: 1}]
6650 close $gdtf
6651 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6652 set flist {}
6653 foreach f $treediff {
6654 if {[path_filter $vfilelimit($curview) $f]} {
6655 lappend flist $f
6658 set treediffs($ids) $flist
6659 } else {
6660 set treediffs($ids) $treediff
6662 unset treepending
6663 if {$cmitmode eq "tree"} {
6664 gettree $diffids
6665 } elseif {$ids != $diffids} {
6666 if {![info exists diffmergeid]} {
6667 gettreediffs $diffids
6669 } else {
6670 addtocflist $ids
6672 return 0
6675 # empty string or positive integer
6676 proc diffcontextvalidate {v} {
6677 return [regexp {^(|[1-9][0-9]*)$} $v]
6680 proc diffcontextchange {n1 n2 op} {
6681 global diffcontextstring diffcontext
6683 if {[string is integer -strict $diffcontextstring]} {
6684 if {$diffcontextstring > 0} {
6685 set diffcontext $diffcontextstring
6686 reselectline
6691 proc changeignorespace {} {
6692 reselectline
6695 proc getblobdiffs {ids} {
6696 global blobdifffd diffids env
6697 global diffinhdr treediffs
6698 global diffcontext
6699 global ignorespace
6700 global limitdiffs vfilelimit curview
6701 global diffencoding
6703 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6704 if {$ignorespace} {
6705 append cmd " -w"
6707 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6708 set cmd [concat $cmd -- $vfilelimit($curview)]
6710 if {[catch {set bdf [open $cmd r]} err]} {
6711 puts "error getting diffs: $err"
6712 return
6714 set diffinhdr 0
6715 set diffencoding [get_path_encoding {}]
6716 fconfigure $bdf -blocking 0 -encoding binary
6717 set blobdifffd($ids) $bdf
6718 filerun $bdf [list getblobdiffline $bdf $diffids]
6721 proc setinlist {var i val} {
6722 global $var
6724 while {[llength [set $var]] < $i} {
6725 lappend $var {}
6727 if {[llength [set $var]] == $i} {
6728 lappend $var $val
6729 } else {
6730 lset $var $i $val
6734 proc makediffhdr {fname ids} {
6735 global ctext curdiffstart treediffs
6737 set i [lsearch -exact $treediffs($ids) $fname]
6738 if {$i >= 0} {
6739 setinlist difffilestart $i $curdiffstart
6741 set l [expr {(78 - [string length $fname]) / 2}]
6742 set pad [string range "----------------------------------------" 1 $l]
6743 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6746 proc getblobdiffline {bdf ids} {
6747 global diffids blobdifffd ctext curdiffstart
6748 global diffnexthead diffnextnote difffilestart
6749 global diffinhdr treediffs
6750 global diffencoding
6752 set nr 0
6753 $ctext conf -state normal
6754 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6755 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6756 close $bdf
6757 return 0
6759 if {![string compare -length 11 "diff --git " $line]} {
6760 # trim off "diff --git "
6761 set line [string range $line 11 end]
6762 set diffinhdr 1
6763 # start of a new file
6764 $ctext insert end "\n"
6765 set curdiffstart [$ctext index "end - 1c"]
6766 $ctext insert end "\n" filesep
6767 # If the name hasn't changed the length will be odd,
6768 # the middle char will be a space, and the two bits either
6769 # side will be a/name and b/name, or "a/name" and "b/name".
6770 # If the name has changed we'll get "rename from" and
6771 # "rename to" or "copy from" and "copy to" lines following this,
6772 # and we'll use them to get the filenames.
6773 # This complexity is necessary because spaces in the filename(s)
6774 # don't get escaped.
6775 set l [string length $line]
6776 set i [expr {$l / 2}]
6777 if {!(($l & 1) && [string index $line $i] eq " " &&
6778 [string range $line 2 [expr {$i - 1}]] eq \
6779 [string range $line [expr {$i + 3}] end])} {
6780 continue
6782 # unescape if quoted and chop off the a/ from the front
6783 if {[string index $line 0] eq "\""} {
6784 set fname [string range [lindex $line 0] 2 end]
6785 } else {
6786 set fname [string range $line 2 [expr {$i - 1}]]
6788 set fname [encoding convertfrom $fname]
6789 set diffencoding [get_path_encoding $fname]
6790 makediffhdr $fname $ids
6792 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6793 $line match f1l f1c f2l f2c rest]} {
6794 set line [encoding convertfrom $diffencoding $line]
6795 $ctext insert end "$line\n" hunksep
6796 set diffinhdr 0
6798 } elseif {$diffinhdr} {
6799 if {![string compare -length 12 "rename from " $line]} {
6800 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6801 if {[string index $fname 0] eq "\""} {
6802 set fname [lindex $fname 0]
6804 set fname [encoding convertfrom $fname]
6805 set i [lsearch -exact $treediffs($ids) $fname]
6806 if {$i >= 0} {
6807 setinlist difffilestart $i $curdiffstart
6809 } elseif {![string compare -length 10 $line "rename to "] ||
6810 ![string compare -length 8 $line "copy to "]} {
6811 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6812 if {[string index $fname 0] eq "\""} {
6813 set fname [lindex $fname 0]
6815 set fname [encoding convertfrom $fname]
6816 set diffencoding [get_path_encoding $fname]
6817 makediffhdr $fname $ids
6818 } elseif {[string compare -length 3 $line "---"] == 0} {
6819 # do nothing
6820 continue
6821 } elseif {[string compare -length 3 $line "+++"] == 0} {
6822 set diffinhdr 0
6823 continue
6825 $ctext insert end "$line\n" filesep
6827 } else {
6828 set line [encoding convertfrom $diffencoding $line]
6829 set x [string range $line 0 0]
6830 if {$x == "-" || $x == "+"} {
6831 set tag [expr {$x == "+"}]
6832 $ctext insert end "$line\n" d$tag
6833 } elseif {$x == " "} {
6834 $ctext insert end "$line\n"
6835 } else {
6836 # "\ No newline at end of file",
6837 # or something else we don't recognize
6838 $ctext insert end "$line\n" hunksep
6842 $ctext conf -state disabled
6843 if {[eof $bdf]} {
6844 close $bdf
6845 return 0
6847 return [expr {$nr >= 1000? 2: 1}]
6850 proc changediffdisp {} {
6851 global ctext diffelide
6853 $ctext tag conf d0 -elide [lindex $diffelide 0]
6854 $ctext tag conf d1 -elide [lindex $diffelide 1]
6857 proc highlightfile {loc cline} {
6858 global ctext cflist cflist_top
6860 $ctext yview $loc
6861 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6862 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6863 $cflist see $cline.0
6864 set cflist_top $cline
6867 proc prevfile {} {
6868 global difffilestart ctext cmitmode
6870 if {$cmitmode eq "tree"} return
6871 set prev 0.0
6872 set prevline 1
6873 set here [$ctext index @0,0]
6874 foreach loc $difffilestart {
6875 if {[$ctext compare $loc >= $here]} {
6876 highlightfile $prev $prevline
6877 return
6879 set prev $loc
6880 incr prevline
6882 highlightfile $prev $prevline
6885 proc nextfile {} {
6886 global difffilestart ctext cmitmode
6888 if {$cmitmode eq "tree"} return
6889 set here [$ctext index @0,0]
6890 set line 1
6891 foreach loc $difffilestart {
6892 incr line
6893 if {[$ctext compare $loc > $here]} {
6894 highlightfile $loc $line
6895 return
6900 proc clear_ctext {{first 1.0}} {
6901 global ctext smarktop smarkbot
6902 global pendinglinks
6904 set l [lindex [split $first .] 0]
6905 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6906 set smarktop $l
6908 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6909 set smarkbot $l
6911 $ctext delete $first end
6912 if {$first eq "1.0"} {
6913 catch {unset pendinglinks}
6917 proc settabs {{firstab {}}} {
6918 global firsttabstop tabstop ctext have_tk85
6920 if {$firstab ne {} && $have_tk85} {
6921 set firsttabstop $firstab
6923 set w [font measure textfont "0"]
6924 if {$firsttabstop != 0} {
6925 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6926 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6927 } elseif {$have_tk85 || $tabstop != 8} {
6928 $ctext conf -tabs [expr {$tabstop * $w}]
6929 } else {
6930 $ctext conf -tabs {}
6934 proc incrsearch {name ix op} {
6935 global ctext searchstring searchdirn
6937 $ctext tag remove found 1.0 end
6938 if {[catch {$ctext index anchor}]} {
6939 # no anchor set, use start of selection, or of visible area
6940 set sel [$ctext tag ranges sel]
6941 if {$sel ne {}} {
6942 $ctext mark set anchor [lindex $sel 0]
6943 } elseif {$searchdirn eq "-forwards"} {
6944 $ctext mark set anchor @0,0
6945 } else {
6946 $ctext mark set anchor @0,[winfo height $ctext]
6949 if {$searchstring ne {}} {
6950 set here [$ctext search $searchdirn -- $searchstring anchor]
6951 if {$here ne {}} {
6952 $ctext see $here
6954 searchmarkvisible 1
6958 proc dosearch {} {
6959 global sstring ctext searchstring searchdirn
6961 focus $sstring
6962 $sstring icursor end
6963 set searchdirn -forwards
6964 if {$searchstring ne {}} {
6965 set sel [$ctext tag ranges sel]
6966 if {$sel ne {}} {
6967 set start "[lindex $sel 0] + 1c"
6968 } elseif {[catch {set start [$ctext index anchor]}]} {
6969 set start "@0,0"
6971 set match [$ctext search -count mlen -- $searchstring $start]
6972 $ctext tag remove sel 1.0 end
6973 if {$match eq {}} {
6974 bell
6975 return
6977 $ctext see $match
6978 set mend "$match + $mlen c"
6979 $ctext tag add sel $match $mend
6980 $ctext mark unset anchor
6984 proc dosearchback {} {
6985 global sstring ctext searchstring searchdirn
6987 focus $sstring
6988 $sstring icursor end
6989 set searchdirn -backwards
6990 if {$searchstring ne {}} {
6991 set sel [$ctext tag ranges sel]
6992 if {$sel ne {}} {
6993 set start [lindex $sel 0]
6994 } elseif {[catch {set start [$ctext index anchor]}]} {
6995 set start @0,[winfo height $ctext]
6997 set match [$ctext search -backwards -count ml -- $searchstring $start]
6998 $ctext tag remove sel 1.0 end
6999 if {$match eq {}} {
7000 bell
7001 return
7003 $ctext see $match
7004 set mend "$match + $ml c"
7005 $ctext tag add sel $match $mend
7006 $ctext mark unset anchor
7010 proc searchmark {first last} {
7011 global ctext searchstring
7013 set mend $first.0
7014 while {1} {
7015 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7016 if {$match eq {}} break
7017 set mend "$match + $mlen c"
7018 $ctext tag add found $match $mend
7022 proc searchmarkvisible {doall} {
7023 global ctext smarktop smarkbot
7025 set topline [lindex [split [$ctext index @0,0] .] 0]
7026 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7027 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7028 # no overlap with previous
7029 searchmark $topline $botline
7030 set smarktop $topline
7031 set smarkbot $botline
7032 } else {
7033 if {$topline < $smarktop} {
7034 searchmark $topline [expr {$smarktop-1}]
7035 set smarktop $topline
7037 if {$botline > $smarkbot} {
7038 searchmark [expr {$smarkbot+1}] $botline
7039 set smarkbot $botline
7044 proc scrolltext {f0 f1} {
7045 global searchstring
7047 .bleft.bottom.sb set $f0 $f1
7048 if {$searchstring ne {}} {
7049 searchmarkvisible 0
7053 proc setcoords {} {
7054 global linespc charspc canvx0 canvy0
7055 global xspc1 xspc2 lthickness
7057 set linespc [font metrics mainfont -linespace]
7058 set charspc [font measure mainfont "m"]
7059 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7060 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7061 set lthickness [expr {int($linespc / 9) + 1}]
7062 set xspc1(0) $linespc
7063 set xspc2 $linespc
7066 proc redisplay {} {
7067 global canv
7068 global selectedline
7070 set ymax [lindex [$canv cget -scrollregion] 3]
7071 if {$ymax eq {} || $ymax == 0} return
7072 set span [$canv yview]
7073 clear_display
7074 setcanvscroll
7075 allcanvs yview moveto [lindex $span 0]
7076 drawvisible
7077 if {$selectedline ne {}} {
7078 selectline $selectedline 0
7079 allcanvs yview moveto [lindex $span 0]
7083 proc parsefont {f n} {
7084 global fontattr
7086 set fontattr($f,family) [lindex $n 0]
7087 set s [lindex $n 1]
7088 if {$s eq {} || $s == 0} {
7089 set s 10
7090 } elseif {$s < 0} {
7091 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7093 set fontattr($f,size) $s
7094 set fontattr($f,weight) normal
7095 set fontattr($f,slant) roman
7096 foreach style [lrange $n 2 end] {
7097 switch -- $style {
7098 "normal" -
7099 "bold" {set fontattr($f,weight) $style}
7100 "roman" -
7101 "italic" {set fontattr($f,slant) $style}
7106 proc fontflags {f {isbold 0}} {
7107 global fontattr
7109 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7110 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7111 -slant $fontattr($f,slant)]
7114 proc fontname {f} {
7115 global fontattr
7117 set n [list $fontattr($f,family) $fontattr($f,size)]
7118 if {$fontattr($f,weight) eq "bold"} {
7119 lappend n "bold"
7121 if {$fontattr($f,slant) eq "italic"} {
7122 lappend n "italic"
7124 return $n
7127 proc incrfont {inc} {
7128 global mainfont textfont ctext canv cflist showrefstop
7129 global stopped entries fontattr
7131 unmarkmatches
7132 set s $fontattr(mainfont,size)
7133 incr s $inc
7134 if {$s < 1} {
7135 set s 1
7137 set fontattr(mainfont,size) $s
7138 font config mainfont -size $s
7139 font config mainfontbold -size $s
7140 set mainfont [fontname mainfont]
7141 set s $fontattr(textfont,size)
7142 incr s $inc
7143 if {$s < 1} {
7144 set s 1
7146 set fontattr(textfont,size) $s
7147 font config textfont -size $s
7148 font config textfontbold -size $s
7149 set textfont [fontname textfont]
7150 setcoords
7151 settabs
7152 redisplay
7155 proc clearsha1 {} {
7156 global sha1entry sha1string
7157 if {[string length $sha1string] == 40} {
7158 $sha1entry delete 0 end
7162 proc sha1change {n1 n2 op} {
7163 global sha1string currentid sha1but
7164 if {$sha1string == {}
7165 || ([info exists currentid] && $sha1string == $currentid)} {
7166 set state disabled
7167 } else {
7168 set state normal
7170 if {[$sha1but cget -state] == $state} return
7171 if {$state == "normal"} {
7172 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7173 } else {
7174 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7178 proc gotocommit {} {
7179 global sha1string tagids headids curview varcid
7181 if {$sha1string == {}
7182 || ([info exists currentid] && $sha1string == $currentid)} return
7183 if {[info exists tagids($sha1string)]} {
7184 set id $tagids($sha1string)
7185 } elseif {[info exists headids($sha1string)]} {
7186 set id $headids($sha1string)
7187 } else {
7188 set id [string tolower $sha1string]
7189 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7190 set matches [longid $id]
7191 if {$matches ne {}} {
7192 if {[llength $matches] > 1} {
7193 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7194 return
7196 set id [lindex $matches 0]
7200 if {[commitinview $id $curview]} {
7201 selectline [rowofcommit $id] 1
7202 return
7204 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7205 set msg [mc "SHA1 id %s is not known" $sha1string]
7206 } else {
7207 set msg [mc "Tag/Head %s is not known" $sha1string]
7209 error_popup $msg
7212 proc lineenter {x y id} {
7213 global hoverx hovery hoverid hovertimer
7214 global commitinfo canv
7216 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7217 set hoverx $x
7218 set hovery $y
7219 set hoverid $id
7220 if {[info exists hovertimer]} {
7221 after cancel $hovertimer
7223 set hovertimer [after 500 linehover]
7224 $canv delete hover
7227 proc linemotion {x y id} {
7228 global hoverx hovery hoverid hovertimer
7230 if {[info exists hoverid] && $id == $hoverid} {
7231 set hoverx $x
7232 set hovery $y
7233 if {[info exists hovertimer]} {
7234 after cancel $hovertimer
7236 set hovertimer [after 500 linehover]
7240 proc lineleave {id} {
7241 global hoverid hovertimer canv
7243 if {[info exists hoverid] && $id == $hoverid} {
7244 $canv delete hover
7245 if {[info exists hovertimer]} {
7246 after cancel $hovertimer
7247 unset hovertimer
7249 unset hoverid
7253 proc linehover {} {
7254 global hoverx hovery hoverid hovertimer
7255 global canv linespc lthickness
7256 global commitinfo
7258 set text [lindex $commitinfo($hoverid) 0]
7259 set ymax [lindex [$canv cget -scrollregion] 3]
7260 if {$ymax == {}} return
7261 set yfrac [lindex [$canv yview] 0]
7262 set x [expr {$hoverx + 2 * $linespc}]
7263 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7264 set x0 [expr {$x - 2 * $lthickness}]
7265 set y0 [expr {$y - 2 * $lthickness}]
7266 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7267 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7268 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7269 -fill \#ffff80 -outline black -width 1 -tags hover]
7270 $canv raise $t
7271 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7272 -font mainfont]
7273 $canv raise $t
7276 proc clickisonarrow {id y} {
7277 global lthickness
7279 set ranges [rowranges $id]
7280 set thresh [expr {2 * $lthickness + 6}]
7281 set n [expr {[llength $ranges] - 1}]
7282 for {set i 1} {$i < $n} {incr i} {
7283 set row [lindex $ranges $i]
7284 if {abs([yc $row] - $y) < $thresh} {
7285 return $i
7288 return {}
7291 proc arrowjump {id n y} {
7292 global canv
7294 # 1 <-> 2, 3 <-> 4, etc...
7295 set n [expr {(($n - 1) ^ 1) + 1}]
7296 set row [lindex [rowranges $id] $n]
7297 set yt [yc $row]
7298 set ymax [lindex [$canv cget -scrollregion] 3]
7299 if {$ymax eq {} || $ymax <= 0} return
7300 set view [$canv yview]
7301 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7302 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7303 if {$yfrac < 0} {
7304 set yfrac 0
7306 allcanvs yview moveto $yfrac
7309 proc lineclick {x y id isnew} {
7310 global ctext commitinfo children canv thickerline curview
7312 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7313 unmarkmatches
7314 unselectline
7315 normalline
7316 $canv delete hover
7317 # draw this line thicker than normal
7318 set thickerline $id
7319 drawlines $id
7320 if {$isnew} {
7321 set ymax [lindex [$canv cget -scrollregion] 3]
7322 if {$ymax eq {}} return
7323 set yfrac [lindex [$canv yview] 0]
7324 set y [expr {$y + $yfrac * $ymax}]
7326 set dirn [clickisonarrow $id $y]
7327 if {$dirn ne {}} {
7328 arrowjump $id $dirn $y
7329 return
7332 if {$isnew} {
7333 addtohistory [list lineclick $x $y $id 0]
7335 # fill the details pane with info about this line
7336 $ctext conf -state normal
7337 clear_ctext
7338 settabs 0
7339 $ctext insert end "[mc "Parent"]:\t"
7340 $ctext insert end $id link0
7341 setlink $id link0
7342 set info $commitinfo($id)
7343 $ctext insert end "\n\t[lindex $info 0]\n"
7344 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7345 set date [formatdate [lindex $info 2]]
7346 $ctext insert end "\t[mc "Date"]:\t$date\n"
7347 set kids $children($curview,$id)
7348 if {$kids ne {}} {
7349 $ctext insert end "\n[mc "Children"]:"
7350 set i 0
7351 foreach child $kids {
7352 incr i
7353 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7354 set info $commitinfo($child)
7355 $ctext insert end "\n\t"
7356 $ctext insert end $child link$i
7357 setlink $child link$i
7358 $ctext insert end "\n\t[lindex $info 0]"
7359 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7360 set date [formatdate [lindex $info 2]]
7361 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7364 $ctext conf -state disabled
7365 init_flist {}
7368 proc normalline {} {
7369 global thickerline
7370 if {[info exists thickerline]} {
7371 set id $thickerline
7372 unset thickerline
7373 drawlines $id
7377 proc selbyid {id} {
7378 global curview
7379 if {[commitinview $id $curview]} {
7380 selectline [rowofcommit $id] 1
7384 proc mstime {} {
7385 global startmstime
7386 if {![info exists startmstime]} {
7387 set startmstime [clock clicks -milliseconds]
7389 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7392 proc rowmenu {x y id} {
7393 global rowctxmenu selectedline rowmenuid curview
7394 global nullid nullid2 fakerowmenu mainhead
7396 stopfinding
7397 set rowmenuid $id
7398 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7399 set state disabled
7400 } else {
7401 set state normal
7403 if {$id ne $nullid && $id ne $nullid2} {
7404 set menu $rowctxmenu
7405 if {$mainhead ne {}} {
7406 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7407 } else {
7408 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7410 } else {
7411 set menu $fakerowmenu
7413 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7414 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7415 $menu entryconfigure [mca "Make patch"] -state $state
7416 tk_popup $menu $x $y
7419 proc diffvssel {dirn} {
7420 global rowmenuid selectedline
7422 if {$selectedline eq {}} return
7423 if {$dirn} {
7424 set oldid [commitonrow $selectedline]
7425 set newid $rowmenuid
7426 } else {
7427 set oldid $rowmenuid
7428 set newid [commitonrow $selectedline]
7430 addtohistory [list doseldiff $oldid $newid]
7431 doseldiff $oldid $newid
7434 proc doseldiff {oldid newid} {
7435 global ctext
7436 global commitinfo
7438 $ctext conf -state normal
7439 clear_ctext
7440 init_flist [mc "Top"]
7441 $ctext insert end "[mc "From"] "
7442 $ctext insert end $oldid link0
7443 setlink $oldid link0
7444 $ctext insert end "\n "
7445 $ctext insert end [lindex $commitinfo($oldid) 0]
7446 $ctext insert end "\n\n[mc "To"] "
7447 $ctext insert end $newid link1
7448 setlink $newid link1
7449 $ctext insert end "\n "
7450 $ctext insert end [lindex $commitinfo($newid) 0]
7451 $ctext insert end "\n"
7452 $ctext conf -state disabled
7453 $ctext tag remove found 1.0 end
7454 startdiff [list $oldid $newid]
7457 proc mkpatch {} {
7458 global rowmenuid currentid commitinfo patchtop patchnum
7460 if {![info exists currentid]} return
7461 set oldid $currentid
7462 set oldhead [lindex $commitinfo($oldid) 0]
7463 set newid $rowmenuid
7464 set newhead [lindex $commitinfo($newid) 0]
7465 set top .patch
7466 set patchtop $top
7467 catch {destroy $top}
7468 toplevel $top
7469 label $top.title -text [mc "Generate patch"]
7470 grid $top.title - -pady 10
7471 label $top.from -text [mc "From:"]
7472 entry $top.fromsha1 -width 40 -relief flat
7473 $top.fromsha1 insert 0 $oldid
7474 $top.fromsha1 conf -state readonly
7475 grid $top.from $top.fromsha1 -sticky w
7476 entry $top.fromhead -width 60 -relief flat
7477 $top.fromhead insert 0 $oldhead
7478 $top.fromhead conf -state readonly
7479 grid x $top.fromhead -sticky w
7480 label $top.to -text [mc "To:"]
7481 entry $top.tosha1 -width 40 -relief flat
7482 $top.tosha1 insert 0 $newid
7483 $top.tosha1 conf -state readonly
7484 grid $top.to $top.tosha1 -sticky w
7485 entry $top.tohead -width 60 -relief flat
7486 $top.tohead insert 0 $newhead
7487 $top.tohead conf -state readonly
7488 grid x $top.tohead -sticky w
7489 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7490 grid $top.rev x -pady 10
7491 label $top.flab -text [mc "Output file:"]
7492 entry $top.fname -width 60
7493 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7494 incr patchnum
7495 grid $top.flab $top.fname -sticky w
7496 frame $top.buts
7497 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7498 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7499 grid $top.buts.gen $top.buts.can
7500 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7501 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7502 grid $top.buts - -pady 10 -sticky ew
7503 focus $top.fname
7506 proc mkpatchrev {} {
7507 global patchtop
7509 set oldid [$patchtop.fromsha1 get]
7510 set oldhead [$patchtop.fromhead get]
7511 set newid [$patchtop.tosha1 get]
7512 set newhead [$patchtop.tohead get]
7513 foreach e [list fromsha1 fromhead tosha1 tohead] \
7514 v [list $newid $newhead $oldid $oldhead] {
7515 $patchtop.$e conf -state normal
7516 $patchtop.$e delete 0 end
7517 $patchtop.$e insert 0 $v
7518 $patchtop.$e conf -state readonly
7522 proc mkpatchgo {} {
7523 global patchtop nullid nullid2
7525 set oldid [$patchtop.fromsha1 get]
7526 set newid [$patchtop.tosha1 get]
7527 set fname [$patchtop.fname get]
7528 set cmd [diffcmd [list $oldid $newid] -p]
7529 # trim off the initial "|"
7530 set cmd [lrange $cmd 1 end]
7531 lappend cmd >$fname &
7532 if {[catch {eval exec $cmd} err]} {
7533 error_popup "[mc "Error creating patch:"] $err"
7535 catch {destroy $patchtop}
7536 unset patchtop
7539 proc mkpatchcan {} {
7540 global patchtop
7542 catch {destroy $patchtop}
7543 unset patchtop
7546 proc mktag {} {
7547 global rowmenuid mktagtop commitinfo
7549 set top .maketag
7550 set mktagtop $top
7551 catch {destroy $top}
7552 toplevel $top
7553 label $top.title -text [mc "Create tag"]
7554 grid $top.title - -pady 10
7555 label $top.id -text [mc "ID:"]
7556 entry $top.sha1 -width 40 -relief flat
7557 $top.sha1 insert 0 $rowmenuid
7558 $top.sha1 conf -state readonly
7559 grid $top.id $top.sha1 -sticky w
7560 entry $top.head -width 60 -relief flat
7561 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7562 $top.head conf -state readonly
7563 grid x $top.head -sticky w
7564 label $top.tlab -text [mc "Tag name:"]
7565 entry $top.tag -width 60
7566 grid $top.tlab $top.tag -sticky w
7567 frame $top.buts
7568 button $top.buts.gen -text [mc "Create"] -command mktaggo
7569 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7570 grid $top.buts.gen $top.buts.can
7571 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7572 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7573 grid $top.buts - -pady 10 -sticky ew
7574 focus $top.tag
7577 proc domktag {} {
7578 global mktagtop env tagids idtags
7580 set id [$mktagtop.sha1 get]
7581 set tag [$mktagtop.tag get]
7582 if {$tag == {}} {
7583 error_popup [mc "No tag name specified"]
7584 return
7586 if {[info exists tagids($tag)]} {
7587 error_popup [mc "Tag \"%s\" already exists" $tag]
7588 return
7590 if {[catch {
7591 exec git tag $tag $id
7592 } err]} {
7593 error_popup "[mc "Error creating tag:"] $err"
7594 return
7597 set tagids($tag) $id
7598 lappend idtags($id) $tag
7599 redrawtags $id
7600 addedtag $id
7601 dispneartags 0
7602 run refill_reflist
7605 proc redrawtags {id} {
7606 global canv linehtag idpos currentid curview cmitlisted
7607 global canvxmax iddrawn circleitem mainheadid circlecolors
7609 if {![commitinview $id $curview]} return
7610 if {![info exists iddrawn($id)]} return
7611 set row [rowofcommit $id]
7612 if {$id eq $mainheadid} {
7613 set ofill yellow
7614 } else {
7615 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7617 $canv itemconf $circleitem($row) -fill $ofill
7618 $canv delete tag.$id
7619 set xt [eval drawtags $id $idpos($id)]
7620 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7621 set text [$canv itemcget $linehtag($row) -text]
7622 set font [$canv itemcget $linehtag($row) -font]
7623 set xr [expr {$xt + [font measure $font $text]}]
7624 if {$xr > $canvxmax} {
7625 set canvxmax $xr
7626 setcanvscroll
7628 if {[info exists currentid] && $currentid == $id} {
7629 make_secsel $row
7633 proc mktagcan {} {
7634 global mktagtop
7636 catch {destroy $mktagtop}
7637 unset mktagtop
7640 proc mktaggo {} {
7641 domktag
7642 mktagcan
7645 proc writecommit {} {
7646 global rowmenuid wrcomtop commitinfo wrcomcmd
7648 set top .writecommit
7649 set wrcomtop $top
7650 catch {destroy $top}
7651 toplevel $top
7652 label $top.title -text [mc "Write commit to file"]
7653 grid $top.title - -pady 10
7654 label $top.id -text [mc "ID:"]
7655 entry $top.sha1 -width 40 -relief flat
7656 $top.sha1 insert 0 $rowmenuid
7657 $top.sha1 conf -state readonly
7658 grid $top.id $top.sha1 -sticky w
7659 entry $top.head -width 60 -relief flat
7660 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7661 $top.head conf -state readonly
7662 grid x $top.head -sticky w
7663 label $top.clab -text [mc "Command:"]
7664 entry $top.cmd -width 60 -textvariable wrcomcmd
7665 grid $top.clab $top.cmd -sticky w -pady 10
7666 label $top.flab -text [mc "Output file:"]
7667 entry $top.fname -width 60
7668 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7669 grid $top.flab $top.fname -sticky w
7670 frame $top.buts
7671 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7672 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7673 grid $top.buts.gen $top.buts.can
7674 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7675 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7676 grid $top.buts - -pady 10 -sticky ew
7677 focus $top.fname
7680 proc wrcomgo {} {
7681 global wrcomtop
7683 set id [$wrcomtop.sha1 get]
7684 set cmd "echo $id | [$wrcomtop.cmd get]"
7685 set fname [$wrcomtop.fname get]
7686 if {[catch {exec sh -c $cmd >$fname &} err]} {
7687 error_popup "[mc "Error writing commit:"] $err"
7689 catch {destroy $wrcomtop}
7690 unset wrcomtop
7693 proc wrcomcan {} {
7694 global wrcomtop
7696 catch {destroy $wrcomtop}
7697 unset wrcomtop
7700 proc mkbranch {} {
7701 global rowmenuid mkbrtop
7703 set top .makebranch
7704 catch {destroy $top}
7705 toplevel $top
7706 label $top.title -text [mc "Create new branch"]
7707 grid $top.title - -pady 10
7708 label $top.id -text [mc "ID:"]
7709 entry $top.sha1 -width 40 -relief flat
7710 $top.sha1 insert 0 $rowmenuid
7711 $top.sha1 conf -state readonly
7712 grid $top.id $top.sha1 -sticky w
7713 label $top.nlab -text [mc "Name:"]
7714 entry $top.name -width 40
7715 bind $top.name <Key-Return> "[list mkbrgo $top]"
7716 grid $top.nlab $top.name -sticky w
7717 frame $top.buts
7718 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7719 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7720 grid $top.buts.go $top.buts.can
7721 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7722 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7723 grid $top.buts - -pady 10 -sticky ew
7724 focus $top.name
7727 proc mkbrgo {top} {
7728 global headids idheads
7730 set name [$top.name get]
7731 set id [$top.sha1 get]
7732 set cmdargs {}
7733 set old_id {}
7734 if {$name eq {}} {
7735 error_popup [mc "Please specify a name for the new branch"]
7736 return
7738 if {[info exists headids($name)]} {
7739 if {![confirm_popup [mc \
7740 "Branch '%s' already exists. Overwrite?" $name]]} {
7741 return
7743 set old_id $headids($name)
7744 lappend cmdargs -f
7746 catch {destroy $top}
7747 lappend cmdargs $name $id
7748 nowbusy newbranch
7749 update
7750 if {[catch {
7751 eval exec git branch $cmdargs
7752 } err]} {
7753 notbusy newbranch
7754 error_popup $err
7755 } else {
7756 notbusy newbranch
7757 if {$old_id ne {}} {
7758 movehead $id $name
7759 movedhead $id $name
7760 redrawtags $old_id
7761 redrawtags $id
7762 } else {
7763 set headids($name) $id
7764 lappend idheads($id) $name
7765 addedhead $id $name
7766 redrawtags $id
7768 dispneartags 0
7769 run refill_reflist
7773 proc cherrypick {} {
7774 global rowmenuid curview
7775 global mainhead mainheadid
7777 set oldhead [exec git rev-parse HEAD]
7778 set dheads [descheads $rowmenuid]
7779 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7780 set ok [confirm_popup [mc "Commit %s is already\
7781 included in branch %s -- really re-apply it?" \
7782 [string range $rowmenuid 0 7] $mainhead]]
7783 if {!$ok} return
7785 nowbusy cherrypick [mc "Cherry-picking"]
7786 update
7787 # Unfortunately git-cherry-pick writes stuff to stderr even when
7788 # no error occurs, and exec takes that as an indication of error...
7789 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7790 notbusy cherrypick
7791 error_popup $err
7792 return
7794 set newhead [exec git rev-parse HEAD]
7795 if {$newhead eq $oldhead} {
7796 notbusy cherrypick
7797 error_popup [mc "No changes committed"]
7798 return
7800 addnewchild $newhead $oldhead
7801 if {[commitinview $oldhead $curview]} {
7802 insertrow $newhead $oldhead $curview
7803 if {$mainhead ne {}} {
7804 movehead $newhead $mainhead
7805 movedhead $newhead $mainhead
7807 set mainheadid $newhead
7808 redrawtags $oldhead
7809 redrawtags $newhead
7810 selbyid $newhead
7812 notbusy cherrypick
7815 proc resethead {} {
7816 global mainhead rowmenuid confirm_ok resettype
7818 set confirm_ok 0
7819 set w ".confirmreset"
7820 toplevel $w
7821 wm transient $w .
7822 wm title $w [mc "Confirm reset"]
7823 message $w.m -text \
7824 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7825 -justify center -aspect 1000
7826 pack $w.m -side top -fill x -padx 20 -pady 20
7827 frame $w.f -relief sunken -border 2
7828 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7829 grid $w.f.rt -sticky w
7830 set resettype mixed
7831 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7832 -text [mc "Soft: Leave working tree and index untouched"]
7833 grid $w.f.soft -sticky w
7834 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7835 -text [mc "Mixed: Leave working tree untouched, reset index"]
7836 grid $w.f.mixed -sticky w
7837 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7838 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7839 grid $w.f.hard -sticky w
7840 pack $w.f -side top -fill x
7841 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7842 pack $w.ok -side left -fill x -padx 20 -pady 20
7843 button $w.cancel -text [mc Cancel] -command "destroy $w"
7844 pack $w.cancel -side right -fill x -padx 20 -pady 20
7845 bind $w <Visibility> "grab $w; focus $w"
7846 tkwait window $w
7847 if {!$confirm_ok} return
7848 if {[catch {set fd [open \
7849 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7850 error_popup $err
7851 } else {
7852 dohidelocalchanges
7853 filerun $fd [list readresetstat $fd]
7854 nowbusy reset [mc "Resetting"]
7855 selbyid $rowmenuid
7859 proc readresetstat {fd} {
7860 global mainhead mainheadid showlocalchanges rprogcoord
7862 if {[gets $fd line] >= 0} {
7863 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7864 set rprogcoord [expr {1.0 * $m / $n}]
7865 adjustprogress
7867 return 1
7869 set rprogcoord 0
7870 adjustprogress
7871 notbusy reset
7872 if {[catch {close $fd} err]} {
7873 error_popup $err
7875 set oldhead $mainheadid
7876 set newhead [exec git rev-parse HEAD]
7877 if {$newhead ne $oldhead} {
7878 movehead $newhead $mainhead
7879 movedhead $newhead $mainhead
7880 set mainheadid $newhead
7881 redrawtags $oldhead
7882 redrawtags $newhead
7884 if {$showlocalchanges} {
7885 doshowlocalchanges
7887 return 0
7890 # context menu for a head
7891 proc headmenu {x y id head} {
7892 global headmenuid headmenuhead headctxmenu mainhead
7894 stopfinding
7895 set headmenuid $id
7896 set headmenuhead $head
7897 set state normal
7898 if {$head eq $mainhead} {
7899 set state disabled
7901 $headctxmenu entryconfigure 0 -state $state
7902 $headctxmenu entryconfigure 1 -state $state
7903 tk_popup $headctxmenu $x $y
7906 proc cobranch {} {
7907 global headmenuid headmenuhead headids
7908 global showlocalchanges mainheadid
7910 # check the tree is clean first??
7911 nowbusy checkout [mc "Checking out"]
7912 update
7913 dohidelocalchanges
7914 if {[catch {
7915 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7916 } err]} {
7917 notbusy checkout
7918 error_popup $err
7919 if {$showlocalchanges} {
7920 dodiffindex
7922 } else {
7923 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7927 proc readcheckoutstat {fd newhead newheadid} {
7928 global mainhead mainheadid headids showlocalchanges progresscoords
7930 if {[gets $fd line] >= 0} {
7931 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7932 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7933 adjustprogress
7935 return 1
7937 set progresscoords {0 0}
7938 adjustprogress
7939 notbusy checkout
7940 if {[catch {close $fd} err]} {
7941 error_popup $err
7943 set oldmainid $mainheadid
7944 set mainhead $newhead
7945 set mainheadid $newheadid
7946 redrawtags $oldmainid
7947 redrawtags $newheadid
7948 selbyid $newheadid
7949 if {$showlocalchanges} {
7950 dodiffindex
7954 proc rmbranch {} {
7955 global headmenuid headmenuhead mainhead
7956 global idheads
7958 set head $headmenuhead
7959 set id $headmenuid
7960 # this check shouldn't be needed any more...
7961 if {$head eq $mainhead} {
7962 error_popup [mc "Cannot delete the currently checked-out branch"]
7963 return
7965 set dheads [descheads $id]
7966 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7967 # the stuff on this branch isn't on any other branch
7968 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7969 branch.\nReally delete branch %s?" $head $head]]} return
7971 nowbusy rmbranch
7972 update
7973 if {[catch {exec git branch -D $head} err]} {
7974 notbusy rmbranch
7975 error_popup $err
7976 return
7978 removehead $id $head
7979 removedhead $id $head
7980 redrawtags $id
7981 notbusy rmbranch
7982 dispneartags 0
7983 run refill_reflist
7986 # Display a list of tags and heads
7987 proc showrefs {} {
7988 global showrefstop bgcolor fgcolor selectbgcolor
7989 global bglist fglist reflistfilter reflist maincursor
7991 set top .showrefs
7992 set showrefstop $top
7993 if {[winfo exists $top]} {
7994 raise $top
7995 refill_reflist
7996 return
7998 toplevel $top
7999 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8000 text $top.list -background $bgcolor -foreground $fgcolor \
8001 -selectbackground $selectbgcolor -font mainfont \
8002 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8003 -width 30 -height 20 -cursor $maincursor \
8004 -spacing1 1 -spacing3 1 -state disabled
8005 $top.list tag configure highlight -background $selectbgcolor
8006 lappend bglist $top.list
8007 lappend fglist $top.list
8008 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8009 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8010 grid $top.list $top.ysb -sticky nsew
8011 grid $top.xsb x -sticky ew
8012 frame $top.f
8013 label $top.f.l -text "[mc "Filter"]: "
8014 entry $top.f.e -width 20 -textvariable reflistfilter
8015 set reflistfilter "*"
8016 trace add variable reflistfilter write reflistfilter_change
8017 pack $top.f.e -side right -fill x -expand 1
8018 pack $top.f.l -side left
8019 grid $top.f - -sticky ew -pady 2
8020 button $top.close -command [list destroy $top] -text [mc "Close"]
8021 grid $top.close -
8022 grid columnconfigure $top 0 -weight 1
8023 grid rowconfigure $top 0 -weight 1
8024 bind $top.list <1> {break}
8025 bind $top.list <B1-Motion> {break}
8026 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8027 set reflist {}
8028 refill_reflist
8031 proc sel_reflist {w x y} {
8032 global showrefstop reflist headids tagids otherrefids
8034 if {![winfo exists $showrefstop]} return
8035 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8036 set ref [lindex $reflist [expr {$l-1}]]
8037 set n [lindex $ref 0]
8038 switch -- [lindex $ref 1] {
8039 "H" {selbyid $headids($n)}
8040 "T" {selbyid $tagids($n)}
8041 "o" {selbyid $otherrefids($n)}
8043 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8046 proc unsel_reflist {} {
8047 global showrefstop
8049 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8050 $showrefstop.list tag remove highlight 0.0 end
8053 proc reflistfilter_change {n1 n2 op} {
8054 global reflistfilter
8056 after cancel refill_reflist
8057 after 200 refill_reflist
8060 proc refill_reflist {} {
8061 global reflist reflistfilter showrefstop headids tagids otherrefids
8062 global curview
8064 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8065 set refs {}
8066 foreach n [array names headids] {
8067 if {[string match $reflistfilter $n]} {
8068 if {[commitinview $headids($n) $curview]} {
8069 lappend refs [list $n H]
8070 } else {
8071 interestedin $headids($n) {run refill_reflist}
8075 foreach n [array names tagids] {
8076 if {[string match $reflistfilter $n]} {
8077 if {[commitinview $tagids($n) $curview]} {
8078 lappend refs [list $n T]
8079 } else {
8080 interestedin $tagids($n) {run refill_reflist}
8084 foreach n [array names otherrefids] {
8085 if {[string match $reflistfilter $n]} {
8086 if {[commitinview $otherrefids($n) $curview]} {
8087 lappend refs [list $n o]
8088 } else {
8089 interestedin $otherrefids($n) {run refill_reflist}
8093 set refs [lsort -index 0 $refs]
8094 if {$refs eq $reflist} return
8096 # Update the contents of $showrefstop.list according to the
8097 # differences between $reflist (old) and $refs (new)
8098 $showrefstop.list conf -state normal
8099 $showrefstop.list insert end "\n"
8100 set i 0
8101 set j 0
8102 while {$i < [llength $reflist] || $j < [llength $refs]} {
8103 if {$i < [llength $reflist]} {
8104 if {$j < [llength $refs]} {
8105 set cmp [string compare [lindex $reflist $i 0] \
8106 [lindex $refs $j 0]]
8107 if {$cmp == 0} {
8108 set cmp [string compare [lindex $reflist $i 1] \
8109 [lindex $refs $j 1]]
8111 } else {
8112 set cmp -1
8114 } else {
8115 set cmp 1
8117 switch -- $cmp {
8118 -1 {
8119 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8120 incr i
8123 incr i
8124 incr j
8127 set l [expr {$j + 1}]
8128 $showrefstop.list image create $l.0 -align baseline \
8129 -image reficon-[lindex $refs $j 1] -padx 2
8130 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8131 incr j
8135 set reflist $refs
8136 # delete last newline
8137 $showrefstop.list delete end-2c end-1c
8138 $showrefstop.list conf -state disabled
8141 # Stuff for finding nearby tags
8142 proc getallcommits {} {
8143 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8144 global idheads idtags idotherrefs allparents tagobjid
8146 if {![info exists allcommits]} {
8147 set nextarc 0
8148 set allcommits 0
8149 set seeds {}
8150 set allcwait 0
8151 set cachedarcs 0
8152 set allccache [file join [gitdir] "gitk.cache"]
8153 if {![catch {
8154 set f [open $allccache r]
8155 set allcwait 1
8156 getcache $f
8157 }]} return
8160 if {$allcwait} {
8161 return
8163 set cmd [list | git rev-list --parents]
8164 set allcupdate [expr {$seeds ne {}}]
8165 if {!$allcupdate} {
8166 set ids "--all"
8167 } else {
8168 set refs [concat [array names idheads] [array names idtags] \
8169 [array names idotherrefs]]
8170 set ids {}
8171 set tagobjs {}
8172 foreach name [array names tagobjid] {
8173 lappend tagobjs $tagobjid($name)
8175 foreach id [lsort -unique $refs] {
8176 if {![info exists allparents($id)] &&
8177 [lsearch -exact $tagobjs $id] < 0} {
8178 lappend ids $id
8181 if {$ids ne {}} {
8182 foreach id $seeds {
8183 lappend ids "^$id"
8187 if {$ids ne {}} {
8188 set fd [open [concat $cmd $ids] r]
8189 fconfigure $fd -blocking 0
8190 incr allcommits
8191 nowbusy allcommits
8192 filerun $fd [list getallclines $fd]
8193 } else {
8194 dispneartags 0
8198 # Since most commits have 1 parent and 1 child, we group strings of
8199 # such commits into "arcs" joining branch/merge points (BMPs), which
8200 # are commits that either don't have 1 parent or don't have 1 child.
8202 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8203 # arcout(id) - outgoing arcs for BMP
8204 # arcids(a) - list of IDs on arc including end but not start
8205 # arcstart(a) - BMP ID at start of arc
8206 # arcend(a) - BMP ID at end of arc
8207 # growing(a) - arc a is still growing
8208 # arctags(a) - IDs out of arcids (excluding end) that have tags
8209 # archeads(a) - IDs out of arcids (excluding end) that have heads
8210 # The start of an arc is at the descendent end, so "incoming" means
8211 # coming from descendents, and "outgoing" means going towards ancestors.
8213 proc getallclines {fd} {
8214 global allparents allchildren idtags idheads nextarc
8215 global arcnos arcids arctags arcout arcend arcstart archeads growing
8216 global seeds allcommits cachedarcs allcupdate
8218 set nid 0
8219 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8220 set id [lindex $line 0]
8221 if {[info exists allparents($id)]} {
8222 # seen it already
8223 continue
8225 set cachedarcs 0
8226 set olds [lrange $line 1 end]
8227 set allparents($id) $olds
8228 if {![info exists allchildren($id)]} {
8229 set allchildren($id) {}
8230 set arcnos($id) {}
8231 lappend seeds $id
8232 } else {
8233 set a $arcnos($id)
8234 if {[llength $olds] == 1 && [llength $a] == 1} {
8235 lappend arcids($a) $id
8236 if {[info exists idtags($id)]} {
8237 lappend arctags($a) $id
8239 if {[info exists idheads($id)]} {
8240 lappend archeads($a) $id
8242 if {[info exists allparents($olds)]} {
8243 # seen parent already
8244 if {![info exists arcout($olds)]} {
8245 splitarc $olds
8247 lappend arcids($a) $olds
8248 set arcend($a) $olds
8249 unset growing($a)
8251 lappend allchildren($olds) $id
8252 lappend arcnos($olds) $a
8253 continue
8256 foreach a $arcnos($id) {
8257 lappend arcids($a) $id
8258 set arcend($a) $id
8259 unset growing($a)
8262 set ao {}
8263 foreach p $olds {
8264 lappend allchildren($p) $id
8265 set a [incr nextarc]
8266 set arcstart($a) $id
8267 set archeads($a) {}
8268 set arctags($a) {}
8269 set archeads($a) {}
8270 set arcids($a) {}
8271 lappend ao $a
8272 set growing($a) 1
8273 if {[info exists allparents($p)]} {
8274 # seen it already, may need to make a new branch
8275 if {![info exists arcout($p)]} {
8276 splitarc $p
8278 lappend arcids($a) $p
8279 set arcend($a) $p
8280 unset growing($a)
8282 lappend arcnos($p) $a
8284 set arcout($id) $ao
8286 if {$nid > 0} {
8287 global cached_dheads cached_dtags cached_atags
8288 catch {unset cached_dheads}
8289 catch {unset cached_dtags}
8290 catch {unset cached_atags}
8292 if {![eof $fd]} {
8293 return [expr {$nid >= 1000? 2: 1}]
8295 set cacheok 1
8296 if {[catch {
8297 fconfigure $fd -blocking 1
8298 close $fd
8299 } err]} {
8300 # got an error reading the list of commits
8301 # if we were updating, try rereading the whole thing again
8302 if {$allcupdate} {
8303 incr allcommits -1
8304 dropcache $err
8305 return
8307 error_popup "[mc "Error reading commit topology information;\
8308 branch and preceding/following tag information\
8309 will be incomplete."]\n($err)"
8310 set cacheok 0
8312 if {[incr allcommits -1] == 0} {
8313 notbusy allcommits
8314 if {$cacheok} {
8315 run savecache
8318 dispneartags 0
8319 return 0
8322 proc recalcarc {a} {
8323 global arctags archeads arcids idtags idheads
8325 set at {}
8326 set ah {}
8327 foreach id [lrange $arcids($a) 0 end-1] {
8328 if {[info exists idtags($id)]} {
8329 lappend at $id
8331 if {[info exists idheads($id)]} {
8332 lappend ah $id
8335 set arctags($a) $at
8336 set archeads($a) $ah
8339 proc splitarc {p} {
8340 global arcnos arcids nextarc arctags archeads idtags idheads
8341 global arcstart arcend arcout allparents growing
8343 set a $arcnos($p)
8344 if {[llength $a] != 1} {
8345 puts "oops splitarc called but [llength $a] arcs already"
8346 return
8348 set a [lindex $a 0]
8349 set i [lsearch -exact $arcids($a) $p]
8350 if {$i < 0} {
8351 puts "oops splitarc $p not in arc $a"
8352 return
8354 set na [incr nextarc]
8355 if {[info exists arcend($a)]} {
8356 set arcend($na) $arcend($a)
8357 } else {
8358 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8359 set j [lsearch -exact $arcnos($l) $a]
8360 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8362 set tail [lrange $arcids($a) [expr {$i+1}] end]
8363 set arcids($a) [lrange $arcids($a) 0 $i]
8364 set arcend($a) $p
8365 set arcstart($na) $p
8366 set arcout($p) $na
8367 set arcids($na) $tail
8368 if {[info exists growing($a)]} {
8369 set growing($na) 1
8370 unset growing($a)
8373 foreach id $tail {
8374 if {[llength $arcnos($id)] == 1} {
8375 set arcnos($id) $na
8376 } else {
8377 set j [lsearch -exact $arcnos($id) $a]
8378 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8382 # reconstruct tags and heads lists
8383 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8384 recalcarc $a
8385 recalcarc $na
8386 } else {
8387 set arctags($na) {}
8388 set archeads($na) {}
8392 # Update things for a new commit added that is a child of one
8393 # existing commit. Used when cherry-picking.
8394 proc addnewchild {id p} {
8395 global allparents allchildren idtags nextarc
8396 global arcnos arcids arctags arcout arcend arcstart archeads growing
8397 global seeds allcommits
8399 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8400 set allparents($id) [list $p]
8401 set allchildren($id) {}
8402 set arcnos($id) {}
8403 lappend seeds $id
8404 lappend allchildren($p) $id
8405 set a [incr nextarc]
8406 set arcstart($a) $id
8407 set archeads($a) {}
8408 set arctags($a) {}
8409 set arcids($a) [list $p]
8410 set arcend($a) $p
8411 if {![info exists arcout($p)]} {
8412 splitarc $p
8414 lappend arcnos($p) $a
8415 set arcout($id) [list $a]
8418 # This implements a cache for the topology information.
8419 # The cache saves, for each arc, the start and end of the arc,
8420 # the ids on the arc, and the outgoing arcs from the end.
8421 proc readcache {f} {
8422 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8423 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8424 global allcwait
8426 set a $nextarc
8427 set lim $cachedarcs
8428 if {$lim - $a > 500} {
8429 set lim [expr {$a + 500}]
8431 if {[catch {
8432 if {$a == $lim} {
8433 # finish reading the cache and setting up arctags, etc.
8434 set line [gets $f]
8435 if {$line ne "1"} {error "bad final version"}
8436 close $f
8437 foreach id [array names idtags] {
8438 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8439 [llength $allparents($id)] == 1} {
8440 set a [lindex $arcnos($id) 0]
8441 if {$arctags($a) eq {}} {
8442 recalcarc $a
8446 foreach id [array names idheads] {
8447 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8448 [llength $allparents($id)] == 1} {
8449 set a [lindex $arcnos($id) 0]
8450 if {$archeads($a) eq {}} {
8451 recalcarc $a
8455 foreach id [lsort -unique $possible_seeds] {
8456 if {$arcnos($id) eq {}} {
8457 lappend seeds $id
8460 set allcwait 0
8461 } else {
8462 while {[incr a] <= $lim} {
8463 set line [gets $f]
8464 if {[llength $line] != 3} {error "bad line"}
8465 set s [lindex $line 0]
8466 set arcstart($a) $s
8467 lappend arcout($s) $a
8468 if {![info exists arcnos($s)]} {
8469 lappend possible_seeds $s
8470 set arcnos($s) {}
8472 set e [lindex $line 1]
8473 if {$e eq {}} {
8474 set growing($a) 1
8475 } else {
8476 set arcend($a) $e
8477 if {![info exists arcout($e)]} {
8478 set arcout($e) {}
8481 set arcids($a) [lindex $line 2]
8482 foreach id $arcids($a) {
8483 lappend allparents($s) $id
8484 set s $id
8485 lappend arcnos($id) $a
8487 if {![info exists allparents($s)]} {
8488 set allparents($s) {}
8490 set arctags($a) {}
8491 set archeads($a) {}
8493 set nextarc [expr {$a - 1}]
8495 } err]} {
8496 dropcache $err
8497 return 0
8499 if {!$allcwait} {
8500 getallcommits
8502 return $allcwait
8505 proc getcache {f} {
8506 global nextarc cachedarcs possible_seeds
8508 if {[catch {
8509 set line [gets $f]
8510 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8511 # make sure it's an integer
8512 set cachedarcs [expr {int([lindex $line 1])}]
8513 if {$cachedarcs < 0} {error "bad number of arcs"}
8514 set nextarc 0
8515 set possible_seeds {}
8516 run readcache $f
8517 } err]} {
8518 dropcache $err
8520 return 0
8523 proc dropcache {err} {
8524 global allcwait nextarc cachedarcs seeds
8526 #puts "dropping cache ($err)"
8527 foreach v {arcnos arcout arcids arcstart arcend growing \
8528 arctags archeads allparents allchildren} {
8529 global $v
8530 catch {unset $v}
8532 set allcwait 0
8533 set nextarc 0
8534 set cachedarcs 0
8535 set seeds {}
8536 getallcommits
8539 proc writecache {f} {
8540 global cachearc cachedarcs allccache
8541 global arcstart arcend arcnos arcids arcout
8543 set a $cachearc
8544 set lim $cachedarcs
8545 if {$lim - $a > 1000} {
8546 set lim [expr {$a + 1000}]
8548 if {[catch {
8549 while {[incr a] <= $lim} {
8550 if {[info exists arcend($a)]} {
8551 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8552 } else {
8553 puts $f [list $arcstart($a) {} $arcids($a)]
8556 } err]} {
8557 catch {close $f}
8558 catch {file delete $allccache}
8559 #puts "writing cache failed ($err)"
8560 return 0
8562 set cachearc [expr {$a - 1}]
8563 if {$a > $cachedarcs} {
8564 puts $f "1"
8565 close $f
8566 return 0
8568 return 1
8571 proc savecache {} {
8572 global nextarc cachedarcs cachearc allccache
8574 if {$nextarc == $cachedarcs} return
8575 set cachearc 0
8576 set cachedarcs $nextarc
8577 catch {
8578 set f [open $allccache w]
8579 puts $f [list 1 $cachedarcs]
8580 run writecache $f
8584 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8585 # or 0 if neither is true.
8586 proc anc_or_desc {a b} {
8587 global arcout arcstart arcend arcnos cached_isanc
8589 if {$arcnos($a) eq $arcnos($b)} {
8590 # Both are on the same arc(s); either both are the same BMP,
8591 # or if one is not a BMP, the other is also not a BMP or is
8592 # the BMP at end of the arc (and it only has 1 incoming arc).
8593 # Or both can be BMPs with no incoming arcs.
8594 if {$a eq $b || $arcnos($a) eq {}} {
8595 return 0
8597 # assert {[llength $arcnos($a)] == 1}
8598 set arc [lindex $arcnos($a) 0]
8599 set i [lsearch -exact $arcids($arc) $a]
8600 set j [lsearch -exact $arcids($arc) $b]
8601 if {$i < 0 || $i > $j} {
8602 return 1
8603 } else {
8604 return -1
8608 if {![info exists arcout($a)]} {
8609 set arc [lindex $arcnos($a) 0]
8610 if {[info exists arcend($arc)]} {
8611 set aend $arcend($arc)
8612 } else {
8613 set aend {}
8615 set a $arcstart($arc)
8616 } else {
8617 set aend $a
8619 if {![info exists arcout($b)]} {
8620 set arc [lindex $arcnos($b) 0]
8621 if {[info exists arcend($arc)]} {
8622 set bend $arcend($arc)
8623 } else {
8624 set bend {}
8626 set b $arcstart($arc)
8627 } else {
8628 set bend $b
8630 if {$a eq $bend} {
8631 return 1
8633 if {$b eq $aend} {
8634 return -1
8636 if {[info exists cached_isanc($a,$bend)]} {
8637 if {$cached_isanc($a,$bend)} {
8638 return 1
8641 if {[info exists cached_isanc($b,$aend)]} {
8642 if {$cached_isanc($b,$aend)} {
8643 return -1
8645 if {[info exists cached_isanc($a,$bend)]} {
8646 return 0
8650 set todo [list $a $b]
8651 set anc($a) a
8652 set anc($b) b
8653 for {set i 0} {$i < [llength $todo]} {incr i} {
8654 set x [lindex $todo $i]
8655 if {$anc($x) eq {}} {
8656 continue
8658 foreach arc $arcnos($x) {
8659 set xd $arcstart($arc)
8660 if {$xd eq $bend} {
8661 set cached_isanc($a,$bend) 1
8662 set cached_isanc($b,$aend) 0
8663 return 1
8664 } elseif {$xd eq $aend} {
8665 set cached_isanc($b,$aend) 1
8666 set cached_isanc($a,$bend) 0
8667 return -1
8669 if {![info exists anc($xd)]} {
8670 set anc($xd) $anc($x)
8671 lappend todo $xd
8672 } elseif {$anc($xd) ne $anc($x)} {
8673 set anc($xd) {}
8677 set cached_isanc($a,$bend) 0
8678 set cached_isanc($b,$aend) 0
8679 return 0
8682 # This identifies whether $desc has an ancestor that is
8683 # a growing tip of the graph and which is not an ancestor of $anc
8684 # and returns 0 if so and 1 if not.
8685 # If we subsequently discover a tag on such a growing tip, and that
8686 # turns out to be a descendent of $anc (which it could, since we
8687 # don't necessarily see children before parents), then $desc
8688 # isn't a good choice to display as a descendent tag of
8689 # $anc (since it is the descendent of another tag which is
8690 # a descendent of $anc). Similarly, $anc isn't a good choice to
8691 # display as a ancestor tag of $desc.
8693 proc is_certain {desc anc} {
8694 global arcnos arcout arcstart arcend growing problems
8696 set certain {}
8697 if {[llength $arcnos($anc)] == 1} {
8698 # tags on the same arc are certain
8699 if {$arcnos($desc) eq $arcnos($anc)} {
8700 return 1
8702 if {![info exists arcout($anc)]} {
8703 # if $anc is partway along an arc, use the start of the arc instead
8704 set a [lindex $arcnos($anc) 0]
8705 set anc $arcstart($a)
8708 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8709 set x $desc
8710 } else {
8711 set a [lindex $arcnos($desc) 0]
8712 set x $arcend($a)
8714 if {$x == $anc} {
8715 return 1
8717 set anclist [list $x]
8718 set dl($x) 1
8719 set nnh 1
8720 set ngrowanc 0
8721 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8722 set x [lindex $anclist $i]
8723 if {$dl($x)} {
8724 incr nnh -1
8726 set done($x) 1
8727 foreach a $arcout($x) {
8728 if {[info exists growing($a)]} {
8729 if {![info exists growanc($x)] && $dl($x)} {
8730 set growanc($x) 1
8731 incr ngrowanc
8733 } else {
8734 set y $arcend($a)
8735 if {[info exists dl($y)]} {
8736 if {$dl($y)} {
8737 if {!$dl($x)} {
8738 set dl($y) 0
8739 if {![info exists done($y)]} {
8740 incr nnh -1
8742 if {[info exists growanc($x)]} {
8743 incr ngrowanc -1
8745 set xl [list $y]
8746 for {set k 0} {$k < [llength $xl]} {incr k} {
8747 set z [lindex $xl $k]
8748 foreach c $arcout($z) {
8749 if {[info exists arcend($c)]} {
8750 set v $arcend($c)
8751 if {[info exists dl($v)] && $dl($v)} {
8752 set dl($v) 0
8753 if {![info exists done($v)]} {
8754 incr nnh -1
8756 if {[info exists growanc($v)]} {
8757 incr ngrowanc -1
8759 lappend xl $v
8766 } elseif {$y eq $anc || !$dl($x)} {
8767 set dl($y) 0
8768 lappend anclist $y
8769 } else {
8770 set dl($y) 1
8771 lappend anclist $y
8772 incr nnh
8777 foreach x [array names growanc] {
8778 if {$dl($x)} {
8779 return 0
8781 return 0
8783 return 1
8786 proc validate_arctags {a} {
8787 global arctags idtags
8789 set i -1
8790 set na $arctags($a)
8791 foreach id $arctags($a) {
8792 incr i
8793 if {![info exists idtags($id)]} {
8794 set na [lreplace $na $i $i]
8795 incr i -1
8798 set arctags($a) $na
8801 proc validate_archeads {a} {
8802 global archeads idheads
8804 set i -1
8805 set na $archeads($a)
8806 foreach id $archeads($a) {
8807 incr i
8808 if {![info exists idheads($id)]} {
8809 set na [lreplace $na $i $i]
8810 incr i -1
8813 set archeads($a) $na
8816 # Return the list of IDs that have tags that are descendents of id,
8817 # ignoring IDs that are descendents of IDs already reported.
8818 proc desctags {id} {
8819 global arcnos arcstart arcids arctags idtags allparents
8820 global growing cached_dtags
8822 if {![info exists allparents($id)]} {
8823 return {}
8825 set t1 [clock clicks -milliseconds]
8826 set argid $id
8827 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8828 # part-way along an arc; check that arc first
8829 set a [lindex $arcnos($id) 0]
8830 if {$arctags($a) ne {}} {
8831 validate_arctags $a
8832 set i [lsearch -exact $arcids($a) $id]
8833 set tid {}
8834 foreach t $arctags($a) {
8835 set j [lsearch -exact $arcids($a) $t]
8836 if {$j >= $i} break
8837 set tid $t
8839 if {$tid ne {}} {
8840 return $tid
8843 set id $arcstart($a)
8844 if {[info exists idtags($id)]} {
8845 return $id
8848 if {[info exists cached_dtags($id)]} {
8849 return $cached_dtags($id)
8852 set origid $id
8853 set todo [list $id]
8854 set queued($id) 1
8855 set nc 1
8856 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8857 set id [lindex $todo $i]
8858 set done($id) 1
8859 set ta [info exists hastaggedancestor($id)]
8860 if {!$ta} {
8861 incr nc -1
8863 # ignore tags on starting node
8864 if {!$ta && $i > 0} {
8865 if {[info exists idtags($id)]} {
8866 set tagloc($id) $id
8867 set ta 1
8868 } elseif {[info exists cached_dtags($id)]} {
8869 set tagloc($id) $cached_dtags($id)
8870 set ta 1
8873 foreach a $arcnos($id) {
8874 set d $arcstart($a)
8875 if {!$ta && $arctags($a) ne {}} {
8876 validate_arctags $a
8877 if {$arctags($a) ne {}} {
8878 lappend tagloc($id) [lindex $arctags($a) end]
8881 if {$ta || $arctags($a) ne {}} {
8882 set tomark [list $d]
8883 for {set j 0} {$j < [llength $tomark]} {incr j} {
8884 set dd [lindex $tomark $j]
8885 if {![info exists hastaggedancestor($dd)]} {
8886 if {[info exists done($dd)]} {
8887 foreach b $arcnos($dd) {
8888 lappend tomark $arcstart($b)
8890 if {[info exists tagloc($dd)]} {
8891 unset tagloc($dd)
8893 } elseif {[info exists queued($dd)]} {
8894 incr nc -1
8896 set hastaggedancestor($dd) 1
8900 if {![info exists queued($d)]} {
8901 lappend todo $d
8902 set queued($d) 1
8903 if {![info exists hastaggedancestor($d)]} {
8904 incr nc
8909 set tags {}
8910 foreach id [array names tagloc] {
8911 if {![info exists hastaggedancestor($id)]} {
8912 foreach t $tagloc($id) {
8913 if {[lsearch -exact $tags $t] < 0} {
8914 lappend tags $t
8919 set t2 [clock clicks -milliseconds]
8920 set loopix $i
8922 # remove tags that are descendents of other tags
8923 for {set i 0} {$i < [llength $tags]} {incr i} {
8924 set a [lindex $tags $i]
8925 for {set j 0} {$j < $i} {incr j} {
8926 set b [lindex $tags $j]
8927 set r [anc_or_desc $a $b]
8928 if {$r == 1} {
8929 set tags [lreplace $tags $j $j]
8930 incr j -1
8931 incr i -1
8932 } elseif {$r == -1} {
8933 set tags [lreplace $tags $i $i]
8934 incr i -1
8935 break
8940 if {[array names growing] ne {}} {
8941 # graph isn't finished, need to check if any tag could get
8942 # eclipsed by another tag coming later. Simply ignore any
8943 # tags that could later get eclipsed.
8944 set ctags {}
8945 foreach t $tags {
8946 if {[is_certain $t $origid]} {
8947 lappend ctags $t
8950 if {$tags eq $ctags} {
8951 set cached_dtags($origid) $tags
8952 } else {
8953 set tags $ctags
8955 } else {
8956 set cached_dtags($origid) $tags
8958 set t3 [clock clicks -milliseconds]
8959 if {0 && $t3 - $t1 >= 100} {
8960 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8961 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8963 return $tags
8966 proc anctags {id} {
8967 global arcnos arcids arcout arcend arctags idtags allparents
8968 global growing cached_atags
8970 if {![info exists allparents($id)]} {
8971 return {}
8973 set t1 [clock clicks -milliseconds]
8974 set argid $id
8975 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8976 # part-way along an arc; check that arc first
8977 set a [lindex $arcnos($id) 0]
8978 if {$arctags($a) ne {}} {
8979 validate_arctags $a
8980 set i [lsearch -exact $arcids($a) $id]
8981 foreach t $arctags($a) {
8982 set j [lsearch -exact $arcids($a) $t]
8983 if {$j > $i} {
8984 return $t
8988 if {![info exists arcend($a)]} {
8989 return {}
8991 set id $arcend($a)
8992 if {[info exists idtags($id)]} {
8993 return $id
8996 if {[info exists cached_atags($id)]} {
8997 return $cached_atags($id)
9000 set origid $id
9001 set todo [list $id]
9002 set queued($id) 1
9003 set taglist {}
9004 set nc 1
9005 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9006 set id [lindex $todo $i]
9007 set done($id) 1
9008 set td [info exists hastaggeddescendent($id)]
9009 if {!$td} {
9010 incr nc -1
9012 # ignore tags on starting node
9013 if {!$td && $i > 0} {
9014 if {[info exists idtags($id)]} {
9015 set tagloc($id) $id
9016 set td 1
9017 } elseif {[info exists cached_atags($id)]} {
9018 set tagloc($id) $cached_atags($id)
9019 set td 1
9022 foreach a $arcout($id) {
9023 if {!$td && $arctags($a) ne {}} {
9024 validate_arctags $a
9025 if {$arctags($a) ne {}} {
9026 lappend tagloc($id) [lindex $arctags($a) 0]
9029 if {![info exists arcend($a)]} continue
9030 set d $arcend($a)
9031 if {$td || $arctags($a) ne {}} {
9032 set tomark [list $d]
9033 for {set j 0} {$j < [llength $tomark]} {incr j} {
9034 set dd [lindex $tomark $j]
9035 if {![info exists hastaggeddescendent($dd)]} {
9036 if {[info exists done($dd)]} {
9037 foreach b $arcout($dd) {
9038 if {[info exists arcend($b)]} {
9039 lappend tomark $arcend($b)
9042 if {[info exists tagloc($dd)]} {
9043 unset tagloc($dd)
9045 } elseif {[info exists queued($dd)]} {
9046 incr nc -1
9048 set hastaggeddescendent($dd) 1
9052 if {![info exists queued($d)]} {
9053 lappend todo $d
9054 set queued($d) 1
9055 if {![info exists hastaggeddescendent($d)]} {
9056 incr nc
9061 set t2 [clock clicks -milliseconds]
9062 set loopix $i
9063 set tags {}
9064 foreach id [array names tagloc] {
9065 if {![info exists hastaggeddescendent($id)]} {
9066 foreach t $tagloc($id) {
9067 if {[lsearch -exact $tags $t] < 0} {
9068 lappend tags $t
9074 # remove tags that are ancestors of other tags
9075 for {set i 0} {$i < [llength $tags]} {incr i} {
9076 set a [lindex $tags $i]
9077 for {set j 0} {$j < $i} {incr j} {
9078 set b [lindex $tags $j]
9079 set r [anc_or_desc $a $b]
9080 if {$r == -1} {
9081 set tags [lreplace $tags $j $j]
9082 incr j -1
9083 incr i -1
9084 } elseif {$r == 1} {
9085 set tags [lreplace $tags $i $i]
9086 incr i -1
9087 break
9092 if {[array names growing] ne {}} {
9093 # graph isn't finished, need to check if any tag could get
9094 # eclipsed by another tag coming later. Simply ignore any
9095 # tags that could later get eclipsed.
9096 set ctags {}
9097 foreach t $tags {
9098 if {[is_certain $origid $t]} {
9099 lappend ctags $t
9102 if {$tags eq $ctags} {
9103 set cached_atags($origid) $tags
9104 } else {
9105 set tags $ctags
9107 } else {
9108 set cached_atags($origid) $tags
9110 set t3 [clock clicks -milliseconds]
9111 if {0 && $t3 - $t1 >= 100} {
9112 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9113 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9115 return $tags
9118 # Return the list of IDs that have heads that are descendents of id,
9119 # including id itself if it has a head.
9120 proc descheads {id} {
9121 global arcnos arcstart arcids archeads idheads cached_dheads
9122 global allparents
9124 if {![info exists allparents($id)]} {
9125 return {}
9127 set aret {}
9128 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9129 # part-way along an arc; check it first
9130 set a [lindex $arcnos($id) 0]
9131 if {$archeads($a) ne {}} {
9132 validate_archeads $a
9133 set i [lsearch -exact $arcids($a) $id]
9134 foreach t $archeads($a) {
9135 set j [lsearch -exact $arcids($a) $t]
9136 if {$j > $i} break
9137 lappend aret $t
9140 set id $arcstart($a)
9142 set origid $id
9143 set todo [list $id]
9144 set seen($id) 1
9145 set ret {}
9146 for {set i 0} {$i < [llength $todo]} {incr i} {
9147 set id [lindex $todo $i]
9148 if {[info exists cached_dheads($id)]} {
9149 set ret [concat $ret $cached_dheads($id)]
9150 } else {
9151 if {[info exists idheads($id)]} {
9152 lappend ret $id
9154 foreach a $arcnos($id) {
9155 if {$archeads($a) ne {}} {
9156 validate_archeads $a
9157 if {$archeads($a) ne {}} {
9158 set ret [concat $ret $archeads($a)]
9161 set d $arcstart($a)
9162 if {![info exists seen($d)]} {
9163 lappend todo $d
9164 set seen($d) 1
9169 set ret [lsort -unique $ret]
9170 set cached_dheads($origid) $ret
9171 return [concat $ret $aret]
9174 proc addedtag {id} {
9175 global arcnos arcout cached_dtags cached_atags
9177 if {![info exists arcnos($id)]} return
9178 if {![info exists arcout($id)]} {
9179 recalcarc [lindex $arcnos($id) 0]
9181 catch {unset cached_dtags}
9182 catch {unset cached_atags}
9185 proc addedhead {hid head} {
9186 global arcnos arcout cached_dheads
9188 if {![info exists arcnos($hid)]} return
9189 if {![info exists arcout($hid)]} {
9190 recalcarc [lindex $arcnos($hid) 0]
9192 catch {unset cached_dheads}
9195 proc removedhead {hid head} {
9196 global cached_dheads
9198 catch {unset cached_dheads}
9201 proc movedhead {hid head} {
9202 global arcnos arcout cached_dheads
9204 if {![info exists arcnos($hid)]} return
9205 if {![info exists arcout($hid)]} {
9206 recalcarc [lindex $arcnos($hid) 0]
9208 catch {unset cached_dheads}
9211 proc changedrefs {} {
9212 global cached_dheads cached_dtags cached_atags
9213 global arctags archeads arcnos arcout idheads idtags
9215 foreach id [concat [array names idheads] [array names idtags]] {
9216 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9217 set a [lindex $arcnos($id) 0]
9218 if {![info exists donearc($a)]} {
9219 recalcarc $a
9220 set donearc($a) 1
9224 catch {unset cached_dtags}
9225 catch {unset cached_atags}
9226 catch {unset cached_dheads}
9229 proc rereadrefs {} {
9230 global idtags idheads idotherrefs mainheadid
9232 set refids [concat [array names idtags] \
9233 [array names idheads] [array names idotherrefs]]
9234 foreach id $refids {
9235 if {![info exists ref($id)]} {
9236 set ref($id) [listrefs $id]
9239 set oldmainhead $mainheadid
9240 readrefs
9241 changedrefs
9242 set refids [lsort -unique [concat $refids [array names idtags] \
9243 [array names idheads] [array names idotherrefs]]]
9244 foreach id $refids {
9245 set v [listrefs $id]
9246 if {![info exists ref($id)] || $ref($id) != $v} {
9247 redrawtags $id
9250 if {$oldmainhead ne $mainheadid} {
9251 redrawtags $oldmainhead
9252 redrawtags $mainheadid
9254 run refill_reflist
9257 proc listrefs {id} {
9258 global idtags idheads idotherrefs
9260 set x {}
9261 if {[info exists idtags($id)]} {
9262 set x $idtags($id)
9264 set y {}
9265 if {[info exists idheads($id)]} {
9266 set y $idheads($id)
9268 set z {}
9269 if {[info exists idotherrefs($id)]} {
9270 set z $idotherrefs($id)
9272 return [list $x $y $z]
9275 proc showtag {tag isnew} {
9276 global ctext tagcontents tagids linknum tagobjid
9278 if {$isnew} {
9279 addtohistory [list showtag $tag 0]
9281 $ctext conf -state normal
9282 clear_ctext
9283 settabs 0
9284 set linknum 0
9285 if {![info exists tagcontents($tag)]} {
9286 catch {
9287 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9290 if {[info exists tagcontents($tag)]} {
9291 set text $tagcontents($tag)
9292 } else {
9293 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9295 appendwithlinks $text {}
9296 $ctext conf -state disabled
9297 init_flist {}
9300 proc doquit {} {
9301 global stopped
9302 global gitktmpdir
9304 set stopped 100
9305 savestuff .
9306 destroy .
9308 if {[info exists gitktmpdir]} {
9309 catch {file delete -force $gitktmpdir}
9313 proc mkfontdisp {font top which} {
9314 global fontattr fontpref $font
9316 set fontpref($font) [set $font]
9317 button $top.${font}but -text $which -font optionfont \
9318 -command [list choosefont $font $which]
9319 label $top.$font -relief flat -font $font \
9320 -text $fontattr($font,family) -justify left
9321 grid x $top.${font}but $top.$font -sticky w
9324 proc choosefont {font which} {
9325 global fontparam fontlist fonttop fontattr
9327 set fontparam(which) $which
9328 set fontparam(font) $font
9329 set fontparam(family) [font actual $font -family]
9330 set fontparam(size) $fontattr($font,size)
9331 set fontparam(weight) $fontattr($font,weight)
9332 set fontparam(slant) $fontattr($font,slant)
9333 set top .gitkfont
9334 set fonttop $top
9335 if {![winfo exists $top]} {
9336 font create sample
9337 eval font config sample [font actual $font]
9338 toplevel $top
9339 wm title $top [mc "Gitk font chooser"]
9340 label $top.l -textvariable fontparam(which)
9341 pack $top.l -side top
9342 set fontlist [lsort [font families]]
9343 frame $top.f
9344 listbox $top.f.fam -listvariable fontlist \
9345 -yscrollcommand [list $top.f.sb set]
9346 bind $top.f.fam <<ListboxSelect>> selfontfam
9347 scrollbar $top.f.sb -command [list $top.f.fam yview]
9348 pack $top.f.sb -side right -fill y
9349 pack $top.f.fam -side left -fill both -expand 1
9350 pack $top.f -side top -fill both -expand 1
9351 frame $top.g
9352 spinbox $top.g.size -from 4 -to 40 -width 4 \
9353 -textvariable fontparam(size) \
9354 -validatecommand {string is integer -strict %s}
9355 checkbutton $top.g.bold -padx 5 \
9356 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9357 -variable fontparam(weight) -onvalue bold -offvalue normal
9358 checkbutton $top.g.ital -padx 5 \
9359 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9360 -variable fontparam(slant) -onvalue italic -offvalue roman
9361 pack $top.g.size $top.g.bold $top.g.ital -side left
9362 pack $top.g -side top
9363 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9364 -background white
9365 $top.c create text 100 25 -anchor center -text $which -font sample \
9366 -fill black -tags text
9367 bind $top.c <Configure> [list centertext $top.c]
9368 pack $top.c -side top -fill x
9369 frame $top.buts
9370 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9371 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9372 grid $top.buts.ok $top.buts.can
9373 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9374 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9375 pack $top.buts -side bottom -fill x
9376 trace add variable fontparam write chg_fontparam
9377 } else {
9378 raise $top
9379 $top.c itemconf text -text $which
9381 set i [lsearch -exact $fontlist $fontparam(family)]
9382 if {$i >= 0} {
9383 $top.f.fam selection set $i
9384 $top.f.fam see $i
9388 proc centertext {w} {
9389 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9392 proc fontok {} {
9393 global fontparam fontpref prefstop
9395 set f $fontparam(font)
9396 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9397 if {$fontparam(weight) eq "bold"} {
9398 lappend fontpref($f) "bold"
9400 if {$fontparam(slant) eq "italic"} {
9401 lappend fontpref($f) "italic"
9403 set w $prefstop.$f
9404 $w conf -text $fontparam(family) -font $fontpref($f)
9406 fontcan
9409 proc fontcan {} {
9410 global fonttop fontparam
9412 if {[info exists fonttop]} {
9413 catch {destroy $fonttop}
9414 catch {font delete sample}
9415 unset fonttop
9416 unset fontparam
9420 proc selfontfam {} {
9421 global fonttop fontparam
9423 set i [$fonttop.f.fam curselection]
9424 if {$i ne {}} {
9425 set fontparam(family) [$fonttop.f.fam get $i]
9429 proc chg_fontparam {v sub op} {
9430 global fontparam
9432 font config sample -$sub $fontparam($sub)
9435 proc doprefs {} {
9436 global maxwidth maxgraphpct
9437 global oldprefs prefstop showneartags showlocalchanges
9438 global bgcolor fgcolor ctext diffcolors selectbgcolor
9439 global tabstop limitdiffs autoselect extdifftool perfile_attrs
9441 set top .gitkprefs
9442 set prefstop $top
9443 if {[winfo exists $top]} {
9444 raise $top
9445 return
9447 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9448 limitdiffs tabstop perfile_attrs} {
9449 set oldprefs($v) [set $v]
9451 toplevel $top
9452 wm title $top [mc "Gitk preferences"]
9453 label $top.ldisp -text [mc "Commit list display options"]
9454 grid $top.ldisp - -sticky w -pady 10
9455 label $top.spacer -text " "
9456 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9457 -font optionfont
9458 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9459 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9460 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9461 -font optionfont
9462 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9463 grid x $top.maxpctl $top.maxpct -sticky w
9464 frame $top.showlocal
9465 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9466 checkbutton $top.showlocal.b -variable showlocalchanges
9467 pack $top.showlocal.b $top.showlocal.l -side left
9468 grid x $top.showlocal -sticky w
9469 frame $top.autoselect
9470 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9471 checkbutton $top.autoselect.b -variable autoselect
9472 pack $top.autoselect.b $top.autoselect.l -side left
9473 grid x $top.autoselect -sticky w
9475 label $top.ddisp -text [mc "Diff display options"]
9476 grid $top.ddisp - -sticky w -pady 10
9477 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9478 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9479 grid x $top.tabstopl $top.tabstop -sticky w
9480 frame $top.ntag
9481 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9482 checkbutton $top.ntag.b -variable showneartags
9483 pack $top.ntag.b $top.ntag.l -side left
9484 grid x $top.ntag -sticky w
9485 frame $top.ldiff
9486 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9487 checkbutton $top.ldiff.b -variable limitdiffs
9488 pack $top.ldiff.b $top.ldiff.l -side left
9489 grid x $top.ldiff -sticky w
9490 frame $top.lattr
9491 label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
9492 checkbutton $top.lattr.b -variable perfile_attrs
9493 pack $top.lattr.b $top.lattr.l -side left
9494 grid x $top.lattr -sticky w
9496 entry $top.extdifft -textvariable extdifftool
9497 frame $top.extdifff
9498 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9499 -padx 10
9500 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9501 -command choose_extdiff
9502 pack $top.extdifff.l $top.extdifff.b -side left
9503 grid x $top.extdifff $top.extdifft -sticky w
9505 label $top.cdisp -text [mc "Colors: press to choose"]
9506 grid $top.cdisp - -sticky w -pady 10
9507 label $top.bg -padx 40 -relief sunk -background $bgcolor
9508 button $top.bgbut -text [mc "Background"] -font optionfont \
9509 -command [list choosecolor bgcolor {} $top.bg background setbg]
9510 grid x $top.bgbut $top.bg -sticky w
9511 label $top.fg -padx 40 -relief sunk -background $fgcolor
9512 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9513 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9514 grid x $top.fgbut $top.fg -sticky w
9515 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9516 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9517 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9518 [list $ctext tag conf d0 -foreground]]
9519 grid x $top.diffoldbut $top.diffold -sticky w
9520 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9521 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9522 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9523 [list $ctext tag conf d1 -foreground]]
9524 grid x $top.diffnewbut $top.diffnew -sticky w
9525 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9526 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9527 -command [list choosecolor diffcolors 2 $top.hunksep \
9528 "diff hunk header" \
9529 [list $ctext tag conf hunksep -foreground]]
9530 grid x $top.hunksepbut $top.hunksep -sticky w
9531 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9532 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9533 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9534 grid x $top.selbgbut $top.selbgsep -sticky w
9536 label $top.cfont -text [mc "Fonts: press to choose"]
9537 grid $top.cfont - -sticky w -pady 10
9538 mkfontdisp mainfont $top [mc "Main font"]
9539 mkfontdisp textfont $top [mc "Diff display font"]
9540 mkfontdisp uifont $top [mc "User interface font"]
9542 frame $top.buts
9543 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9544 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9545 grid $top.buts.ok $top.buts.can
9546 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9547 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9548 grid $top.buts - - -pady 10 -sticky ew
9549 bind $top <Visibility> "focus $top.buts.ok"
9552 proc choose_extdiff {} {
9553 global extdifftool
9555 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9556 if {$prog ne {}} {
9557 set extdifftool $prog
9561 proc choosecolor {v vi w x cmd} {
9562 global $v
9564 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9565 -title [mc "Gitk: choose color for %s" $x]]
9566 if {$c eq {}} return
9567 $w conf -background $c
9568 lset $v $vi $c
9569 eval $cmd $c
9572 proc setselbg {c} {
9573 global bglist cflist
9574 foreach w $bglist {
9575 $w configure -selectbackground $c
9577 $cflist tag configure highlight \
9578 -background [$cflist cget -selectbackground]
9579 allcanvs itemconf secsel -fill $c
9582 proc setbg {c} {
9583 global bglist
9585 foreach w $bglist {
9586 $w conf -background $c
9590 proc setfg {c} {
9591 global fglist canv
9593 foreach w $fglist {
9594 $w conf -foreground $c
9596 allcanvs itemconf text -fill $c
9597 $canv itemconf circle -outline $c
9600 proc prefscan {} {
9601 global oldprefs prefstop
9603 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9604 limitdiffs tabstop perfile_attrs} {
9605 global $v
9606 set $v $oldprefs($v)
9608 catch {destroy $prefstop}
9609 unset prefstop
9610 fontcan
9613 proc prefsok {} {
9614 global maxwidth maxgraphpct
9615 global oldprefs prefstop showneartags showlocalchanges
9616 global fontpref mainfont textfont uifont
9617 global limitdiffs treediffs perfile_attrs
9619 catch {destroy $prefstop}
9620 unset prefstop
9621 fontcan
9622 set fontchanged 0
9623 if {$mainfont ne $fontpref(mainfont)} {
9624 set mainfont $fontpref(mainfont)
9625 parsefont mainfont $mainfont
9626 eval font configure mainfont [fontflags mainfont]
9627 eval font configure mainfontbold [fontflags mainfont 1]
9628 setcoords
9629 set fontchanged 1
9631 if {$textfont ne $fontpref(textfont)} {
9632 set textfont $fontpref(textfont)
9633 parsefont textfont $textfont
9634 eval font configure textfont [fontflags textfont]
9635 eval font configure textfontbold [fontflags textfont 1]
9637 if {$uifont ne $fontpref(uifont)} {
9638 set uifont $fontpref(uifont)
9639 parsefont uifont $uifont
9640 eval font configure uifont [fontflags uifont]
9642 settabs
9643 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9644 if {$showlocalchanges} {
9645 doshowlocalchanges
9646 } else {
9647 dohidelocalchanges
9650 if {$limitdiffs != $oldprefs(limitdiffs) ||
9651 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
9652 # treediffs elements are limited by path;
9653 # won't have encodings cached if perfile_attrs was just turned on
9654 catch {unset treediffs}
9656 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9657 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9658 redisplay
9659 } elseif {$showneartags != $oldprefs(showneartags) ||
9660 $limitdiffs != $oldprefs(limitdiffs)} {
9661 reselectline
9665 proc formatdate {d} {
9666 global datetimeformat
9667 if {$d ne {}} {
9668 set d [clock format $d -format $datetimeformat]
9670 return $d
9673 # This list of encoding names and aliases is distilled from
9674 # http://www.iana.org/assignments/character-sets.
9675 # Not all of them are supported by Tcl.
9676 set encoding_aliases {
9677 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9678 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9679 { ISO-10646-UTF-1 csISO10646UTF1 }
9680 { ISO_646.basic:1983 ref csISO646basic1983 }
9681 { INVARIANT csINVARIANT }
9682 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9683 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9684 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9685 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9686 { NATS-DANO iso-ir-9-1 csNATSDANO }
9687 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9688 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9689 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9690 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9691 { ISO-2022-KR csISO2022KR }
9692 { EUC-KR csEUCKR }
9693 { ISO-2022-JP csISO2022JP }
9694 { ISO-2022-JP-2 csISO2022JP2 }
9695 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9696 csISO13JISC6220jp }
9697 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9698 { IT iso-ir-15 ISO646-IT csISO15Italian }
9699 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9700 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9701 { greek7-old iso-ir-18 csISO18Greek7Old }
9702 { latin-greek iso-ir-19 csISO19LatinGreek }
9703 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9704 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9705 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9706 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9707 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9708 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9709 { INIS iso-ir-49 csISO49INIS }
9710 { INIS-8 iso-ir-50 csISO50INIS8 }
9711 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9712 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9713 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9714 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9715 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9716 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9717 csISO60Norwegian1 }
9718 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9719 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9720 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9721 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9722 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9723 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9724 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9725 { greek7 iso-ir-88 csISO88Greek7 }
9726 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9727 { iso-ir-90 csISO90 }
9728 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9729 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9730 csISO92JISC62991984b }
9731 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9732 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9733 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9734 csISO95JIS62291984handadd }
9735 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9736 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9737 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9738 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9739 CP819 csISOLatin1 }
9740 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9741 { T.61-7bit iso-ir-102 csISO102T617bit }
9742 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9743 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9744 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9745 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9746 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9747 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9748 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9749 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9750 arabic csISOLatinArabic }
9751 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9752 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9753 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9754 greek greek8 csISOLatinGreek }
9755 { T.101-G2 iso-ir-128 csISO128T101G2 }
9756 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9757 csISOLatinHebrew }
9758 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9759 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9760 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9761 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9762 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9763 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9764 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9765 csISOLatinCyrillic }
9766 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9767 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9768 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9769 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9770 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9771 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9772 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9773 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9774 { ISO_10367-box iso-ir-155 csISO10367Box }
9775 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9776 { latin-lap lap iso-ir-158 csISO158Lap }
9777 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9778 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9779 { us-dk csUSDK }
9780 { dk-us csDKUS }
9781 { JIS_X0201 X0201 csHalfWidthKatakana }
9782 { KSC5636 ISO646-KR csKSC5636 }
9783 { ISO-10646-UCS-2 csUnicode }
9784 { ISO-10646-UCS-4 csUCS4 }
9785 { DEC-MCS dec csDECMCS }
9786 { hp-roman8 roman8 r8 csHPRoman8 }
9787 { macintosh mac csMacintosh }
9788 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9789 csIBM037 }
9790 { IBM038 EBCDIC-INT cp038 csIBM038 }
9791 { IBM273 CP273 csIBM273 }
9792 { IBM274 EBCDIC-BE CP274 csIBM274 }
9793 { IBM275 EBCDIC-BR cp275 csIBM275 }
9794 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9795 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9796 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9797 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9798 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9799 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9800 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9801 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9802 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9803 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9804 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9805 { IBM437 cp437 437 csPC8CodePage437 }
9806 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9807 { IBM775 cp775 csPC775Baltic }
9808 { IBM850 cp850 850 csPC850Multilingual }
9809 { IBM851 cp851 851 csIBM851 }
9810 { IBM852 cp852 852 csPCp852 }
9811 { IBM855 cp855 855 csIBM855 }
9812 { IBM857 cp857 857 csIBM857 }
9813 { IBM860 cp860 860 csIBM860 }
9814 { IBM861 cp861 861 cp-is csIBM861 }
9815 { IBM862 cp862 862 csPC862LatinHebrew }
9816 { IBM863 cp863 863 csIBM863 }
9817 { IBM864 cp864 csIBM864 }
9818 { IBM865 cp865 865 csIBM865 }
9819 { IBM866 cp866 866 csIBM866 }
9820 { IBM868 CP868 cp-ar csIBM868 }
9821 { IBM869 cp869 869 cp-gr csIBM869 }
9822 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9823 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9824 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9825 { IBM891 cp891 csIBM891 }
9826 { IBM903 cp903 csIBM903 }
9827 { IBM904 cp904 904 csIBBM904 }
9828 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9829 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9830 { IBM1026 CP1026 csIBM1026 }
9831 { EBCDIC-AT-DE csIBMEBCDICATDE }
9832 { EBCDIC-AT-DE-A csEBCDICATDEA }
9833 { EBCDIC-CA-FR csEBCDICCAFR }
9834 { EBCDIC-DK-NO csEBCDICDKNO }
9835 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9836 { EBCDIC-FI-SE csEBCDICFISE }
9837 { EBCDIC-FI-SE-A csEBCDICFISEA }
9838 { EBCDIC-FR csEBCDICFR }
9839 { EBCDIC-IT csEBCDICIT }
9840 { EBCDIC-PT csEBCDICPT }
9841 { EBCDIC-ES csEBCDICES }
9842 { EBCDIC-ES-A csEBCDICESA }
9843 { EBCDIC-ES-S csEBCDICESS }
9844 { EBCDIC-UK csEBCDICUK }
9845 { EBCDIC-US csEBCDICUS }
9846 { UNKNOWN-8BIT csUnknown8BiT }
9847 { MNEMONIC csMnemonic }
9848 { MNEM csMnem }
9849 { VISCII csVISCII }
9850 { VIQR csVIQR }
9851 { KOI8-R csKOI8R }
9852 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9853 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9854 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9855 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9856 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9857 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9858 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9859 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9860 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9861 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9862 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9863 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9864 { IBM1047 IBM-1047 }
9865 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9866 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9867 { UNICODE-1-1 csUnicode11 }
9868 { CESU-8 csCESU-8 }
9869 { BOCU-1 csBOCU-1 }
9870 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9871 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9872 l8 }
9873 { ISO-8859-15 ISO_8859-15 Latin-9 }
9874 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9875 { GBK CP936 MS936 windows-936 }
9876 { JIS_Encoding csJISEncoding }
9877 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
9878 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9879 EUC-JP }
9880 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9881 { ISO-10646-UCS-Basic csUnicodeASCII }
9882 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9883 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9884 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9885 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9886 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9887 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9888 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9889 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9890 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9891 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9892 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9893 { Ventura-US csVenturaUS }
9894 { Ventura-International csVenturaInternational }
9895 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9896 { PC8-Turkish csPC8Turkish }
9897 { IBM-Symbols csIBMSymbols }
9898 { IBM-Thai csIBMThai }
9899 { HP-Legal csHPLegal }
9900 { HP-Pi-font csHPPiFont }
9901 { HP-Math8 csHPMath8 }
9902 { Adobe-Symbol-Encoding csHPPSMath }
9903 { HP-DeskTop csHPDesktop }
9904 { Ventura-Math csVenturaMath }
9905 { Microsoft-Publishing csMicrosoftPublishing }
9906 { Windows-31J csWindows31J }
9907 { GB2312 csGB2312 }
9908 { Big5 csBig5 }
9911 proc tcl_encoding {enc} {
9912 global encoding_aliases tcl_encoding_cache
9913 if {[info exists tcl_encoding_cache($enc)]} {
9914 return $tcl_encoding_cache($enc)
9916 set names [encoding names]
9917 set lcnames [string tolower $names]
9918 set enc [string tolower $enc]
9919 set i [lsearch -exact $lcnames $enc]
9920 if {$i < 0} {
9921 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9922 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
9923 set i [lsearch -exact $lcnames $encx]
9926 if {$i < 0} {
9927 foreach l $encoding_aliases {
9928 set ll [string tolower $l]
9929 if {[lsearch -exact $ll $enc] < 0} continue
9930 # look through the aliases for one that tcl knows about
9931 foreach e $ll {
9932 set i [lsearch -exact $lcnames $e]
9933 if {$i < 0} {
9934 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
9935 set i [lsearch -exact $lcnames $ex]
9938 if {$i >= 0} break
9940 break
9943 set tclenc {}
9944 if {$i >= 0} {
9945 set tclenc [lindex $names $i]
9947 set tcl_encoding_cache($enc) $tclenc
9948 return $tclenc
9951 proc gitattr {path attr default} {
9952 global path_attr_cache
9953 if {[info exists path_attr_cache($attr,$path)]} {
9954 set r $path_attr_cache($attr,$path)
9955 } else {
9956 set r "unspecified"
9957 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
9958 regexp "(.*): encoding: (.*)" $line m f r
9960 set path_attr_cache($attr,$path) $r
9962 if {$r eq "unspecified"} {
9963 return $default
9965 return $r
9968 proc cache_gitattr {attr pathlist} {
9969 global path_attr_cache
9970 set newlist {}
9971 foreach path $pathlist {
9972 if {![info exists path_attr_cache($attr,$path)]} {
9973 lappend newlist $path
9976 set lim 1000
9977 if {[tk windowingsystem] == "win32"} {
9978 # windows has a 32k limit on the arguments to a command...
9979 set lim 30
9981 while {$newlist ne {}} {
9982 set head [lrange $newlist 0 [expr {$lim - 1}]]
9983 set newlist [lrange $newlist $lim end]
9984 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
9985 foreach row [split $rlist "\n"] {
9986 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
9987 if {[string index $path 0] eq "\""} {
9988 set path [encoding convertfrom [lindex $path 0]]
9990 set path_attr_cache($attr,$path) $value
9997 proc get_path_encoding {path} {
9998 global gui_encoding perfile_attrs
9999 set tcl_enc $gui_encoding
10000 if {$path ne {} && $perfile_attrs} {
10001 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10002 if {$enc2 ne {}} {
10003 set tcl_enc $enc2
10006 return $tcl_enc
10009 # First check that Tcl/Tk is recent enough
10010 if {[catch {package require Tk 8.4} err]} {
10011 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10012 Gitk requires at least Tcl/Tk 8.4."]
10013 exit 1
10016 # defaults...
10017 set wrcomcmd "git diff-tree --stdin -p --pretty"
10019 set gitencoding {}
10020 catch {
10021 set gitencoding [exec git config --get i18n.commitencoding]
10023 if {$gitencoding == ""} {
10024 set gitencoding "utf-8"
10026 set tclencoding [tcl_encoding $gitencoding]
10027 if {$tclencoding == {}} {
10028 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10031 set gui_encoding [encoding system]
10032 catch {
10033 set enc [exec git config --get gui.encoding]
10034 if {$enc ne {}} {
10035 set tclenc [tcl_encoding $enc]
10036 if {$tclenc ne {}} {
10037 set gui_encoding $tclenc
10038 } else {
10039 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10044 set mainfont {Helvetica 9}
10045 set textfont {Courier 9}
10046 set uifont {Helvetica 9 bold}
10047 set tabstop 8
10048 set findmergefiles 0
10049 set maxgraphpct 50
10050 set maxwidth 16
10051 set revlistorder 0
10052 set fastdate 0
10053 set uparrowlen 5
10054 set downarrowlen 5
10055 set mingaplen 100
10056 set cmitmode "patch"
10057 set wrapcomment "none"
10058 set showneartags 1
10059 set maxrefs 20
10060 set maxlinelen 200
10061 set showlocalchanges 1
10062 set limitdiffs 1
10063 set datetimeformat "%Y-%m-%d %H:%M:%S"
10064 set autoselect 1
10065 set perfile_attrs 0
10067 set extdifftool "meld"
10069 set colors {green red blue magenta darkgrey brown orange}
10070 set bgcolor white
10071 set fgcolor black
10072 set diffcolors {red "#00a000" blue}
10073 set diffcontext 3
10074 set ignorespace 0
10075 set selectbgcolor gray85
10077 set circlecolors {white blue gray blue blue}
10079 # button for popping up context menus
10080 if {[tk windowingsystem] eq "aqua"} {
10081 set ctxbut <Button-2>
10082 } else {
10083 set ctxbut <Button-3>
10086 ## For msgcat loading, first locate the installation location.
10087 if { [info exists ::env(GITK_MSGSDIR)] } {
10088 ## Msgsdir was manually set in the environment.
10089 set gitk_msgsdir $::env(GITK_MSGSDIR)
10090 } else {
10091 ## Let's guess the prefix from argv0.
10092 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10093 set gitk_libdir [file join $gitk_prefix share gitk lib]
10094 set gitk_msgsdir [file join $gitk_libdir msgs]
10095 unset gitk_prefix
10098 ## Internationalization (i18n) through msgcat and gettext. See
10099 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10100 package require msgcat
10101 namespace import ::msgcat::mc
10102 ## And eventually load the actual message catalog
10103 ::msgcat::mcload $gitk_msgsdir
10105 catch {source ~/.gitk}
10107 font create optionfont -family sans-serif -size -12
10109 parsefont mainfont $mainfont
10110 eval font create mainfont [fontflags mainfont]
10111 eval font create mainfontbold [fontflags mainfont 1]
10113 parsefont textfont $textfont
10114 eval font create textfont [fontflags textfont]
10115 eval font create textfontbold [fontflags textfont 1]
10117 parsefont uifont $uifont
10118 eval font create uifont [fontflags uifont]
10120 setoptions
10122 # check that we can find a .git directory somewhere...
10123 if {[catch {set gitdir [gitdir]}]} {
10124 show_error {} . [mc "Cannot find a git repository here."]
10125 exit 1
10127 if {![file isdirectory $gitdir]} {
10128 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10129 exit 1
10132 set selecthead {}
10133 set selectheadid {}
10135 set revtreeargs {}
10136 set cmdline_files {}
10137 set i 0
10138 set revtreeargscmd {}
10139 foreach arg $argv {
10140 switch -glob -- $arg {
10141 "" { }
10142 "--" {
10143 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10144 break
10146 "--select-commit=*" {
10147 set selecthead [string range $arg 16 end]
10149 "--argscmd=*" {
10150 set revtreeargscmd [string range $arg 10 end]
10152 default {
10153 lappend revtreeargs $arg
10156 incr i
10159 if {$selecthead eq "HEAD"} {
10160 set selecthead {}
10163 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10164 # no -- on command line, but some arguments (other than --argscmd)
10165 if {[catch {
10166 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10167 set cmdline_files [split $f "\n"]
10168 set n [llength $cmdline_files]
10169 set revtreeargs [lrange $revtreeargs 0 end-$n]
10170 # Unfortunately git rev-parse doesn't produce an error when
10171 # something is both a revision and a filename. To be consistent
10172 # with git log and git rev-list, check revtreeargs for filenames.
10173 foreach arg $revtreeargs {
10174 if {[file exists $arg]} {
10175 show_error {} . [mc "Ambiguous argument '%s': both revision\
10176 and filename" $arg]
10177 exit 1
10180 } err]} {
10181 # unfortunately we get both stdout and stderr in $err,
10182 # so look for "fatal:".
10183 set i [string first "fatal:" $err]
10184 if {$i > 0} {
10185 set err [string range $err [expr {$i + 6}] end]
10187 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10188 exit 1
10192 set nullid "0000000000000000000000000000000000000000"
10193 set nullid2 "0000000000000000000000000000000000000001"
10194 set nullfile "/dev/null"
10196 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10198 set runq {}
10199 set history {}
10200 set historyindex 0
10201 set fh_serial 0
10202 set nhl_names {}
10203 set highlight_paths {}
10204 set findpattern {}
10205 set searchdirn -forwards
10206 set boldrows {}
10207 set boldnamerows {}
10208 set diffelide {0 0}
10209 set markingmatches 0
10210 set linkentercount 0
10211 set need_redisplay 0
10212 set nrows_drawn 0
10213 set firsttabstop 0
10215 set nextviewnum 1
10216 set curview 0
10217 set selectedview 0
10218 set selectedhlview [mc "None"]
10219 set highlight_related [mc "None"]
10220 set highlight_files {}
10221 set viewfiles(0) {}
10222 set viewperm(0) 0
10223 set viewargs(0) {}
10224 set viewargscmd(0) {}
10226 set selectedline {}
10227 set numcommits 0
10228 set loginstance 0
10229 set cmdlineok 0
10230 set stopped 0
10231 set stuffsaved 0
10232 set patchnum 0
10233 set lserial 0
10234 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10235 setcoords
10236 makewindow
10237 # wait for the window to become visible
10238 tkwait visibility .
10239 wm title . "[file tail $argv0]: [file tail [pwd]]"
10240 readrefs
10242 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10243 # create a view for the files/dirs specified on the command line
10244 set curview 1
10245 set selectedview 1
10246 set nextviewnum 2
10247 set viewname(1) [mc "Command line"]
10248 set viewfiles(1) $cmdline_files
10249 set viewargs(1) $revtreeargs
10250 set viewargscmd(1) $revtreeargscmd
10251 set viewperm(1) 0
10252 set vdatemode(1) 0
10253 addviewmenu 1
10254 .bar.view entryconf [mca "Edit view..."] -state normal
10255 .bar.view entryconf [mca "Delete view"] -state normal
10258 if {[info exists permviews]} {
10259 foreach v $permviews {
10260 set n $nextviewnum
10261 incr nextviewnum
10262 set viewname($n) [lindex $v 0]
10263 set viewfiles($n) [lindex $v 1]
10264 set viewargs($n) [lindex $v 2]
10265 set viewargscmd($n) [lindex $v 3]
10266 set viewperm($n) 1
10267 addviewmenu $n
10270 getcommits {}