gitk: New way of constructing menus that allows for Alt+letter accelerators
[git/jrn.git] / gitk
blobdedc95dcf9cd8d8d977981b5969192ca535ed94e
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 commitinterest
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 lappend commitinterest($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 commitinterest 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 if {[info exists commitinterest($p)]} {
1260 foreach script $commitinterest($p) {
1261 lappend scripts [string map [list "%I" $p] $script]
1263 unset commitinterest($id)
1267 if {$missing_parents > 0} {
1268 foreach s $scripts {
1269 eval $s
1274 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1275 # Assumes we already have an arc for $rwid.
1276 proc rewrite_commit {v id rwid} {
1277 global children parents varcid varctok vtokmod varccommits
1279 foreach ch $children($v,$id) {
1280 # make $rwid be $ch's parent in place of $id
1281 set i [lsearch -exact $parents($v,$ch) $id]
1282 if {$i < 0} {
1283 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1285 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1286 # add $ch to $rwid's children and sort the list if necessary
1287 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1288 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1289 $children($v,$rwid)]
1291 # fix the graph after joining $id to $rwid
1292 set a $varcid($v,$ch)
1293 fix_reversal $rwid $a $v
1294 # parentlist is wrong for the last element of arc $a
1295 # even if displayorder is right, hence the 3rd arg here
1296 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1300 proc getcommitlines {fd inst view updating} {
1301 global cmitlisted commitinterest leftover
1302 global commitidx commitdata vdatemode
1303 global parents children curview hlview
1304 global idpending ordertok
1305 global varccommits varcid varctok vtokmod vfilelimit
1307 set stuff [read $fd 500000]
1308 # git log doesn't terminate the last commit with a null...
1309 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1310 set stuff "\0"
1312 if {$stuff == {}} {
1313 if {![eof $fd]} {
1314 return 1
1316 global commfd viewcomplete viewactive viewname
1317 global viewinstances
1318 unset commfd($inst)
1319 set i [lsearch -exact $viewinstances($view) $inst]
1320 if {$i >= 0} {
1321 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1323 # set it blocking so we wait for the process to terminate
1324 fconfigure $fd -blocking 1
1325 if {[catch {close $fd} err]} {
1326 set fv {}
1327 if {$view != $curview} {
1328 set fv " for the \"$viewname($view)\" view"
1330 if {[string range $err 0 4] == "usage"} {
1331 set err "Gitk: error reading commits$fv:\
1332 bad arguments to git log."
1333 if {$viewname($view) eq "Command line"} {
1334 append err \
1335 " (Note: arguments to gitk are passed to git log\
1336 to allow selection of commits to be displayed.)"
1338 } else {
1339 set err "Error reading commits$fv: $err"
1341 error_popup $err
1343 if {[incr viewactive($view) -1] <= 0} {
1344 set viewcomplete($view) 1
1345 # Check if we have seen any ids listed as parents that haven't
1346 # appeared in the list
1347 closevarcs $view
1348 notbusy $view
1350 if {$view == $curview} {
1351 run chewcommits
1353 return 0
1355 set start 0
1356 set gotsome 0
1357 set scripts {}
1358 while 1 {
1359 set i [string first "\0" $stuff $start]
1360 if {$i < 0} {
1361 append leftover($inst) [string range $stuff $start end]
1362 break
1364 if {$start == 0} {
1365 set cmit $leftover($inst)
1366 append cmit [string range $stuff 0 [expr {$i - 1}]]
1367 set leftover($inst) {}
1368 } else {
1369 set cmit [string range $stuff $start [expr {$i - 1}]]
1371 set start [expr {$i + 1}]
1372 set j [string first "\n" $cmit]
1373 set ok 0
1374 set listed 1
1375 if {$j >= 0 && [string match "commit *" $cmit]} {
1376 set ids [string range $cmit 7 [expr {$j - 1}]]
1377 if {[string match {[-^<>]*} $ids]} {
1378 switch -- [string index $ids 0] {
1379 "-" {set listed 0}
1380 "^" {set listed 2}
1381 "<" {set listed 3}
1382 ">" {set listed 4}
1384 set ids [string range $ids 1 end]
1386 set ok 1
1387 foreach id $ids {
1388 if {[string length $id] != 40} {
1389 set ok 0
1390 break
1394 if {!$ok} {
1395 set shortcmit $cmit
1396 if {[string length $shortcmit] > 80} {
1397 set shortcmit "[string range $shortcmit 0 80]..."
1399 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1400 exit 1
1402 set id [lindex $ids 0]
1403 set vid $view,$id
1405 if {!$listed && $updating && ![info exists varcid($vid)] &&
1406 $vfilelimit($view) ne {}} {
1407 # git log doesn't rewrite parents for unlisted commits
1408 # when doing path limiting, so work around that here
1409 # by working out the rewritten parent with git rev-list
1410 # and if we already know about it, using the rewritten
1411 # parent as a substitute parent for $id's children.
1412 if {![catch {
1413 set rwid [exec git rev-list --first-parent --max-count=1 \
1414 $id -- $vfilelimit($view)]
1415 }]} {
1416 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1417 # use $rwid in place of $id
1418 rewrite_commit $view $id $rwid
1419 continue
1424 set a 0
1425 if {[info exists varcid($vid)]} {
1426 if {$cmitlisted($vid) || !$listed} continue
1427 set a $varcid($vid)
1429 if {$listed} {
1430 set olds [lrange $ids 1 end]
1431 } else {
1432 set olds {}
1434 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1435 set cmitlisted($vid) $listed
1436 set parents($vid) $olds
1437 if {![info exists children($vid)]} {
1438 set children($vid) {}
1439 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1440 set k [lindex $children($vid) 0]
1441 if {[llength $parents($view,$k)] == 1 &&
1442 (!$vdatemode($view) ||
1443 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1444 set a $varcid($view,$k)
1447 if {$a == 0} {
1448 # new arc
1449 set a [newvarc $view $id]
1451 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1452 modify_arc $view $a
1454 if {![info exists varcid($vid)]} {
1455 set varcid($vid) $a
1456 lappend varccommits($view,$a) $id
1457 incr commitidx($view)
1460 set i 0
1461 foreach p $olds {
1462 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1463 set vp $view,$p
1464 if {[llength [lappend children($vp) $id]] > 1 &&
1465 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1466 set children($vp) [lsort -command [list vtokcmp $view] \
1467 $children($vp)]
1468 catch {unset ordertok}
1470 if {[info exists varcid($view,$p)]} {
1471 fix_reversal $p $a $view
1474 incr i
1477 if {[info exists commitinterest($id)]} {
1478 foreach script $commitinterest($id) {
1479 lappend scripts [string map [list "%I" $id] $script]
1481 unset commitinterest($id)
1483 set gotsome 1
1485 if {$gotsome} {
1486 global numcommits hlview
1488 if {$view == $curview} {
1489 set numcommits $commitidx($view)
1490 run chewcommits
1492 if {[info exists hlview] && $view == $hlview} {
1493 # we never actually get here...
1494 run vhighlightmore
1496 foreach s $scripts {
1497 eval $s
1500 return 2
1503 proc chewcommits {} {
1504 global curview hlview viewcomplete
1505 global pending_select
1507 layoutmore
1508 if {$viewcomplete($curview)} {
1509 global commitidx varctok
1510 global numcommits startmsecs
1512 if {[info exists pending_select]} {
1513 update
1514 reset_pending_select {}
1516 if {[commitinview $pending_select $curview]} {
1517 selectline [rowofcommit $pending_select] 1
1518 } else {
1519 set row [first_real_row]
1520 selectline $row 1
1523 if {$commitidx($curview) > 0} {
1524 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1525 #puts "overall $ms ms for $numcommits commits"
1526 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1527 } else {
1528 show_status [mc "No commits selected"]
1530 notbusy layout
1532 return 0
1535 proc readcommit {id} {
1536 if {[catch {set contents [exec git cat-file commit $id]}]} return
1537 parsecommit $id $contents 0
1540 proc parsecommit {id contents listed} {
1541 global commitinfo cdate
1543 set inhdr 1
1544 set comment {}
1545 set headline {}
1546 set auname {}
1547 set audate {}
1548 set comname {}
1549 set comdate {}
1550 set hdrend [string first "\n\n" $contents]
1551 if {$hdrend < 0} {
1552 # should never happen...
1553 set hdrend [string length $contents]
1555 set header [string range $contents 0 [expr {$hdrend - 1}]]
1556 set comment [string range $contents [expr {$hdrend + 2}] end]
1557 foreach line [split $header "\n"] {
1558 set tag [lindex $line 0]
1559 if {$tag == "author"} {
1560 set audate [lindex $line end-1]
1561 set auname [lrange $line 1 end-2]
1562 } elseif {$tag == "committer"} {
1563 set comdate [lindex $line end-1]
1564 set comname [lrange $line 1 end-2]
1567 set headline {}
1568 # take the first non-blank line of the comment as the headline
1569 set headline [string trimleft $comment]
1570 set i [string first "\n" $headline]
1571 if {$i >= 0} {
1572 set headline [string range $headline 0 $i]
1574 set headline [string trimright $headline]
1575 set i [string first "\r" $headline]
1576 if {$i >= 0} {
1577 set headline [string trimright [string range $headline 0 $i]]
1579 if {!$listed} {
1580 # git log indents the comment by 4 spaces;
1581 # if we got this via git cat-file, add the indentation
1582 set newcomment {}
1583 foreach line [split $comment "\n"] {
1584 append newcomment " "
1585 append newcomment $line
1586 append newcomment "\n"
1588 set comment $newcomment
1590 if {$comdate != {}} {
1591 set cdate($id) $comdate
1593 set commitinfo($id) [list $headline $auname $audate \
1594 $comname $comdate $comment]
1597 proc getcommit {id} {
1598 global commitdata commitinfo
1600 if {[info exists commitdata($id)]} {
1601 parsecommit $id $commitdata($id) 1
1602 } else {
1603 readcommit $id
1604 if {![info exists commitinfo($id)]} {
1605 set commitinfo($id) [list [mc "No commit information available"]]
1608 return 1
1611 proc readrefs {} {
1612 global tagids idtags headids idheads tagobjid
1613 global otherrefids idotherrefs mainhead mainheadid
1614 global selecthead selectheadid
1616 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1617 catch {unset $v}
1619 set refd [open [list | git show-ref -d] r]
1620 while {[gets $refd line] >= 0} {
1621 if {[string index $line 40] ne " "} continue
1622 set id [string range $line 0 39]
1623 set ref [string range $line 41 end]
1624 if {![string match "refs/*" $ref]} continue
1625 set name [string range $ref 5 end]
1626 if {[string match "remotes/*" $name]} {
1627 if {![string match "*/HEAD" $name]} {
1628 set headids($name) $id
1629 lappend idheads($id) $name
1631 } elseif {[string match "heads/*" $name]} {
1632 set name [string range $name 6 end]
1633 set headids($name) $id
1634 lappend idheads($id) $name
1635 } elseif {[string match "tags/*" $name]} {
1636 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1637 # which is what we want since the former is the commit ID
1638 set name [string range $name 5 end]
1639 if {[string match "*^{}" $name]} {
1640 set name [string range $name 0 end-3]
1641 } else {
1642 set tagobjid($name) $id
1644 set tagids($name) $id
1645 lappend idtags($id) $name
1646 } else {
1647 set otherrefids($name) $id
1648 lappend idotherrefs($id) $name
1651 catch {close $refd}
1652 set mainhead {}
1653 set mainheadid {}
1654 catch {
1655 set mainheadid [exec git rev-parse HEAD]
1656 set thehead [exec git symbolic-ref HEAD]
1657 if {[string match "refs/heads/*" $thehead]} {
1658 set mainhead [string range $thehead 11 end]
1661 set selectheadid {}
1662 if {$selecthead ne {}} {
1663 catch {
1664 set selectheadid [exec git rev-parse --verify $selecthead]
1669 # skip over fake commits
1670 proc first_real_row {} {
1671 global nullid nullid2 numcommits
1673 for {set row 0} {$row < $numcommits} {incr row} {
1674 set id [commitonrow $row]
1675 if {$id ne $nullid && $id ne $nullid2} {
1676 break
1679 return $row
1682 # update things for a head moved to a child of its previous location
1683 proc movehead {id name} {
1684 global headids idheads
1686 removehead $headids($name) $name
1687 set headids($name) $id
1688 lappend idheads($id) $name
1691 # update things when a head has been removed
1692 proc removehead {id name} {
1693 global headids idheads
1695 if {$idheads($id) eq $name} {
1696 unset idheads($id)
1697 } else {
1698 set i [lsearch -exact $idheads($id) $name]
1699 if {$i >= 0} {
1700 set idheads($id) [lreplace $idheads($id) $i $i]
1703 unset headids($name)
1706 proc show_error {w top msg} {
1707 message $w.m -text $msg -justify center -aspect 400
1708 pack $w.m -side top -fill x -padx 20 -pady 20
1709 button $w.ok -text [mc OK] -command "destroy $top"
1710 pack $w.ok -side bottom -fill x
1711 bind $top <Visibility> "grab $top; focus $top"
1712 bind $top <Key-Return> "destroy $top"
1713 tkwait window $top
1716 proc error_popup msg {
1717 set w .error
1718 toplevel $w
1719 wm transient $w .
1720 show_error $w $w $msg
1723 proc confirm_popup msg {
1724 global confirm_ok
1725 set confirm_ok 0
1726 set w .confirm
1727 toplevel $w
1728 wm transient $w .
1729 message $w.m -text $msg -justify center -aspect 400
1730 pack $w.m -side top -fill x -padx 20 -pady 20
1731 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1732 pack $w.ok -side left -fill x
1733 button $w.cancel -text [mc Cancel] -command "destroy $w"
1734 pack $w.cancel -side right -fill x
1735 bind $w <Visibility> "grab $w; focus $w"
1736 tkwait window $w
1737 return $confirm_ok
1740 proc setoptions {} {
1741 option add *Panedwindow.showHandle 1 startupFile
1742 option add *Panedwindow.sashRelief raised startupFile
1743 option add *Button.font uifont startupFile
1744 option add *Checkbutton.font uifont startupFile
1745 option add *Radiobutton.font uifont startupFile
1746 option add *Menu.font uifont startupFile
1747 option add *Menubutton.font uifont startupFile
1748 option add *Label.font uifont startupFile
1749 option add *Message.font uifont startupFile
1750 option add *Entry.font uifont startupFile
1753 proc makemenu {m items} {
1754 menu $m
1755 foreach i $items {
1756 set name [mc [lindex $i 0]]
1757 set type [lindex $i 1]
1758 set thing [lindex $i 2]
1759 set params [list $type]
1760 if {$name ne {}} {
1761 set u [string first "&" [string map {&& x} $name]]
1762 lappend params -label [string map {&& & & {}} $name]
1763 if {$u >= 0} {
1764 lappend params -underline $u
1767 switch -- $type {
1768 "cascade" {
1769 set submenu [string tolower [string map {& ""} [lindex $i 0]]]
1770 lappend params -menu $m.$submenu
1772 "command" {
1773 lappend params -command $thing
1775 "radiobutton" {
1776 lappend params -variable [lindex $thing 0] \
1777 -value [lindex $thing 1]
1780 eval $m add $params [lrange $i 3 end]
1781 if {$type eq "cascade"} {
1782 makemenu $m.$submenu $thing
1787 # translate string and remove ampersands
1788 proc mca {str} {
1789 return [string map {&& & & {}} [mc $str]]
1792 proc makewindow {} {
1793 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1794 global tabstop
1795 global findtype findtypemenu findloc findstring fstring geometry
1796 global entries sha1entry sha1string sha1but
1797 global diffcontextstring diffcontext
1798 global ignorespace
1799 global maincursor textcursor curtextcursor
1800 global rowctxmenu fakerowmenu mergemax wrapcomment
1801 global highlight_files gdttype
1802 global searchstring sstring
1803 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1804 global headctxmenu progresscanv progressitem progresscoords statusw
1805 global fprogitem fprogcoord lastprogupdate progupdatepending
1806 global rprogitem rprogcoord rownumsel numcommits
1807 global have_tk85
1809 makemenu .bar {
1810 {"File" cascade {
1811 {"Update" command updatecommits -accelerator F5}
1812 {"Reload" command reloadcommits}
1813 {"Reread references" command rereadrefs}
1814 {"List references" command showrefs}
1815 {"Quit" command doquit}
1817 {"Edit" cascade {
1818 {"Preferences" command doprefs}
1820 {"View" cascade {
1821 {"New view..." command {newview 0}}
1822 {"Edit view..." command editview -state disabled}
1823 {"Delete view" command delview -state disabled}
1824 {"" separator}
1825 {"All files" radiobutton {selectedview 0} -command {showview 0}}
1827 {"Help" cascade {
1828 {"About gitk" command about}
1829 {"Key bindings" command keys}
1832 . configure -menu .bar
1834 # the gui has upper and lower half, parts of a paned window.
1835 panedwindow .ctop -orient vertical
1837 # possibly use assumed geometry
1838 if {![info exists geometry(pwsash0)]} {
1839 set geometry(topheight) [expr {15 * $linespc}]
1840 set geometry(topwidth) [expr {80 * $charspc}]
1841 set geometry(botheight) [expr {15 * $linespc}]
1842 set geometry(botwidth) [expr {50 * $charspc}]
1843 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1844 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1847 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1848 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1849 frame .tf.histframe
1850 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1852 # create three canvases
1853 set cscroll .tf.histframe.csb
1854 set canv .tf.histframe.pwclist.canv
1855 canvas $canv \
1856 -selectbackground $selectbgcolor \
1857 -background $bgcolor -bd 0 \
1858 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1859 .tf.histframe.pwclist add $canv
1860 set canv2 .tf.histframe.pwclist.canv2
1861 canvas $canv2 \
1862 -selectbackground $selectbgcolor \
1863 -background $bgcolor -bd 0 -yscrollincr $linespc
1864 .tf.histframe.pwclist add $canv2
1865 set canv3 .tf.histframe.pwclist.canv3
1866 canvas $canv3 \
1867 -selectbackground $selectbgcolor \
1868 -background $bgcolor -bd 0 -yscrollincr $linespc
1869 .tf.histframe.pwclist add $canv3
1870 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1871 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1873 # a scroll bar to rule them
1874 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1875 pack $cscroll -side right -fill y
1876 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1877 lappend bglist $canv $canv2 $canv3
1878 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1880 # we have two button bars at bottom of top frame. Bar 1
1881 frame .tf.bar
1882 frame .tf.lbar -height 15
1884 set sha1entry .tf.bar.sha1
1885 set entries $sha1entry
1886 set sha1but .tf.bar.sha1label
1887 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1888 -command gotocommit -width 8
1889 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1890 pack .tf.bar.sha1label -side left
1891 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1892 trace add variable sha1string write sha1change
1893 pack $sha1entry -side left -pady 2
1895 image create bitmap bm-left -data {
1896 #define left_width 16
1897 #define left_height 16
1898 static unsigned char left_bits[] = {
1899 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1900 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1901 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1903 image create bitmap bm-right -data {
1904 #define right_width 16
1905 #define right_height 16
1906 static unsigned char right_bits[] = {
1907 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1908 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1909 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1911 button .tf.bar.leftbut -image bm-left -command goback \
1912 -state disabled -width 26
1913 pack .tf.bar.leftbut -side left -fill y
1914 button .tf.bar.rightbut -image bm-right -command goforw \
1915 -state disabled -width 26
1916 pack .tf.bar.rightbut -side left -fill y
1918 label .tf.bar.rowlabel -text [mc "Row"]
1919 set rownumsel {}
1920 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1921 -relief sunken -anchor e
1922 label .tf.bar.rowlabel2 -text "/"
1923 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1924 -relief sunken -anchor e
1925 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1926 -side left
1927 global selectedline
1928 trace add variable selectedline write selectedline_change
1930 # Status label and progress bar
1931 set statusw .tf.bar.status
1932 label $statusw -width 15 -relief sunken
1933 pack $statusw -side left -padx 5
1934 set h [expr {[font metrics uifont -linespace] + 2}]
1935 set progresscanv .tf.bar.progress
1936 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1937 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1938 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1939 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1940 pack $progresscanv -side right -expand 1 -fill x
1941 set progresscoords {0 0}
1942 set fprogcoord 0
1943 set rprogcoord 0
1944 bind $progresscanv <Configure> adjustprogress
1945 set lastprogupdate [clock clicks -milliseconds]
1946 set progupdatepending 0
1948 # build up the bottom bar of upper window
1949 label .tf.lbar.flabel -text "[mc "Find"] "
1950 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1951 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1952 label .tf.lbar.flab2 -text " [mc "commit"] "
1953 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1954 -side left -fill y
1955 set gdttype [mc "containing:"]
1956 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1957 [mc "containing:"] \
1958 [mc "touching paths:"] \
1959 [mc "adding/removing string:"]]
1960 trace add variable gdttype write gdttype_change
1961 pack .tf.lbar.gdttype -side left -fill y
1963 set findstring {}
1964 set fstring .tf.lbar.findstring
1965 lappend entries $fstring
1966 entry $fstring -width 30 -font textfont -textvariable findstring
1967 trace add variable findstring write find_change
1968 set findtype [mc "Exact"]
1969 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1970 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1971 trace add variable findtype write findcom_change
1972 set findloc [mc "All fields"]
1973 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1974 [mc "Comments"] [mc "Author"] [mc "Committer"]
1975 trace add variable findloc write find_change
1976 pack .tf.lbar.findloc -side right
1977 pack .tf.lbar.findtype -side right
1978 pack $fstring -side left -expand 1 -fill x
1980 # Finish putting the upper half of the viewer together
1981 pack .tf.lbar -in .tf -side bottom -fill x
1982 pack .tf.bar -in .tf -side bottom -fill x
1983 pack .tf.histframe -fill both -side top -expand 1
1984 .ctop add .tf
1985 .ctop paneconfigure .tf -height $geometry(topheight)
1986 .ctop paneconfigure .tf -width $geometry(topwidth)
1988 # now build up the bottom
1989 panedwindow .pwbottom -orient horizontal
1991 # lower left, a text box over search bar, scroll bar to the right
1992 # if we know window height, then that will set the lower text height, otherwise
1993 # we set lower text height which will drive window height
1994 if {[info exists geometry(main)]} {
1995 frame .bleft -width $geometry(botwidth)
1996 } else {
1997 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1999 frame .bleft.top
2000 frame .bleft.mid
2001 frame .bleft.bottom
2003 button .bleft.top.search -text [mc "Search"] -command dosearch
2004 pack .bleft.top.search -side left -padx 5
2005 set sstring .bleft.top.sstring
2006 entry $sstring -width 20 -font textfont -textvariable searchstring
2007 lappend entries $sstring
2008 trace add variable searchstring write incrsearch
2009 pack $sstring -side left -expand 1 -fill x
2010 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2011 -command changediffdisp -variable diffelide -value {0 0}
2012 radiobutton .bleft.mid.old -text [mc "Old version"] \
2013 -command changediffdisp -variable diffelide -value {0 1}
2014 radiobutton .bleft.mid.new -text [mc "New version"] \
2015 -command changediffdisp -variable diffelide -value {1 0}
2016 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2017 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2018 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2019 -from 1 -increment 1 -to 10000000 \
2020 -validate all -validatecommand "diffcontextvalidate %P" \
2021 -textvariable diffcontextstring
2022 .bleft.mid.diffcontext set $diffcontext
2023 trace add variable diffcontextstring write diffcontextchange
2024 lappend entries .bleft.mid.diffcontext
2025 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2026 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2027 -command changeignorespace -variable ignorespace
2028 pack .bleft.mid.ignspace -side left -padx 5
2029 set ctext .bleft.bottom.ctext
2030 text $ctext -background $bgcolor -foreground $fgcolor \
2031 -state disabled -font textfont \
2032 -yscrollcommand scrolltext -wrap none \
2033 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2034 if {$have_tk85} {
2035 $ctext conf -tabstyle wordprocessor
2037 scrollbar .bleft.bottom.sb -command "$ctext yview"
2038 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2039 -width 10
2040 pack .bleft.top -side top -fill x
2041 pack .bleft.mid -side top -fill x
2042 grid $ctext .bleft.bottom.sb -sticky nsew
2043 grid .bleft.bottom.sbhorizontal -sticky ew
2044 grid columnconfigure .bleft.bottom 0 -weight 1
2045 grid rowconfigure .bleft.bottom 0 -weight 1
2046 grid rowconfigure .bleft.bottom 1 -weight 0
2047 pack .bleft.bottom -side top -fill both -expand 1
2048 lappend bglist $ctext
2049 lappend fglist $ctext
2051 $ctext tag conf comment -wrap $wrapcomment
2052 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2053 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2054 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2055 $ctext tag conf d1 -fore [lindex $diffcolors 1]
2056 $ctext tag conf m0 -fore red
2057 $ctext tag conf m1 -fore blue
2058 $ctext tag conf m2 -fore green
2059 $ctext tag conf m3 -fore purple
2060 $ctext tag conf m4 -fore brown
2061 $ctext tag conf m5 -fore "#009090"
2062 $ctext tag conf m6 -fore magenta
2063 $ctext tag conf m7 -fore "#808000"
2064 $ctext tag conf m8 -fore "#009000"
2065 $ctext tag conf m9 -fore "#ff0080"
2066 $ctext tag conf m10 -fore cyan
2067 $ctext tag conf m11 -fore "#b07070"
2068 $ctext tag conf m12 -fore "#70b0f0"
2069 $ctext tag conf m13 -fore "#70f0b0"
2070 $ctext tag conf m14 -fore "#f0b070"
2071 $ctext tag conf m15 -fore "#ff70b0"
2072 $ctext tag conf mmax -fore darkgrey
2073 set mergemax 16
2074 $ctext tag conf mresult -font textfontbold
2075 $ctext tag conf msep -font textfontbold
2076 $ctext tag conf found -back yellow
2078 .pwbottom add .bleft
2079 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2081 # lower right
2082 frame .bright
2083 frame .bright.mode
2084 radiobutton .bright.mode.patch -text [mc "Patch"] \
2085 -command reselectline -variable cmitmode -value "patch"
2086 radiobutton .bright.mode.tree -text [mc "Tree"] \
2087 -command reselectline -variable cmitmode -value "tree"
2088 grid .bright.mode.patch .bright.mode.tree -sticky ew
2089 pack .bright.mode -side top -fill x
2090 set cflist .bright.cfiles
2091 set indent [font measure mainfont "nn"]
2092 text $cflist \
2093 -selectbackground $selectbgcolor \
2094 -background $bgcolor -foreground $fgcolor \
2095 -font mainfont \
2096 -tabs [list $indent [expr {2 * $indent}]] \
2097 -yscrollcommand ".bright.sb set" \
2098 -cursor [. cget -cursor] \
2099 -spacing1 1 -spacing3 1
2100 lappend bglist $cflist
2101 lappend fglist $cflist
2102 scrollbar .bright.sb -command "$cflist yview"
2103 pack .bright.sb -side right -fill y
2104 pack $cflist -side left -fill both -expand 1
2105 $cflist tag configure highlight \
2106 -background [$cflist cget -selectbackground]
2107 $cflist tag configure bold -font mainfontbold
2109 .pwbottom add .bright
2110 .ctop add .pwbottom
2112 # restore window width & height if known
2113 if {[info exists geometry(main)]} {
2114 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2115 if {$w > [winfo screenwidth .]} {
2116 set w [winfo screenwidth .]
2118 if {$h > [winfo screenheight .]} {
2119 set h [winfo screenheight .]
2121 wm geometry . "${w}x$h"
2125 if {[tk windowingsystem] eq {aqua}} {
2126 set M1B M1
2127 } else {
2128 set M1B Control
2131 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2132 pack .ctop -fill both -expand 1
2133 bindall <1> {selcanvline %W %x %y}
2134 #bindall <B1-Motion> {selcanvline %W %x %y}
2135 if {[tk windowingsystem] == "win32"} {
2136 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2137 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2138 } else {
2139 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2140 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2141 if {[tk windowingsystem] eq "aqua"} {
2142 bindall <MouseWheel> {
2143 set delta [expr {- (%D)}]
2144 allcanvs yview scroll $delta units
2148 bindall <2> "canvscan mark %W %x %y"
2149 bindall <B2-Motion> "canvscan dragto %W %x %y"
2150 bindkey <Home> selfirstline
2151 bindkey <End> sellastline
2152 bind . <Key-Up> "selnextline -1"
2153 bind . <Key-Down> "selnextline 1"
2154 bind . <Shift-Key-Up> "dofind -1 0"
2155 bind . <Shift-Key-Down> "dofind 1 0"
2156 bindkey <Key-Right> "goforw"
2157 bindkey <Key-Left> "goback"
2158 bind . <Key-Prior> "selnextpage -1"
2159 bind . <Key-Next> "selnextpage 1"
2160 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2161 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2162 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2163 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2164 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2165 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2166 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2167 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2168 bindkey <Key-space> "$ctext yview scroll 1 pages"
2169 bindkey p "selnextline -1"
2170 bindkey n "selnextline 1"
2171 bindkey z "goback"
2172 bindkey x "goforw"
2173 bindkey i "selnextline -1"
2174 bindkey k "selnextline 1"
2175 bindkey j "goback"
2176 bindkey l "goforw"
2177 bindkey b prevfile
2178 bindkey d "$ctext yview scroll 18 units"
2179 bindkey u "$ctext yview scroll -18 units"
2180 bindkey / {dofind 1 1}
2181 bindkey <Key-Return> {dofind 1 1}
2182 bindkey ? {dofind -1 1}
2183 bindkey f nextfile
2184 bindkey <F5> updatecommits
2185 bind . <$M1B-q> doquit
2186 bind . <$M1B-f> {dofind 1 1}
2187 bind . <$M1B-g> {dofind 1 0}
2188 bind . <$M1B-r> dosearchback
2189 bind . <$M1B-s> dosearch
2190 bind . <$M1B-equal> {incrfont 1}
2191 bind . <$M1B-plus> {incrfont 1}
2192 bind . <$M1B-KP_Add> {incrfont 1}
2193 bind . <$M1B-minus> {incrfont -1}
2194 bind . <$M1B-KP_Subtract> {incrfont -1}
2195 wm protocol . WM_DELETE_WINDOW doquit
2196 bind . <Destroy> {stop_backends}
2197 bind . <Button-1> "click %W"
2198 bind $fstring <Key-Return> {dofind 1 1}
2199 bind $sha1entry <Key-Return> {gotocommit; break}
2200 bind $sha1entry <<PasteSelection>> clearsha1
2201 bind $cflist <1> {sel_flist %W %x %y; break}
2202 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2203 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2204 global ctxbut
2205 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2207 set maincursor [. cget -cursor]
2208 set textcursor [$ctext cget -cursor]
2209 set curtextcursor $textcursor
2211 set rowctxmenu .rowctxmenu
2212 makemenu $rowctxmenu {
2213 {"Diff this -> selected" command {diffvssel 0}}
2214 {"Diff selected -> this" command {diffvssel 1}}
2215 {"Make patch" command mkpatch}
2216 {"Create tag" command mktag}
2217 {"Write commit to file" command writecommit}
2218 {"Create new branch" command mkbranch}
2219 {"Cherry-pick this commit" command cherrypick}
2220 {"Reset HEAD branch to here" command resethead}
2222 $rowctxmenu configure -tearoff 0
2224 set fakerowmenu .fakerowmenu
2225 makemenu $fakerowmenu {
2226 {"Diff this -> selected" command {diffvssel 0}}
2227 {"Diff selected -> this" command {diffvssel 1}}
2228 {"Make patch" command mkpatch}
2230 $fakerowmenu configure -tearoff 0
2232 set headctxmenu .headctxmenu
2233 makemenu $headctxmenu {
2234 {"Check out this branch" command cobranch}
2235 {"Remove this branch" command rmbranch}
2237 $headctxmenu configure -tearoff 0
2239 global flist_menu
2240 set flist_menu .flistctxmenu
2241 makemenu $flist_menu {
2242 {"Highlight this too" command {flist_hl 0}}
2243 {"Highlight this only" command {flist_hl 1}}
2244 {"External diff" command {external_diff}}
2245 {"Blame parent commit" command {external_blame 1}}
2247 $flist_menu configure -tearoff 0
2250 # Windows sends all mouse wheel events to the current focused window, not
2251 # the one where the mouse hovers, so bind those events here and redirect
2252 # to the correct window
2253 proc windows_mousewheel_redirector {W X Y D} {
2254 global canv canv2 canv3
2255 set w [winfo containing -displayof $W $X $Y]
2256 if {$w ne ""} {
2257 set u [expr {$D < 0 ? 5 : -5}]
2258 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2259 allcanvs yview scroll $u units
2260 } else {
2261 catch {
2262 $w yview scroll $u units
2268 # Update row number label when selectedline changes
2269 proc selectedline_change {n1 n2 op} {
2270 global selectedline rownumsel
2272 if {$selectedline eq {}} {
2273 set rownumsel {}
2274 } else {
2275 set rownumsel [expr {$selectedline + 1}]
2279 # mouse-2 makes all windows scan vertically, but only the one
2280 # the cursor is in scans horizontally
2281 proc canvscan {op w x y} {
2282 global canv canv2 canv3
2283 foreach c [list $canv $canv2 $canv3] {
2284 if {$c == $w} {
2285 $c scan $op $x $y
2286 } else {
2287 $c scan $op 0 $y
2292 proc scrollcanv {cscroll f0 f1} {
2293 $cscroll set $f0 $f1
2294 drawvisible
2295 flushhighlights
2298 # when we make a key binding for the toplevel, make sure
2299 # it doesn't get triggered when that key is pressed in the
2300 # find string entry widget.
2301 proc bindkey {ev script} {
2302 global entries
2303 bind . $ev $script
2304 set escript [bind Entry $ev]
2305 if {$escript == {}} {
2306 set escript [bind Entry <Key>]
2308 foreach e $entries {
2309 bind $e $ev "$escript; break"
2313 # set the focus back to the toplevel for any click outside
2314 # the entry widgets
2315 proc click {w} {
2316 global ctext entries
2317 foreach e [concat $entries $ctext] {
2318 if {$w == $e} return
2320 focus .
2323 # Adjust the progress bar for a change in requested extent or canvas size
2324 proc adjustprogress {} {
2325 global progresscanv progressitem progresscoords
2326 global fprogitem fprogcoord lastprogupdate progupdatepending
2327 global rprogitem rprogcoord
2329 set w [expr {[winfo width $progresscanv] - 4}]
2330 set x0 [expr {$w * [lindex $progresscoords 0]}]
2331 set x1 [expr {$w * [lindex $progresscoords 1]}]
2332 set h [winfo height $progresscanv]
2333 $progresscanv coords $progressitem $x0 0 $x1 $h
2334 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2335 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2336 set now [clock clicks -milliseconds]
2337 if {$now >= $lastprogupdate + 100} {
2338 set progupdatepending 0
2339 update
2340 } elseif {!$progupdatepending} {
2341 set progupdatepending 1
2342 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2346 proc doprogupdate {} {
2347 global lastprogupdate progupdatepending
2349 if {$progupdatepending} {
2350 set progupdatepending 0
2351 set lastprogupdate [clock clicks -milliseconds]
2352 update
2356 proc savestuff {w} {
2357 global canv canv2 canv3 mainfont textfont uifont tabstop
2358 global stuffsaved findmergefiles maxgraphpct
2359 global maxwidth showneartags showlocalchanges
2360 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2361 global cmitmode wrapcomment datetimeformat limitdiffs
2362 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2363 global autoselect extdifftool perfile_attrs
2365 if {$stuffsaved} return
2366 if {![winfo viewable .]} return
2367 catch {
2368 set f [open "~/.gitk-new" w]
2369 puts $f [list set mainfont $mainfont]
2370 puts $f [list set textfont $textfont]
2371 puts $f [list set uifont $uifont]
2372 puts $f [list set tabstop $tabstop]
2373 puts $f [list set findmergefiles $findmergefiles]
2374 puts $f [list set maxgraphpct $maxgraphpct]
2375 puts $f [list set maxwidth $maxwidth]
2376 puts $f [list set cmitmode $cmitmode]
2377 puts $f [list set wrapcomment $wrapcomment]
2378 puts $f [list set autoselect $autoselect]
2379 puts $f [list set showneartags $showneartags]
2380 puts $f [list set showlocalchanges $showlocalchanges]
2381 puts $f [list set datetimeformat $datetimeformat]
2382 puts $f [list set limitdiffs $limitdiffs]
2383 puts $f [list set bgcolor $bgcolor]
2384 puts $f [list set fgcolor $fgcolor]
2385 puts $f [list set colors $colors]
2386 puts $f [list set diffcolors $diffcolors]
2387 puts $f [list set diffcontext $diffcontext]
2388 puts $f [list set selectbgcolor $selectbgcolor]
2389 puts $f [list set extdifftool $extdifftool]
2390 puts $f [list set perfile_attrs $perfile_attrs]
2392 puts $f "set geometry(main) [wm geometry .]"
2393 puts $f "set geometry(topwidth) [winfo width .tf]"
2394 puts $f "set geometry(topheight) [winfo height .tf]"
2395 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2396 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2397 puts $f "set geometry(botwidth) [winfo width .bleft]"
2398 puts $f "set geometry(botheight) [winfo height .bleft]"
2400 puts -nonewline $f "set permviews {"
2401 for {set v 0} {$v < $nextviewnum} {incr v} {
2402 if {$viewperm($v)} {
2403 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2406 puts $f "}"
2407 close $f
2408 file rename -force "~/.gitk-new" "~/.gitk"
2410 set stuffsaved 1
2413 proc resizeclistpanes {win w} {
2414 global oldwidth
2415 if {[info exists oldwidth($win)]} {
2416 set s0 [$win sash coord 0]
2417 set s1 [$win sash coord 1]
2418 if {$w < 60} {
2419 set sash0 [expr {int($w/2 - 2)}]
2420 set sash1 [expr {int($w*5/6 - 2)}]
2421 } else {
2422 set factor [expr {1.0 * $w / $oldwidth($win)}]
2423 set sash0 [expr {int($factor * [lindex $s0 0])}]
2424 set sash1 [expr {int($factor * [lindex $s1 0])}]
2425 if {$sash0 < 30} {
2426 set sash0 30
2428 if {$sash1 < $sash0 + 20} {
2429 set sash1 [expr {$sash0 + 20}]
2431 if {$sash1 > $w - 10} {
2432 set sash1 [expr {$w - 10}]
2433 if {$sash0 > $sash1 - 20} {
2434 set sash0 [expr {$sash1 - 20}]
2438 $win sash place 0 $sash0 [lindex $s0 1]
2439 $win sash place 1 $sash1 [lindex $s1 1]
2441 set oldwidth($win) $w
2444 proc resizecdetpanes {win w} {
2445 global oldwidth
2446 if {[info exists oldwidth($win)]} {
2447 set s0 [$win sash coord 0]
2448 if {$w < 60} {
2449 set sash0 [expr {int($w*3/4 - 2)}]
2450 } else {
2451 set factor [expr {1.0 * $w / $oldwidth($win)}]
2452 set sash0 [expr {int($factor * [lindex $s0 0])}]
2453 if {$sash0 < 45} {
2454 set sash0 45
2456 if {$sash0 > $w - 15} {
2457 set sash0 [expr {$w - 15}]
2460 $win sash place 0 $sash0 [lindex $s0 1]
2462 set oldwidth($win) $w
2465 proc allcanvs args {
2466 global canv canv2 canv3
2467 eval $canv $args
2468 eval $canv2 $args
2469 eval $canv3 $args
2472 proc bindall {event action} {
2473 global canv canv2 canv3
2474 bind $canv $event $action
2475 bind $canv2 $event $action
2476 bind $canv3 $event $action
2479 proc about {} {
2480 global uifont
2481 set w .about
2482 if {[winfo exists $w]} {
2483 raise $w
2484 return
2486 toplevel $w
2487 wm title $w [mc "About gitk"]
2488 message $w.m -text [mc "
2489 Gitk - a commit viewer for git
2491 Copyright © 2005-2008 Paul Mackerras
2493 Use and redistribute under the terms of the GNU General Public License"] \
2494 -justify center -aspect 400 -border 2 -bg white -relief groove
2495 pack $w.m -side top -fill x -padx 2 -pady 2
2496 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2497 pack $w.ok -side bottom
2498 bind $w <Visibility> "focus $w.ok"
2499 bind $w <Key-Escape> "destroy $w"
2500 bind $w <Key-Return> "destroy $w"
2503 proc keys {} {
2504 set w .keys
2505 if {[winfo exists $w]} {
2506 raise $w
2507 return
2509 if {[tk windowingsystem] eq {aqua}} {
2510 set M1T Cmd
2511 } else {
2512 set M1T Ctrl
2514 toplevel $w
2515 wm title $w [mc "Gitk key bindings"]
2516 message $w.m -text "
2517 [mc "Gitk key bindings:"]
2519 [mc "<%s-Q> Quit" $M1T]
2520 [mc "<Home> Move to first commit"]
2521 [mc "<End> Move to last commit"]
2522 [mc "<Up>, p, i Move up one commit"]
2523 [mc "<Down>, n, k Move down one commit"]
2524 [mc "<Left>, z, j Go back in history list"]
2525 [mc "<Right>, x, l Go forward in history list"]
2526 [mc "<PageUp> Move up one page in commit list"]
2527 [mc "<PageDown> Move down one page in commit list"]
2528 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2529 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2530 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2531 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2532 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2533 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2534 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2535 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2536 [mc "<Delete>, b Scroll diff view up one page"]
2537 [mc "<Backspace> Scroll diff view up one page"]
2538 [mc "<Space> Scroll diff view down one page"]
2539 [mc "u Scroll diff view up 18 lines"]
2540 [mc "d Scroll diff view down 18 lines"]
2541 [mc "<%s-F> Find" $M1T]
2542 [mc "<%s-G> Move to next find hit" $M1T]
2543 [mc "<Return> Move to next find hit"]
2544 [mc "/ Move to next find hit, or redo find"]
2545 [mc "? Move to previous find hit"]
2546 [mc "f Scroll diff view to next file"]
2547 [mc "<%s-S> Search for next hit in diff view" $M1T]
2548 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2549 [mc "<%s-KP+> Increase font size" $M1T]
2550 [mc "<%s-plus> Increase font size" $M1T]
2551 [mc "<%s-KP-> Decrease font size" $M1T]
2552 [mc "<%s-minus> Decrease font size" $M1T]
2553 [mc "<F5> Update"]
2555 -justify left -bg white -border 2 -relief groove
2556 pack $w.m -side top -fill both -padx 2 -pady 2
2557 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2558 pack $w.ok -side bottom
2559 bind $w <Visibility> "focus $w.ok"
2560 bind $w <Key-Escape> "destroy $w"
2561 bind $w <Key-Return> "destroy $w"
2564 # Procedures for manipulating the file list window at the
2565 # bottom right of the overall window.
2567 proc treeview {w l openlevs} {
2568 global treecontents treediropen treeheight treeparent treeindex
2570 set ix 0
2571 set treeindex() 0
2572 set lev 0
2573 set prefix {}
2574 set prefixend -1
2575 set prefendstack {}
2576 set htstack {}
2577 set ht 0
2578 set treecontents() {}
2579 $w conf -state normal
2580 foreach f $l {
2581 while {[string range $f 0 $prefixend] ne $prefix} {
2582 if {$lev <= $openlevs} {
2583 $w mark set e:$treeindex($prefix) "end -1c"
2584 $w mark gravity e:$treeindex($prefix) left
2586 set treeheight($prefix) $ht
2587 incr ht [lindex $htstack end]
2588 set htstack [lreplace $htstack end end]
2589 set prefixend [lindex $prefendstack end]
2590 set prefendstack [lreplace $prefendstack end end]
2591 set prefix [string range $prefix 0 $prefixend]
2592 incr lev -1
2594 set tail [string range $f [expr {$prefixend+1}] end]
2595 while {[set slash [string first "/" $tail]] >= 0} {
2596 lappend htstack $ht
2597 set ht 0
2598 lappend prefendstack $prefixend
2599 incr prefixend [expr {$slash + 1}]
2600 set d [string range $tail 0 $slash]
2601 lappend treecontents($prefix) $d
2602 set oldprefix $prefix
2603 append prefix $d
2604 set treecontents($prefix) {}
2605 set treeindex($prefix) [incr ix]
2606 set treeparent($prefix) $oldprefix
2607 set tail [string range $tail [expr {$slash+1}] end]
2608 if {$lev <= $openlevs} {
2609 set ht 1
2610 set treediropen($prefix) [expr {$lev < $openlevs}]
2611 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2612 $w mark set d:$ix "end -1c"
2613 $w mark gravity d:$ix left
2614 set str "\n"
2615 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2616 $w insert end $str
2617 $w image create end -align center -image $bm -padx 1 \
2618 -name a:$ix
2619 $w insert end $d [highlight_tag $prefix]
2620 $w mark set s:$ix "end -1c"
2621 $w mark gravity s:$ix left
2623 incr lev
2625 if {$tail ne {}} {
2626 if {$lev <= $openlevs} {
2627 incr ht
2628 set str "\n"
2629 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2630 $w insert end $str
2631 $w insert end $tail [highlight_tag $f]
2633 lappend treecontents($prefix) $tail
2636 while {$htstack ne {}} {
2637 set treeheight($prefix) $ht
2638 incr ht [lindex $htstack end]
2639 set htstack [lreplace $htstack end end]
2640 set prefixend [lindex $prefendstack end]
2641 set prefendstack [lreplace $prefendstack end end]
2642 set prefix [string range $prefix 0 $prefixend]
2644 $w conf -state disabled
2647 proc linetoelt {l} {
2648 global treeheight treecontents
2650 set y 2
2651 set prefix {}
2652 while {1} {
2653 foreach e $treecontents($prefix) {
2654 if {$y == $l} {
2655 return "$prefix$e"
2657 set n 1
2658 if {[string index $e end] eq "/"} {
2659 set n $treeheight($prefix$e)
2660 if {$y + $n > $l} {
2661 append prefix $e
2662 incr y
2663 break
2666 incr y $n
2671 proc highlight_tree {y prefix} {
2672 global treeheight treecontents cflist
2674 foreach e $treecontents($prefix) {
2675 set path $prefix$e
2676 if {[highlight_tag $path] ne {}} {
2677 $cflist tag add bold $y.0 "$y.0 lineend"
2679 incr y
2680 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2681 set y [highlight_tree $y $path]
2684 return $y
2687 proc treeclosedir {w dir} {
2688 global treediropen treeheight treeparent treeindex
2690 set ix $treeindex($dir)
2691 $w conf -state normal
2692 $w delete s:$ix e:$ix
2693 set treediropen($dir) 0
2694 $w image configure a:$ix -image tri-rt
2695 $w conf -state disabled
2696 set n [expr {1 - $treeheight($dir)}]
2697 while {$dir ne {}} {
2698 incr treeheight($dir) $n
2699 set dir $treeparent($dir)
2703 proc treeopendir {w dir} {
2704 global treediropen treeheight treeparent treecontents treeindex
2706 set ix $treeindex($dir)
2707 $w conf -state normal
2708 $w image configure a:$ix -image tri-dn
2709 $w mark set e:$ix s:$ix
2710 $w mark gravity e:$ix right
2711 set lev 0
2712 set str "\n"
2713 set n [llength $treecontents($dir)]
2714 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2715 incr lev
2716 append str "\t"
2717 incr treeheight($x) $n
2719 foreach e $treecontents($dir) {
2720 set de $dir$e
2721 if {[string index $e end] eq "/"} {
2722 set iy $treeindex($de)
2723 $w mark set d:$iy e:$ix
2724 $w mark gravity d:$iy left
2725 $w insert e:$ix $str
2726 set treediropen($de) 0
2727 $w image create e:$ix -align center -image tri-rt -padx 1 \
2728 -name a:$iy
2729 $w insert e:$ix $e [highlight_tag $de]
2730 $w mark set s:$iy e:$ix
2731 $w mark gravity s:$iy left
2732 set treeheight($de) 1
2733 } else {
2734 $w insert e:$ix $str
2735 $w insert e:$ix $e [highlight_tag $de]
2738 $w mark gravity e:$ix right
2739 $w conf -state disabled
2740 set treediropen($dir) 1
2741 set top [lindex [split [$w index @0,0] .] 0]
2742 set ht [$w cget -height]
2743 set l [lindex [split [$w index s:$ix] .] 0]
2744 if {$l < $top} {
2745 $w yview $l.0
2746 } elseif {$l + $n + 1 > $top + $ht} {
2747 set top [expr {$l + $n + 2 - $ht}]
2748 if {$l < $top} {
2749 set top $l
2751 $w yview $top.0
2755 proc treeclick {w x y} {
2756 global treediropen cmitmode ctext cflist cflist_top
2758 if {$cmitmode ne "tree"} return
2759 if {![info exists cflist_top]} return
2760 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2761 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2762 $cflist tag add highlight $l.0 "$l.0 lineend"
2763 set cflist_top $l
2764 if {$l == 1} {
2765 $ctext yview 1.0
2766 return
2768 set e [linetoelt $l]
2769 if {[string index $e end] ne "/"} {
2770 showfile $e
2771 } elseif {$treediropen($e)} {
2772 treeclosedir $w $e
2773 } else {
2774 treeopendir $w $e
2778 proc setfilelist {id} {
2779 global treefilelist cflist
2781 treeview $cflist $treefilelist($id) 0
2784 image create bitmap tri-rt -background black -foreground blue -data {
2785 #define tri-rt_width 13
2786 #define tri-rt_height 13
2787 static unsigned char tri-rt_bits[] = {
2788 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2789 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2790 0x00, 0x00};
2791 } -maskdata {
2792 #define tri-rt-mask_width 13
2793 #define tri-rt-mask_height 13
2794 static unsigned char tri-rt-mask_bits[] = {
2795 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2796 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2797 0x08, 0x00};
2799 image create bitmap tri-dn -background black -foreground blue -data {
2800 #define tri-dn_width 13
2801 #define tri-dn_height 13
2802 static unsigned char tri-dn_bits[] = {
2803 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2804 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2805 0x00, 0x00};
2806 } -maskdata {
2807 #define tri-dn-mask_width 13
2808 #define tri-dn-mask_height 13
2809 static unsigned char tri-dn-mask_bits[] = {
2810 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2811 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2812 0x00, 0x00};
2815 image create bitmap reficon-T -background black -foreground yellow -data {
2816 #define tagicon_width 13
2817 #define tagicon_height 9
2818 static unsigned char tagicon_bits[] = {
2819 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2820 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2821 } -maskdata {
2822 #define tagicon-mask_width 13
2823 #define tagicon-mask_height 9
2824 static unsigned char tagicon-mask_bits[] = {
2825 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2826 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2828 set rectdata {
2829 #define headicon_width 13
2830 #define headicon_height 9
2831 static unsigned char headicon_bits[] = {
2832 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2833 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2835 set rectmask {
2836 #define headicon-mask_width 13
2837 #define headicon-mask_height 9
2838 static unsigned char headicon-mask_bits[] = {
2839 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2840 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2842 image create bitmap reficon-H -background black -foreground green \
2843 -data $rectdata -maskdata $rectmask
2844 image create bitmap reficon-o -background black -foreground "#ddddff" \
2845 -data $rectdata -maskdata $rectmask
2847 proc init_flist {first} {
2848 global cflist cflist_top difffilestart
2850 $cflist conf -state normal
2851 $cflist delete 0.0 end
2852 if {$first ne {}} {
2853 $cflist insert end $first
2854 set cflist_top 1
2855 $cflist tag add highlight 1.0 "1.0 lineend"
2856 } else {
2857 catch {unset cflist_top}
2859 $cflist conf -state disabled
2860 set difffilestart {}
2863 proc highlight_tag {f} {
2864 global highlight_paths
2866 foreach p $highlight_paths {
2867 if {[string match $p $f]} {
2868 return "bold"
2871 return {}
2874 proc highlight_filelist {} {
2875 global cmitmode cflist
2877 $cflist conf -state normal
2878 if {$cmitmode ne "tree"} {
2879 set end [lindex [split [$cflist index end] .] 0]
2880 for {set l 2} {$l < $end} {incr l} {
2881 set line [$cflist get $l.0 "$l.0 lineend"]
2882 if {[highlight_tag $line] ne {}} {
2883 $cflist tag add bold $l.0 "$l.0 lineend"
2886 } else {
2887 highlight_tree 2 {}
2889 $cflist conf -state disabled
2892 proc unhighlight_filelist {} {
2893 global cflist
2895 $cflist conf -state normal
2896 $cflist tag remove bold 1.0 end
2897 $cflist conf -state disabled
2900 proc add_flist {fl} {
2901 global cflist
2903 $cflist conf -state normal
2904 foreach f $fl {
2905 $cflist insert end "\n"
2906 $cflist insert end $f [highlight_tag $f]
2908 $cflist conf -state disabled
2911 proc sel_flist {w x y} {
2912 global ctext difffilestart cflist cflist_top cmitmode
2914 if {$cmitmode eq "tree"} return
2915 if {![info exists cflist_top]} return
2916 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2917 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2918 $cflist tag add highlight $l.0 "$l.0 lineend"
2919 set cflist_top $l
2920 if {$l == 1} {
2921 $ctext yview 1.0
2922 } else {
2923 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2927 proc pop_flist_menu {w X Y x y} {
2928 global ctext cflist cmitmode flist_menu flist_menu_file
2929 global treediffs diffids
2931 stopfinding
2932 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2933 if {$l <= 1} return
2934 if {$cmitmode eq "tree"} {
2935 set e [linetoelt $l]
2936 if {[string index $e end] eq "/"} return
2937 } else {
2938 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2940 set flist_menu_file $e
2941 set xdiffstate "normal"
2942 if {$cmitmode eq "tree"} {
2943 set xdiffstate "disabled"
2945 # Disable "External diff" item in tree mode
2946 $flist_menu entryconf 2 -state $xdiffstate
2947 tk_popup $flist_menu $X $Y
2950 proc flist_hl {only} {
2951 global flist_menu_file findstring gdttype
2953 set x [shellquote $flist_menu_file]
2954 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2955 set findstring $x
2956 } else {
2957 append findstring " " $x
2959 set gdttype [mc "touching paths:"]
2962 proc save_file_from_commit {filename output what} {
2963 global nullfile
2965 if {[catch {exec git show $filename -- > $output} err]} {
2966 if {[string match "fatal: bad revision *" $err]} {
2967 return $nullfile
2969 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
2970 return {}
2972 return $output
2975 proc external_diff_get_one_file {diffid filename diffdir} {
2976 global nullid nullid2 nullfile
2977 global gitdir
2979 if {$diffid == $nullid} {
2980 set difffile [file join [file dirname $gitdir] $filename]
2981 if {[file exists $difffile]} {
2982 return $difffile
2984 return $nullfile
2986 if {$diffid == $nullid2} {
2987 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2988 return [save_file_from_commit :$filename $difffile index]
2990 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2991 return [save_file_from_commit $diffid:$filename $difffile \
2992 "revision $diffid"]
2995 proc external_diff {} {
2996 global gitktmpdir nullid nullid2
2997 global flist_menu_file
2998 global diffids
2999 global diffnum
3000 global gitdir extdifftool
3002 if {[llength $diffids] == 1} {
3003 # no reference commit given
3004 set diffidto [lindex $diffids 0]
3005 if {$diffidto eq $nullid} {
3006 # diffing working copy with index
3007 set diffidfrom $nullid2
3008 } elseif {$diffidto eq $nullid2} {
3009 # diffing index with HEAD
3010 set diffidfrom "HEAD"
3011 } else {
3012 # use first parent commit
3013 global parentlist selectedline
3014 set diffidfrom [lindex $parentlist $selectedline 0]
3016 } else {
3017 set diffidfrom [lindex $diffids 0]
3018 set diffidto [lindex $diffids 1]
3021 # make sure that several diffs wont collide
3022 if {![info exists gitktmpdir]} {
3023 set gitktmpdir [file join [file dirname $gitdir] \
3024 [format ".gitk-tmp.%s" [pid]]]
3025 if {[catch {file mkdir $gitktmpdir} err]} {
3026 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3027 unset gitktmpdir
3028 return
3030 set diffnum 0
3032 incr diffnum
3033 set diffdir [file join $gitktmpdir $diffnum]
3034 if {[catch {file mkdir $diffdir} err]} {
3035 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3036 return
3039 # gather files to diff
3040 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3041 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3043 if {$difffromfile ne {} && $difftofile ne {}} {
3044 set cmd [concat | [shellsplit $extdifftool] \
3045 [list $difffromfile $difftofile]]
3046 if {[catch {set fl [open $cmd r]} err]} {
3047 file delete -force $diffdir
3048 error_popup "$extdifftool: [mc "command failed:"] $err"
3049 } else {
3050 fconfigure $fl -blocking 0
3051 filerun $fl [list delete_at_eof $fl $diffdir]
3056 proc external_blame {parent_idx} {
3057 global flist_menu_file
3058 global nullid nullid2
3059 global parentlist selectedline currentid
3061 if {$parent_idx > 0} {
3062 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3063 } else {
3064 set base_commit $currentid
3067 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3068 error_popup [mc "No such commit"]
3069 return
3072 if {[catch {exec git gui blame $base_commit $flist_menu_file &} err]} {
3073 error_popup "[mc "git gui blame: command failed:"] $err"
3077 # delete $dir when we see eof on $f (presumably because the child has exited)
3078 proc delete_at_eof {f dir} {
3079 while {[gets $f line] >= 0} {}
3080 if {[eof $f]} {
3081 if {[catch {close $f} err]} {
3082 error_popup "[mc "External diff viewer failed:"] $err"
3084 file delete -force $dir
3085 return 0
3087 return 1
3090 # Functions for adding and removing shell-type quoting
3092 proc shellquote {str} {
3093 if {![string match "*\['\"\\ \t]*" $str]} {
3094 return $str
3096 if {![string match "*\['\"\\]*" $str]} {
3097 return "\"$str\""
3099 if {![string match "*'*" $str]} {
3100 return "'$str'"
3102 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3105 proc shellarglist {l} {
3106 set str {}
3107 foreach a $l {
3108 if {$str ne {}} {
3109 append str " "
3111 append str [shellquote $a]
3113 return $str
3116 proc shelldequote {str} {
3117 set ret {}
3118 set used -1
3119 while {1} {
3120 incr used
3121 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3122 append ret [string range $str $used end]
3123 set used [string length $str]
3124 break
3126 set first [lindex $first 0]
3127 set ch [string index $str $first]
3128 if {$first > $used} {
3129 append ret [string range $str $used [expr {$first - 1}]]
3130 set used $first
3132 if {$ch eq " " || $ch eq "\t"} break
3133 incr used
3134 if {$ch eq "'"} {
3135 set first [string first "'" $str $used]
3136 if {$first < 0} {
3137 error "unmatched single-quote"
3139 append ret [string range $str $used [expr {$first - 1}]]
3140 set used $first
3141 continue
3143 if {$ch eq "\\"} {
3144 if {$used >= [string length $str]} {
3145 error "trailing backslash"
3147 append ret [string index $str $used]
3148 continue
3150 # here ch == "\""
3151 while {1} {
3152 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3153 error "unmatched double-quote"
3155 set first [lindex $first 0]
3156 set ch [string index $str $first]
3157 if {$first > $used} {
3158 append ret [string range $str $used [expr {$first - 1}]]
3159 set used $first
3161 if {$ch eq "\""} break
3162 incr used
3163 append ret [string index $str $used]
3164 incr used
3167 return [list $used $ret]
3170 proc shellsplit {str} {
3171 set l {}
3172 while {1} {
3173 set str [string trimleft $str]
3174 if {$str eq {}} break
3175 set dq [shelldequote $str]
3176 set n [lindex $dq 0]
3177 set word [lindex $dq 1]
3178 set str [string range $str $n end]
3179 lappend l $word
3181 return $l
3184 # Code to implement multiple views
3186 proc newview {ishighlight} {
3187 global nextviewnum newviewname newviewperm newishighlight
3188 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3190 set newishighlight $ishighlight
3191 set top .gitkview
3192 if {[winfo exists $top]} {
3193 raise $top
3194 return
3196 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3197 set newviewperm($nextviewnum) 0
3198 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3199 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3200 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3203 proc editview {} {
3204 global curview
3205 global viewname viewperm newviewname newviewperm
3206 global viewargs newviewargs viewargscmd newviewargscmd
3208 set top .gitkvedit-$curview
3209 if {[winfo exists $top]} {
3210 raise $top
3211 return
3213 set newviewname($curview) $viewname($curview)
3214 set newviewperm($curview) $viewperm($curview)
3215 set newviewargs($curview) [shellarglist $viewargs($curview)]
3216 set newviewargscmd($curview) $viewargscmd($curview)
3217 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3220 proc vieweditor {top n title} {
3221 global newviewname newviewperm viewfiles bgcolor
3223 toplevel $top
3224 wm title $top $title
3225 label $top.nl -text [mc "Name"]
3226 entry $top.name -width 20 -textvariable newviewname($n)
3227 grid $top.nl $top.name -sticky w -pady 5
3228 checkbutton $top.perm -text [mc "Remember this view"] \
3229 -variable newviewperm($n)
3230 grid $top.perm - -pady 5 -sticky w
3231 message $top.al -aspect 1000 \
3232 -text [mc "Commits to include (arguments to git log):"]
3233 grid $top.al - -sticky w -pady 5
3234 entry $top.args -width 50 -textvariable newviewargs($n) \
3235 -background $bgcolor
3236 grid $top.args - -sticky ew -padx 5
3238 message $top.ac -aspect 1000 \
3239 -text [mc "Command to generate more commits to include:"]
3240 grid $top.ac - -sticky w -pady 5
3241 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3242 -background white
3243 grid $top.argscmd - -sticky ew -padx 5
3245 message $top.l -aspect 1000 \
3246 -text [mc "Enter files and directories to include, one per line:"]
3247 grid $top.l - -sticky w
3248 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3249 if {[info exists viewfiles($n)]} {
3250 foreach f $viewfiles($n) {
3251 $top.t insert end $f
3252 $top.t insert end "\n"
3254 $top.t delete {end - 1c} end
3255 $top.t mark set insert 0.0
3257 grid $top.t - -sticky ew -padx 5
3258 frame $top.buts
3259 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3260 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3261 grid $top.buts.ok $top.buts.can
3262 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3263 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3264 grid $top.buts - -pady 10 -sticky ew
3265 focus $top.t
3268 proc doviewmenu {m first cmd op argv} {
3269 set nmenu [$m index end]
3270 for {set i $first} {$i <= $nmenu} {incr i} {
3271 if {[$m entrycget $i -command] eq $cmd} {
3272 eval $m $op $i $argv
3273 break
3278 proc allviewmenus {n op args} {
3279 # global viewhlmenu
3281 doviewmenu .bar.view 5 [list showview $n] $op $args
3282 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3285 proc newviewok {top n} {
3286 global nextviewnum newviewperm newviewname newishighlight
3287 global viewname viewfiles viewperm selectedview curview
3288 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3290 if {[catch {
3291 set newargs [shellsplit $newviewargs($n)]
3292 } err]} {
3293 error_popup "[mc "Error in commit selection arguments:"] $err"
3294 wm raise $top
3295 focus $top
3296 return
3298 set files {}
3299 foreach f [split [$top.t get 0.0 end] "\n"] {
3300 set ft [string trim $f]
3301 if {$ft ne {}} {
3302 lappend files $ft
3305 if {![info exists viewfiles($n)]} {
3306 # creating a new view
3307 incr nextviewnum
3308 set viewname($n) $newviewname($n)
3309 set viewperm($n) $newviewperm($n)
3310 set viewfiles($n) $files
3311 set viewargs($n) $newargs
3312 set viewargscmd($n) $newviewargscmd($n)
3313 addviewmenu $n
3314 if {!$newishighlight} {
3315 run showview $n
3316 } else {
3317 run addvhighlight $n
3319 } else {
3320 # editing an existing view
3321 set viewperm($n) $newviewperm($n)
3322 if {$newviewname($n) ne $viewname($n)} {
3323 set viewname($n) $newviewname($n)
3324 doviewmenu .bar.view 5 [list showview $n] \
3325 entryconf [list -label $viewname($n)]
3326 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3327 # entryconf [list -label $viewname($n) -value $viewname($n)]
3329 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3330 $newviewargscmd($n) ne $viewargscmd($n)} {
3331 set viewfiles($n) $files
3332 set viewargs($n) $newargs
3333 set viewargscmd($n) $newviewargscmd($n)
3334 if {$curview == $n} {
3335 run reloadcommits
3339 catch {destroy $top}
3342 proc delview {} {
3343 global curview viewperm hlview selectedhlview
3345 if {$curview == 0} return
3346 if {[info exists hlview] && $hlview == $curview} {
3347 set selectedhlview [mc "None"]
3348 unset hlview
3350 allviewmenus $curview delete
3351 set viewperm($curview) 0
3352 showview 0
3355 proc addviewmenu {n} {
3356 global viewname viewhlmenu
3358 .bar.view add radiobutton -label $viewname($n) \
3359 -command [list showview $n] -variable selectedview -value $n
3360 #$viewhlmenu add radiobutton -label $viewname($n) \
3361 # -command [list addvhighlight $n] -variable selectedhlview
3364 proc showview {n} {
3365 global curview cached_commitrow ordertok
3366 global displayorder parentlist rowidlist rowisopt rowfinal
3367 global colormap rowtextx nextcolor canvxmax
3368 global numcommits viewcomplete
3369 global selectedline currentid canv canvy0
3370 global treediffs
3371 global pending_select mainheadid
3372 global commitidx
3373 global selectedview
3374 global hlview selectedhlview commitinterest
3376 if {$n == $curview} return
3377 set selid {}
3378 set ymax [lindex [$canv cget -scrollregion] 3]
3379 set span [$canv yview]
3380 set ytop [expr {[lindex $span 0] * $ymax}]
3381 set ybot [expr {[lindex $span 1] * $ymax}]
3382 set yscreen [expr {($ybot - $ytop) / 2}]
3383 if {$selectedline ne {}} {
3384 set selid $currentid
3385 set y [yc $selectedline]
3386 if {$ytop < $y && $y < $ybot} {
3387 set yscreen [expr {$y - $ytop}]
3389 } elseif {[info exists pending_select]} {
3390 set selid $pending_select
3391 unset pending_select
3393 unselectline
3394 normalline
3395 catch {unset treediffs}
3396 clear_display
3397 if {[info exists hlview] && $hlview == $n} {
3398 unset hlview
3399 set selectedhlview [mc "None"]
3401 catch {unset commitinterest}
3402 catch {unset cached_commitrow}
3403 catch {unset ordertok}
3405 set curview $n
3406 set selectedview $n
3407 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3408 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3410 run refill_reflist
3411 if {![info exists viewcomplete($n)]} {
3412 getcommits $selid
3413 return
3416 set displayorder {}
3417 set parentlist {}
3418 set rowidlist {}
3419 set rowisopt {}
3420 set rowfinal {}
3421 set numcommits $commitidx($n)
3423 catch {unset colormap}
3424 catch {unset rowtextx}
3425 set nextcolor 0
3426 set canvxmax [$canv cget -width]
3427 set curview $n
3428 set row 0
3429 setcanvscroll
3430 set yf 0
3431 set row {}
3432 if {$selid ne {} && [commitinview $selid $n]} {
3433 set row [rowofcommit $selid]
3434 # try to get the selected row in the same position on the screen
3435 set ymax [lindex [$canv cget -scrollregion] 3]
3436 set ytop [expr {[yc $row] - $yscreen}]
3437 if {$ytop < 0} {
3438 set ytop 0
3440 set yf [expr {$ytop * 1.0 / $ymax}]
3442 allcanvs yview moveto $yf
3443 drawvisible
3444 if {$row ne {}} {
3445 selectline $row 0
3446 } elseif {!$viewcomplete($n)} {
3447 reset_pending_select $selid
3448 } else {
3449 reset_pending_select {}
3451 if {[commitinview $pending_select $curview]} {
3452 selectline [rowofcommit $pending_select] 1
3453 } else {
3454 set row [first_real_row]
3455 if {$row < $numcommits} {
3456 selectline $row 0
3460 if {!$viewcomplete($n)} {
3461 if {$numcommits == 0} {
3462 show_status [mc "Reading commits..."]
3464 } elseif {$numcommits == 0} {
3465 show_status [mc "No commits selected"]
3469 # Stuff relating to the highlighting facility
3471 proc ishighlighted {id} {
3472 global vhighlights fhighlights nhighlights rhighlights
3474 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3475 return $nhighlights($id)
3477 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3478 return $vhighlights($id)
3480 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3481 return $fhighlights($id)
3483 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3484 return $rhighlights($id)
3486 return 0
3489 proc bolden {row font} {
3490 global canv linehtag selectedline boldrows
3492 lappend boldrows $row
3493 $canv itemconf $linehtag($row) -font $font
3494 if {$row == $selectedline} {
3495 $canv delete secsel
3496 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3497 -outline {{}} -tags secsel \
3498 -fill [$canv cget -selectbackground]]
3499 $canv lower $t
3503 proc bolden_name {row font} {
3504 global canv2 linentag selectedline boldnamerows
3506 lappend boldnamerows $row
3507 $canv2 itemconf $linentag($row) -font $font
3508 if {$row == $selectedline} {
3509 $canv2 delete secsel
3510 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3511 -outline {{}} -tags secsel \
3512 -fill [$canv2 cget -selectbackground]]
3513 $canv2 lower $t
3517 proc unbolden {} {
3518 global boldrows
3520 set stillbold {}
3521 foreach row $boldrows {
3522 if {![ishighlighted [commitonrow $row]]} {
3523 bolden $row mainfont
3524 } else {
3525 lappend stillbold $row
3528 set boldrows $stillbold
3531 proc addvhighlight {n} {
3532 global hlview viewcomplete curview vhl_done commitidx
3534 if {[info exists hlview]} {
3535 delvhighlight
3537 set hlview $n
3538 if {$n != $curview && ![info exists viewcomplete($n)]} {
3539 start_rev_list $n
3541 set vhl_done $commitidx($hlview)
3542 if {$vhl_done > 0} {
3543 drawvisible
3547 proc delvhighlight {} {
3548 global hlview vhighlights
3550 if {![info exists hlview]} return
3551 unset hlview
3552 catch {unset vhighlights}
3553 unbolden
3556 proc vhighlightmore {} {
3557 global hlview vhl_done commitidx vhighlights curview
3559 set max $commitidx($hlview)
3560 set vr [visiblerows]
3561 set r0 [lindex $vr 0]
3562 set r1 [lindex $vr 1]
3563 for {set i $vhl_done} {$i < $max} {incr i} {
3564 set id [commitonrow $i $hlview]
3565 if {[commitinview $id $curview]} {
3566 set row [rowofcommit $id]
3567 if {$r0 <= $row && $row <= $r1} {
3568 if {![highlighted $row]} {
3569 bolden $row mainfontbold
3571 set vhighlights($id) 1
3575 set vhl_done $max
3576 return 0
3579 proc askvhighlight {row id} {
3580 global hlview vhighlights iddrawn
3582 if {[commitinview $id $hlview]} {
3583 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3584 bolden $row mainfontbold
3586 set vhighlights($id) 1
3587 } else {
3588 set vhighlights($id) 0
3592 proc hfiles_change {} {
3593 global highlight_files filehighlight fhighlights fh_serial
3594 global highlight_paths gdttype
3596 if {[info exists filehighlight]} {
3597 # delete previous highlights
3598 catch {close $filehighlight}
3599 unset filehighlight
3600 catch {unset fhighlights}
3601 unbolden
3602 unhighlight_filelist
3604 set highlight_paths {}
3605 after cancel do_file_hl $fh_serial
3606 incr fh_serial
3607 if {$highlight_files ne {}} {
3608 after 300 do_file_hl $fh_serial
3612 proc gdttype_change {name ix op} {
3613 global gdttype highlight_files findstring findpattern
3615 stopfinding
3616 if {$findstring ne {}} {
3617 if {$gdttype eq [mc "containing:"]} {
3618 if {$highlight_files ne {}} {
3619 set highlight_files {}
3620 hfiles_change
3622 findcom_change
3623 } else {
3624 if {$findpattern ne {}} {
3625 set findpattern {}
3626 findcom_change
3628 set highlight_files $findstring
3629 hfiles_change
3631 drawvisible
3633 # enable/disable findtype/findloc menus too
3636 proc find_change {name ix op} {
3637 global gdttype findstring highlight_files
3639 stopfinding
3640 if {$gdttype eq [mc "containing:"]} {
3641 findcom_change
3642 } else {
3643 if {$highlight_files ne $findstring} {
3644 set highlight_files $findstring
3645 hfiles_change
3648 drawvisible
3651 proc findcom_change args {
3652 global nhighlights boldnamerows
3653 global findpattern findtype findstring gdttype
3655 stopfinding
3656 # delete previous highlights, if any
3657 foreach row $boldnamerows {
3658 bolden_name $row mainfont
3660 set boldnamerows {}
3661 catch {unset nhighlights}
3662 unbolden
3663 unmarkmatches
3664 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3665 set findpattern {}
3666 } elseif {$findtype eq [mc "Regexp"]} {
3667 set findpattern $findstring
3668 } else {
3669 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3670 $findstring]
3671 set findpattern "*$e*"
3675 proc makepatterns {l} {
3676 set ret {}
3677 foreach e $l {
3678 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3679 if {[string index $ee end] eq "/"} {
3680 lappend ret "$ee*"
3681 } else {
3682 lappend ret $ee
3683 lappend ret "$ee/*"
3686 return $ret
3689 proc do_file_hl {serial} {
3690 global highlight_files filehighlight highlight_paths gdttype fhl_list
3692 if {$gdttype eq [mc "touching paths:"]} {
3693 if {[catch {set paths [shellsplit $highlight_files]}]} return
3694 set highlight_paths [makepatterns $paths]
3695 highlight_filelist
3696 set gdtargs [concat -- $paths]
3697 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3698 set gdtargs [list "-S$highlight_files"]
3699 } else {
3700 # must be "containing:", i.e. we're searching commit info
3701 return
3703 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3704 set filehighlight [open $cmd r+]
3705 fconfigure $filehighlight -blocking 0
3706 filerun $filehighlight readfhighlight
3707 set fhl_list {}
3708 drawvisible
3709 flushhighlights
3712 proc flushhighlights {} {
3713 global filehighlight fhl_list
3715 if {[info exists filehighlight]} {
3716 lappend fhl_list {}
3717 puts $filehighlight ""
3718 flush $filehighlight
3722 proc askfilehighlight {row id} {
3723 global filehighlight fhighlights fhl_list
3725 lappend fhl_list $id
3726 set fhighlights($id) -1
3727 puts $filehighlight $id
3730 proc readfhighlight {} {
3731 global filehighlight fhighlights curview iddrawn
3732 global fhl_list find_dirn
3734 if {![info exists filehighlight]} {
3735 return 0
3737 set nr 0
3738 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3739 set line [string trim $line]
3740 set i [lsearch -exact $fhl_list $line]
3741 if {$i < 0} continue
3742 for {set j 0} {$j < $i} {incr j} {
3743 set id [lindex $fhl_list $j]
3744 set fhighlights($id) 0
3746 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3747 if {$line eq {}} continue
3748 if {![commitinview $line $curview]} continue
3749 set row [rowofcommit $line]
3750 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3751 bolden $row mainfontbold
3753 set fhighlights($line) 1
3755 if {[eof $filehighlight]} {
3756 # strange...
3757 puts "oops, git diff-tree died"
3758 catch {close $filehighlight}
3759 unset filehighlight
3760 return 0
3762 if {[info exists find_dirn]} {
3763 run findmore
3765 return 1
3768 proc doesmatch {f} {
3769 global findtype findpattern
3771 if {$findtype eq [mc "Regexp"]} {
3772 return [regexp $findpattern $f]
3773 } elseif {$findtype eq [mc "IgnCase"]} {
3774 return [string match -nocase $findpattern $f]
3775 } else {
3776 return [string match $findpattern $f]
3780 proc askfindhighlight {row id} {
3781 global nhighlights commitinfo iddrawn
3782 global findloc
3783 global markingmatches
3785 if {![info exists commitinfo($id)]} {
3786 getcommit $id
3788 set info $commitinfo($id)
3789 set isbold 0
3790 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3791 foreach f $info ty $fldtypes {
3792 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3793 [doesmatch $f]} {
3794 if {$ty eq [mc "Author"]} {
3795 set isbold 2
3796 break
3798 set isbold 1
3801 if {$isbold && [info exists iddrawn($id)]} {
3802 if {![ishighlighted $id]} {
3803 bolden $row mainfontbold
3804 if {$isbold > 1} {
3805 bolden_name $row mainfontbold
3808 if {$markingmatches} {
3809 markrowmatches $row $id
3812 set nhighlights($id) $isbold
3815 proc markrowmatches {row id} {
3816 global canv canv2 linehtag linentag commitinfo findloc
3818 set headline [lindex $commitinfo($id) 0]
3819 set author [lindex $commitinfo($id) 1]
3820 $canv delete match$row
3821 $canv2 delete match$row
3822 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3823 set m [findmatches $headline]
3824 if {$m ne {}} {
3825 markmatches $canv $row $headline $linehtag($row) $m \
3826 [$canv itemcget $linehtag($row) -font] $row
3829 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3830 set m [findmatches $author]
3831 if {$m ne {}} {
3832 markmatches $canv2 $row $author $linentag($row) $m \
3833 [$canv2 itemcget $linentag($row) -font] $row
3838 proc vrel_change {name ix op} {
3839 global highlight_related
3841 rhighlight_none
3842 if {$highlight_related ne [mc "None"]} {
3843 run drawvisible
3847 # prepare for testing whether commits are descendents or ancestors of a
3848 proc rhighlight_sel {a} {
3849 global descendent desc_todo ancestor anc_todo
3850 global highlight_related
3852 catch {unset descendent}
3853 set desc_todo [list $a]
3854 catch {unset ancestor}
3855 set anc_todo [list $a]
3856 if {$highlight_related ne [mc "None"]} {
3857 rhighlight_none
3858 run drawvisible
3862 proc rhighlight_none {} {
3863 global rhighlights
3865 catch {unset rhighlights}
3866 unbolden
3869 proc is_descendent {a} {
3870 global curview children descendent desc_todo
3872 set v $curview
3873 set la [rowofcommit $a]
3874 set todo $desc_todo
3875 set leftover {}
3876 set done 0
3877 for {set i 0} {$i < [llength $todo]} {incr i} {
3878 set do [lindex $todo $i]
3879 if {[rowofcommit $do] < $la} {
3880 lappend leftover $do
3881 continue
3883 foreach nk $children($v,$do) {
3884 if {![info exists descendent($nk)]} {
3885 set descendent($nk) 1
3886 lappend todo $nk
3887 if {$nk eq $a} {
3888 set done 1
3892 if {$done} {
3893 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3894 return
3897 set descendent($a) 0
3898 set desc_todo $leftover
3901 proc is_ancestor {a} {
3902 global curview parents ancestor anc_todo
3904 set v $curview
3905 set la [rowofcommit $a]
3906 set todo $anc_todo
3907 set leftover {}
3908 set done 0
3909 for {set i 0} {$i < [llength $todo]} {incr i} {
3910 set do [lindex $todo $i]
3911 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3912 lappend leftover $do
3913 continue
3915 foreach np $parents($v,$do) {
3916 if {![info exists ancestor($np)]} {
3917 set ancestor($np) 1
3918 lappend todo $np
3919 if {$np eq $a} {
3920 set done 1
3924 if {$done} {
3925 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3926 return
3929 set ancestor($a) 0
3930 set anc_todo $leftover
3933 proc askrelhighlight {row id} {
3934 global descendent highlight_related iddrawn rhighlights
3935 global selectedline ancestor
3937 if {$selectedline eq {}} return
3938 set isbold 0
3939 if {$highlight_related eq [mc "Descendant"] ||
3940 $highlight_related eq [mc "Not descendant"]} {
3941 if {![info exists descendent($id)]} {
3942 is_descendent $id
3944 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3945 set isbold 1
3947 } elseif {$highlight_related eq [mc "Ancestor"] ||
3948 $highlight_related eq [mc "Not ancestor"]} {
3949 if {![info exists ancestor($id)]} {
3950 is_ancestor $id
3952 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3953 set isbold 1
3956 if {[info exists iddrawn($id)]} {
3957 if {$isbold && ![ishighlighted $id]} {
3958 bolden $row mainfontbold
3961 set rhighlights($id) $isbold
3964 # Graph layout functions
3966 proc shortids {ids} {
3967 set res {}
3968 foreach id $ids {
3969 if {[llength $id] > 1} {
3970 lappend res [shortids $id]
3971 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3972 lappend res [string range $id 0 7]
3973 } else {
3974 lappend res $id
3977 return $res
3980 proc ntimes {n o} {
3981 set ret {}
3982 set o [list $o]
3983 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3984 if {($n & $mask) != 0} {
3985 set ret [concat $ret $o]
3987 set o [concat $o $o]
3989 return $ret
3992 proc ordertoken {id} {
3993 global ordertok curview varcid varcstart varctok curview parents children
3994 global nullid nullid2
3996 if {[info exists ordertok($id)]} {
3997 return $ordertok($id)
3999 set origid $id
4000 set todo {}
4001 while {1} {
4002 if {[info exists varcid($curview,$id)]} {
4003 set a $varcid($curview,$id)
4004 set p [lindex $varcstart($curview) $a]
4005 } else {
4006 set p [lindex $children($curview,$id) 0]
4008 if {[info exists ordertok($p)]} {
4009 set tok $ordertok($p)
4010 break
4012 set id [first_real_child $curview,$p]
4013 if {$id eq {}} {
4014 # it's a root
4015 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4016 break
4018 if {[llength $parents($curview,$id)] == 1} {
4019 lappend todo [list $p {}]
4020 } else {
4021 set j [lsearch -exact $parents($curview,$id) $p]
4022 if {$j < 0} {
4023 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4025 lappend todo [list $p [strrep $j]]
4028 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4029 set p [lindex $todo $i 0]
4030 append tok [lindex $todo $i 1]
4031 set ordertok($p) $tok
4033 set ordertok($origid) $tok
4034 return $tok
4037 # Work out where id should go in idlist so that order-token
4038 # values increase from left to right
4039 proc idcol {idlist id {i 0}} {
4040 set t [ordertoken $id]
4041 if {$i < 0} {
4042 set i 0
4044 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4045 if {$i > [llength $idlist]} {
4046 set i [llength $idlist]
4048 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4049 incr i
4050 } else {
4051 if {$t > [ordertoken [lindex $idlist $i]]} {
4052 while {[incr i] < [llength $idlist] &&
4053 $t >= [ordertoken [lindex $idlist $i]]} {}
4056 return $i
4059 proc initlayout {} {
4060 global rowidlist rowisopt rowfinal displayorder parentlist
4061 global numcommits canvxmax canv
4062 global nextcolor
4063 global colormap rowtextx
4065 set numcommits 0
4066 set displayorder {}
4067 set parentlist {}
4068 set nextcolor 0
4069 set rowidlist {}
4070 set rowisopt {}
4071 set rowfinal {}
4072 set canvxmax [$canv cget -width]
4073 catch {unset colormap}
4074 catch {unset rowtextx}
4075 setcanvscroll
4078 proc setcanvscroll {} {
4079 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4080 global lastscrollset lastscrollrows
4082 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4083 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4084 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4085 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4086 set lastscrollset [clock clicks -milliseconds]
4087 set lastscrollrows $numcommits
4090 proc visiblerows {} {
4091 global canv numcommits linespc
4093 set ymax [lindex [$canv cget -scrollregion] 3]
4094 if {$ymax eq {} || $ymax == 0} return
4095 set f [$canv yview]
4096 set y0 [expr {int([lindex $f 0] * $ymax)}]
4097 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4098 if {$r0 < 0} {
4099 set r0 0
4101 set y1 [expr {int([lindex $f 1] * $ymax)}]
4102 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4103 if {$r1 >= $numcommits} {
4104 set r1 [expr {$numcommits - 1}]
4106 return [list $r0 $r1]
4109 proc layoutmore {} {
4110 global commitidx viewcomplete curview
4111 global numcommits pending_select curview
4112 global lastscrollset lastscrollrows commitinterest
4114 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4115 [clock clicks -milliseconds] - $lastscrollset > 500} {
4116 setcanvscroll
4118 if {[info exists pending_select] &&
4119 [commitinview $pending_select $curview]} {
4120 update
4121 selectline [rowofcommit $pending_select] 1
4123 drawvisible
4126 proc doshowlocalchanges {} {
4127 global curview mainheadid
4129 if {$mainheadid eq {}} return
4130 if {[commitinview $mainheadid $curview]} {
4131 dodiffindex
4132 } else {
4133 lappend commitinterest($mainheadid) {dodiffindex}
4137 proc dohidelocalchanges {} {
4138 global nullid nullid2 lserial curview
4140 if {[commitinview $nullid $curview]} {
4141 removefakerow $nullid
4143 if {[commitinview $nullid2 $curview]} {
4144 removefakerow $nullid2
4146 incr lserial
4149 # spawn off a process to do git diff-index --cached HEAD
4150 proc dodiffindex {} {
4151 global lserial showlocalchanges
4152 global isworktree
4154 if {!$showlocalchanges || !$isworktree} return
4155 incr lserial
4156 set fd [open "|git diff-index --cached HEAD" r]
4157 fconfigure $fd -blocking 0
4158 set i [reg_instance $fd]
4159 filerun $fd [list readdiffindex $fd $lserial $i]
4162 proc readdiffindex {fd serial inst} {
4163 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4165 set isdiff 1
4166 if {[gets $fd line] < 0} {
4167 if {![eof $fd]} {
4168 return 1
4170 set isdiff 0
4172 # we only need to see one line and we don't really care what it says...
4173 stop_instance $inst
4175 if {$serial != $lserial} {
4176 return 0
4179 # now see if there are any local changes not checked in to the index
4180 set fd [open "|git diff-files" r]
4181 fconfigure $fd -blocking 0
4182 set i [reg_instance $fd]
4183 filerun $fd [list readdifffiles $fd $serial $i]
4185 if {$isdiff && ![commitinview $nullid2 $curview]} {
4186 # add the line for the changes in the index to the graph
4187 set hl [mc "Local changes checked in to index but not committed"]
4188 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4189 set commitdata($nullid2) "\n $hl\n"
4190 if {[commitinview $nullid $curview]} {
4191 removefakerow $nullid
4193 insertfakerow $nullid2 $mainheadid
4194 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4195 removefakerow $nullid2
4197 return 0
4200 proc readdifffiles {fd serial inst} {
4201 global mainheadid nullid nullid2 curview
4202 global commitinfo commitdata lserial
4204 set isdiff 1
4205 if {[gets $fd line] < 0} {
4206 if {![eof $fd]} {
4207 return 1
4209 set isdiff 0
4211 # we only need to see one line and we don't really care what it says...
4212 stop_instance $inst
4214 if {$serial != $lserial} {
4215 return 0
4218 if {$isdiff && ![commitinview $nullid $curview]} {
4219 # add the line for the local diff to the graph
4220 set hl [mc "Local uncommitted changes, not checked in to index"]
4221 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4222 set commitdata($nullid) "\n $hl\n"
4223 if {[commitinview $nullid2 $curview]} {
4224 set p $nullid2
4225 } else {
4226 set p $mainheadid
4228 insertfakerow $nullid $p
4229 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4230 removefakerow $nullid
4232 return 0
4235 proc nextuse {id row} {
4236 global curview children
4238 if {[info exists children($curview,$id)]} {
4239 foreach kid $children($curview,$id) {
4240 if {![commitinview $kid $curview]} {
4241 return -1
4243 if {[rowofcommit $kid] > $row} {
4244 return [rowofcommit $kid]
4248 if {[commitinview $id $curview]} {
4249 return [rowofcommit $id]
4251 return -1
4254 proc prevuse {id row} {
4255 global curview children
4257 set ret -1
4258 if {[info exists children($curview,$id)]} {
4259 foreach kid $children($curview,$id) {
4260 if {![commitinview $kid $curview]} break
4261 if {[rowofcommit $kid] < $row} {
4262 set ret [rowofcommit $kid]
4266 return $ret
4269 proc make_idlist {row} {
4270 global displayorder parentlist uparrowlen downarrowlen mingaplen
4271 global commitidx curview children
4273 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4274 if {$r < 0} {
4275 set r 0
4277 set ra [expr {$row - $downarrowlen}]
4278 if {$ra < 0} {
4279 set ra 0
4281 set rb [expr {$row + $uparrowlen}]
4282 if {$rb > $commitidx($curview)} {
4283 set rb $commitidx($curview)
4285 make_disporder $r [expr {$rb + 1}]
4286 set ids {}
4287 for {} {$r < $ra} {incr r} {
4288 set nextid [lindex $displayorder [expr {$r + 1}]]
4289 foreach p [lindex $parentlist $r] {
4290 if {$p eq $nextid} continue
4291 set rn [nextuse $p $r]
4292 if {$rn >= $row &&
4293 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4294 lappend ids [list [ordertoken $p] $p]
4298 for {} {$r < $row} {incr r} {
4299 set nextid [lindex $displayorder [expr {$r + 1}]]
4300 foreach p [lindex $parentlist $r] {
4301 if {$p eq $nextid} continue
4302 set rn [nextuse $p $r]
4303 if {$rn < 0 || $rn >= $row} {
4304 lappend ids [list [ordertoken $p] $p]
4308 set id [lindex $displayorder $row]
4309 lappend ids [list [ordertoken $id] $id]
4310 while {$r < $rb} {
4311 foreach p [lindex $parentlist $r] {
4312 set firstkid [lindex $children($curview,$p) 0]
4313 if {[rowofcommit $firstkid] < $row} {
4314 lappend ids [list [ordertoken $p] $p]
4317 incr r
4318 set id [lindex $displayorder $r]
4319 if {$id ne {}} {
4320 set firstkid [lindex $children($curview,$id) 0]
4321 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4322 lappend ids [list [ordertoken $id] $id]
4326 set idlist {}
4327 foreach idx [lsort -unique $ids] {
4328 lappend idlist [lindex $idx 1]
4330 return $idlist
4333 proc rowsequal {a b} {
4334 while {[set i [lsearch -exact $a {}]] >= 0} {
4335 set a [lreplace $a $i $i]
4337 while {[set i [lsearch -exact $b {}]] >= 0} {
4338 set b [lreplace $b $i $i]
4340 return [expr {$a eq $b}]
4343 proc makeupline {id row rend col} {
4344 global rowidlist uparrowlen downarrowlen mingaplen
4346 for {set r $rend} {1} {set r $rstart} {
4347 set rstart [prevuse $id $r]
4348 if {$rstart < 0} return
4349 if {$rstart < $row} break
4351 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4352 set rstart [expr {$rend - $uparrowlen - 1}]
4354 for {set r $rstart} {[incr r] <= $row} {} {
4355 set idlist [lindex $rowidlist $r]
4356 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4357 set col [idcol $idlist $id $col]
4358 lset rowidlist $r [linsert $idlist $col $id]
4359 changedrow $r
4364 proc layoutrows {row endrow} {
4365 global rowidlist rowisopt rowfinal displayorder
4366 global uparrowlen downarrowlen maxwidth mingaplen
4367 global children parentlist
4368 global commitidx viewcomplete curview
4370 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4371 set idlist {}
4372 if {$row > 0} {
4373 set rm1 [expr {$row - 1}]
4374 foreach id [lindex $rowidlist $rm1] {
4375 if {$id ne {}} {
4376 lappend idlist $id
4379 set final [lindex $rowfinal $rm1]
4381 for {} {$row < $endrow} {incr row} {
4382 set rm1 [expr {$row - 1}]
4383 if {$rm1 < 0 || $idlist eq {}} {
4384 set idlist [make_idlist $row]
4385 set final 1
4386 } else {
4387 set id [lindex $displayorder $rm1]
4388 set col [lsearch -exact $idlist $id]
4389 set idlist [lreplace $idlist $col $col]
4390 foreach p [lindex $parentlist $rm1] {
4391 if {[lsearch -exact $idlist $p] < 0} {
4392 set col [idcol $idlist $p $col]
4393 set idlist [linsert $idlist $col $p]
4394 # if not the first child, we have to insert a line going up
4395 if {$id ne [lindex $children($curview,$p) 0]} {
4396 makeupline $p $rm1 $row $col
4400 set id [lindex $displayorder $row]
4401 if {$row > $downarrowlen} {
4402 set termrow [expr {$row - $downarrowlen - 1}]
4403 foreach p [lindex $parentlist $termrow] {
4404 set i [lsearch -exact $idlist $p]
4405 if {$i < 0} continue
4406 set nr [nextuse $p $termrow]
4407 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4408 set idlist [lreplace $idlist $i $i]
4412 set col [lsearch -exact $idlist $id]
4413 if {$col < 0} {
4414 set col [idcol $idlist $id]
4415 set idlist [linsert $idlist $col $id]
4416 if {$children($curview,$id) ne {}} {
4417 makeupline $id $rm1 $row $col
4420 set r [expr {$row + $uparrowlen - 1}]
4421 if {$r < $commitidx($curview)} {
4422 set x $col
4423 foreach p [lindex $parentlist $r] {
4424 if {[lsearch -exact $idlist $p] >= 0} continue
4425 set fk [lindex $children($curview,$p) 0]
4426 if {[rowofcommit $fk] < $row} {
4427 set x [idcol $idlist $p $x]
4428 set idlist [linsert $idlist $x $p]
4431 if {[incr r] < $commitidx($curview)} {
4432 set p [lindex $displayorder $r]
4433 if {[lsearch -exact $idlist $p] < 0} {
4434 set fk [lindex $children($curview,$p) 0]
4435 if {$fk ne {} && [rowofcommit $fk] < $row} {
4436 set x [idcol $idlist $p $x]
4437 set idlist [linsert $idlist $x $p]
4443 if {$final && !$viewcomplete($curview) &&
4444 $row + $uparrowlen + $mingaplen + $downarrowlen
4445 >= $commitidx($curview)} {
4446 set final 0
4448 set l [llength $rowidlist]
4449 if {$row == $l} {
4450 lappend rowidlist $idlist
4451 lappend rowisopt 0
4452 lappend rowfinal $final
4453 } elseif {$row < $l} {
4454 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4455 lset rowidlist $row $idlist
4456 changedrow $row
4458 lset rowfinal $row $final
4459 } else {
4460 set pad [ntimes [expr {$row - $l}] {}]
4461 set rowidlist [concat $rowidlist $pad]
4462 lappend rowidlist $idlist
4463 set rowfinal [concat $rowfinal $pad]
4464 lappend rowfinal $final
4465 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4468 return $row
4471 proc changedrow {row} {
4472 global displayorder iddrawn rowisopt need_redisplay
4474 set l [llength $rowisopt]
4475 if {$row < $l} {
4476 lset rowisopt $row 0
4477 if {$row + 1 < $l} {
4478 lset rowisopt [expr {$row + 1}] 0
4479 if {$row + 2 < $l} {
4480 lset rowisopt [expr {$row + 2}] 0
4484 set id [lindex $displayorder $row]
4485 if {[info exists iddrawn($id)]} {
4486 set need_redisplay 1
4490 proc insert_pad {row col npad} {
4491 global rowidlist
4493 set pad [ntimes $npad {}]
4494 set idlist [lindex $rowidlist $row]
4495 set bef [lrange $idlist 0 [expr {$col - 1}]]
4496 set aft [lrange $idlist $col end]
4497 set i [lsearch -exact $aft {}]
4498 if {$i > 0} {
4499 set aft [lreplace $aft $i $i]
4501 lset rowidlist $row [concat $bef $pad $aft]
4502 changedrow $row
4505 proc optimize_rows {row col endrow} {
4506 global rowidlist rowisopt displayorder curview children
4508 if {$row < 1} {
4509 set row 1
4511 for {} {$row < $endrow} {incr row; set col 0} {
4512 if {[lindex $rowisopt $row]} continue
4513 set haspad 0
4514 set y0 [expr {$row - 1}]
4515 set ym [expr {$row - 2}]
4516 set idlist [lindex $rowidlist $row]
4517 set previdlist [lindex $rowidlist $y0]
4518 if {$idlist eq {} || $previdlist eq {}} continue
4519 if {$ym >= 0} {
4520 set pprevidlist [lindex $rowidlist $ym]
4521 if {$pprevidlist eq {}} continue
4522 } else {
4523 set pprevidlist {}
4525 set x0 -1
4526 set xm -1
4527 for {} {$col < [llength $idlist]} {incr col} {
4528 set id [lindex $idlist $col]
4529 if {[lindex $previdlist $col] eq $id} continue
4530 if {$id eq {}} {
4531 set haspad 1
4532 continue
4534 set x0 [lsearch -exact $previdlist $id]
4535 if {$x0 < 0} continue
4536 set z [expr {$x0 - $col}]
4537 set isarrow 0
4538 set z0 {}
4539 if {$ym >= 0} {
4540 set xm [lsearch -exact $pprevidlist $id]
4541 if {$xm >= 0} {
4542 set z0 [expr {$xm - $x0}]
4545 if {$z0 eq {}} {
4546 # if row y0 is the first child of $id then it's not an arrow
4547 if {[lindex $children($curview,$id) 0] ne
4548 [lindex $displayorder $y0]} {
4549 set isarrow 1
4552 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4553 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4554 set isarrow 1
4556 # Looking at lines from this row to the previous row,
4557 # make them go straight up if they end in an arrow on
4558 # the previous row; otherwise make them go straight up
4559 # or at 45 degrees.
4560 if {$z < -1 || ($z < 0 && $isarrow)} {
4561 # Line currently goes left too much;
4562 # insert pads in the previous row, then optimize it
4563 set npad [expr {-1 - $z + $isarrow}]
4564 insert_pad $y0 $x0 $npad
4565 if {$y0 > 0} {
4566 optimize_rows $y0 $x0 $row
4568 set previdlist [lindex $rowidlist $y0]
4569 set x0 [lsearch -exact $previdlist $id]
4570 set z [expr {$x0 - $col}]
4571 if {$z0 ne {}} {
4572 set pprevidlist [lindex $rowidlist $ym]
4573 set xm [lsearch -exact $pprevidlist $id]
4574 set z0 [expr {$xm - $x0}]
4576 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4577 # Line currently goes right too much;
4578 # insert pads in this line
4579 set npad [expr {$z - 1 + $isarrow}]
4580 insert_pad $row $col $npad
4581 set idlist [lindex $rowidlist $row]
4582 incr col $npad
4583 set z [expr {$x0 - $col}]
4584 set haspad 1
4586 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4587 # this line links to its first child on row $row-2
4588 set id [lindex $displayorder $ym]
4589 set xc [lsearch -exact $pprevidlist $id]
4590 if {$xc >= 0} {
4591 set z0 [expr {$xc - $x0}]
4594 # avoid lines jigging left then immediately right
4595 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4596 insert_pad $y0 $x0 1
4597 incr x0
4598 optimize_rows $y0 $x0 $row
4599 set previdlist [lindex $rowidlist $y0]
4602 if {!$haspad} {
4603 # Find the first column that doesn't have a line going right
4604 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4605 set id [lindex $idlist $col]
4606 if {$id eq {}} break
4607 set x0 [lsearch -exact $previdlist $id]
4608 if {$x0 < 0} {
4609 # check if this is the link to the first child
4610 set kid [lindex $displayorder $y0]
4611 if {[lindex $children($curview,$id) 0] eq $kid} {
4612 # it is, work out offset to child
4613 set x0 [lsearch -exact $previdlist $kid]
4616 if {$x0 <= $col} break
4618 # Insert a pad at that column as long as it has a line and
4619 # isn't the last column
4620 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4621 set idlist [linsert $idlist $col {}]
4622 lset rowidlist $row $idlist
4623 changedrow $row
4629 proc xc {row col} {
4630 global canvx0 linespc
4631 return [expr {$canvx0 + $col * $linespc}]
4634 proc yc {row} {
4635 global canvy0 linespc
4636 return [expr {$canvy0 + $row * $linespc}]
4639 proc linewidth {id} {
4640 global thickerline lthickness
4642 set wid $lthickness
4643 if {[info exists thickerline] && $id eq $thickerline} {
4644 set wid [expr {2 * $lthickness}]
4646 return $wid
4649 proc rowranges {id} {
4650 global curview children uparrowlen downarrowlen
4651 global rowidlist
4653 set kids $children($curview,$id)
4654 if {$kids eq {}} {
4655 return {}
4657 set ret {}
4658 lappend kids $id
4659 foreach child $kids {
4660 if {![commitinview $child $curview]} break
4661 set row [rowofcommit $child]
4662 if {![info exists prev]} {
4663 lappend ret [expr {$row + 1}]
4664 } else {
4665 if {$row <= $prevrow} {
4666 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4668 # see if the line extends the whole way from prevrow to row
4669 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4670 [lsearch -exact [lindex $rowidlist \
4671 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4672 # it doesn't, see where it ends
4673 set r [expr {$prevrow + $downarrowlen}]
4674 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4675 while {[incr r -1] > $prevrow &&
4676 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4677 } else {
4678 while {[incr r] <= $row &&
4679 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4680 incr r -1
4682 lappend ret $r
4683 # see where it starts up again
4684 set r [expr {$row - $uparrowlen}]
4685 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4686 while {[incr r] < $row &&
4687 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4688 } else {
4689 while {[incr r -1] >= $prevrow &&
4690 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4691 incr r
4693 lappend ret $r
4696 if {$child eq $id} {
4697 lappend ret $row
4699 set prev $child
4700 set prevrow $row
4702 return $ret
4705 proc drawlineseg {id row endrow arrowlow} {
4706 global rowidlist displayorder iddrawn linesegs
4707 global canv colormap linespc curview maxlinelen parentlist
4709 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4710 set le [expr {$row + 1}]
4711 set arrowhigh 1
4712 while {1} {
4713 set c [lsearch -exact [lindex $rowidlist $le] $id]
4714 if {$c < 0} {
4715 incr le -1
4716 break
4718 lappend cols $c
4719 set x [lindex $displayorder $le]
4720 if {$x eq $id} {
4721 set arrowhigh 0
4722 break
4724 if {[info exists iddrawn($x)] || $le == $endrow} {
4725 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4726 if {$c >= 0} {
4727 lappend cols $c
4728 set arrowhigh 0
4730 break
4732 incr le
4734 if {$le <= $row} {
4735 return $row
4738 set lines {}
4739 set i 0
4740 set joinhigh 0
4741 if {[info exists linesegs($id)]} {
4742 set lines $linesegs($id)
4743 foreach li $lines {
4744 set r0 [lindex $li 0]
4745 if {$r0 > $row} {
4746 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4747 set joinhigh 1
4749 break
4751 incr i
4754 set joinlow 0
4755 if {$i > 0} {
4756 set li [lindex $lines [expr {$i-1}]]
4757 set r1 [lindex $li 1]
4758 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4759 set joinlow 1
4763 set x [lindex $cols [expr {$le - $row}]]
4764 set xp [lindex $cols [expr {$le - 1 - $row}]]
4765 set dir [expr {$xp - $x}]
4766 if {$joinhigh} {
4767 set ith [lindex $lines $i 2]
4768 set coords [$canv coords $ith]
4769 set ah [$canv itemcget $ith -arrow]
4770 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4771 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4772 if {$x2 ne {} && $x - $x2 == $dir} {
4773 set coords [lrange $coords 0 end-2]
4775 } else {
4776 set coords [list [xc $le $x] [yc $le]]
4778 if {$joinlow} {
4779 set itl [lindex $lines [expr {$i-1}] 2]
4780 set al [$canv itemcget $itl -arrow]
4781 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4782 } elseif {$arrowlow} {
4783 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4784 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4785 set arrowlow 0
4788 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4789 for {set y $le} {[incr y -1] > $row} {} {
4790 set x $xp
4791 set xp [lindex $cols [expr {$y - 1 - $row}]]
4792 set ndir [expr {$xp - $x}]
4793 if {$dir != $ndir || $xp < 0} {
4794 lappend coords [xc $y $x] [yc $y]
4796 set dir $ndir
4798 if {!$joinlow} {
4799 if {$xp < 0} {
4800 # join parent line to first child
4801 set ch [lindex $displayorder $row]
4802 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4803 if {$xc < 0} {
4804 puts "oops: drawlineseg: child $ch not on row $row"
4805 } elseif {$xc != $x} {
4806 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4807 set d [expr {int(0.5 * $linespc)}]
4808 set x1 [xc $row $x]
4809 if {$xc < $x} {
4810 set x2 [expr {$x1 - $d}]
4811 } else {
4812 set x2 [expr {$x1 + $d}]
4814 set y2 [yc $row]
4815 set y1 [expr {$y2 + $d}]
4816 lappend coords $x1 $y1 $x2 $y2
4817 } elseif {$xc < $x - 1} {
4818 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4819 } elseif {$xc > $x + 1} {
4820 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4822 set x $xc
4824 lappend coords [xc $row $x] [yc $row]
4825 } else {
4826 set xn [xc $row $xp]
4827 set yn [yc $row]
4828 lappend coords $xn $yn
4830 if {!$joinhigh} {
4831 assigncolor $id
4832 set t [$canv create line $coords -width [linewidth $id] \
4833 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4834 $canv lower $t
4835 bindline $t $id
4836 set lines [linsert $lines $i [list $row $le $t]]
4837 } else {
4838 $canv coords $ith $coords
4839 if {$arrow ne $ah} {
4840 $canv itemconf $ith -arrow $arrow
4842 lset lines $i 0 $row
4844 } else {
4845 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4846 set ndir [expr {$xo - $xp}]
4847 set clow [$canv coords $itl]
4848 if {$dir == $ndir} {
4849 set clow [lrange $clow 2 end]
4851 set coords [concat $coords $clow]
4852 if {!$joinhigh} {
4853 lset lines [expr {$i-1}] 1 $le
4854 } else {
4855 # coalesce two pieces
4856 $canv delete $ith
4857 set b [lindex $lines [expr {$i-1}] 0]
4858 set e [lindex $lines $i 1]
4859 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4861 $canv coords $itl $coords
4862 if {$arrow ne $al} {
4863 $canv itemconf $itl -arrow $arrow
4867 set linesegs($id) $lines
4868 return $le
4871 proc drawparentlinks {id row} {
4872 global rowidlist canv colormap curview parentlist
4873 global idpos linespc
4875 set rowids [lindex $rowidlist $row]
4876 set col [lsearch -exact $rowids $id]
4877 if {$col < 0} return
4878 set olds [lindex $parentlist $row]
4879 set row2 [expr {$row + 1}]
4880 set x [xc $row $col]
4881 set y [yc $row]
4882 set y2 [yc $row2]
4883 set d [expr {int(0.5 * $linespc)}]
4884 set ymid [expr {$y + $d}]
4885 set ids [lindex $rowidlist $row2]
4886 # rmx = right-most X coord used
4887 set rmx 0
4888 foreach p $olds {
4889 set i [lsearch -exact $ids $p]
4890 if {$i < 0} {
4891 puts "oops, parent $p of $id not in list"
4892 continue
4894 set x2 [xc $row2 $i]
4895 if {$x2 > $rmx} {
4896 set rmx $x2
4898 set j [lsearch -exact $rowids $p]
4899 if {$j < 0} {
4900 # drawlineseg will do this one for us
4901 continue
4903 assigncolor $p
4904 # should handle duplicated parents here...
4905 set coords [list $x $y]
4906 if {$i != $col} {
4907 # if attaching to a vertical segment, draw a smaller
4908 # slant for visual distinctness
4909 if {$i == $j} {
4910 if {$i < $col} {
4911 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4912 } else {
4913 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4915 } elseif {$i < $col && $i < $j} {
4916 # segment slants towards us already
4917 lappend coords [xc $row $j] $y
4918 } else {
4919 if {$i < $col - 1} {
4920 lappend coords [expr {$x2 + $linespc}] $y
4921 } elseif {$i > $col + 1} {
4922 lappend coords [expr {$x2 - $linespc}] $y
4924 lappend coords $x2 $y2
4926 } else {
4927 lappend coords $x2 $y2
4929 set t [$canv create line $coords -width [linewidth $p] \
4930 -fill $colormap($p) -tags lines.$p]
4931 $canv lower $t
4932 bindline $t $p
4934 if {$rmx > [lindex $idpos($id) 1]} {
4935 lset idpos($id) 1 $rmx
4936 redrawtags $id
4940 proc drawlines {id} {
4941 global canv
4943 $canv itemconf lines.$id -width [linewidth $id]
4946 proc drawcmittext {id row col} {
4947 global linespc canv canv2 canv3 fgcolor curview
4948 global cmitlisted commitinfo rowidlist parentlist
4949 global rowtextx idpos idtags idheads idotherrefs
4950 global linehtag linentag linedtag selectedline
4951 global canvxmax boldrows boldnamerows fgcolor
4952 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
4954 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4955 set listed $cmitlisted($curview,$id)
4956 if {$id eq $nullid} {
4957 set ofill red
4958 } elseif {$id eq $nullid2} {
4959 set ofill green
4960 } elseif {$id eq $mainheadid} {
4961 set ofill yellow
4962 } else {
4963 set ofill [lindex $circlecolors $listed]
4965 set x [xc $row $col]
4966 set y [yc $row]
4967 set orad [expr {$linespc / 3}]
4968 if {$listed <= 2} {
4969 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4970 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4971 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4972 } elseif {$listed == 3} {
4973 # triangle pointing left for left-side commits
4974 set t [$canv create polygon \
4975 [expr {$x - $orad}] $y \
4976 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4977 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4978 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4979 } else {
4980 # triangle pointing right for right-side commits
4981 set t [$canv create polygon \
4982 [expr {$x + $orad - 1}] $y \
4983 [expr {$x - $orad}] [expr {$y - $orad}] \
4984 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4985 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4987 set circleitem($row) $t
4988 $canv raise $t
4989 $canv bind $t <1> {selcanvline {} %x %y}
4990 set rmx [llength [lindex $rowidlist $row]]
4991 set olds [lindex $parentlist $row]
4992 if {$olds ne {}} {
4993 set nextids [lindex $rowidlist [expr {$row + 1}]]
4994 foreach p $olds {
4995 set i [lsearch -exact $nextids $p]
4996 if {$i > $rmx} {
4997 set rmx $i
5001 set xt [xc $row $rmx]
5002 set rowtextx($row) $xt
5003 set idpos($id) [list $x $xt $y]
5004 if {[info exists idtags($id)] || [info exists idheads($id)]
5005 || [info exists idotherrefs($id)]} {
5006 set xt [drawtags $id $x $xt $y]
5008 set headline [lindex $commitinfo($id) 0]
5009 set name [lindex $commitinfo($id) 1]
5010 set date [lindex $commitinfo($id) 2]
5011 set date [formatdate $date]
5012 set font mainfont
5013 set nfont mainfont
5014 set isbold [ishighlighted $id]
5015 if {$isbold > 0} {
5016 lappend boldrows $row
5017 set font mainfontbold
5018 if {$isbold > 1} {
5019 lappend boldnamerows $row
5020 set nfont mainfontbold
5023 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
5024 -text $headline -font $font -tags text]
5025 $canv bind $linehtag($row) $ctxbut "rowmenu %X %Y $id"
5026 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5027 -text $name -font $nfont -tags text]
5028 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5029 -text $date -font mainfont -tags text]
5030 if {$selectedline == $row} {
5031 make_secsel $row
5033 set xr [expr {$xt + [font measure $font $headline]}]
5034 if {$xr > $canvxmax} {
5035 set canvxmax $xr
5036 setcanvscroll
5040 proc drawcmitrow {row} {
5041 global displayorder rowidlist nrows_drawn
5042 global iddrawn markingmatches
5043 global commitinfo numcommits
5044 global filehighlight fhighlights findpattern nhighlights
5045 global hlview vhighlights
5046 global highlight_related rhighlights
5048 if {$row >= $numcommits} return
5050 set id [lindex $displayorder $row]
5051 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5052 askvhighlight $row $id
5054 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5055 askfilehighlight $row $id
5057 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5058 askfindhighlight $row $id
5060 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5061 askrelhighlight $row $id
5063 if {![info exists iddrawn($id)]} {
5064 set col [lsearch -exact [lindex $rowidlist $row] $id]
5065 if {$col < 0} {
5066 puts "oops, row $row id $id not in list"
5067 return
5069 if {![info exists commitinfo($id)]} {
5070 getcommit $id
5072 assigncolor $id
5073 drawcmittext $id $row $col
5074 set iddrawn($id) 1
5075 incr nrows_drawn
5077 if {$markingmatches} {
5078 markrowmatches $row $id
5082 proc drawcommits {row {endrow {}}} {
5083 global numcommits iddrawn displayorder curview need_redisplay
5084 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5086 if {$row < 0} {
5087 set row 0
5089 if {$endrow eq {}} {
5090 set endrow $row
5092 if {$endrow >= $numcommits} {
5093 set endrow [expr {$numcommits - 1}]
5096 set rl1 [expr {$row - $downarrowlen - 3}]
5097 if {$rl1 < 0} {
5098 set rl1 0
5100 set ro1 [expr {$row - 3}]
5101 if {$ro1 < 0} {
5102 set ro1 0
5104 set r2 [expr {$endrow + $uparrowlen + 3}]
5105 if {$r2 > $numcommits} {
5106 set r2 $numcommits
5108 for {set r $rl1} {$r < $r2} {incr r} {
5109 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5110 if {$rl1 < $r} {
5111 layoutrows $rl1 $r
5113 set rl1 [expr {$r + 1}]
5116 if {$rl1 < $r} {
5117 layoutrows $rl1 $r
5119 optimize_rows $ro1 0 $r2
5120 if {$need_redisplay || $nrows_drawn > 2000} {
5121 clear_display
5122 drawvisible
5125 # make the lines join to already-drawn rows either side
5126 set r [expr {$row - 1}]
5127 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5128 set r $row
5130 set er [expr {$endrow + 1}]
5131 if {$er >= $numcommits ||
5132 ![info exists iddrawn([lindex $displayorder $er])]} {
5133 set er $endrow
5135 for {} {$r <= $er} {incr r} {
5136 set id [lindex $displayorder $r]
5137 set wasdrawn [info exists iddrawn($id)]
5138 drawcmitrow $r
5139 if {$r == $er} break
5140 set nextid [lindex $displayorder [expr {$r + 1}]]
5141 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5142 drawparentlinks $id $r
5144 set rowids [lindex $rowidlist $r]
5145 foreach lid $rowids {
5146 if {$lid eq {}} continue
5147 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5148 if {$lid eq $id} {
5149 # see if this is the first child of any of its parents
5150 foreach p [lindex $parentlist $r] {
5151 if {[lsearch -exact $rowids $p] < 0} {
5152 # make this line extend up to the child
5153 set lineend($p) [drawlineseg $p $r $er 0]
5156 } else {
5157 set lineend($lid) [drawlineseg $lid $r $er 1]
5163 proc undolayout {row} {
5164 global uparrowlen mingaplen downarrowlen
5165 global rowidlist rowisopt rowfinal need_redisplay
5167 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5168 if {$r < 0} {
5169 set r 0
5171 if {[llength $rowidlist] > $r} {
5172 incr r -1
5173 set rowidlist [lrange $rowidlist 0 $r]
5174 set rowfinal [lrange $rowfinal 0 $r]
5175 set rowisopt [lrange $rowisopt 0 $r]
5176 set need_redisplay 1
5177 run drawvisible
5181 proc drawvisible {} {
5182 global canv linespc curview vrowmod selectedline targetrow targetid
5183 global need_redisplay cscroll numcommits
5185 set fs [$canv yview]
5186 set ymax [lindex [$canv cget -scrollregion] 3]
5187 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5188 set f0 [lindex $fs 0]
5189 set f1 [lindex $fs 1]
5190 set y0 [expr {int($f0 * $ymax)}]
5191 set y1 [expr {int($f1 * $ymax)}]
5193 if {[info exists targetid]} {
5194 if {[commitinview $targetid $curview]} {
5195 set r [rowofcommit $targetid]
5196 if {$r != $targetrow} {
5197 # Fix up the scrollregion and change the scrolling position
5198 # now that our target row has moved.
5199 set diff [expr {($r - $targetrow) * $linespc}]
5200 set targetrow $r
5201 setcanvscroll
5202 set ymax [lindex [$canv cget -scrollregion] 3]
5203 incr y0 $diff
5204 incr y1 $diff
5205 set f0 [expr {$y0 / $ymax}]
5206 set f1 [expr {$y1 / $ymax}]
5207 allcanvs yview moveto $f0
5208 $cscroll set $f0 $f1
5209 set need_redisplay 1
5211 } else {
5212 unset targetid
5216 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5217 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5218 if {$endrow >= $vrowmod($curview)} {
5219 update_arcrows $curview
5221 if {$selectedline ne {} &&
5222 $row <= $selectedline && $selectedline <= $endrow} {
5223 set targetrow $selectedline
5224 } elseif {[info exists targetid]} {
5225 set targetrow [expr {int(($row + $endrow) / 2)}]
5227 if {[info exists targetrow]} {
5228 if {$targetrow >= $numcommits} {
5229 set targetrow [expr {$numcommits - 1}]
5231 set targetid [commitonrow $targetrow]
5233 drawcommits $row $endrow
5236 proc clear_display {} {
5237 global iddrawn linesegs need_redisplay nrows_drawn
5238 global vhighlights fhighlights nhighlights rhighlights
5239 global linehtag linentag linedtag boldrows boldnamerows
5241 allcanvs delete all
5242 catch {unset iddrawn}
5243 catch {unset linesegs}
5244 catch {unset linehtag}
5245 catch {unset linentag}
5246 catch {unset linedtag}
5247 set boldrows {}
5248 set boldnamerows {}
5249 catch {unset vhighlights}
5250 catch {unset fhighlights}
5251 catch {unset nhighlights}
5252 catch {unset rhighlights}
5253 set need_redisplay 0
5254 set nrows_drawn 0
5257 proc findcrossings {id} {
5258 global rowidlist parentlist numcommits displayorder
5260 set cross {}
5261 set ccross {}
5262 foreach {s e} [rowranges $id] {
5263 if {$e >= $numcommits} {
5264 set e [expr {$numcommits - 1}]
5266 if {$e <= $s} continue
5267 for {set row $e} {[incr row -1] >= $s} {} {
5268 set x [lsearch -exact [lindex $rowidlist $row] $id]
5269 if {$x < 0} break
5270 set olds [lindex $parentlist $row]
5271 set kid [lindex $displayorder $row]
5272 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5273 if {$kidx < 0} continue
5274 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5275 foreach p $olds {
5276 set px [lsearch -exact $nextrow $p]
5277 if {$px < 0} continue
5278 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5279 if {[lsearch -exact $ccross $p] >= 0} continue
5280 if {$x == $px + ($kidx < $px? -1: 1)} {
5281 lappend ccross $p
5282 } elseif {[lsearch -exact $cross $p] < 0} {
5283 lappend cross $p
5289 return [concat $ccross {{}} $cross]
5292 proc assigncolor {id} {
5293 global colormap colors nextcolor
5294 global parents children children curview
5296 if {[info exists colormap($id)]} return
5297 set ncolors [llength $colors]
5298 if {[info exists children($curview,$id)]} {
5299 set kids $children($curview,$id)
5300 } else {
5301 set kids {}
5303 if {[llength $kids] == 1} {
5304 set child [lindex $kids 0]
5305 if {[info exists colormap($child)]
5306 && [llength $parents($curview,$child)] == 1} {
5307 set colormap($id) $colormap($child)
5308 return
5311 set badcolors {}
5312 set origbad {}
5313 foreach x [findcrossings $id] {
5314 if {$x eq {}} {
5315 # delimiter between corner crossings and other crossings
5316 if {[llength $badcolors] >= $ncolors - 1} break
5317 set origbad $badcolors
5319 if {[info exists colormap($x)]
5320 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5321 lappend badcolors $colormap($x)
5324 if {[llength $badcolors] >= $ncolors} {
5325 set badcolors $origbad
5327 set origbad $badcolors
5328 if {[llength $badcolors] < $ncolors - 1} {
5329 foreach child $kids {
5330 if {[info exists colormap($child)]
5331 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5332 lappend badcolors $colormap($child)
5334 foreach p $parents($curview,$child) {
5335 if {[info exists colormap($p)]
5336 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5337 lappend badcolors $colormap($p)
5341 if {[llength $badcolors] >= $ncolors} {
5342 set badcolors $origbad
5345 for {set i 0} {$i <= $ncolors} {incr i} {
5346 set c [lindex $colors $nextcolor]
5347 if {[incr nextcolor] >= $ncolors} {
5348 set nextcolor 0
5350 if {[lsearch -exact $badcolors $c]} break
5352 set colormap($id) $c
5355 proc bindline {t id} {
5356 global canv
5358 $canv bind $t <Enter> "lineenter %x %y $id"
5359 $canv bind $t <Motion> "linemotion %x %y $id"
5360 $canv bind $t <Leave> "lineleave $id"
5361 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5364 proc drawtags {id x xt y1} {
5365 global idtags idheads idotherrefs mainhead
5366 global linespc lthickness
5367 global canv rowtextx curview fgcolor bgcolor ctxbut
5369 set marks {}
5370 set ntags 0
5371 set nheads 0
5372 if {[info exists idtags($id)]} {
5373 set marks $idtags($id)
5374 set ntags [llength $marks]
5376 if {[info exists idheads($id)]} {
5377 set marks [concat $marks $idheads($id)]
5378 set nheads [llength $idheads($id)]
5380 if {[info exists idotherrefs($id)]} {
5381 set marks [concat $marks $idotherrefs($id)]
5383 if {$marks eq {}} {
5384 return $xt
5387 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5388 set yt [expr {$y1 - 0.5 * $linespc}]
5389 set yb [expr {$yt + $linespc - 1}]
5390 set xvals {}
5391 set wvals {}
5392 set i -1
5393 foreach tag $marks {
5394 incr i
5395 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5396 set wid [font measure mainfontbold $tag]
5397 } else {
5398 set wid [font measure mainfont $tag]
5400 lappend xvals $xt
5401 lappend wvals $wid
5402 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5404 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5405 -width $lthickness -fill black -tags tag.$id]
5406 $canv lower $t
5407 foreach tag $marks x $xvals wid $wvals {
5408 set xl [expr {$x + $delta}]
5409 set xr [expr {$x + $delta + $wid + $lthickness}]
5410 set font mainfont
5411 if {[incr ntags -1] >= 0} {
5412 # draw a tag
5413 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5414 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5415 -width 1 -outline black -fill yellow -tags tag.$id]
5416 $canv bind $t <1> [list showtag $tag 1]
5417 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5418 } else {
5419 # draw a head or other ref
5420 if {[incr nheads -1] >= 0} {
5421 set col green
5422 if {$tag eq $mainhead} {
5423 set font mainfontbold
5425 } else {
5426 set col "#ddddff"
5428 set xl [expr {$xl - $delta/2}]
5429 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5430 -width 1 -outline black -fill $col -tags tag.$id
5431 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5432 set rwid [font measure mainfont $remoteprefix]
5433 set xi [expr {$x + 1}]
5434 set yti [expr {$yt + 1}]
5435 set xri [expr {$x + $rwid}]
5436 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5437 -width 0 -fill "#ffddaa" -tags tag.$id
5440 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5441 -font $font -tags [list tag.$id text]]
5442 if {$ntags >= 0} {
5443 $canv bind $t <1> [list showtag $tag 1]
5444 } elseif {$nheads >= 0} {
5445 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
5448 return $xt
5451 proc xcoord {i level ln} {
5452 global canvx0 xspc1 xspc2
5454 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5455 if {$i > 0 && $i == $level} {
5456 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5457 } elseif {$i > $level} {
5458 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5460 return $x
5463 proc show_status {msg} {
5464 global canv fgcolor
5466 clear_display
5467 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5468 -tags text -fill $fgcolor
5471 # Don't change the text pane cursor if it is currently the hand cursor,
5472 # showing that we are over a sha1 ID link.
5473 proc settextcursor {c} {
5474 global ctext curtextcursor
5476 if {[$ctext cget -cursor] == $curtextcursor} {
5477 $ctext config -cursor $c
5479 set curtextcursor $c
5482 proc nowbusy {what {name {}}} {
5483 global isbusy busyname statusw
5485 if {[array names isbusy] eq {}} {
5486 . config -cursor watch
5487 settextcursor watch
5489 set isbusy($what) 1
5490 set busyname($what) $name
5491 if {$name ne {}} {
5492 $statusw conf -text $name
5496 proc notbusy {what} {
5497 global isbusy maincursor textcursor busyname statusw
5499 catch {
5500 unset isbusy($what)
5501 if {$busyname($what) ne {} &&
5502 [$statusw cget -text] eq $busyname($what)} {
5503 $statusw conf -text {}
5506 if {[array names isbusy] eq {}} {
5507 . config -cursor $maincursor
5508 settextcursor $textcursor
5512 proc findmatches {f} {
5513 global findtype findstring
5514 if {$findtype == [mc "Regexp"]} {
5515 set matches [regexp -indices -all -inline $findstring $f]
5516 } else {
5517 set fs $findstring
5518 if {$findtype == [mc "IgnCase"]} {
5519 set f [string tolower $f]
5520 set fs [string tolower $fs]
5522 set matches {}
5523 set i 0
5524 set l [string length $fs]
5525 while {[set j [string first $fs $f $i]] >= 0} {
5526 lappend matches [list $j [expr {$j+$l-1}]]
5527 set i [expr {$j + $l}]
5530 return $matches
5533 proc dofind {{dirn 1} {wrap 1}} {
5534 global findstring findstartline findcurline selectedline numcommits
5535 global gdttype filehighlight fh_serial find_dirn findallowwrap
5537 if {[info exists find_dirn]} {
5538 if {$find_dirn == $dirn} return
5539 stopfinding
5541 focus .
5542 if {$findstring eq {} || $numcommits == 0} return
5543 if {$selectedline eq {}} {
5544 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5545 } else {
5546 set findstartline $selectedline
5548 set findcurline $findstartline
5549 nowbusy finding [mc "Searching"]
5550 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5551 after cancel do_file_hl $fh_serial
5552 do_file_hl $fh_serial
5554 set find_dirn $dirn
5555 set findallowwrap $wrap
5556 run findmore
5559 proc stopfinding {} {
5560 global find_dirn findcurline fprogcoord
5562 if {[info exists find_dirn]} {
5563 unset find_dirn
5564 unset findcurline
5565 notbusy finding
5566 set fprogcoord 0
5567 adjustprogress
5571 proc findmore {} {
5572 global commitdata commitinfo numcommits findpattern findloc
5573 global findstartline findcurline findallowwrap
5574 global find_dirn gdttype fhighlights fprogcoord
5575 global curview varcorder vrownum varccommits vrowmod
5577 if {![info exists find_dirn]} {
5578 return 0
5580 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5581 set l $findcurline
5582 set moretodo 0
5583 if {$find_dirn > 0} {
5584 incr l
5585 if {$l >= $numcommits} {
5586 set l 0
5588 if {$l <= $findstartline} {
5589 set lim [expr {$findstartline + 1}]
5590 } else {
5591 set lim $numcommits
5592 set moretodo $findallowwrap
5594 } else {
5595 if {$l == 0} {
5596 set l $numcommits
5598 incr l -1
5599 if {$l >= $findstartline} {
5600 set lim [expr {$findstartline - 1}]
5601 } else {
5602 set lim -1
5603 set moretodo $findallowwrap
5606 set n [expr {($lim - $l) * $find_dirn}]
5607 if {$n > 500} {
5608 set n 500
5609 set moretodo 1
5611 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5612 update_arcrows $curview
5614 set found 0
5615 set domore 1
5616 set ai [bsearch $vrownum($curview) $l]
5617 set a [lindex $varcorder($curview) $ai]
5618 set arow [lindex $vrownum($curview) $ai]
5619 set ids [lindex $varccommits($curview,$a)]
5620 set arowend [expr {$arow + [llength $ids]}]
5621 if {$gdttype eq [mc "containing:"]} {
5622 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5623 if {$l < $arow || $l >= $arowend} {
5624 incr ai $find_dirn
5625 set a [lindex $varcorder($curview) $ai]
5626 set arow [lindex $vrownum($curview) $ai]
5627 set ids [lindex $varccommits($curview,$a)]
5628 set arowend [expr {$arow + [llength $ids]}]
5630 set id [lindex $ids [expr {$l - $arow}]]
5631 # shouldn't happen unless git log doesn't give all the commits...
5632 if {![info exists commitdata($id)] ||
5633 ![doesmatch $commitdata($id)]} {
5634 continue
5636 if {![info exists commitinfo($id)]} {
5637 getcommit $id
5639 set info $commitinfo($id)
5640 foreach f $info ty $fldtypes {
5641 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5642 [doesmatch $f]} {
5643 set found 1
5644 break
5647 if {$found} break
5649 } else {
5650 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5651 if {$l < $arow || $l >= $arowend} {
5652 incr ai $find_dirn
5653 set a [lindex $varcorder($curview) $ai]
5654 set arow [lindex $vrownum($curview) $ai]
5655 set ids [lindex $varccommits($curview,$a)]
5656 set arowend [expr {$arow + [llength $ids]}]
5658 set id [lindex $ids [expr {$l - $arow}]]
5659 if {![info exists fhighlights($id)]} {
5660 # this sets fhighlights($id) to -1
5661 askfilehighlight $l $id
5663 if {$fhighlights($id) > 0} {
5664 set found $domore
5665 break
5667 if {$fhighlights($id) < 0} {
5668 if {$domore} {
5669 set domore 0
5670 set findcurline [expr {$l - $find_dirn}]
5675 if {$found || ($domore && !$moretodo)} {
5676 unset findcurline
5677 unset find_dirn
5678 notbusy finding
5679 set fprogcoord 0
5680 adjustprogress
5681 if {$found} {
5682 findselectline $l
5683 } else {
5684 bell
5686 return 0
5688 if {!$domore} {
5689 flushhighlights
5690 } else {
5691 set findcurline [expr {$l - $find_dirn}]
5693 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5694 if {$n < 0} {
5695 incr n $numcommits
5697 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5698 adjustprogress
5699 return $domore
5702 proc findselectline {l} {
5703 global findloc commentend ctext findcurline markingmatches gdttype
5705 set markingmatches 1
5706 set findcurline $l
5707 selectline $l 1
5708 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5709 # highlight the matches in the comments
5710 set f [$ctext get 1.0 $commentend]
5711 set matches [findmatches $f]
5712 foreach match $matches {
5713 set start [lindex $match 0]
5714 set end [expr {[lindex $match 1] + 1}]
5715 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5718 drawvisible
5721 # mark the bits of a headline or author that match a find string
5722 proc markmatches {canv l str tag matches font row} {
5723 global selectedline
5725 set bbox [$canv bbox $tag]
5726 set x0 [lindex $bbox 0]
5727 set y0 [lindex $bbox 1]
5728 set y1 [lindex $bbox 3]
5729 foreach match $matches {
5730 set start [lindex $match 0]
5731 set end [lindex $match 1]
5732 if {$start > $end} continue
5733 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5734 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5735 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5736 [expr {$x0+$xlen+2}] $y1 \
5737 -outline {} -tags [list match$l matches] -fill yellow]
5738 $canv lower $t
5739 if {$row == $selectedline} {
5740 $canv raise $t secsel
5745 proc unmarkmatches {} {
5746 global markingmatches
5748 allcanvs delete matches
5749 set markingmatches 0
5750 stopfinding
5753 proc selcanvline {w x y} {
5754 global canv canvy0 ctext linespc
5755 global rowtextx
5756 set ymax [lindex [$canv cget -scrollregion] 3]
5757 if {$ymax == {}} return
5758 set yfrac [lindex [$canv yview] 0]
5759 set y [expr {$y + $yfrac * $ymax}]
5760 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5761 if {$l < 0} {
5762 set l 0
5764 if {$w eq $canv} {
5765 set xmax [lindex [$canv cget -scrollregion] 2]
5766 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5767 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5769 unmarkmatches
5770 selectline $l 1
5773 proc commit_descriptor {p} {
5774 global commitinfo
5775 if {![info exists commitinfo($p)]} {
5776 getcommit $p
5778 set l "..."
5779 if {[llength $commitinfo($p)] > 1} {
5780 set l [lindex $commitinfo($p) 0]
5782 return "$p ($l)\n"
5785 # append some text to the ctext widget, and make any SHA1 ID
5786 # that we know about be a clickable link.
5787 proc appendwithlinks {text tags} {
5788 global ctext linknum curview pendinglinks
5790 set start [$ctext index "end - 1c"]
5791 $ctext insert end $text $tags
5792 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5793 foreach l $links {
5794 set s [lindex $l 0]
5795 set e [lindex $l 1]
5796 set linkid [string range $text $s $e]
5797 incr e
5798 $ctext tag delete link$linknum
5799 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5800 setlink $linkid link$linknum
5801 incr linknum
5805 proc setlink {id lk} {
5806 global curview ctext pendinglinks commitinterest
5808 if {[commitinview $id $curview]} {
5809 $ctext tag conf $lk -foreground blue -underline 1
5810 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5811 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5812 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5813 } else {
5814 lappend pendinglinks($id) $lk
5815 lappend commitinterest($id) {makelink %I}
5819 proc makelink {id} {
5820 global pendinglinks
5822 if {![info exists pendinglinks($id)]} return
5823 foreach lk $pendinglinks($id) {
5824 setlink $id $lk
5826 unset pendinglinks($id)
5829 proc linkcursor {w inc} {
5830 global linkentercount curtextcursor
5832 if {[incr linkentercount $inc] > 0} {
5833 $w configure -cursor hand2
5834 } else {
5835 $w configure -cursor $curtextcursor
5836 if {$linkentercount < 0} {
5837 set linkentercount 0
5842 proc viewnextline {dir} {
5843 global canv linespc
5845 $canv delete hover
5846 set ymax [lindex [$canv cget -scrollregion] 3]
5847 set wnow [$canv yview]
5848 set wtop [expr {[lindex $wnow 0] * $ymax}]
5849 set newtop [expr {$wtop + $dir * $linespc}]
5850 if {$newtop < 0} {
5851 set newtop 0
5852 } elseif {$newtop > $ymax} {
5853 set newtop $ymax
5855 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5858 # add a list of tag or branch names at position pos
5859 # returns the number of names inserted
5860 proc appendrefs {pos ids var} {
5861 global ctext linknum curview $var maxrefs
5863 if {[catch {$ctext index $pos}]} {
5864 return 0
5866 $ctext conf -state normal
5867 $ctext delete $pos "$pos lineend"
5868 set tags {}
5869 foreach id $ids {
5870 foreach tag [set $var\($id\)] {
5871 lappend tags [list $tag $id]
5874 if {[llength $tags] > $maxrefs} {
5875 $ctext insert $pos "many ([llength $tags])"
5876 } else {
5877 set tags [lsort -index 0 -decreasing $tags]
5878 set sep {}
5879 foreach ti $tags {
5880 set id [lindex $ti 1]
5881 set lk link$linknum
5882 incr linknum
5883 $ctext tag delete $lk
5884 $ctext insert $pos $sep
5885 $ctext insert $pos [lindex $ti 0] $lk
5886 setlink $id $lk
5887 set sep ", "
5890 $ctext conf -state disabled
5891 return [llength $tags]
5894 # called when we have finished computing the nearby tags
5895 proc dispneartags {delay} {
5896 global selectedline currentid showneartags tagphase
5898 if {$selectedline eq {} || !$showneartags} return
5899 after cancel dispnexttag
5900 if {$delay} {
5901 after 200 dispnexttag
5902 set tagphase -1
5903 } else {
5904 after idle dispnexttag
5905 set tagphase 0
5909 proc dispnexttag {} {
5910 global selectedline currentid showneartags tagphase ctext
5912 if {$selectedline eq {} || !$showneartags} return
5913 switch -- $tagphase {
5915 set dtags [desctags $currentid]
5916 if {$dtags ne {}} {
5917 appendrefs precedes $dtags idtags
5921 set atags [anctags $currentid]
5922 if {$atags ne {}} {
5923 appendrefs follows $atags idtags
5927 set dheads [descheads $currentid]
5928 if {$dheads ne {}} {
5929 if {[appendrefs branch $dheads idheads] > 1
5930 && [$ctext get "branch -3c"] eq "h"} {
5931 # turn "Branch" into "Branches"
5932 $ctext conf -state normal
5933 $ctext insert "branch -2c" "es"
5934 $ctext conf -state disabled
5939 if {[incr tagphase] <= 2} {
5940 after idle dispnexttag
5944 proc make_secsel {l} {
5945 global linehtag linentag linedtag canv canv2 canv3
5947 if {![info exists linehtag($l)]} return
5948 $canv delete secsel
5949 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5950 -tags secsel -fill [$canv cget -selectbackground]]
5951 $canv lower $t
5952 $canv2 delete secsel
5953 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5954 -tags secsel -fill [$canv2 cget -selectbackground]]
5955 $canv2 lower $t
5956 $canv3 delete secsel
5957 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5958 -tags secsel -fill [$canv3 cget -selectbackground]]
5959 $canv3 lower $t
5962 proc selectline {l isnew} {
5963 global canv ctext commitinfo selectedline
5964 global canvy0 linespc parents children curview
5965 global currentid sha1entry
5966 global commentend idtags linknum
5967 global mergemax numcommits pending_select
5968 global cmitmode showneartags allcommits
5969 global targetrow targetid lastscrollrows
5970 global autoselect
5972 catch {unset pending_select}
5973 $canv delete hover
5974 normalline
5975 unsel_reflist
5976 stopfinding
5977 if {$l < 0 || $l >= $numcommits} return
5978 set id [commitonrow $l]
5979 set targetid $id
5980 set targetrow $l
5981 set selectedline $l
5982 set currentid $id
5983 if {$lastscrollrows < $numcommits} {
5984 setcanvscroll
5987 set y [expr {$canvy0 + $l * $linespc}]
5988 set ymax [lindex [$canv cget -scrollregion] 3]
5989 set ytop [expr {$y - $linespc - 1}]
5990 set ybot [expr {$y + $linespc + 1}]
5991 set wnow [$canv yview]
5992 set wtop [expr {[lindex $wnow 0] * $ymax}]
5993 set wbot [expr {[lindex $wnow 1] * $ymax}]
5994 set wh [expr {$wbot - $wtop}]
5995 set newtop $wtop
5996 if {$ytop < $wtop} {
5997 if {$ybot < $wtop} {
5998 set newtop [expr {$y - $wh / 2.0}]
5999 } else {
6000 set newtop $ytop
6001 if {$newtop > $wtop - $linespc} {
6002 set newtop [expr {$wtop - $linespc}]
6005 } elseif {$ybot > $wbot} {
6006 if {$ytop > $wbot} {
6007 set newtop [expr {$y - $wh / 2.0}]
6008 } else {
6009 set newtop [expr {$ybot - $wh}]
6010 if {$newtop < $wtop + $linespc} {
6011 set newtop [expr {$wtop + $linespc}]
6015 if {$newtop != $wtop} {
6016 if {$newtop < 0} {
6017 set newtop 0
6019 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6020 drawvisible
6023 make_secsel $l
6025 if {$isnew} {
6026 addtohistory [list selbyid $id]
6029 $sha1entry delete 0 end
6030 $sha1entry insert 0 $id
6031 if {$autoselect} {
6032 $sha1entry selection from 0
6033 $sha1entry selection to end
6035 rhighlight_sel $id
6037 $ctext conf -state normal
6038 clear_ctext
6039 set linknum 0
6040 if {![info exists commitinfo($id)]} {
6041 getcommit $id
6043 set info $commitinfo($id)
6044 set date [formatdate [lindex $info 2]]
6045 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6046 set date [formatdate [lindex $info 4]]
6047 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6048 if {[info exists idtags($id)]} {
6049 $ctext insert end [mc "Tags:"]
6050 foreach tag $idtags($id) {
6051 $ctext insert end " $tag"
6053 $ctext insert end "\n"
6056 set headers {}
6057 set olds $parents($curview,$id)
6058 if {[llength $olds] > 1} {
6059 set np 0
6060 foreach p $olds {
6061 if {$np >= $mergemax} {
6062 set tag mmax
6063 } else {
6064 set tag m$np
6066 $ctext insert end "[mc "Parent"]: " $tag
6067 appendwithlinks [commit_descriptor $p] {}
6068 incr np
6070 } else {
6071 foreach p $olds {
6072 append headers "[mc "Parent"]: [commit_descriptor $p]"
6076 foreach c $children($curview,$id) {
6077 append headers "[mc "Child"]: [commit_descriptor $c]"
6080 # make anything that looks like a SHA1 ID be a clickable link
6081 appendwithlinks $headers {}
6082 if {$showneartags} {
6083 if {![info exists allcommits]} {
6084 getallcommits
6086 $ctext insert end "[mc "Branch"]: "
6087 $ctext mark set branch "end -1c"
6088 $ctext mark gravity branch left
6089 $ctext insert end "\n[mc "Follows"]: "
6090 $ctext mark set follows "end -1c"
6091 $ctext mark gravity follows left
6092 $ctext insert end "\n[mc "Precedes"]: "
6093 $ctext mark set precedes "end -1c"
6094 $ctext mark gravity precedes left
6095 $ctext insert end "\n"
6096 dispneartags 1
6098 $ctext insert end "\n"
6099 set comment [lindex $info 5]
6100 if {[string first "\r" $comment] >= 0} {
6101 set comment [string map {"\r" "\n "} $comment]
6103 appendwithlinks $comment {comment}
6105 $ctext tag remove found 1.0 end
6106 $ctext conf -state disabled
6107 set commentend [$ctext index "end - 1c"]
6109 init_flist [mc "Comments"]
6110 if {$cmitmode eq "tree"} {
6111 gettree $id
6112 } elseif {[llength $olds] <= 1} {
6113 startdiff $id
6114 } else {
6115 mergediff $id
6119 proc selfirstline {} {
6120 unmarkmatches
6121 selectline 0 1
6124 proc sellastline {} {
6125 global numcommits
6126 unmarkmatches
6127 set l [expr {$numcommits - 1}]
6128 selectline $l 1
6131 proc selnextline {dir} {
6132 global selectedline
6133 focus .
6134 if {$selectedline eq {}} return
6135 set l [expr {$selectedline + $dir}]
6136 unmarkmatches
6137 selectline $l 1
6140 proc selnextpage {dir} {
6141 global canv linespc selectedline numcommits
6143 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6144 if {$lpp < 1} {
6145 set lpp 1
6147 allcanvs yview scroll [expr {$dir * $lpp}] units
6148 drawvisible
6149 if {$selectedline eq {}} return
6150 set l [expr {$selectedline + $dir * $lpp}]
6151 if {$l < 0} {
6152 set l 0
6153 } elseif {$l >= $numcommits} {
6154 set l [expr $numcommits - 1]
6156 unmarkmatches
6157 selectline $l 1
6160 proc unselectline {} {
6161 global selectedline currentid
6163 set selectedline {}
6164 catch {unset currentid}
6165 allcanvs delete secsel
6166 rhighlight_none
6169 proc reselectline {} {
6170 global selectedline
6172 if {$selectedline ne {}} {
6173 selectline $selectedline 0
6177 proc addtohistory {cmd} {
6178 global history historyindex curview
6180 set elt [list $curview $cmd]
6181 if {$historyindex > 0
6182 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6183 return
6186 if {$historyindex < [llength $history]} {
6187 set history [lreplace $history $historyindex end $elt]
6188 } else {
6189 lappend history $elt
6191 incr historyindex
6192 if {$historyindex > 1} {
6193 .tf.bar.leftbut conf -state normal
6194 } else {
6195 .tf.bar.leftbut conf -state disabled
6197 .tf.bar.rightbut conf -state disabled
6200 proc godo {elt} {
6201 global curview
6203 set view [lindex $elt 0]
6204 set cmd [lindex $elt 1]
6205 if {$curview != $view} {
6206 showview $view
6208 eval $cmd
6211 proc goback {} {
6212 global history historyindex
6213 focus .
6215 if {$historyindex > 1} {
6216 incr historyindex -1
6217 godo [lindex $history [expr {$historyindex - 1}]]
6218 .tf.bar.rightbut conf -state normal
6220 if {$historyindex <= 1} {
6221 .tf.bar.leftbut conf -state disabled
6225 proc goforw {} {
6226 global history historyindex
6227 focus .
6229 if {$historyindex < [llength $history]} {
6230 set cmd [lindex $history $historyindex]
6231 incr historyindex
6232 godo $cmd
6233 .tf.bar.leftbut conf -state normal
6235 if {$historyindex >= [llength $history]} {
6236 .tf.bar.rightbut conf -state disabled
6240 proc gettree {id} {
6241 global treefilelist treeidlist diffids diffmergeid treepending
6242 global nullid nullid2
6244 set diffids $id
6245 catch {unset diffmergeid}
6246 if {![info exists treefilelist($id)]} {
6247 if {![info exists treepending]} {
6248 if {$id eq $nullid} {
6249 set cmd [list | git ls-files]
6250 } elseif {$id eq $nullid2} {
6251 set cmd [list | git ls-files --stage -t]
6252 } else {
6253 set cmd [list | git ls-tree -r $id]
6255 if {[catch {set gtf [open $cmd r]}]} {
6256 return
6258 set treepending $id
6259 set treefilelist($id) {}
6260 set treeidlist($id) {}
6261 fconfigure $gtf -blocking 0 -encoding binary
6262 filerun $gtf [list gettreeline $gtf $id]
6264 } else {
6265 setfilelist $id
6269 proc gettreeline {gtf id} {
6270 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6272 set nl 0
6273 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6274 if {$diffids eq $nullid} {
6275 set fname $line
6276 } else {
6277 set i [string first "\t" $line]
6278 if {$i < 0} continue
6279 set fname [string range $line [expr {$i+1}] end]
6280 set line [string range $line 0 [expr {$i-1}]]
6281 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6282 set sha1 [lindex $line 2]
6283 lappend treeidlist($id) $sha1
6285 if {[string index $fname 0] eq "\""} {
6286 set fname [lindex $fname 0]
6288 set fname [encoding convertfrom $fname]
6289 lappend treefilelist($id) $fname
6291 if {![eof $gtf]} {
6292 return [expr {$nl >= 1000? 2: 1}]
6294 close $gtf
6295 unset treepending
6296 if {$cmitmode ne "tree"} {
6297 if {![info exists diffmergeid]} {
6298 gettreediffs $diffids
6300 } elseif {$id ne $diffids} {
6301 gettree $diffids
6302 } else {
6303 setfilelist $id
6305 return 0
6308 proc showfile {f} {
6309 global treefilelist treeidlist diffids nullid nullid2
6310 global ctext commentend
6312 set i [lsearch -exact $treefilelist($diffids) $f]
6313 if {$i < 0} {
6314 puts "oops, $f not in list for id $diffids"
6315 return
6317 if {$diffids eq $nullid} {
6318 if {[catch {set bf [open $f r]} err]} {
6319 puts "oops, can't read $f: $err"
6320 return
6322 } else {
6323 set blob [lindex $treeidlist($diffids) $i]
6324 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6325 puts "oops, error reading blob $blob: $err"
6326 return
6329 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6330 filerun $bf [list getblobline $bf $diffids]
6331 $ctext config -state normal
6332 clear_ctext $commentend
6333 $ctext insert end "\n"
6334 $ctext insert end "$f\n" filesep
6335 $ctext config -state disabled
6336 $ctext yview $commentend
6337 settabs 0
6340 proc getblobline {bf id} {
6341 global diffids cmitmode ctext
6343 if {$id ne $diffids || $cmitmode ne "tree"} {
6344 catch {close $bf}
6345 return 0
6347 $ctext config -state normal
6348 set nl 0
6349 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6350 $ctext insert end "$line\n"
6352 if {[eof $bf]} {
6353 # delete last newline
6354 $ctext delete "end - 2c" "end - 1c"
6355 close $bf
6356 return 0
6358 $ctext config -state disabled
6359 return [expr {$nl >= 1000? 2: 1}]
6362 proc mergediff {id} {
6363 global diffmergeid mdifffd
6364 global diffids
6365 global parents
6366 global diffcontext
6367 global diffencoding
6368 global limitdiffs vfilelimit curview
6370 set diffmergeid $id
6371 set diffids $id
6372 # this doesn't seem to actually affect anything...
6373 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6374 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6375 set cmd [concat $cmd -- $vfilelimit($curview)]
6377 if {[catch {set mdf [open $cmd r]} err]} {
6378 error_popup "[mc "Error getting merge diffs:"] $err"
6379 return
6381 fconfigure $mdf -blocking 0 -encoding binary
6382 set mdifffd($id) $mdf
6383 set np [llength $parents($curview,$id)]
6384 set diffencoding [get_path_encoding {}]
6385 settabs $np
6386 filerun $mdf [list getmergediffline $mdf $id $np]
6389 proc getmergediffline {mdf id np} {
6390 global diffmergeid ctext cflist mergemax
6391 global difffilestart mdifffd
6392 global diffencoding
6394 $ctext conf -state normal
6395 set nr 0
6396 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6397 if {![info exists diffmergeid] || $id != $diffmergeid
6398 || $mdf != $mdifffd($id)} {
6399 close $mdf
6400 return 0
6402 if {[regexp {^diff --cc (.*)} $line match fname]} {
6403 # start of a new file
6404 set fname [encoding convertfrom $fname]
6405 $ctext insert end "\n"
6406 set here [$ctext index "end - 1c"]
6407 lappend difffilestart $here
6408 add_flist [list $fname]
6409 set diffencoding [get_path_encoding $fname]
6410 set l [expr {(78 - [string length $fname]) / 2}]
6411 set pad [string range "----------------------------------------" 1 $l]
6412 $ctext insert end "$pad $fname $pad\n" filesep
6413 } elseif {[regexp {^@@} $line]} {
6414 set line [encoding convertfrom $diffencoding $line]
6415 $ctext insert end "$line\n" hunksep
6416 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6417 # do nothing
6418 } else {
6419 set line [encoding convertfrom $diffencoding $line]
6420 # parse the prefix - one ' ', '-' or '+' for each parent
6421 set spaces {}
6422 set minuses {}
6423 set pluses {}
6424 set isbad 0
6425 for {set j 0} {$j < $np} {incr j} {
6426 set c [string range $line $j $j]
6427 if {$c == " "} {
6428 lappend spaces $j
6429 } elseif {$c == "-"} {
6430 lappend minuses $j
6431 } elseif {$c == "+"} {
6432 lappend pluses $j
6433 } else {
6434 set isbad 1
6435 break
6438 set tags {}
6439 set num {}
6440 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6441 # line doesn't appear in result, parents in $minuses have the line
6442 set num [lindex $minuses 0]
6443 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6444 # line appears in result, parents in $pluses don't have the line
6445 lappend tags mresult
6446 set num [lindex $spaces 0]
6448 if {$num ne {}} {
6449 if {$num >= $mergemax} {
6450 set num "max"
6452 lappend tags m$num
6454 $ctext insert end "$line\n" $tags
6457 $ctext conf -state disabled
6458 if {[eof $mdf]} {
6459 close $mdf
6460 return 0
6462 return [expr {$nr >= 1000? 2: 1}]
6465 proc startdiff {ids} {
6466 global treediffs diffids treepending diffmergeid nullid nullid2
6468 settabs 1
6469 set diffids $ids
6470 catch {unset diffmergeid}
6471 if {![info exists treediffs($ids)] ||
6472 [lsearch -exact $ids $nullid] >= 0 ||
6473 [lsearch -exact $ids $nullid2] >= 0} {
6474 if {![info exists treepending]} {
6475 gettreediffs $ids
6477 } else {
6478 addtocflist $ids
6482 proc path_filter {filter name} {
6483 foreach p $filter {
6484 set l [string length $p]
6485 if {[string index $p end] eq "/"} {
6486 if {[string compare -length $l $p $name] == 0} {
6487 return 1
6489 } else {
6490 if {[string compare -length $l $p $name] == 0 &&
6491 ([string length $name] == $l ||
6492 [string index $name $l] eq "/")} {
6493 return 1
6497 return 0
6500 proc addtocflist {ids} {
6501 global treediffs
6503 add_flist $treediffs($ids)
6504 getblobdiffs $ids
6507 proc diffcmd {ids flags} {
6508 global nullid nullid2
6510 set i [lsearch -exact $ids $nullid]
6511 set j [lsearch -exact $ids $nullid2]
6512 if {$i >= 0} {
6513 if {[llength $ids] > 1 && $j < 0} {
6514 # comparing working directory with some specific revision
6515 set cmd [concat | git diff-index $flags]
6516 if {$i == 0} {
6517 lappend cmd -R [lindex $ids 1]
6518 } else {
6519 lappend cmd [lindex $ids 0]
6521 } else {
6522 # comparing working directory with index
6523 set cmd [concat | git diff-files $flags]
6524 if {$j == 1} {
6525 lappend cmd -R
6528 } elseif {$j >= 0} {
6529 set cmd [concat | git diff-index --cached $flags]
6530 if {[llength $ids] > 1} {
6531 # comparing index with specific revision
6532 if {$i == 0} {
6533 lappend cmd -R [lindex $ids 1]
6534 } else {
6535 lappend cmd [lindex $ids 0]
6537 } else {
6538 # comparing index with HEAD
6539 lappend cmd HEAD
6541 } else {
6542 set cmd [concat | git diff-tree -r $flags $ids]
6544 return $cmd
6547 proc gettreediffs {ids} {
6548 global treediff treepending
6550 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6552 set treepending $ids
6553 set treediff {}
6554 fconfigure $gdtf -blocking 0 -encoding binary
6555 filerun $gdtf [list gettreediffline $gdtf $ids]
6558 proc gettreediffline {gdtf ids} {
6559 global treediff treediffs treepending diffids diffmergeid
6560 global cmitmode vfilelimit curview limitdiffs perfile_attrs
6562 set nr 0
6563 set sublist {}
6564 set max 1000
6565 if {$perfile_attrs} {
6566 # cache_gitattr is slow, and even slower on win32 where we
6567 # have to invoke it for only about 30 paths at a time
6568 set max 500
6569 if {[tk windowingsystem] == "win32"} {
6570 set max 120
6573 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
6574 set i [string first "\t" $line]
6575 if {$i >= 0} {
6576 set file [string range $line [expr {$i+1}] end]
6577 if {[string index $file 0] eq "\""} {
6578 set file [lindex $file 0]
6580 set file [encoding convertfrom $file]
6581 lappend treediff $file
6582 lappend sublist $file
6585 if {$perfile_attrs} {
6586 cache_gitattr encoding $sublist
6588 if {![eof $gdtf]} {
6589 return [expr {$nr >= $max? 2: 1}]
6591 close $gdtf
6592 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6593 set flist {}
6594 foreach f $treediff {
6595 if {[path_filter $vfilelimit($curview) $f]} {
6596 lappend flist $f
6599 set treediffs($ids) $flist
6600 } else {
6601 set treediffs($ids) $treediff
6603 unset treepending
6604 if {$cmitmode eq "tree"} {
6605 gettree $diffids
6606 } elseif {$ids != $diffids} {
6607 if {![info exists diffmergeid]} {
6608 gettreediffs $diffids
6610 } else {
6611 addtocflist $ids
6613 return 0
6616 # empty string or positive integer
6617 proc diffcontextvalidate {v} {
6618 return [regexp {^(|[1-9][0-9]*)$} $v]
6621 proc diffcontextchange {n1 n2 op} {
6622 global diffcontextstring diffcontext
6624 if {[string is integer -strict $diffcontextstring]} {
6625 if {$diffcontextstring > 0} {
6626 set diffcontext $diffcontextstring
6627 reselectline
6632 proc changeignorespace {} {
6633 reselectline
6636 proc getblobdiffs {ids} {
6637 global blobdifffd diffids env
6638 global diffinhdr treediffs
6639 global diffcontext
6640 global ignorespace
6641 global limitdiffs vfilelimit curview
6642 global diffencoding
6644 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6645 if {$ignorespace} {
6646 append cmd " -w"
6648 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6649 set cmd [concat $cmd -- $vfilelimit($curview)]
6651 if {[catch {set bdf [open $cmd r]} err]} {
6652 puts "error getting diffs: $err"
6653 return
6655 set diffinhdr 0
6656 set diffencoding [get_path_encoding {}]
6657 fconfigure $bdf -blocking 0 -encoding binary
6658 set blobdifffd($ids) $bdf
6659 filerun $bdf [list getblobdiffline $bdf $diffids]
6662 proc setinlist {var i val} {
6663 global $var
6665 while {[llength [set $var]] < $i} {
6666 lappend $var {}
6668 if {[llength [set $var]] == $i} {
6669 lappend $var $val
6670 } else {
6671 lset $var $i $val
6675 proc makediffhdr {fname ids} {
6676 global ctext curdiffstart treediffs
6678 set i [lsearch -exact $treediffs($ids) $fname]
6679 if {$i >= 0} {
6680 setinlist difffilestart $i $curdiffstart
6682 set l [expr {(78 - [string length $fname]) / 2}]
6683 set pad [string range "----------------------------------------" 1 $l]
6684 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6687 proc getblobdiffline {bdf ids} {
6688 global diffids blobdifffd ctext curdiffstart
6689 global diffnexthead diffnextnote difffilestart
6690 global diffinhdr treediffs
6691 global diffencoding
6693 set nr 0
6694 $ctext conf -state normal
6695 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6696 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6697 close $bdf
6698 return 0
6700 if {![string compare -length 11 "diff --git " $line]} {
6701 # trim off "diff --git "
6702 set line [string range $line 11 end]
6703 set diffinhdr 1
6704 # start of a new file
6705 $ctext insert end "\n"
6706 set curdiffstart [$ctext index "end - 1c"]
6707 $ctext insert end "\n" filesep
6708 # If the name hasn't changed the length will be odd,
6709 # the middle char will be a space, and the two bits either
6710 # side will be a/name and b/name, or "a/name" and "b/name".
6711 # If the name has changed we'll get "rename from" and
6712 # "rename to" or "copy from" and "copy to" lines following this,
6713 # and we'll use them to get the filenames.
6714 # This complexity is necessary because spaces in the filename(s)
6715 # don't get escaped.
6716 set l [string length $line]
6717 set i [expr {$l / 2}]
6718 if {!(($l & 1) && [string index $line $i] eq " " &&
6719 [string range $line 2 [expr {$i - 1}]] eq \
6720 [string range $line [expr {$i + 3}] end])} {
6721 continue
6723 # unescape if quoted and chop off the a/ from the front
6724 if {[string index $line 0] eq "\""} {
6725 set fname [string range [lindex $line 0] 2 end]
6726 } else {
6727 set fname [string range $line 2 [expr {$i - 1}]]
6729 set fname [encoding convertfrom $fname]
6730 set diffencoding [get_path_encoding $fname]
6731 makediffhdr $fname $ids
6733 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6734 $line match f1l f1c f2l f2c rest]} {
6735 set line [encoding convertfrom $diffencoding $line]
6736 $ctext insert end "$line\n" hunksep
6737 set diffinhdr 0
6739 } elseif {$diffinhdr} {
6740 if {![string compare -length 12 "rename from " $line]} {
6741 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6742 if {[string index $fname 0] eq "\""} {
6743 set fname [lindex $fname 0]
6745 set fname [encoding convertfrom $fname]
6746 set i [lsearch -exact $treediffs($ids) $fname]
6747 if {$i >= 0} {
6748 setinlist difffilestart $i $curdiffstart
6750 } elseif {![string compare -length 10 $line "rename to "] ||
6751 ![string compare -length 8 $line "copy to "]} {
6752 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6753 if {[string index $fname 0] eq "\""} {
6754 set fname [lindex $fname 0]
6756 set fname [encoding convertfrom $fname]
6757 set diffencoding [get_path_encoding $fname]
6758 makediffhdr $fname $ids
6759 } elseif {[string compare -length 3 $line "---"] == 0} {
6760 # do nothing
6761 continue
6762 } elseif {[string compare -length 3 $line "+++"] == 0} {
6763 set diffinhdr 0
6764 continue
6766 $ctext insert end "$line\n" filesep
6768 } else {
6769 set line [encoding convertfrom $diffencoding $line]
6770 set x [string range $line 0 0]
6771 if {$x == "-" || $x == "+"} {
6772 set tag [expr {$x == "+"}]
6773 $ctext insert end "$line\n" d$tag
6774 } elseif {$x == " "} {
6775 $ctext insert end "$line\n"
6776 } else {
6777 # "\ No newline at end of file",
6778 # or something else we don't recognize
6779 $ctext insert end "$line\n" hunksep
6783 $ctext conf -state disabled
6784 if {[eof $bdf]} {
6785 close $bdf
6786 return 0
6788 return [expr {$nr >= 1000? 2: 1}]
6791 proc changediffdisp {} {
6792 global ctext diffelide
6794 $ctext tag conf d0 -elide [lindex $diffelide 0]
6795 $ctext tag conf d1 -elide [lindex $diffelide 1]
6798 proc highlightfile {loc cline} {
6799 global ctext cflist cflist_top
6801 $ctext yview $loc
6802 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6803 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6804 $cflist see $cline.0
6805 set cflist_top $cline
6808 proc prevfile {} {
6809 global difffilestart ctext cmitmode
6811 if {$cmitmode eq "tree"} return
6812 set prev 0.0
6813 set prevline 1
6814 set here [$ctext index @0,0]
6815 foreach loc $difffilestart {
6816 if {[$ctext compare $loc >= $here]} {
6817 highlightfile $prev $prevline
6818 return
6820 set prev $loc
6821 incr prevline
6823 highlightfile $prev $prevline
6826 proc nextfile {} {
6827 global difffilestart ctext cmitmode
6829 if {$cmitmode eq "tree"} return
6830 set here [$ctext index @0,0]
6831 set line 1
6832 foreach loc $difffilestart {
6833 incr line
6834 if {[$ctext compare $loc > $here]} {
6835 highlightfile $loc $line
6836 return
6841 proc clear_ctext {{first 1.0}} {
6842 global ctext smarktop smarkbot
6843 global pendinglinks
6845 set l [lindex [split $first .] 0]
6846 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6847 set smarktop $l
6849 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6850 set smarkbot $l
6852 $ctext delete $first end
6853 if {$first eq "1.0"} {
6854 catch {unset pendinglinks}
6858 proc settabs {{firstab {}}} {
6859 global firsttabstop tabstop ctext have_tk85
6861 if {$firstab ne {} && $have_tk85} {
6862 set firsttabstop $firstab
6864 set w [font measure textfont "0"]
6865 if {$firsttabstop != 0} {
6866 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6867 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6868 } elseif {$have_tk85 || $tabstop != 8} {
6869 $ctext conf -tabs [expr {$tabstop * $w}]
6870 } else {
6871 $ctext conf -tabs {}
6875 proc incrsearch {name ix op} {
6876 global ctext searchstring searchdirn
6878 $ctext tag remove found 1.0 end
6879 if {[catch {$ctext index anchor}]} {
6880 # no anchor set, use start of selection, or of visible area
6881 set sel [$ctext tag ranges sel]
6882 if {$sel ne {}} {
6883 $ctext mark set anchor [lindex $sel 0]
6884 } elseif {$searchdirn eq "-forwards"} {
6885 $ctext mark set anchor @0,0
6886 } else {
6887 $ctext mark set anchor @0,[winfo height $ctext]
6890 if {$searchstring ne {}} {
6891 set here [$ctext search $searchdirn -- $searchstring anchor]
6892 if {$here ne {}} {
6893 $ctext see $here
6895 searchmarkvisible 1
6899 proc dosearch {} {
6900 global sstring ctext searchstring searchdirn
6902 focus $sstring
6903 $sstring icursor end
6904 set searchdirn -forwards
6905 if {$searchstring ne {}} {
6906 set sel [$ctext tag ranges sel]
6907 if {$sel ne {}} {
6908 set start "[lindex $sel 0] + 1c"
6909 } elseif {[catch {set start [$ctext index anchor]}]} {
6910 set start "@0,0"
6912 set match [$ctext search -count mlen -- $searchstring $start]
6913 $ctext tag remove sel 1.0 end
6914 if {$match eq {}} {
6915 bell
6916 return
6918 $ctext see $match
6919 set mend "$match + $mlen c"
6920 $ctext tag add sel $match $mend
6921 $ctext mark unset anchor
6925 proc dosearchback {} {
6926 global sstring ctext searchstring searchdirn
6928 focus $sstring
6929 $sstring icursor end
6930 set searchdirn -backwards
6931 if {$searchstring ne {}} {
6932 set sel [$ctext tag ranges sel]
6933 if {$sel ne {}} {
6934 set start [lindex $sel 0]
6935 } elseif {[catch {set start [$ctext index anchor]}]} {
6936 set start @0,[winfo height $ctext]
6938 set match [$ctext search -backwards -count ml -- $searchstring $start]
6939 $ctext tag remove sel 1.0 end
6940 if {$match eq {}} {
6941 bell
6942 return
6944 $ctext see $match
6945 set mend "$match + $ml c"
6946 $ctext tag add sel $match $mend
6947 $ctext mark unset anchor
6951 proc searchmark {first last} {
6952 global ctext searchstring
6954 set mend $first.0
6955 while {1} {
6956 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6957 if {$match eq {}} break
6958 set mend "$match + $mlen c"
6959 $ctext tag add found $match $mend
6963 proc searchmarkvisible {doall} {
6964 global ctext smarktop smarkbot
6966 set topline [lindex [split [$ctext index @0,0] .] 0]
6967 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6968 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6969 # no overlap with previous
6970 searchmark $topline $botline
6971 set smarktop $topline
6972 set smarkbot $botline
6973 } else {
6974 if {$topline < $smarktop} {
6975 searchmark $topline [expr {$smarktop-1}]
6976 set smarktop $topline
6978 if {$botline > $smarkbot} {
6979 searchmark [expr {$smarkbot+1}] $botline
6980 set smarkbot $botline
6985 proc scrolltext {f0 f1} {
6986 global searchstring
6988 .bleft.bottom.sb set $f0 $f1
6989 if {$searchstring ne {}} {
6990 searchmarkvisible 0
6994 proc setcoords {} {
6995 global linespc charspc canvx0 canvy0
6996 global xspc1 xspc2 lthickness
6998 set linespc [font metrics mainfont -linespace]
6999 set charspc [font measure mainfont "m"]
7000 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7001 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7002 set lthickness [expr {int($linespc / 9) + 1}]
7003 set xspc1(0) $linespc
7004 set xspc2 $linespc
7007 proc redisplay {} {
7008 global canv
7009 global selectedline
7011 set ymax [lindex [$canv cget -scrollregion] 3]
7012 if {$ymax eq {} || $ymax == 0} return
7013 set span [$canv yview]
7014 clear_display
7015 setcanvscroll
7016 allcanvs yview moveto [lindex $span 0]
7017 drawvisible
7018 if {$selectedline ne {}} {
7019 selectline $selectedline 0
7020 allcanvs yview moveto [lindex $span 0]
7024 proc parsefont {f n} {
7025 global fontattr
7027 set fontattr($f,family) [lindex $n 0]
7028 set s [lindex $n 1]
7029 if {$s eq {} || $s == 0} {
7030 set s 10
7031 } elseif {$s < 0} {
7032 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7034 set fontattr($f,size) $s
7035 set fontattr($f,weight) normal
7036 set fontattr($f,slant) roman
7037 foreach style [lrange $n 2 end] {
7038 switch -- $style {
7039 "normal" -
7040 "bold" {set fontattr($f,weight) $style}
7041 "roman" -
7042 "italic" {set fontattr($f,slant) $style}
7047 proc fontflags {f {isbold 0}} {
7048 global fontattr
7050 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7051 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7052 -slant $fontattr($f,slant)]
7055 proc fontname {f} {
7056 global fontattr
7058 set n [list $fontattr($f,family) $fontattr($f,size)]
7059 if {$fontattr($f,weight) eq "bold"} {
7060 lappend n "bold"
7062 if {$fontattr($f,slant) eq "italic"} {
7063 lappend n "italic"
7065 return $n
7068 proc incrfont {inc} {
7069 global mainfont textfont ctext canv cflist showrefstop
7070 global stopped entries fontattr
7072 unmarkmatches
7073 set s $fontattr(mainfont,size)
7074 incr s $inc
7075 if {$s < 1} {
7076 set s 1
7078 set fontattr(mainfont,size) $s
7079 font config mainfont -size $s
7080 font config mainfontbold -size $s
7081 set mainfont [fontname mainfont]
7082 set s $fontattr(textfont,size)
7083 incr s $inc
7084 if {$s < 1} {
7085 set s 1
7087 set fontattr(textfont,size) $s
7088 font config textfont -size $s
7089 font config textfontbold -size $s
7090 set textfont [fontname textfont]
7091 setcoords
7092 settabs
7093 redisplay
7096 proc clearsha1 {} {
7097 global sha1entry sha1string
7098 if {[string length $sha1string] == 40} {
7099 $sha1entry delete 0 end
7103 proc sha1change {n1 n2 op} {
7104 global sha1string currentid sha1but
7105 if {$sha1string == {}
7106 || ([info exists currentid] && $sha1string == $currentid)} {
7107 set state disabled
7108 } else {
7109 set state normal
7111 if {[$sha1but cget -state] == $state} return
7112 if {$state == "normal"} {
7113 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7114 } else {
7115 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7119 proc gotocommit {} {
7120 global sha1string tagids headids curview varcid
7122 if {$sha1string == {}
7123 || ([info exists currentid] && $sha1string == $currentid)} return
7124 if {[info exists tagids($sha1string)]} {
7125 set id $tagids($sha1string)
7126 } elseif {[info exists headids($sha1string)]} {
7127 set id $headids($sha1string)
7128 } else {
7129 set id [string tolower $sha1string]
7130 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7131 set matches [array names varcid "$curview,$id*"]
7132 if {$matches ne {}} {
7133 if {[llength $matches] > 1} {
7134 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7135 return
7137 set id [lindex [split [lindex $matches 0] ","] 1]
7141 if {[commitinview $id $curview]} {
7142 selectline [rowofcommit $id] 1
7143 return
7145 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7146 set msg [mc "SHA1 id %s is not known" $sha1string]
7147 } else {
7148 set msg [mc "Tag/Head %s is not known" $sha1string]
7150 error_popup $msg
7153 proc lineenter {x y id} {
7154 global hoverx hovery hoverid hovertimer
7155 global commitinfo canv
7157 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7158 set hoverx $x
7159 set hovery $y
7160 set hoverid $id
7161 if {[info exists hovertimer]} {
7162 after cancel $hovertimer
7164 set hovertimer [after 500 linehover]
7165 $canv delete hover
7168 proc linemotion {x y id} {
7169 global hoverx hovery hoverid hovertimer
7171 if {[info exists hoverid] && $id == $hoverid} {
7172 set hoverx $x
7173 set hovery $y
7174 if {[info exists hovertimer]} {
7175 after cancel $hovertimer
7177 set hovertimer [after 500 linehover]
7181 proc lineleave {id} {
7182 global hoverid hovertimer canv
7184 if {[info exists hoverid] && $id == $hoverid} {
7185 $canv delete hover
7186 if {[info exists hovertimer]} {
7187 after cancel $hovertimer
7188 unset hovertimer
7190 unset hoverid
7194 proc linehover {} {
7195 global hoverx hovery hoverid hovertimer
7196 global canv linespc lthickness
7197 global commitinfo
7199 set text [lindex $commitinfo($hoverid) 0]
7200 set ymax [lindex [$canv cget -scrollregion] 3]
7201 if {$ymax == {}} return
7202 set yfrac [lindex [$canv yview] 0]
7203 set x [expr {$hoverx + 2 * $linespc}]
7204 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7205 set x0 [expr {$x - 2 * $lthickness}]
7206 set y0 [expr {$y - 2 * $lthickness}]
7207 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7208 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7209 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7210 -fill \#ffff80 -outline black -width 1 -tags hover]
7211 $canv raise $t
7212 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7213 -font mainfont]
7214 $canv raise $t
7217 proc clickisonarrow {id y} {
7218 global lthickness
7220 set ranges [rowranges $id]
7221 set thresh [expr {2 * $lthickness + 6}]
7222 set n [expr {[llength $ranges] - 1}]
7223 for {set i 1} {$i < $n} {incr i} {
7224 set row [lindex $ranges $i]
7225 if {abs([yc $row] - $y) < $thresh} {
7226 return $i
7229 return {}
7232 proc arrowjump {id n y} {
7233 global canv
7235 # 1 <-> 2, 3 <-> 4, etc...
7236 set n [expr {(($n - 1) ^ 1) + 1}]
7237 set row [lindex [rowranges $id] $n]
7238 set yt [yc $row]
7239 set ymax [lindex [$canv cget -scrollregion] 3]
7240 if {$ymax eq {} || $ymax <= 0} return
7241 set view [$canv yview]
7242 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7243 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7244 if {$yfrac < 0} {
7245 set yfrac 0
7247 allcanvs yview moveto $yfrac
7250 proc lineclick {x y id isnew} {
7251 global ctext commitinfo children canv thickerline curview
7253 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7254 unmarkmatches
7255 unselectline
7256 normalline
7257 $canv delete hover
7258 # draw this line thicker than normal
7259 set thickerline $id
7260 drawlines $id
7261 if {$isnew} {
7262 set ymax [lindex [$canv cget -scrollregion] 3]
7263 if {$ymax eq {}} return
7264 set yfrac [lindex [$canv yview] 0]
7265 set y [expr {$y + $yfrac * $ymax}]
7267 set dirn [clickisonarrow $id $y]
7268 if {$dirn ne {}} {
7269 arrowjump $id $dirn $y
7270 return
7273 if {$isnew} {
7274 addtohistory [list lineclick $x $y $id 0]
7276 # fill the details pane with info about this line
7277 $ctext conf -state normal
7278 clear_ctext
7279 settabs 0
7280 $ctext insert end "[mc "Parent"]:\t"
7281 $ctext insert end $id link0
7282 setlink $id link0
7283 set info $commitinfo($id)
7284 $ctext insert end "\n\t[lindex $info 0]\n"
7285 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7286 set date [formatdate [lindex $info 2]]
7287 $ctext insert end "\t[mc "Date"]:\t$date\n"
7288 set kids $children($curview,$id)
7289 if {$kids ne {}} {
7290 $ctext insert end "\n[mc "Children"]:"
7291 set i 0
7292 foreach child $kids {
7293 incr i
7294 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7295 set info $commitinfo($child)
7296 $ctext insert end "\n\t"
7297 $ctext insert end $child link$i
7298 setlink $child link$i
7299 $ctext insert end "\n\t[lindex $info 0]"
7300 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7301 set date [formatdate [lindex $info 2]]
7302 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7305 $ctext conf -state disabled
7306 init_flist {}
7309 proc normalline {} {
7310 global thickerline
7311 if {[info exists thickerline]} {
7312 set id $thickerline
7313 unset thickerline
7314 drawlines $id
7318 proc selbyid {id} {
7319 global curview
7320 if {[commitinview $id $curview]} {
7321 selectline [rowofcommit $id] 1
7325 proc mstime {} {
7326 global startmstime
7327 if {![info exists startmstime]} {
7328 set startmstime [clock clicks -milliseconds]
7330 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7333 proc rowmenu {x y id} {
7334 global rowctxmenu selectedline rowmenuid curview
7335 global nullid nullid2 fakerowmenu mainhead
7337 stopfinding
7338 set rowmenuid $id
7339 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7340 set state disabled
7341 } else {
7342 set state normal
7344 if {$id ne $nullid && $id ne $nullid2} {
7345 set menu $rowctxmenu
7346 if {$mainhead ne {}} {
7347 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7348 } else {
7349 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7351 } else {
7352 set menu $fakerowmenu
7354 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7355 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7356 $menu entryconfigure [mca "Make patch"] -state $state
7357 tk_popup $menu $x $y
7360 proc diffvssel {dirn} {
7361 global rowmenuid selectedline
7363 if {$selectedline eq {}} return
7364 if {$dirn} {
7365 set oldid [commitonrow $selectedline]
7366 set newid $rowmenuid
7367 } else {
7368 set oldid $rowmenuid
7369 set newid [commitonrow $selectedline]
7371 addtohistory [list doseldiff $oldid $newid]
7372 doseldiff $oldid $newid
7375 proc doseldiff {oldid newid} {
7376 global ctext
7377 global commitinfo
7379 $ctext conf -state normal
7380 clear_ctext
7381 init_flist [mc "Top"]
7382 $ctext insert end "[mc "From"] "
7383 $ctext insert end $oldid link0
7384 setlink $oldid link0
7385 $ctext insert end "\n "
7386 $ctext insert end [lindex $commitinfo($oldid) 0]
7387 $ctext insert end "\n\n[mc "To"] "
7388 $ctext insert end $newid link1
7389 setlink $newid link1
7390 $ctext insert end "\n "
7391 $ctext insert end [lindex $commitinfo($newid) 0]
7392 $ctext insert end "\n"
7393 $ctext conf -state disabled
7394 $ctext tag remove found 1.0 end
7395 startdiff [list $oldid $newid]
7398 proc mkpatch {} {
7399 global rowmenuid currentid commitinfo patchtop patchnum
7401 if {![info exists currentid]} return
7402 set oldid $currentid
7403 set oldhead [lindex $commitinfo($oldid) 0]
7404 set newid $rowmenuid
7405 set newhead [lindex $commitinfo($newid) 0]
7406 set top .patch
7407 set patchtop $top
7408 catch {destroy $top}
7409 toplevel $top
7410 label $top.title -text [mc "Generate patch"]
7411 grid $top.title - -pady 10
7412 label $top.from -text [mc "From:"]
7413 entry $top.fromsha1 -width 40 -relief flat
7414 $top.fromsha1 insert 0 $oldid
7415 $top.fromsha1 conf -state readonly
7416 grid $top.from $top.fromsha1 -sticky w
7417 entry $top.fromhead -width 60 -relief flat
7418 $top.fromhead insert 0 $oldhead
7419 $top.fromhead conf -state readonly
7420 grid x $top.fromhead -sticky w
7421 label $top.to -text [mc "To:"]
7422 entry $top.tosha1 -width 40 -relief flat
7423 $top.tosha1 insert 0 $newid
7424 $top.tosha1 conf -state readonly
7425 grid $top.to $top.tosha1 -sticky w
7426 entry $top.tohead -width 60 -relief flat
7427 $top.tohead insert 0 $newhead
7428 $top.tohead conf -state readonly
7429 grid x $top.tohead -sticky w
7430 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7431 grid $top.rev x -pady 10
7432 label $top.flab -text [mc "Output file:"]
7433 entry $top.fname -width 60
7434 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7435 incr patchnum
7436 grid $top.flab $top.fname -sticky w
7437 frame $top.buts
7438 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7439 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7440 grid $top.buts.gen $top.buts.can
7441 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7442 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7443 grid $top.buts - -pady 10 -sticky ew
7444 focus $top.fname
7447 proc mkpatchrev {} {
7448 global patchtop
7450 set oldid [$patchtop.fromsha1 get]
7451 set oldhead [$patchtop.fromhead get]
7452 set newid [$patchtop.tosha1 get]
7453 set newhead [$patchtop.tohead get]
7454 foreach e [list fromsha1 fromhead tosha1 tohead] \
7455 v [list $newid $newhead $oldid $oldhead] {
7456 $patchtop.$e conf -state normal
7457 $patchtop.$e delete 0 end
7458 $patchtop.$e insert 0 $v
7459 $patchtop.$e conf -state readonly
7463 proc mkpatchgo {} {
7464 global patchtop nullid nullid2
7466 set oldid [$patchtop.fromsha1 get]
7467 set newid [$patchtop.tosha1 get]
7468 set fname [$patchtop.fname get]
7469 set cmd [diffcmd [list $oldid $newid] -p]
7470 # trim off the initial "|"
7471 set cmd [lrange $cmd 1 end]
7472 lappend cmd >$fname &
7473 if {[catch {eval exec $cmd} err]} {
7474 error_popup "[mc "Error creating patch:"] $err"
7476 catch {destroy $patchtop}
7477 unset patchtop
7480 proc mkpatchcan {} {
7481 global patchtop
7483 catch {destroy $patchtop}
7484 unset patchtop
7487 proc mktag {} {
7488 global rowmenuid mktagtop commitinfo
7490 set top .maketag
7491 set mktagtop $top
7492 catch {destroy $top}
7493 toplevel $top
7494 label $top.title -text [mc "Create tag"]
7495 grid $top.title - -pady 10
7496 label $top.id -text [mc "ID:"]
7497 entry $top.sha1 -width 40 -relief flat
7498 $top.sha1 insert 0 $rowmenuid
7499 $top.sha1 conf -state readonly
7500 grid $top.id $top.sha1 -sticky w
7501 entry $top.head -width 60 -relief flat
7502 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7503 $top.head conf -state readonly
7504 grid x $top.head -sticky w
7505 label $top.tlab -text [mc "Tag name:"]
7506 entry $top.tag -width 60
7507 grid $top.tlab $top.tag -sticky w
7508 frame $top.buts
7509 button $top.buts.gen -text [mc "Create"] -command mktaggo
7510 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7511 grid $top.buts.gen $top.buts.can
7512 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7513 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7514 grid $top.buts - -pady 10 -sticky ew
7515 focus $top.tag
7518 proc domktag {} {
7519 global mktagtop env tagids idtags
7521 set id [$mktagtop.sha1 get]
7522 set tag [$mktagtop.tag get]
7523 if {$tag == {}} {
7524 error_popup [mc "No tag name specified"]
7525 return
7527 if {[info exists tagids($tag)]} {
7528 error_popup [mc "Tag \"%s\" already exists" $tag]
7529 return
7531 if {[catch {
7532 exec git tag $tag $id
7533 } err]} {
7534 error_popup "[mc "Error creating tag:"] $err"
7535 return
7538 set tagids($tag) $id
7539 lappend idtags($id) $tag
7540 redrawtags $id
7541 addedtag $id
7542 dispneartags 0
7543 run refill_reflist
7546 proc redrawtags {id} {
7547 global canv linehtag idpos currentid curview cmitlisted
7548 global canvxmax iddrawn circleitem mainheadid circlecolors
7550 if {![commitinview $id $curview]} return
7551 if {![info exists iddrawn($id)]} return
7552 set row [rowofcommit $id]
7553 if {$id eq $mainheadid} {
7554 set ofill yellow
7555 } else {
7556 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7558 $canv itemconf $circleitem($row) -fill $ofill
7559 $canv delete tag.$id
7560 set xt [eval drawtags $id $idpos($id)]
7561 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7562 set text [$canv itemcget $linehtag($row) -text]
7563 set font [$canv itemcget $linehtag($row) -font]
7564 set xr [expr {$xt + [font measure $font $text]}]
7565 if {$xr > $canvxmax} {
7566 set canvxmax $xr
7567 setcanvscroll
7569 if {[info exists currentid] && $currentid == $id} {
7570 make_secsel $row
7574 proc mktagcan {} {
7575 global mktagtop
7577 catch {destroy $mktagtop}
7578 unset mktagtop
7581 proc mktaggo {} {
7582 domktag
7583 mktagcan
7586 proc writecommit {} {
7587 global rowmenuid wrcomtop commitinfo wrcomcmd
7589 set top .writecommit
7590 set wrcomtop $top
7591 catch {destroy $top}
7592 toplevel $top
7593 label $top.title -text [mc "Write commit to file"]
7594 grid $top.title - -pady 10
7595 label $top.id -text [mc "ID:"]
7596 entry $top.sha1 -width 40 -relief flat
7597 $top.sha1 insert 0 $rowmenuid
7598 $top.sha1 conf -state readonly
7599 grid $top.id $top.sha1 -sticky w
7600 entry $top.head -width 60 -relief flat
7601 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7602 $top.head conf -state readonly
7603 grid x $top.head -sticky w
7604 label $top.clab -text [mc "Command:"]
7605 entry $top.cmd -width 60 -textvariable wrcomcmd
7606 grid $top.clab $top.cmd -sticky w -pady 10
7607 label $top.flab -text [mc "Output file:"]
7608 entry $top.fname -width 60
7609 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7610 grid $top.flab $top.fname -sticky w
7611 frame $top.buts
7612 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7613 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7614 grid $top.buts.gen $top.buts.can
7615 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7616 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7617 grid $top.buts - -pady 10 -sticky ew
7618 focus $top.fname
7621 proc wrcomgo {} {
7622 global wrcomtop
7624 set id [$wrcomtop.sha1 get]
7625 set cmd "echo $id | [$wrcomtop.cmd get]"
7626 set fname [$wrcomtop.fname get]
7627 if {[catch {exec sh -c $cmd >$fname &} err]} {
7628 error_popup "[mc "Error writing commit:"] $err"
7630 catch {destroy $wrcomtop}
7631 unset wrcomtop
7634 proc wrcomcan {} {
7635 global wrcomtop
7637 catch {destroy $wrcomtop}
7638 unset wrcomtop
7641 proc mkbranch {} {
7642 global rowmenuid mkbrtop
7644 set top .makebranch
7645 catch {destroy $top}
7646 toplevel $top
7647 label $top.title -text [mc "Create new branch"]
7648 grid $top.title - -pady 10
7649 label $top.id -text [mc "ID:"]
7650 entry $top.sha1 -width 40 -relief flat
7651 $top.sha1 insert 0 $rowmenuid
7652 $top.sha1 conf -state readonly
7653 grid $top.id $top.sha1 -sticky w
7654 label $top.nlab -text [mc "Name:"]
7655 entry $top.name -width 40
7656 bind $top.name <Key-Return> "[list mkbrgo $top]"
7657 grid $top.nlab $top.name -sticky w
7658 frame $top.buts
7659 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7660 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7661 grid $top.buts.go $top.buts.can
7662 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7663 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7664 grid $top.buts - -pady 10 -sticky ew
7665 focus $top.name
7668 proc mkbrgo {top} {
7669 global headids idheads
7671 set name [$top.name get]
7672 set id [$top.sha1 get]
7673 if {$name eq {}} {
7674 error_popup [mc "Please specify a name for the new branch"]
7675 return
7677 catch {destroy $top}
7678 nowbusy newbranch
7679 update
7680 if {[catch {
7681 exec git branch $name $id
7682 } err]} {
7683 notbusy newbranch
7684 error_popup $err
7685 } else {
7686 set headids($name) $id
7687 lappend idheads($id) $name
7688 addedhead $id $name
7689 notbusy newbranch
7690 redrawtags $id
7691 dispneartags 0
7692 run refill_reflist
7696 proc cherrypick {} {
7697 global rowmenuid curview
7698 global mainhead mainheadid
7700 set oldhead [exec git rev-parse HEAD]
7701 set dheads [descheads $rowmenuid]
7702 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7703 set ok [confirm_popup [mc "Commit %s is already\
7704 included in branch %s -- really re-apply it?" \
7705 [string range $rowmenuid 0 7] $mainhead]]
7706 if {!$ok} return
7708 nowbusy cherrypick [mc "Cherry-picking"]
7709 update
7710 # Unfortunately git-cherry-pick writes stuff to stderr even when
7711 # no error occurs, and exec takes that as an indication of error...
7712 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7713 notbusy cherrypick
7714 error_popup $err
7715 return
7717 set newhead [exec git rev-parse HEAD]
7718 if {$newhead eq $oldhead} {
7719 notbusy cherrypick
7720 error_popup [mc "No changes committed"]
7721 return
7723 addnewchild $newhead $oldhead
7724 if {[commitinview $oldhead $curview]} {
7725 insertrow $newhead $oldhead $curview
7726 if {$mainhead ne {}} {
7727 movehead $newhead $mainhead
7728 movedhead $newhead $mainhead
7730 set mainheadid $newhead
7731 redrawtags $oldhead
7732 redrawtags $newhead
7733 selbyid $newhead
7735 notbusy cherrypick
7738 proc resethead {} {
7739 global mainhead rowmenuid confirm_ok resettype
7741 set confirm_ok 0
7742 set w ".confirmreset"
7743 toplevel $w
7744 wm transient $w .
7745 wm title $w [mc "Confirm reset"]
7746 message $w.m -text \
7747 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7748 -justify center -aspect 1000
7749 pack $w.m -side top -fill x -padx 20 -pady 20
7750 frame $w.f -relief sunken -border 2
7751 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7752 grid $w.f.rt -sticky w
7753 set resettype mixed
7754 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7755 -text [mc "Soft: Leave working tree and index untouched"]
7756 grid $w.f.soft -sticky w
7757 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7758 -text [mc "Mixed: Leave working tree untouched, reset index"]
7759 grid $w.f.mixed -sticky w
7760 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7761 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7762 grid $w.f.hard -sticky w
7763 pack $w.f -side top -fill x
7764 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7765 pack $w.ok -side left -fill x -padx 20 -pady 20
7766 button $w.cancel -text [mc Cancel] -command "destroy $w"
7767 pack $w.cancel -side right -fill x -padx 20 -pady 20
7768 bind $w <Visibility> "grab $w; focus $w"
7769 tkwait window $w
7770 if {!$confirm_ok} return
7771 if {[catch {set fd [open \
7772 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7773 error_popup $err
7774 } else {
7775 dohidelocalchanges
7776 filerun $fd [list readresetstat $fd]
7777 nowbusy reset [mc "Resetting"]
7778 selbyid $rowmenuid
7782 proc readresetstat {fd} {
7783 global mainhead mainheadid showlocalchanges rprogcoord
7785 if {[gets $fd line] >= 0} {
7786 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7787 set rprogcoord [expr {1.0 * $m / $n}]
7788 adjustprogress
7790 return 1
7792 set rprogcoord 0
7793 adjustprogress
7794 notbusy reset
7795 if {[catch {close $fd} err]} {
7796 error_popup $err
7798 set oldhead $mainheadid
7799 set newhead [exec git rev-parse HEAD]
7800 if {$newhead ne $oldhead} {
7801 movehead $newhead $mainhead
7802 movedhead $newhead $mainhead
7803 set mainheadid $newhead
7804 redrawtags $oldhead
7805 redrawtags $newhead
7807 if {$showlocalchanges} {
7808 doshowlocalchanges
7810 return 0
7813 # context menu for a head
7814 proc headmenu {x y id head} {
7815 global headmenuid headmenuhead headctxmenu mainhead
7817 stopfinding
7818 set headmenuid $id
7819 set headmenuhead $head
7820 set state normal
7821 if {$head eq $mainhead} {
7822 set state disabled
7824 $headctxmenu entryconfigure 0 -state $state
7825 $headctxmenu entryconfigure 1 -state $state
7826 tk_popup $headctxmenu $x $y
7829 proc cobranch {} {
7830 global headmenuid headmenuhead headids
7831 global showlocalchanges mainheadid
7833 # check the tree is clean first??
7834 nowbusy checkout [mc "Checking out"]
7835 update
7836 dohidelocalchanges
7837 if {[catch {
7838 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7839 } err]} {
7840 notbusy checkout
7841 error_popup $err
7842 if {$showlocalchanges} {
7843 dodiffindex
7845 } else {
7846 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7850 proc readcheckoutstat {fd newhead newheadid} {
7851 global mainhead mainheadid headids showlocalchanges progresscoords
7853 if {[gets $fd line] >= 0} {
7854 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7855 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7856 adjustprogress
7858 return 1
7860 set progresscoords {0 0}
7861 adjustprogress
7862 notbusy checkout
7863 if {[catch {close $fd} err]} {
7864 error_popup $err
7866 set oldmainid $mainheadid
7867 set mainhead $newhead
7868 set mainheadid $newheadid
7869 redrawtags $oldmainid
7870 redrawtags $newheadid
7871 selbyid $newheadid
7872 if {$showlocalchanges} {
7873 dodiffindex
7877 proc rmbranch {} {
7878 global headmenuid headmenuhead mainhead
7879 global idheads
7881 set head $headmenuhead
7882 set id $headmenuid
7883 # this check shouldn't be needed any more...
7884 if {$head eq $mainhead} {
7885 error_popup [mc "Cannot delete the currently checked-out branch"]
7886 return
7888 set dheads [descheads $id]
7889 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7890 # the stuff on this branch isn't on any other branch
7891 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7892 branch.\nReally delete branch %s?" $head $head]]} return
7894 nowbusy rmbranch
7895 update
7896 if {[catch {exec git branch -D $head} err]} {
7897 notbusy rmbranch
7898 error_popup $err
7899 return
7901 removehead $id $head
7902 removedhead $id $head
7903 redrawtags $id
7904 notbusy rmbranch
7905 dispneartags 0
7906 run refill_reflist
7909 # Display a list of tags and heads
7910 proc showrefs {} {
7911 global showrefstop bgcolor fgcolor selectbgcolor
7912 global bglist fglist reflistfilter reflist maincursor
7914 set top .showrefs
7915 set showrefstop $top
7916 if {[winfo exists $top]} {
7917 raise $top
7918 refill_reflist
7919 return
7921 toplevel $top
7922 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7923 text $top.list -background $bgcolor -foreground $fgcolor \
7924 -selectbackground $selectbgcolor -font mainfont \
7925 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7926 -width 30 -height 20 -cursor $maincursor \
7927 -spacing1 1 -spacing3 1 -state disabled
7928 $top.list tag configure highlight -background $selectbgcolor
7929 lappend bglist $top.list
7930 lappend fglist $top.list
7931 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7932 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7933 grid $top.list $top.ysb -sticky nsew
7934 grid $top.xsb x -sticky ew
7935 frame $top.f
7936 label $top.f.l -text "[mc "Filter"]: "
7937 entry $top.f.e -width 20 -textvariable reflistfilter
7938 set reflistfilter "*"
7939 trace add variable reflistfilter write reflistfilter_change
7940 pack $top.f.e -side right -fill x -expand 1
7941 pack $top.f.l -side left
7942 grid $top.f - -sticky ew -pady 2
7943 button $top.close -command [list destroy $top] -text [mc "Close"]
7944 grid $top.close -
7945 grid columnconfigure $top 0 -weight 1
7946 grid rowconfigure $top 0 -weight 1
7947 bind $top.list <1> {break}
7948 bind $top.list <B1-Motion> {break}
7949 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7950 set reflist {}
7951 refill_reflist
7954 proc sel_reflist {w x y} {
7955 global showrefstop reflist headids tagids otherrefids
7957 if {![winfo exists $showrefstop]} return
7958 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7959 set ref [lindex $reflist [expr {$l-1}]]
7960 set n [lindex $ref 0]
7961 switch -- [lindex $ref 1] {
7962 "H" {selbyid $headids($n)}
7963 "T" {selbyid $tagids($n)}
7964 "o" {selbyid $otherrefids($n)}
7966 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7969 proc unsel_reflist {} {
7970 global showrefstop
7972 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7973 $showrefstop.list tag remove highlight 0.0 end
7976 proc reflistfilter_change {n1 n2 op} {
7977 global reflistfilter
7979 after cancel refill_reflist
7980 after 200 refill_reflist
7983 proc refill_reflist {} {
7984 global reflist reflistfilter showrefstop headids tagids otherrefids
7985 global curview commitinterest
7987 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7988 set refs {}
7989 foreach n [array names headids] {
7990 if {[string match $reflistfilter $n]} {
7991 if {[commitinview $headids($n) $curview]} {
7992 lappend refs [list $n H]
7993 } else {
7994 set commitinterest($headids($n)) {run refill_reflist}
7998 foreach n [array names tagids] {
7999 if {[string match $reflistfilter $n]} {
8000 if {[commitinview $tagids($n) $curview]} {
8001 lappend refs [list $n T]
8002 } else {
8003 set commitinterest($tagids($n)) {run refill_reflist}
8007 foreach n [array names otherrefids] {
8008 if {[string match $reflistfilter $n]} {
8009 if {[commitinview $otherrefids($n) $curview]} {
8010 lappend refs [list $n o]
8011 } else {
8012 set commitinterest($otherrefids($n)) {run refill_reflist}
8016 set refs [lsort -index 0 $refs]
8017 if {$refs eq $reflist} return
8019 # Update the contents of $showrefstop.list according to the
8020 # differences between $reflist (old) and $refs (new)
8021 $showrefstop.list conf -state normal
8022 $showrefstop.list insert end "\n"
8023 set i 0
8024 set j 0
8025 while {$i < [llength $reflist] || $j < [llength $refs]} {
8026 if {$i < [llength $reflist]} {
8027 if {$j < [llength $refs]} {
8028 set cmp [string compare [lindex $reflist $i 0] \
8029 [lindex $refs $j 0]]
8030 if {$cmp == 0} {
8031 set cmp [string compare [lindex $reflist $i 1] \
8032 [lindex $refs $j 1]]
8034 } else {
8035 set cmp -1
8037 } else {
8038 set cmp 1
8040 switch -- $cmp {
8041 -1 {
8042 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8043 incr i
8046 incr i
8047 incr j
8050 set l [expr {$j + 1}]
8051 $showrefstop.list image create $l.0 -align baseline \
8052 -image reficon-[lindex $refs $j 1] -padx 2
8053 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8054 incr j
8058 set reflist $refs
8059 # delete last newline
8060 $showrefstop.list delete end-2c end-1c
8061 $showrefstop.list conf -state disabled
8064 # Stuff for finding nearby tags
8065 proc getallcommits {} {
8066 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8067 global idheads idtags idotherrefs allparents tagobjid
8069 if {![info exists allcommits]} {
8070 set nextarc 0
8071 set allcommits 0
8072 set seeds {}
8073 set allcwait 0
8074 set cachedarcs 0
8075 set allccache [file join [gitdir] "gitk.cache"]
8076 if {![catch {
8077 set f [open $allccache r]
8078 set allcwait 1
8079 getcache $f
8080 }]} return
8083 if {$allcwait} {
8084 return
8086 set cmd [list | git rev-list --parents]
8087 set allcupdate [expr {$seeds ne {}}]
8088 if {!$allcupdate} {
8089 set ids "--all"
8090 } else {
8091 set refs [concat [array names idheads] [array names idtags] \
8092 [array names idotherrefs]]
8093 set ids {}
8094 set tagobjs {}
8095 foreach name [array names tagobjid] {
8096 lappend tagobjs $tagobjid($name)
8098 foreach id [lsort -unique $refs] {
8099 if {![info exists allparents($id)] &&
8100 [lsearch -exact $tagobjs $id] < 0} {
8101 lappend ids $id
8104 if {$ids ne {}} {
8105 foreach id $seeds {
8106 lappend ids "^$id"
8110 if {$ids ne {}} {
8111 set fd [open [concat $cmd $ids] r]
8112 fconfigure $fd -blocking 0
8113 incr allcommits
8114 nowbusy allcommits
8115 filerun $fd [list getallclines $fd]
8116 } else {
8117 dispneartags 0
8121 # Since most commits have 1 parent and 1 child, we group strings of
8122 # such commits into "arcs" joining branch/merge points (BMPs), which
8123 # are commits that either don't have 1 parent or don't have 1 child.
8125 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8126 # arcout(id) - outgoing arcs for BMP
8127 # arcids(a) - list of IDs on arc including end but not start
8128 # arcstart(a) - BMP ID at start of arc
8129 # arcend(a) - BMP ID at end of arc
8130 # growing(a) - arc a is still growing
8131 # arctags(a) - IDs out of arcids (excluding end) that have tags
8132 # archeads(a) - IDs out of arcids (excluding end) that have heads
8133 # The start of an arc is at the descendent end, so "incoming" means
8134 # coming from descendents, and "outgoing" means going towards ancestors.
8136 proc getallclines {fd} {
8137 global allparents allchildren idtags idheads nextarc
8138 global arcnos arcids arctags arcout arcend arcstart archeads growing
8139 global seeds allcommits cachedarcs allcupdate
8141 set nid 0
8142 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8143 set id [lindex $line 0]
8144 if {[info exists allparents($id)]} {
8145 # seen it already
8146 continue
8148 set cachedarcs 0
8149 set olds [lrange $line 1 end]
8150 set allparents($id) $olds
8151 if {![info exists allchildren($id)]} {
8152 set allchildren($id) {}
8153 set arcnos($id) {}
8154 lappend seeds $id
8155 } else {
8156 set a $arcnos($id)
8157 if {[llength $olds] == 1 && [llength $a] == 1} {
8158 lappend arcids($a) $id
8159 if {[info exists idtags($id)]} {
8160 lappend arctags($a) $id
8162 if {[info exists idheads($id)]} {
8163 lappend archeads($a) $id
8165 if {[info exists allparents($olds)]} {
8166 # seen parent already
8167 if {![info exists arcout($olds)]} {
8168 splitarc $olds
8170 lappend arcids($a) $olds
8171 set arcend($a) $olds
8172 unset growing($a)
8174 lappend allchildren($olds) $id
8175 lappend arcnos($olds) $a
8176 continue
8179 foreach a $arcnos($id) {
8180 lappend arcids($a) $id
8181 set arcend($a) $id
8182 unset growing($a)
8185 set ao {}
8186 foreach p $olds {
8187 lappend allchildren($p) $id
8188 set a [incr nextarc]
8189 set arcstart($a) $id
8190 set archeads($a) {}
8191 set arctags($a) {}
8192 set archeads($a) {}
8193 set arcids($a) {}
8194 lappend ao $a
8195 set growing($a) 1
8196 if {[info exists allparents($p)]} {
8197 # seen it already, may need to make a new branch
8198 if {![info exists arcout($p)]} {
8199 splitarc $p
8201 lappend arcids($a) $p
8202 set arcend($a) $p
8203 unset growing($a)
8205 lappend arcnos($p) $a
8207 set arcout($id) $ao
8209 if {$nid > 0} {
8210 global cached_dheads cached_dtags cached_atags
8211 catch {unset cached_dheads}
8212 catch {unset cached_dtags}
8213 catch {unset cached_atags}
8215 if {![eof $fd]} {
8216 return [expr {$nid >= 1000? 2: 1}]
8218 set cacheok 1
8219 if {[catch {
8220 fconfigure $fd -blocking 1
8221 close $fd
8222 } err]} {
8223 # got an error reading the list of commits
8224 # if we were updating, try rereading the whole thing again
8225 if {$allcupdate} {
8226 incr allcommits -1
8227 dropcache $err
8228 return
8230 error_popup "[mc "Error reading commit topology information;\
8231 branch and preceding/following tag information\
8232 will be incomplete."]\n($err)"
8233 set cacheok 0
8235 if {[incr allcommits -1] == 0} {
8236 notbusy allcommits
8237 if {$cacheok} {
8238 run savecache
8241 dispneartags 0
8242 return 0
8245 proc recalcarc {a} {
8246 global arctags archeads arcids idtags idheads
8248 set at {}
8249 set ah {}
8250 foreach id [lrange $arcids($a) 0 end-1] {
8251 if {[info exists idtags($id)]} {
8252 lappend at $id
8254 if {[info exists idheads($id)]} {
8255 lappend ah $id
8258 set arctags($a) $at
8259 set archeads($a) $ah
8262 proc splitarc {p} {
8263 global arcnos arcids nextarc arctags archeads idtags idheads
8264 global arcstart arcend arcout allparents growing
8266 set a $arcnos($p)
8267 if {[llength $a] != 1} {
8268 puts "oops splitarc called but [llength $a] arcs already"
8269 return
8271 set a [lindex $a 0]
8272 set i [lsearch -exact $arcids($a) $p]
8273 if {$i < 0} {
8274 puts "oops splitarc $p not in arc $a"
8275 return
8277 set na [incr nextarc]
8278 if {[info exists arcend($a)]} {
8279 set arcend($na) $arcend($a)
8280 } else {
8281 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8282 set j [lsearch -exact $arcnos($l) $a]
8283 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8285 set tail [lrange $arcids($a) [expr {$i+1}] end]
8286 set arcids($a) [lrange $arcids($a) 0 $i]
8287 set arcend($a) $p
8288 set arcstart($na) $p
8289 set arcout($p) $na
8290 set arcids($na) $tail
8291 if {[info exists growing($a)]} {
8292 set growing($na) 1
8293 unset growing($a)
8296 foreach id $tail {
8297 if {[llength $arcnos($id)] == 1} {
8298 set arcnos($id) $na
8299 } else {
8300 set j [lsearch -exact $arcnos($id) $a]
8301 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8305 # reconstruct tags and heads lists
8306 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8307 recalcarc $a
8308 recalcarc $na
8309 } else {
8310 set arctags($na) {}
8311 set archeads($na) {}
8315 # Update things for a new commit added that is a child of one
8316 # existing commit. Used when cherry-picking.
8317 proc addnewchild {id p} {
8318 global allparents allchildren idtags nextarc
8319 global arcnos arcids arctags arcout arcend arcstart archeads growing
8320 global seeds allcommits
8322 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8323 set allparents($id) [list $p]
8324 set allchildren($id) {}
8325 set arcnos($id) {}
8326 lappend seeds $id
8327 lappend allchildren($p) $id
8328 set a [incr nextarc]
8329 set arcstart($a) $id
8330 set archeads($a) {}
8331 set arctags($a) {}
8332 set arcids($a) [list $p]
8333 set arcend($a) $p
8334 if {![info exists arcout($p)]} {
8335 splitarc $p
8337 lappend arcnos($p) $a
8338 set arcout($id) [list $a]
8341 # This implements a cache for the topology information.
8342 # The cache saves, for each arc, the start and end of the arc,
8343 # the ids on the arc, and the outgoing arcs from the end.
8344 proc readcache {f} {
8345 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8346 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8347 global allcwait
8349 set a $nextarc
8350 set lim $cachedarcs
8351 if {$lim - $a > 500} {
8352 set lim [expr {$a + 500}]
8354 if {[catch {
8355 if {$a == $lim} {
8356 # finish reading the cache and setting up arctags, etc.
8357 set line [gets $f]
8358 if {$line ne "1"} {error "bad final version"}
8359 close $f
8360 foreach id [array names idtags] {
8361 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8362 [llength $allparents($id)] == 1} {
8363 set a [lindex $arcnos($id) 0]
8364 if {$arctags($a) eq {}} {
8365 recalcarc $a
8369 foreach id [array names idheads] {
8370 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8371 [llength $allparents($id)] == 1} {
8372 set a [lindex $arcnos($id) 0]
8373 if {$archeads($a) eq {}} {
8374 recalcarc $a
8378 foreach id [lsort -unique $possible_seeds] {
8379 if {$arcnos($id) eq {}} {
8380 lappend seeds $id
8383 set allcwait 0
8384 } else {
8385 while {[incr a] <= $lim} {
8386 set line [gets $f]
8387 if {[llength $line] != 3} {error "bad line"}
8388 set s [lindex $line 0]
8389 set arcstart($a) $s
8390 lappend arcout($s) $a
8391 if {![info exists arcnos($s)]} {
8392 lappend possible_seeds $s
8393 set arcnos($s) {}
8395 set e [lindex $line 1]
8396 if {$e eq {}} {
8397 set growing($a) 1
8398 } else {
8399 set arcend($a) $e
8400 if {![info exists arcout($e)]} {
8401 set arcout($e) {}
8404 set arcids($a) [lindex $line 2]
8405 foreach id $arcids($a) {
8406 lappend allparents($s) $id
8407 set s $id
8408 lappend arcnos($id) $a
8410 if {![info exists allparents($s)]} {
8411 set allparents($s) {}
8413 set arctags($a) {}
8414 set archeads($a) {}
8416 set nextarc [expr {$a - 1}]
8418 } err]} {
8419 dropcache $err
8420 return 0
8422 if {!$allcwait} {
8423 getallcommits
8425 return $allcwait
8428 proc getcache {f} {
8429 global nextarc cachedarcs possible_seeds
8431 if {[catch {
8432 set line [gets $f]
8433 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8434 # make sure it's an integer
8435 set cachedarcs [expr {int([lindex $line 1])}]
8436 if {$cachedarcs < 0} {error "bad number of arcs"}
8437 set nextarc 0
8438 set possible_seeds {}
8439 run readcache $f
8440 } err]} {
8441 dropcache $err
8443 return 0
8446 proc dropcache {err} {
8447 global allcwait nextarc cachedarcs seeds
8449 #puts "dropping cache ($err)"
8450 foreach v {arcnos arcout arcids arcstart arcend growing \
8451 arctags archeads allparents allchildren} {
8452 global $v
8453 catch {unset $v}
8455 set allcwait 0
8456 set nextarc 0
8457 set cachedarcs 0
8458 set seeds {}
8459 getallcommits
8462 proc writecache {f} {
8463 global cachearc cachedarcs allccache
8464 global arcstart arcend arcnos arcids arcout
8466 set a $cachearc
8467 set lim $cachedarcs
8468 if {$lim - $a > 1000} {
8469 set lim [expr {$a + 1000}]
8471 if {[catch {
8472 while {[incr a] <= $lim} {
8473 if {[info exists arcend($a)]} {
8474 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8475 } else {
8476 puts $f [list $arcstart($a) {} $arcids($a)]
8479 } err]} {
8480 catch {close $f}
8481 catch {file delete $allccache}
8482 #puts "writing cache failed ($err)"
8483 return 0
8485 set cachearc [expr {$a - 1}]
8486 if {$a > $cachedarcs} {
8487 puts $f "1"
8488 close $f
8489 return 0
8491 return 1
8494 proc savecache {} {
8495 global nextarc cachedarcs cachearc allccache
8497 if {$nextarc == $cachedarcs} return
8498 set cachearc 0
8499 set cachedarcs $nextarc
8500 catch {
8501 set f [open $allccache w]
8502 puts $f [list 1 $cachedarcs]
8503 run writecache $f
8507 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8508 # or 0 if neither is true.
8509 proc anc_or_desc {a b} {
8510 global arcout arcstart arcend arcnos cached_isanc
8512 if {$arcnos($a) eq $arcnos($b)} {
8513 # Both are on the same arc(s); either both are the same BMP,
8514 # or if one is not a BMP, the other is also not a BMP or is
8515 # the BMP at end of the arc (and it only has 1 incoming arc).
8516 # Or both can be BMPs with no incoming arcs.
8517 if {$a eq $b || $arcnos($a) eq {}} {
8518 return 0
8520 # assert {[llength $arcnos($a)] == 1}
8521 set arc [lindex $arcnos($a) 0]
8522 set i [lsearch -exact $arcids($arc) $a]
8523 set j [lsearch -exact $arcids($arc) $b]
8524 if {$i < 0 || $i > $j} {
8525 return 1
8526 } else {
8527 return -1
8531 if {![info exists arcout($a)]} {
8532 set arc [lindex $arcnos($a) 0]
8533 if {[info exists arcend($arc)]} {
8534 set aend $arcend($arc)
8535 } else {
8536 set aend {}
8538 set a $arcstart($arc)
8539 } else {
8540 set aend $a
8542 if {![info exists arcout($b)]} {
8543 set arc [lindex $arcnos($b) 0]
8544 if {[info exists arcend($arc)]} {
8545 set bend $arcend($arc)
8546 } else {
8547 set bend {}
8549 set b $arcstart($arc)
8550 } else {
8551 set bend $b
8553 if {$a eq $bend} {
8554 return 1
8556 if {$b eq $aend} {
8557 return -1
8559 if {[info exists cached_isanc($a,$bend)]} {
8560 if {$cached_isanc($a,$bend)} {
8561 return 1
8564 if {[info exists cached_isanc($b,$aend)]} {
8565 if {$cached_isanc($b,$aend)} {
8566 return -1
8568 if {[info exists cached_isanc($a,$bend)]} {
8569 return 0
8573 set todo [list $a $b]
8574 set anc($a) a
8575 set anc($b) b
8576 for {set i 0} {$i < [llength $todo]} {incr i} {
8577 set x [lindex $todo $i]
8578 if {$anc($x) eq {}} {
8579 continue
8581 foreach arc $arcnos($x) {
8582 set xd $arcstart($arc)
8583 if {$xd eq $bend} {
8584 set cached_isanc($a,$bend) 1
8585 set cached_isanc($b,$aend) 0
8586 return 1
8587 } elseif {$xd eq $aend} {
8588 set cached_isanc($b,$aend) 1
8589 set cached_isanc($a,$bend) 0
8590 return -1
8592 if {![info exists anc($xd)]} {
8593 set anc($xd) $anc($x)
8594 lappend todo $xd
8595 } elseif {$anc($xd) ne $anc($x)} {
8596 set anc($xd) {}
8600 set cached_isanc($a,$bend) 0
8601 set cached_isanc($b,$aend) 0
8602 return 0
8605 # This identifies whether $desc has an ancestor that is
8606 # a growing tip of the graph and which is not an ancestor of $anc
8607 # and returns 0 if so and 1 if not.
8608 # If we subsequently discover a tag on such a growing tip, and that
8609 # turns out to be a descendent of $anc (which it could, since we
8610 # don't necessarily see children before parents), then $desc
8611 # isn't a good choice to display as a descendent tag of
8612 # $anc (since it is the descendent of another tag which is
8613 # a descendent of $anc). Similarly, $anc isn't a good choice to
8614 # display as a ancestor tag of $desc.
8616 proc is_certain {desc anc} {
8617 global arcnos arcout arcstart arcend growing problems
8619 set certain {}
8620 if {[llength $arcnos($anc)] == 1} {
8621 # tags on the same arc are certain
8622 if {$arcnos($desc) eq $arcnos($anc)} {
8623 return 1
8625 if {![info exists arcout($anc)]} {
8626 # if $anc is partway along an arc, use the start of the arc instead
8627 set a [lindex $arcnos($anc) 0]
8628 set anc $arcstart($a)
8631 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8632 set x $desc
8633 } else {
8634 set a [lindex $arcnos($desc) 0]
8635 set x $arcend($a)
8637 if {$x == $anc} {
8638 return 1
8640 set anclist [list $x]
8641 set dl($x) 1
8642 set nnh 1
8643 set ngrowanc 0
8644 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8645 set x [lindex $anclist $i]
8646 if {$dl($x)} {
8647 incr nnh -1
8649 set done($x) 1
8650 foreach a $arcout($x) {
8651 if {[info exists growing($a)]} {
8652 if {![info exists growanc($x)] && $dl($x)} {
8653 set growanc($x) 1
8654 incr ngrowanc
8656 } else {
8657 set y $arcend($a)
8658 if {[info exists dl($y)]} {
8659 if {$dl($y)} {
8660 if {!$dl($x)} {
8661 set dl($y) 0
8662 if {![info exists done($y)]} {
8663 incr nnh -1
8665 if {[info exists growanc($x)]} {
8666 incr ngrowanc -1
8668 set xl [list $y]
8669 for {set k 0} {$k < [llength $xl]} {incr k} {
8670 set z [lindex $xl $k]
8671 foreach c $arcout($z) {
8672 if {[info exists arcend($c)]} {
8673 set v $arcend($c)
8674 if {[info exists dl($v)] && $dl($v)} {
8675 set dl($v) 0
8676 if {![info exists done($v)]} {
8677 incr nnh -1
8679 if {[info exists growanc($v)]} {
8680 incr ngrowanc -1
8682 lappend xl $v
8689 } elseif {$y eq $anc || !$dl($x)} {
8690 set dl($y) 0
8691 lappend anclist $y
8692 } else {
8693 set dl($y) 1
8694 lappend anclist $y
8695 incr nnh
8700 foreach x [array names growanc] {
8701 if {$dl($x)} {
8702 return 0
8704 return 0
8706 return 1
8709 proc validate_arctags {a} {
8710 global arctags idtags
8712 set i -1
8713 set na $arctags($a)
8714 foreach id $arctags($a) {
8715 incr i
8716 if {![info exists idtags($id)]} {
8717 set na [lreplace $na $i $i]
8718 incr i -1
8721 set arctags($a) $na
8724 proc validate_archeads {a} {
8725 global archeads idheads
8727 set i -1
8728 set na $archeads($a)
8729 foreach id $archeads($a) {
8730 incr i
8731 if {![info exists idheads($id)]} {
8732 set na [lreplace $na $i $i]
8733 incr i -1
8736 set archeads($a) $na
8739 # Return the list of IDs that have tags that are descendents of id,
8740 # ignoring IDs that are descendents of IDs already reported.
8741 proc desctags {id} {
8742 global arcnos arcstart arcids arctags idtags allparents
8743 global growing cached_dtags
8745 if {![info exists allparents($id)]} {
8746 return {}
8748 set t1 [clock clicks -milliseconds]
8749 set argid $id
8750 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8751 # part-way along an arc; check that arc first
8752 set a [lindex $arcnos($id) 0]
8753 if {$arctags($a) ne {}} {
8754 validate_arctags $a
8755 set i [lsearch -exact $arcids($a) $id]
8756 set tid {}
8757 foreach t $arctags($a) {
8758 set j [lsearch -exact $arcids($a) $t]
8759 if {$j >= $i} break
8760 set tid $t
8762 if {$tid ne {}} {
8763 return $tid
8766 set id $arcstart($a)
8767 if {[info exists idtags($id)]} {
8768 return $id
8771 if {[info exists cached_dtags($id)]} {
8772 return $cached_dtags($id)
8775 set origid $id
8776 set todo [list $id]
8777 set queued($id) 1
8778 set nc 1
8779 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8780 set id [lindex $todo $i]
8781 set done($id) 1
8782 set ta [info exists hastaggedancestor($id)]
8783 if {!$ta} {
8784 incr nc -1
8786 # ignore tags on starting node
8787 if {!$ta && $i > 0} {
8788 if {[info exists idtags($id)]} {
8789 set tagloc($id) $id
8790 set ta 1
8791 } elseif {[info exists cached_dtags($id)]} {
8792 set tagloc($id) $cached_dtags($id)
8793 set ta 1
8796 foreach a $arcnos($id) {
8797 set d $arcstart($a)
8798 if {!$ta && $arctags($a) ne {}} {
8799 validate_arctags $a
8800 if {$arctags($a) ne {}} {
8801 lappend tagloc($id) [lindex $arctags($a) end]
8804 if {$ta || $arctags($a) ne {}} {
8805 set tomark [list $d]
8806 for {set j 0} {$j < [llength $tomark]} {incr j} {
8807 set dd [lindex $tomark $j]
8808 if {![info exists hastaggedancestor($dd)]} {
8809 if {[info exists done($dd)]} {
8810 foreach b $arcnos($dd) {
8811 lappend tomark $arcstart($b)
8813 if {[info exists tagloc($dd)]} {
8814 unset tagloc($dd)
8816 } elseif {[info exists queued($dd)]} {
8817 incr nc -1
8819 set hastaggedancestor($dd) 1
8823 if {![info exists queued($d)]} {
8824 lappend todo $d
8825 set queued($d) 1
8826 if {![info exists hastaggedancestor($d)]} {
8827 incr nc
8832 set tags {}
8833 foreach id [array names tagloc] {
8834 if {![info exists hastaggedancestor($id)]} {
8835 foreach t $tagloc($id) {
8836 if {[lsearch -exact $tags $t] < 0} {
8837 lappend tags $t
8842 set t2 [clock clicks -milliseconds]
8843 set loopix $i
8845 # remove tags that are descendents of other tags
8846 for {set i 0} {$i < [llength $tags]} {incr i} {
8847 set a [lindex $tags $i]
8848 for {set j 0} {$j < $i} {incr j} {
8849 set b [lindex $tags $j]
8850 set r [anc_or_desc $a $b]
8851 if {$r == 1} {
8852 set tags [lreplace $tags $j $j]
8853 incr j -1
8854 incr i -1
8855 } elseif {$r == -1} {
8856 set tags [lreplace $tags $i $i]
8857 incr i -1
8858 break
8863 if {[array names growing] ne {}} {
8864 # graph isn't finished, need to check if any tag could get
8865 # eclipsed by another tag coming later. Simply ignore any
8866 # tags that could later get eclipsed.
8867 set ctags {}
8868 foreach t $tags {
8869 if {[is_certain $t $origid]} {
8870 lappend ctags $t
8873 if {$tags eq $ctags} {
8874 set cached_dtags($origid) $tags
8875 } else {
8876 set tags $ctags
8878 } else {
8879 set cached_dtags($origid) $tags
8881 set t3 [clock clicks -milliseconds]
8882 if {0 && $t3 - $t1 >= 100} {
8883 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8884 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8886 return $tags
8889 proc anctags {id} {
8890 global arcnos arcids arcout arcend arctags idtags allparents
8891 global growing cached_atags
8893 if {![info exists allparents($id)]} {
8894 return {}
8896 set t1 [clock clicks -milliseconds]
8897 set argid $id
8898 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8899 # part-way along an arc; check that arc first
8900 set a [lindex $arcnos($id) 0]
8901 if {$arctags($a) ne {}} {
8902 validate_arctags $a
8903 set i [lsearch -exact $arcids($a) $id]
8904 foreach t $arctags($a) {
8905 set j [lsearch -exact $arcids($a) $t]
8906 if {$j > $i} {
8907 return $t
8911 if {![info exists arcend($a)]} {
8912 return {}
8914 set id $arcend($a)
8915 if {[info exists idtags($id)]} {
8916 return $id
8919 if {[info exists cached_atags($id)]} {
8920 return $cached_atags($id)
8923 set origid $id
8924 set todo [list $id]
8925 set queued($id) 1
8926 set taglist {}
8927 set nc 1
8928 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8929 set id [lindex $todo $i]
8930 set done($id) 1
8931 set td [info exists hastaggeddescendent($id)]
8932 if {!$td} {
8933 incr nc -1
8935 # ignore tags on starting node
8936 if {!$td && $i > 0} {
8937 if {[info exists idtags($id)]} {
8938 set tagloc($id) $id
8939 set td 1
8940 } elseif {[info exists cached_atags($id)]} {
8941 set tagloc($id) $cached_atags($id)
8942 set td 1
8945 foreach a $arcout($id) {
8946 if {!$td && $arctags($a) ne {}} {
8947 validate_arctags $a
8948 if {$arctags($a) ne {}} {
8949 lappend tagloc($id) [lindex $arctags($a) 0]
8952 if {![info exists arcend($a)]} continue
8953 set d $arcend($a)
8954 if {$td || $arctags($a) ne {}} {
8955 set tomark [list $d]
8956 for {set j 0} {$j < [llength $tomark]} {incr j} {
8957 set dd [lindex $tomark $j]
8958 if {![info exists hastaggeddescendent($dd)]} {
8959 if {[info exists done($dd)]} {
8960 foreach b $arcout($dd) {
8961 if {[info exists arcend($b)]} {
8962 lappend tomark $arcend($b)
8965 if {[info exists tagloc($dd)]} {
8966 unset tagloc($dd)
8968 } elseif {[info exists queued($dd)]} {
8969 incr nc -1
8971 set hastaggeddescendent($dd) 1
8975 if {![info exists queued($d)]} {
8976 lappend todo $d
8977 set queued($d) 1
8978 if {![info exists hastaggeddescendent($d)]} {
8979 incr nc
8984 set t2 [clock clicks -milliseconds]
8985 set loopix $i
8986 set tags {}
8987 foreach id [array names tagloc] {
8988 if {![info exists hastaggeddescendent($id)]} {
8989 foreach t $tagloc($id) {
8990 if {[lsearch -exact $tags $t] < 0} {
8991 lappend tags $t
8997 # remove tags that are ancestors of other tags
8998 for {set i 0} {$i < [llength $tags]} {incr i} {
8999 set a [lindex $tags $i]
9000 for {set j 0} {$j < $i} {incr j} {
9001 set b [lindex $tags $j]
9002 set r [anc_or_desc $a $b]
9003 if {$r == -1} {
9004 set tags [lreplace $tags $j $j]
9005 incr j -1
9006 incr i -1
9007 } elseif {$r == 1} {
9008 set tags [lreplace $tags $i $i]
9009 incr i -1
9010 break
9015 if {[array names growing] ne {}} {
9016 # graph isn't finished, need to check if any tag could get
9017 # eclipsed by another tag coming later. Simply ignore any
9018 # tags that could later get eclipsed.
9019 set ctags {}
9020 foreach t $tags {
9021 if {[is_certain $origid $t]} {
9022 lappend ctags $t
9025 if {$tags eq $ctags} {
9026 set cached_atags($origid) $tags
9027 } else {
9028 set tags $ctags
9030 } else {
9031 set cached_atags($origid) $tags
9033 set t3 [clock clicks -milliseconds]
9034 if {0 && $t3 - $t1 >= 100} {
9035 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9036 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9038 return $tags
9041 # Return the list of IDs that have heads that are descendents of id,
9042 # including id itself if it has a head.
9043 proc descheads {id} {
9044 global arcnos arcstart arcids archeads idheads cached_dheads
9045 global allparents
9047 if {![info exists allparents($id)]} {
9048 return {}
9050 set aret {}
9051 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9052 # part-way along an arc; check it first
9053 set a [lindex $arcnos($id) 0]
9054 if {$archeads($a) ne {}} {
9055 validate_archeads $a
9056 set i [lsearch -exact $arcids($a) $id]
9057 foreach t $archeads($a) {
9058 set j [lsearch -exact $arcids($a) $t]
9059 if {$j > $i} break
9060 lappend aret $t
9063 set id $arcstart($a)
9065 set origid $id
9066 set todo [list $id]
9067 set seen($id) 1
9068 set ret {}
9069 for {set i 0} {$i < [llength $todo]} {incr i} {
9070 set id [lindex $todo $i]
9071 if {[info exists cached_dheads($id)]} {
9072 set ret [concat $ret $cached_dheads($id)]
9073 } else {
9074 if {[info exists idheads($id)]} {
9075 lappend ret $id
9077 foreach a $arcnos($id) {
9078 if {$archeads($a) ne {}} {
9079 validate_archeads $a
9080 if {$archeads($a) ne {}} {
9081 set ret [concat $ret $archeads($a)]
9084 set d $arcstart($a)
9085 if {![info exists seen($d)]} {
9086 lappend todo $d
9087 set seen($d) 1
9092 set ret [lsort -unique $ret]
9093 set cached_dheads($origid) $ret
9094 return [concat $ret $aret]
9097 proc addedtag {id} {
9098 global arcnos arcout cached_dtags cached_atags
9100 if {![info exists arcnos($id)]} return
9101 if {![info exists arcout($id)]} {
9102 recalcarc [lindex $arcnos($id) 0]
9104 catch {unset cached_dtags}
9105 catch {unset cached_atags}
9108 proc addedhead {hid head} {
9109 global arcnos arcout cached_dheads
9111 if {![info exists arcnos($hid)]} return
9112 if {![info exists arcout($hid)]} {
9113 recalcarc [lindex $arcnos($hid) 0]
9115 catch {unset cached_dheads}
9118 proc removedhead {hid head} {
9119 global cached_dheads
9121 catch {unset cached_dheads}
9124 proc movedhead {hid head} {
9125 global arcnos arcout cached_dheads
9127 if {![info exists arcnos($hid)]} return
9128 if {![info exists arcout($hid)]} {
9129 recalcarc [lindex $arcnos($hid) 0]
9131 catch {unset cached_dheads}
9134 proc changedrefs {} {
9135 global cached_dheads cached_dtags cached_atags
9136 global arctags archeads arcnos arcout idheads idtags
9138 foreach id [concat [array names idheads] [array names idtags]] {
9139 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9140 set a [lindex $arcnos($id) 0]
9141 if {![info exists donearc($a)]} {
9142 recalcarc $a
9143 set donearc($a) 1
9147 catch {unset cached_dtags}
9148 catch {unset cached_atags}
9149 catch {unset cached_dheads}
9152 proc rereadrefs {} {
9153 global idtags idheads idotherrefs mainheadid
9155 set refids [concat [array names idtags] \
9156 [array names idheads] [array names idotherrefs]]
9157 foreach id $refids {
9158 if {![info exists ref($id)]} {
9159 set ref($id) [listrefs $id]
9162 set oldmainhead $mainheadid
9163 readrefs
9164 changedrefs
9165 set refids [lsort -unique [concat $refids [array names idtags] \
9166 [array names idheads] [array names idotherrefs]]]
9167 foreach id $refids {
9168 set v [listrefs $id]
9169 if {![info exists ref($id)] || $ref($id) != $v} {
9170 redrawtags $id
9173 if {$oldmainhead ne $mainheadid} {
9174 redrawtags $oldmainhead
9175 redrawtags $mainheadid
9177 run refill_reflist
9180 proc listrefs {id} {
9181 global idtags idheads idotherrefs
9183 set x {}
9184 if {[info exists idtags($id)]} {
9185 set x $idtags($id)
9187 set y {}
9188 if {[info exists idheads($id)]} {
9189 set y $idheads($id)
9191 set z {}
9192 if {[info exists idotherrefs($id)]} {
9193 set z $idotherrefs($id)
9195 return [list $x $y $z]
9198 proc showtag {tag isnew} {
9199 global ctext tagcontents tagids linknum tagobjid
9201 if {$isnew} {
9202 addtohistory [list showtag $tag 0]
9204 $ctext conf -state normal
9205 clear_ctext
9206 settabs 0
9207 set linknum 0
9208 if {![info exists tagcontents($tag)]} {
9209 catch {
9210 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9213 if {[info exists tagcontents($tag)]} {
9214 set text $tagcontents($tag)
9215 } else {
9216 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9218 appendwithlinks $text {}
9219 $ctext conf -state disabled
9220 init_flist {}
9223 proc doquit {} {
9224 global stopped
9225 global gitktmpdir
9227 set stopped 100
9228 savestuff .
9229 destroy .
9231 if {[info exists gitktmpdir]} {
9232 catch {file delete -force $gitktmpdir}
9236 proc mkfontdisp {font top which} {
9237 global fontattr fontpref $font
9239 set fontpref($font) [set $font]
9240 button $top.${font}but -text $which -font optionfont \
9241 -command [list choosefont $font $which]
9242 label $top.$font -relief flat -font $font \
9243 -text $fontattr($font,family) -justify left
9244 grid x $top.${font}but $top.$font -sticky w
9247 proc choosefont {font which} {
9248 global fontparam fontlist fonttop fontattr
9250 set fontparam(which) $which
9251 set fontparam(font) $font
9252 set fontparam(family) [font actual $font -family]
9253 set fontparam(size) $fontattr($font,size)
9254 set fontparam(weight) $fontattr($font,weight)
9255 set fontparam(slant) $fontattr($font,slant)
9256 set top .gitkfont
9257 set fonttop $top
9258 if {![winfo exists $top]} {
9259 font create sample
9260 eval font config sample [font actual $font]
9261 toplevel $top
9262 wm title $top [mc "Gitk font chooser"]
9263 label $top.l -textvariable fontparam(which)
9264 pack $top.l -side top
9265 set fontlist [lsort [font families]]
9266 frame $top.f
9267 listbox $top.f.fam -listvariable fontlist \
9268 -yscrollcommand [list $top.f.sb set]
9269 bind $top.f.fam <<ListboxSelect>> selfontfam
9270 scrollbar $top.f.sb -command [list $top.f.fam yview]
9271 pack $top.f.sb -side right -fill y
9272 pack $top.f.fam -side left -fill both -expand 1
9273 pack $top.f -side top -fill both -expand 1
9274 frame $top.g
9275 spinbox $top.g.size -from 4 -to 40 -width 4 \
9276 -textvariable fontparam(size) \
9277 -validatecommand {string is integer -strict %s}
9278 checkbutton $top.g.bold -padx 5 \
9279 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9280 -variable fontparam(weight) -onvalue bold -offvalue normal
9281 checkbutton $top.g.ital -padx 5 \
9282 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9283 -variable fontparam(slant) -onvalue italic -offvalue roman
9284 pack $top.g.size $top.g.bold $top.g.ital -side left
9285 pack $top.g -side top
9286 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9287 -background white
9288 $top.c create text 100 25 -anchor center -text $which -font sample \
9289 -fill black -tags text
9290 bind $top.c <Configure> [list centertext $top.c]
9291 pack $top.c -side top -fill x
9292 frame $top.buts
9293 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9294 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9295 grid $top.buts.ok $top.buts.can
9296 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9297 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9298 pack $top.buts -side bottom -fill x
9299 trace add variable fontparam write chg_fontparam
9300 } else {
9301 raise $top
9302 $top.c itemconf text -text $which
9304 set i [lsearch -exact $fontlist $fontparam(family)]
9305 if {$i >= 0} {
9306 $top.f.fam selection set $i
9307 $top.f.fam see $i
9311 proc centertext {w} {
9312 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9315 proc fontok {} {
9316 global fontparam fontpref prefstop
9318 set f $fontparam(font)
9319 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9320 if {$fontparam(weight) eq "bold"} {
9321 lappend fontpref($f) "bold"
9323 if {$fontparam(slant) eq "italic"} {
9324 lappend fontpref($f) "italic"
9326 set w $prefstop.$f
9327 $w conf -text $fontparam(family) -font $fontpref($f)
9329 fontcan
9332 proc fontcan {} {
9333 global fonttop fontparam
9335 if {[info exists fonttop]} {
9336 catch {destroy $fonttop}
9337 catch {font delete sample}
9338 unset fonttop
9339 unset fontparam
9343 proc selfontfam {} {
9344 global fonttop fontparam
9346 set i [$fonttop.f.fam curselection]
9347 if {$i ne {}} {
9348 set fontparam(family) [$fonttop.f.fam get $i]
9352 proc chg_fontparam {v sub op} {
9353 global fontparam
9355 font config sample -$sub $fontparam($sub)
9358 proc doprefs {} {
9359 global maxwidth maxgraphpct
9360 global oldprefs prefstop showneartags showlocalchanges
9361 global bgcolor fgcolor ctext diffcolors selectbgcolor
9362 global tabstop limitdiffs autoselect extdifftool perfile_attrs
9364 set top .gitkprefs
9365 set prefstop $top
9366 if {[winfo exists $top]} {
9367 raise $top
9368 return
9370 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9371 limitdiffs tabstop perfile_attrs} {
9372 set oldprefs($v) [set $v]
9374 toplevel $top
9375 wm title $top [mc "Gitk preferences"]
9376 label $top.ldisp -text [mc "Commit list display options"]
9377 grid $top.ldisp - -sticky w -pady 10
9378 label $top.spacer -text " "
9379 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9380 -font optionfont
9381 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9382 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9383 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9384 -font optionfont
9385 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9386 grid x $top.maxpctl $top.maxpct -sticky w
9387 frame $top.showlocal
9388 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9389 checkbutton $top.showlocal.b -variable showlocalchanges
9390 pack $top.showlocal.b $top.showlocal.l -side left
9391 grid x $top.showlocal -sticky w
9392 frame $top.autoselect
9393 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9394 checkbutton $top.autoselect.b -variable autoselect
9395 pack $top.autoselect.b $top.autoselect.l -side left
9396 grid x $top.autoselect -sticky w
9398 label $top.ddisp -text [mc "Diff display options"]
9399 grid $top.ddisp - -sticky w -pady 10
9400 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9401 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9402 grid x $top.tabstopl $top.tabstop -sticky w
9403 frame $top.ntag
9404 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9405 checkbutton $top.ntag.b -variable showneartags
9406 pack $top.ntag.b $top.ntag.l -side left
9407 grid x $top.ntag -sticky w
9408 frame $top.ldiff
9409 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9410 checkbutton $top.ldiff.b -variable limitdiffs
9411 pack $top.ldiff.b $top.ldiff.l -side left
9412 grid x $top.ldiff -sticky w
9413 frame $top.lattr
9414 label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
9415 checkbutton $top.lattr.b -variable perfile_attrs
9416 pack $top.lattr.b $top.lattr.l -side left
9417 grid x $top.lattr -sticky w
9419 entry $top.extdifft -textvariable extdifftool
9420 frame $top.extdifff
9421 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9422 -padx 10
9423 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9424 -command choose_extdiff
9425 pack $top.extdifff.l $top.extdifff.b -side left
9426 grid x $top.extdifff $top.extdifft -sticky w
9428 label $top.cdisp -text [mc "Colors: press to choose"]
9429 grid $top.cdisp - -sticky w -pady 10
9430 label $top.bg -padx 40 -relief sunk -background $bgcolor
9431 button $top.bgbut -text [mc "Background"] -font optionfont \
9432 -command [list choosecolor bgcolor {} $top.bg background setbg]
9433 grid x $top.bgbut $top.bg -sticky w
9434 label $top.fg -padx 40 -relief sunk -background $fgcolor
9435 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9436 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9437 grid x $top.fgbut $top.fg -sticky w
9438 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9439 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9440 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9441 [list $ctext tag conf d0 -foreground]]
9442 grid x $top.diffoldbut $top.diffold -sticky w
9443 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9444 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9445 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9446 [list $ctext tag conf d1 -foreground]]
9447 grid x $top.diffnewbut $top.diffnew -sticky w
9448 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9449 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9450 -command [list choosecolor diffcolors 2 $top.hunksep \
9451 "diff hunk header" \
9452 [list $ctext tag conf hunksep -foreground]]
9453 grid x $top.hunksepbut $top.hunksep -sticky w
9454 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9455 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9456 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9457 grid x $top.selbgbut $top.selbgsep -sticky w
9459 label $top.cfont -text [mc "Fonts: press to choose"]
9460 grid $top.cfont - -sticky w -pady 10
9461 mkfontdisp mainfont $top [mc "Main font"]
9462 mkfontdisp textfont $top [mc "Diff display font"]
9463 mkfontdisp uifont $top [mc "User interface font"]
9465 frame $top.buts
9466 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9467 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9468 grid $top.buts.ok $top.buts.can
9469 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9470 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9471 grid $top.buts - - -pady 10 -sticky ew
9472 bind $top <Visibility> "focus $top.buts.ok"
9475 proc choose_extdiff {} {
9476 global extdifftool
9478 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9479 if {$prog ne {}} {
9480 set extdifftool $prog
9484 proc choosecolor {v vi w x cmd} {
9485 global $v
9487 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9488 -title [mc "Gitk: choose color for %s" $x]]
9489 if {$c eq {}} return
9490 $w conf -background $c
9491 lset $v $vi $c
9492 eval $cmd $c
9495 proc setselbg {c} {
9496 global bglist cflist
9497 foreach w $bglist {
9498 $w configure -selectbackground $c
9500 $cflist tag configure highlight \
9501 -background [$cflist cget -selectbackground]
9502 allcanvs itemconf secsel -fill $c
9505 proc setbg {c} {
9506 global bglist
9508 foreach w $bglist {
9509 $w conf -background $c
9513 proc setfg {c} {
9514 global fglist canv
9516 foreach w $fglist {
9517 $w conf -foreground $c
9519 allcanvs itemconf text -fill $c
9520 $canv itemconf circle -outline $c
9523 proc prefscan {} {
9524 global oldprefs prefstop
9526 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9527 limitdiffs tabstop perfile_attrs} {
9528 global $v
9529 set $v $oldprefs($v)
9531 catch {destroy $prefstop}
9532 unset prefstop
9533 fontcan
9536 proc prefsok {} {
9537 global maxwidth maxgraphpct
9538 global oldprefs prefstop showneartags showlocalchanges
9539 global fontpref mainfont textfont uifont
9540 global limitdiffs treediffs perfile_attrs
9542 catch {destroy $prefstop}
9543 unset prefstop
9544 fontcan
9545 set fontchanged 0
9546 if {$mainfont ne $fontpref(mainfont)} {
9547 set mainfont $fontpref(mainfont)
9548 parsefont mainfont $mainfont
9549 eval font configure mainfont [fontflags mainfont]
9550 eval font configure mainfontbold [fontflags mainfont 1]
9551 setcoords
9552 set fontchanged 1
9554 if {$textfont ne $fontpref(textfont)} {
9555 set textfont $fontpref(textfont)
9556 parsefont textfont $textfont
9557 eval font configure textfont [fontflags textfont]
9558 eval font configure textfontbold [fontflags textfont 1]
9560 if {$uifont ne $fontpref(uifont)} {
9561 set uifont $fontpref(uifont)
9562 parsefont uifont $uifont
9563 eval font configure uifont [fontflags uifont]
9565 settabs
9566 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9567 if {$showlocalchanges} {
9568 doshowlocalchanges
9569 } else {
9570 dohidelocalchanges
9573 if {$limitdiffs != $oldprefs(limitdiffs) ||
9574 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
9575 # treediffs elements are limited by path;
9576 # won't have encodings cached if perfile_attrs was just turned on
9577 catch {unset treediffs}
9579 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9580 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9581 redisplay
9582 } elseif {$showneartags != $oldprefs(showneartags) ||
9583 $limitdiffs != $oldprefs(limitdiffs)} {
9584 reselectline
9588 proc formatdate {d} {
9589 global datetimeformat
9590 if {$d ne {}} {
9591 set d [clock format $d -format $datetimeformat]
9593 return $d
9596 # This list of encoding names and aliases is distilled from
9597 # http://www.iana.org/assignments/character-sets.
9598 # Not all of them are supported by Tcl.
9599 set encoding_aliases {
9600 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9601 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9602 { ISO-10646-UTF-1 csISO10646UTF1 }
9603 { ISO_646.basic:1983 ref csISO646basic1983 }
9604 { INVARIANT csINVARIANT }
9605 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9606 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9607 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9608 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9609 { NATS-DANO iso-ir-9-1 csNATSDANO }
9610 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9611 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9612 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9613 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9614 { ISO-2022-KR csISO2022KR }
9615 { EUC-KR csEUCKR }
9616 { ISO-2022-JP csISO2022JP }
9617 { ISO-2022-JP-2 csISO2022JP2 }
9618 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9619 csISO13JISC6220jp }
9620 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9621 { IT iso-ir-15 ISO646-IT csISO15Italian }
9622 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9623 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9624 { greek7-old iso-ir-18 csISO18Greek7Old }
9625 { latin-greek iso-ir-19 csISO19LatinGreek }
9626 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9627 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9628 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9629 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9630 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9631 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9632 { INIS iso-ir-49 csISO49INIS }
9633 { INIS-8 iso-ir-50 csISO50INIS8 }
9634 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9635 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9636 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9637 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9638 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9639 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9640 csISO60Norwegian1 }
9641 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9642 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9643 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9644 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9645 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9646 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9647 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9648 { greek7 iso-ir-88 csISO88Greek7 }
9649 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9650 { iso-ir-90 csISO90 }
9651 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9652 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9653 csISO92JISC62991984b }
9654 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9655 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9656 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9657 csISO95JIS62291984handadd }
9658 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9659 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9660 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9661 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9662 CP819 csISOLatin1 }
9663 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9664 { T.61-7bit iso-ir-102 csISO102T617bit }
9665 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9666 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9667 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9668 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9669 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9670 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9671 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9672 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9673 arabic csISOLatinArabic }
9674 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9675 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9676 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9677 greek greek8 csISOLatinGreek }
9678 { T.101-G2 iso-ir-128 csISO128T101G2 }
9679 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9680 csISOLatinHebrew }
9681 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9682 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9683 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9684 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9685 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9686 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9687 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9688 csISOLatinCyrillic }
9689 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9690 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9691 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9692 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9693 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9694 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9695 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9696 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9697 { ISO_10367-box iso-ir-155 csISO10367Box }
9698 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9699 { latin-lap lap iso-ir-158 csISO158Lap }
9700 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9701 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9702 { us-dk csUSDK }
9703 { dk-us csDKUS }
9704 { JIS_X0201 X0201 csHalfWidthKatakana }
9705 { KSC5636 ISO646-KR csKSC5636 }
9706 { ISO-10646-UCS-2 csUnicode }
9707 { ISO-10646-UCS-4 csUCS4 }
9708 { DEC-MCS dec csDECMCS }
9709 { hp-roman8 roman8 r8 csHPRoman8 }
9710 { macintosh mac csMacintosh }
9711 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9712 csIBM037 }
9713 { IBM038 EBCDIC-INT cp038 csIBM038 }
9714 { IBM273 CP273 csIBM273 }
9715 { IBM274 EBCDIC-BE CP274 csIBM274 }
9716 { IBM275 EBCDIC-BR cp275 csIBM275 }
9717 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9718 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9719 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9720 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9721 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9722 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9723 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9724 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9725 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9726 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9727 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9728 { IBM437 cp437 437 csPC8CodePage437 }
9729 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9730 { IBM775 cp775 csPC775Baltic }
9731 { IBM850 cp850 850 csPC850Multilingual }
9732 { IBM851 cp851 851 csIBM851 }
9733 { IBM852 cp852 852 csPCp852 }
9734 { IBM855 cp855 855 csIBM855 }
9735 { IBM857 cp857 857 csIBM857 }
9736 { IBM860 cp860 860 csIBM860 }
9737 { IBM861 cp861 861 cp-is csIBM861 }
9738 { IBM862 cp862 862 csPC862LatinHebrew }
9739 { IBM863 cp863 863 csIBM863 }
9740 { IBM864 cp864 csIBM864 }
9741 { IBM865 cp865 865 csIBM865 }
9742 { IBM866 cp866 866 csIBM866 }
9743 { IBM868 CP868 cp-ar csIBM868 }
9744 { IBM869 cp869 869 cp-gr csIBM869 }
9745 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9746 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9747 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9748 { IBM891 cp891 csIBM891 }
9749 { IBM903 cp903 csIBM903 }
9750 { IBM904 cp904 904 csIBBM904 }
9751 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9752 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9753 { IBM1026 CP1026 csIBM1026 }
9754 { EBCDIC-AT-DE csIBMEBCDICATDE }
9755 { EBCDIC-AT-DE-A csEBCDICATDEA }
9756 { EBCDIC-CA-FR csEBCDICCAFR }
9757 { EBCDIC-DK-NO csEBCDICDKNO }
9758 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9759 { EBCDIC-FI-SE csEBCDICFISE }
9760 { EBCDIC-FI-SE-A csEBCDICFISEA }
9761 { EBCDIC-FR csEBCDICFR }
9762 { EBCDIC-IT csEBCDICIT }
9763 { EBCDIC-PT csEBCDICPT }
9764 { EBCDIC-ES csEBCDICES }
9765 { EBCDIC-ES-A csEBCDICESA }
9766 { EBCDIC-ES-S csEBCDICESS }
9767 { EBCDIC-UK csEBCDICUK }
9768 { EBCDIC-US csEBCDICUS }
9769 { UNKNOWN-8BIT csUnknown8BiT }
9770 { MNEMONIC csMnemonic }
9771 { MNEM csMnem }
9772 { VISCII csVISCII }
9773 { VIQR csVIQR }
9774 { KOI8-R csKOI8R }
9775 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9776 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9777 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9778 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9779 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9780 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9781 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9782 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9783 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9784 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9785 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9786 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9787 { IBM1047 IBM-1047 }
9788 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9789 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9790 { UNICODE-1-1 csUnicode11 }
9791 { CESU-8 csCESU-8 }
9792 { BOCU-1 csBOCU-1 }
9793 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9794 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9795 l8 }
9796 { ISO-8859-15 ISO_8859-15 Latin-9 }
9797 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9798 { GBK CP936 MS936 windows-936 }
9799 { JIS_Encoding csJISEncoding }
9800 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
9801 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9802 EUC-JP }
9803 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9804 { ISO-10646-UCS-Basic csUnicodeASCII }
9805 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9806 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9807 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9808 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9809 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9810 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9811 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9812 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9813 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9814 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9815 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9816 { Ventura-US csVenturaUS }
9817 { Ventura-International csVenturaInternational }
9818 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9819 { PC8-Turkish csPC8Turkish }
9820 { IBM-Symbols csIBMSymbols }
9821 { IBM-Thai csIBMThai }
9822 { HP-Legal csHPLegal }
9823 { HP-Pi-font csHPPiFont }
9824 { HP-Math8 csHPMath8 }
9825 { Adobe-Symbol-Encoding csHPPSMath }
9826 { HP-DeskTop csHPDesktop }
9827 { Ventura-Math csVenturaMath }
9828 { Microsoft-Publishing csMicrosoftPublishing }
9829 { Windows-31J csWindows31J }
9830 { GB2312 csGB2312 }
9831 { Big5 csBig5 }
9834 proc tcl_encoding {enc} {
9835 global encoding_aliases tcl_encoding_cache
9836 if {[info exists tcl_encoding_cache($enc)]} {
9837 return $tcl_encoding_cache($enc)
9839 set names [encoding names]
9840 set lcnames [string tolower $names]
9841 set enc [string tolower $enc]
9842 set i [lsearch -exact $lcnames $enc]
9843 if {$i < 0} {
9844 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9845 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
9846 set i [lsearch -exact $lcnames $encx]
9849 if {$i < 0} {
9850 foreach l $encoding_aliases {
9851 set ll [string tolower $l]
9852 if {[lsearch -exact $ll $enc] < 0} continue
9853 # look through the aliases for one that tcl knows about
9854 foreach e $ll {
9855 set i [lsearch -exact $lcnames $e]
9856 if {$i < 0} {
9857 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
9858 set i [lsearch -exact $lcnames $ex]
9861 if {$i >= 0} break
9863 break
9866 set tclenc {}
9867 if {$i >= 0} {
9868 set tclenc [lindex $names $i]
9870 set tcl_encoding_cache($enc) $tclenc
9871 return $tclenc
9874 proc gitattr {path attr default} {
9875 global path_attr_cache
9876 if {[info exists path_attr_cache($attr,$path)]} {
9877 set r $path_attr_cache($attr,$path)
9878 } else {
9879 set r "unspecified"
9880 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
9881 regexp "(.*): encoding: (.*)" $line m f r
9883 set path_attr_cache($attr,$path) $r
9885 if {$r eq "unspecified"} {
9886 return $default
9888 return $r
9891 proc cache_gitattr {attr pathlist} {
9892 global path_attr_cache
9893 set newlist {}
9894 foreach path $pathlist {
9895 if {![info exists path_attr_cache($attr,$path)]} {
9896 lappend newlist $path
9899 set lim 1000
9900 if {[tk windowingsystem] == "win32"} {
9901 # windows has a 32k limit on the arguments to a command...
9902 set lim 30
9904 while {$newlist ne {}} {
9905 set head [lrange $newlist 0 [expr {$lim - 1}]]
9906 set newlist [lrange $newlist $lim end]
9907 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
9908 foreach row [split $rlist "\n"] {
9909 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
9910 if {[string index $path 0] eq "\""} {
9911 set path [encoding convertfrom [lindex $path 0]]
9913 set path_attr_cache($attr,$path) $value
9920 proc get_path_encoding {path} {
9921 global gui_encoding perfile_attrs
9922 set tcl_enc $gui_encoding
9923 if {$path ne {} && $perfile_attrs} {
9924 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
9925 if {$enc2 ne {}} {
9926 set tcl_enc $enc2
9929 return $tcl_enc
9932 # First check that Tcl/Tk is recent enough
9933 if {[catch {package require Tk 8.4} err]} {
9934 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9935 Gitk requires at least Tcl/Tk 8.4."]
9936 exit 1
9939 # defaults...
9940 set wrcomcmd "git diff-tree --stdin -p --pretty"
9942 set gitencoding {}
9943 catch {
9944 set gitencoding [exec git config --get i18n.commitencoding]
9946 if {$gitencoding == ""} {
9947 set gitencoding "utf-8"
9949 set tclencoding [tcl_encoding $gitencoding]
9950 if {$tclencoding == {}} {
9951 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9954 set gui_encoding [encoding system]
9955 catch {
9956 set enc [exec git config --get gui.encoding]
9957 if {$enc ne {}} {
9958 set tclenc [tcl_encoding $enc]
9959 if {$tclenc ne {}} {
9960 set gui_encoding $tclenc
9961 } else {
9962 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
9967 set mainfont {Helvetica 9}
9968 set textfont {Courier 9}
9969 set uifont {Helvetica 9 bold}
9970 set tabstop 8
9971 set findmergefiles 0
9972 set maxgraphpct 50
9973 set maxwidth 16
9974 set revlistorder 0
9975 set fastdate 0
9976 set uparrowlen 5
9977 set downarrowlen 5
9978 set mingaplen 100
9979 set cmitmode "patch"
9980 set wrapcomment "none"
9981 set showneartags 1
9982 set maxrefs 20
9983 set maxlinelen 200
9984 set showlocalchanges 1
9985 set limitdiffs 1
9986 set datetimeformat "%Y-%m-%d %H:%M:%S"
9987 set autoselect 1
9988 set perfile_attrs 0
9990 set extdifftool "meld"
9992 set colors {green red blue magenta darkgrey brown orange}
9993 set bgcolor white
9994 set fgcolor black
9995 set diffcolors {red "#00a000" blue}
9996 set diffcontext 3
9997 set ignorespace 0
9998 set selectbgcolor gray85
10000 set circlecolors {white blue gray blue blue}
10002 # button for popping up context menus
10003 if {[tk windowingsystem] eq "aqua"} {
10004 set ctxbut <Button-2>
10005 } else {
10006 set ctxbut <Button-3>
10009 ## For msgcat loading, first locate the installation location.
10010 if { [info exists ::env(GITK_MSGSDIR)] } {
10011 ## Msgsdir was manually set in the environment.
10012 set gitk_msgsdir $::env(GITK_MSGSDIR)
10013 } else {
10014 ## Let's guess the prefix from argv0.
10015 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10016 set gitk_libdir [file join $gitk_prefix share gitk lib]
10017 set gitk_msgsdir [file join $gitk_libdir msgs]
10018 unset gitk_prefix
10021 ## Internationalization (i18n) through msgcat and gettext. See
10022 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10023 package require msgcat
10024 namespace import ::msgcat::mc
10025 ## And eventually load the actual message catalog
10026 ::msgcat::mcload $gitk_msgsdir
10028 catch {source ~/.gitk}
10030 font create optionfont -family sans-serif -size -12
10032 parsefont mainfont $mainfont
10033 eval font create mainfont [fontflags mainfont]
10034 eval font create mainfontbold [fontflags mainfont 1]
10036 parsefont textfont $textfont
10037 eval font create textfont [fontflags textfont]
10038 eval font create textfontbold [fontflags textfont 1]
10040 parsefont uifont $uifont
10041 eval font create uifont [fontflags uifont]
10043 setoptions
10045 # check that we can find a .git directory somewhere...
10046 if {[catch {set gitdir [gitdir]}]} {
10047 show_error {} . [mc "Cannot find a git repository here."]
10048 exit 1
10050 if {![file isdirectory $gitdir]} {
10051 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10052 exit 1
10055 set selecthead {}
10056 set selectheadid {}
10058 set revtreeargs {}
10059 set cmdline_files {}
10060 set i 0
10061 set revtreeargscmd {}
10062 foreach arg $argv {
10063 switch -glob -- $arg {
10064 "" { }
10065 "--" {
10066 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10067 break
10069 "--select-commit=*" {
10070 set selecthead [string range $arg 16 end]
10072 "--argscmd=*" {
10073 set revtreeargscmd [string range $arg 10 end]
10075 default {
10076 lappend revtreeargs $arg
10079 incr i
10082 if {$selecthead eq "HEAD"} {
10083 set selecthead {}
10086 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10087 # no -- on command line, but some arguments (other than --argscmd)
10088 if {[catch {
10089 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10090 set cmdline_files [split $f "\n"]
10091 set n [llength $cmdline_files]
10092 set revtreeargs [lrange $revtreeargs 0 end-$n]
10093 # Unfortunately git rev-parse doesn't produce an error when
10094 # something is both a revision and a filename. To be consistent
10095 # with git log and git rev-list, check revtreeargs for filenames.
10096 foreach arg $revtreeargs {
10097 if {[file exists $arg]} {
10098 show_error {} . [mc "Ambiguous argument '%s': both revision\
10099 and filename" $arg]
10100 exit 1
10103 } err]} {
10104 # unfortunately we get both stdout and stderr in $err,
10105 # so look for "fatal:".
10106 set i [string first "fatal:" $err]
10107 if {$i > 0} {
10108 set err [string range $err [expr {$i + 6}] end]
10110 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10111 exit 1
10115 set nullid "0000000000000000000000000000000000000000"
10116 set nullid2 "0000000000000000000000000000000000000001"
10117 set nullfile "/dev/null"
10119 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10121 set runq {}
10122 set history {}
10123 set historyindex 0
10124 set fh_serial 0
10125 set nhl_names {}
10126 set highlight_paths {}
10127 set findpattern {}
10128 set searchdirn -forwards
10129 set boldrows {}
10130 set boldnamerows {}
10131 set diffelide {0 0}
10132 set markingmatches 0
10133 set linkentercount 0
10134 set need_redisplay 0
10135 set nrows_drawn 0
10136 set firsttabstop 0
10138 set nextviewnum 1
10139 set curview 0
10140 set selectedview 0
10141 set selectedhlview [mc "None"]
10142 set highlight_related [mc "None"]
10143 set highlight_files {}
10144 set viewfiles(0) {}
10145 set viewperm(0) 0
10146 set viewargs(0) {}
10147 set viewargscmd(0) {}
10149 set selectedline {}
10150 set numcommits 0
10151 set loginstance 0
10152 set cmdlineok 0
10153 set stopped 0
10154 set stuffsaved 0
10155 set patchnum 0
10156 set lserial 0
10157 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10158 setcoords
10159 makewindow
10160 # wait for the window to become visible
10161 tkwait visibility .
10162 wm title . "[file tail $argv0]: [file tail [pwd]]"
10163 readrefs
10165 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10166 # create a view for the files/dirs specified on the command line
10167 set curview 1
10168 set selectedview 1
10169 set nextviewnum 2
10170 set viewname(1) [mc "Command line"]
10171 set viewfiles(1) $cmdline_files
10172 set viewargs(1) $revtreeargs
10173 set viewargscmd(1) $revtreeargscmd
10174 set viewperm(1) 0
10175 set vdatemode(1) 0
10176 addviewmenu 1
10177 .bar.view entryconf [mca "Edit view..."] -state normal
10178 .bar.view entryconf [mca "Delete view"] -state normal
10181 if {[info exists permviews]} {
10182 foreach v $permviews {
10183 set n $nextviewnum
10184 incr nextviewnum
10185 set viewname($n) [lindex $v 0]
10186 set viewfiles($n) [lindex $v 1]
10187 set viewargs($n) [lindex $v 2]
10188 set viewargscmd($n) [lindex $v 3]
10189 set viewperm($n) 1
10190 addviewmenu $n
10193 getcommits {}