git-p4: chdir now properly sets PWD environment variable in msysGit
[git/git-p4.git] / gitk-git / gitk
blob087c4ac733be4b788751d0bae5b7aad22ce0dd99
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 "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 "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
423 if {$selid ne {}} {
424 set pending_select $selid
425 } else {
426 set pending_select $mainheadid
430 proc getcommits {selid} {
431 global canv curview need_redisplay viewactive
433 initlayout
434 if {[start_rev_list $curview]} {
435 reset_pending_select $selid
436 show_status [mc "Reading commits..."]
437 set need_redisplay 1
438 } else {
439 show_status [mc "No commits selected"]
443 proc updatecommits {} {
444 global curview vcanopt vorigargs vfilelimit viewinstances
445 global viewactive viewcomplete tclencoding
446 global startmsecs showneartags showlocalchanges
447 global mainheadid pending_select
448 global isworktree
449 global varcid vposids vnegids vflags vrevs
451 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
452 set oldmainid $mainheadid
453 rereadrefs
454 if {$showlocalchanges} {
455 if {$mainheadid ne $oldmainid} {
456 dohidelocalchanges
458 if {[commitinview $mainheadid $curview]} {
459 dodiffindex
462 set view $curview
463 if {$vcanopt($view)} {
464 set oldpos $vposids($view)
465 set oldneg $vnegids($view)
466 set revs [parseviewrevs $view $vrevs($view)]
467 if {$revs eq {}} {
468 return
470 # note: getting the delta when negative refs change is hard,
471 # and could require multiple git log invocations, so in that
472 # case we ask git log for all the commits (not just the delta)
473 if {$oldneg eq $vnegids($view)} {
474 set newrevs {}
475 set npos 0
476 # take out positive refs that we asked for before or
477 # that we have already seen
478 foreach rev $revs {
479 if {[string length $rev] == 40} {
480 if {[lsearch -exact $oldpos $rev] < 0
481 && ![info exists varcid($view,$rev)]} {
482 lappend newrevs $rev
483 incr npos
485 } else {
486 lappend $newrevs $rev
489 if {$npos == 0} return
490 set revs $newrevs
491 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
493 set args [concat $vflags($view) $revs --not $oldpos]
494 } else {
495 set args $vorigargs($view)
497 if {[catch {
498 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
499 --boundary $args "--" $vfilelimit($view)] r]
500 } err]} {
501 error_popup "Error executing git log: $err"
502 return
504 if {$viewactive($view) == 0} {
505 set startmsecs [clock clicks -milliseconds]
507 set i [reg_instance $fd]
508 lappend viewinstances($view) $i
509 fconfigure $fd -blocking 0 -translation lf -eofchar {}
510 if {$tclencoding != {}} {
511 fconfigure $fd -encoding $tclencoding
513 filerun $fd [list getcommitlines $fd $i $view 1]
514 incr viewactive($view)
515 set viewcomplete($view) 0
516 reset_pending_select {}
517 nowbusy $view "Reading"
518 if {$showneartags} {
519 getallcommits
523 proc reloadcommits {} {
524 global curview viewcomplete selectedline currentid thickerline
525 global showneartags treediffs commitinterest cached_commitrow
526 global targetid
528 set selid {}
529 if {$selectedline ne {}} {
530 set selid $currentid
533 if {!$viewcomplete($curview)} {
534 stop_rev_list $curview
536 resetvarcs $curview
537 set selectedline {}
538 catch {unset currentid}
539 catch {unset thickerline}
540 catch {unset treediffs}
541 readrefs
542 changedrefs
543 if {$showneartags} {
544 getallcommits
546 clear_display
547 catch {unset commitinterest}
548 catch {unset cached_commitrow}
549 catch {unset targetid}
550 setcanvscroll
551 getcommits $selid
552 return 0
555 # This makes a string representation of a positive integer which
556 # sorts as a string in numerical order
557 proc strrep {n} {
558 if {$n < 16} {
559 return [format "%x" $n]
560 } elseif {$n < 256} {
561 return [format "x%.2x" $n]
562 } elseif {$n < 65536} {
563 return [format "y%.4x" $n]
565 return [format "z%.8x" $n]
568 # Procedures used in reordering commits from git log (without
569 # --topo-order) into the order for display.
571 proc varcinit {view} {
572 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
573 global vtokmod varcmod vrowmod varcix vlastins
575 set varcstart($view) {{}}
576 set vupptr($view) {0}
577 set vdownptr($view) {0}
578 set vleftptr($view) {0}
579 set vbackptr($view) {0}
580 set varctok($view) {{}}
581 set varcrow($view) {{}}
582 set vtokmod($view) {}
583 set varcmod($view) 0
584 set vrowmod($view) 0
585 set varcix($view) {{}}
586 set vlastins($view) {0}
589 proc resetvarcs {view} {
590 global varcid varccommits parents children vseedcount ordertok
592 foreach vid [array names varcid $view,*] {
593 unset varcid($vid)
594 unset children($vid)
595 unset parents($vid)
597 # some commits might have children but haven't been seen yet
598 foreach vid [array names children $view,*] {
599 unset children($vid)
601 foreach va [array names varccommits $view,*] {
602 unset varccommits($va)
604 foreach vd [array names vseedcount $view,*] {
605 unset vseedcount($vd)
607 catch {unset ordertok}
610 # returns a list of the commits with no children
611 proc seeds {v} {
612 global vdownptr vleftptr varcstart
614 set ret {}
615 set a [lindex $vdownptr($v) 0]
616 while {$a != 0} {
617 lappend ret [lindex $varcstart($v) $a]
618 set a [lindex $vleftptr($v) $a]
620 return $ret
623 proc newvarc {view id} {
624 global varcid varctok parents children vdatemode
625 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
626 global commitdata commitinfo vseedcount varccommits vlastins
628 set a [llength $varctok($view)]
629 set vid $view,$id
630 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
631 if {![info exists commitinfo($id)]} {
632 parsecommit $id $commitdata($id) 1
634 set cdate [lindex $commitinfo($id) 4]
635 if {![string is integer -strict $cdate]} {
636 set cdate 0
638 if {![info exists vseedcount($view,$cdate)]} {
639 set vseedcount($view,$cdate) -1
641 set c [incr vseedcount($view,$cdate)]
642 set cdate [expr {$cdate ^ 0xffffffff}]
643 set tok "s[strrep $cdate][strrep $c]"
644 } else {
645 set tok {}
647 set ka 0
648 if {[llength $children($vid)] > 0} {
649 set kid [lindex $children($vid) end]
650 set k $varcid($view,$kid)
651 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
652 set ki $kid
653 set ka $k
654 set tok [lindex $varctok($view) $k]
657 if {$ka != 0} {
658 set i [lsearch -exact $parents($view,$ki) $id]
659 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
660 append tok [strrep $j]
662 set c [lindex $vlastins($view) $ka]
663 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
664 set c $ka
665 set b [lindex $vdownptr($view) $ka]
666 } else {
667 set b [lindex $vleftptr($view) $c]
669 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
670 set c $b
671 set b [lindex $vleftptr($view) $c]
673 if {$c == $ka} {
674 lset vdownptr($view) $ka $a
675 lappend vbackptr($view) 0
676 } else {
677 lset vleftptr($view) $c $a
678 lappend vbackptr($view) $c
680 lset vlastins($view) $ka $a
681 lappend vupptr($view) $ka
682 lappend vleftptr($view) $b
683 if {$b != 0} {
684 lset vbackptr($view) $b $a
686 lappend varctok($view) $tok
687 lappend varcstart($view) $id
688 lappend vdownptr($view) 0
689 lappend varcrow($view) {}
690 lappend varcix($view) {}
691 set varccommits($view,$a) {}
692 lappend vlastins($view) 0
693 return $a
696 proc splitvarc {p v} {
697 global varcid varcstart varccommits varctok
698 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
700 set oa $varcid($v,$p)
701 set ac $varccommits($v,$oa)
702 set i [lsearch -exact $varccommits($v,$oa) $p]
703 if {$i <= 0} return
704 set na [llength $varctok($v)]
705 # "%" sorts before "0"...
706 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
707 lappend varctok($v) $tok
708 lappend varcrow($v) {}
709 lappend varcix($v) {}
710 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
711 set varccommits($v,$na) [lrange $ac $i end]
712 lappend varcstart($v) $p
713 foreach id $varccommits($v,$na) {
714 set varcid($v,$id) $na
716 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
717 lappend vlastins($v) [lindex $vlastins($v) $oa]
718 lset vdownptr($v) $oa $na
719 lset vlastins($v) $oa 0
720 lappend vupptr($v) $oa
721 lappend vleftptr($v) 0
722 lappend vbackptr($v) 0
723 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
724 lset vupptr($v) $b $na
728 proc renumbervarc {a v} {
729 global parents children varctok varcstart varccommits
730 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
732 set t1 [clock clicks -milliseconds]
733 set todo {}
734 set isrelated($a) 1
735 set kidchanged($a) 1
736 set ntot 0
737 while {$a != 0} {
738 if {[info exists isrelated($a)]} {
739 lappend todo $a
740 set id [lindex $varccommits($v,$a) end]
741 foreach p $parents($v,$id) {
742 if {[info exists varcid($v,$p)]} {
743 set isrelated($varcid($v,$p)) 1
747 incr ntot
748 set b [lindex $vdownptr($v) $a]
749 if {$b == 0} {
750 while {$a != 0} {
751 set b [lindex $vleftptr($v) $a]
752 if {$b != 0} break
753 set a [lindex $vupptr($v) $a]
756 set a $b
758 foreach a $todo {
759 if {![info exists kidchanged($a)]} continue
760 set id [lindex $varcstart($v) $a]
761 if {[llength $children($v,$id)] > 1} {
762 set children($v,$id) [lsort -command [list vtokcmp $v] \
763 $children($v,$id)]
765 set oldtok [lindex $varctok($v) $a]
766 if {!$vdatemode($v)} {
767 set tok {}
768 } else {
769 set tok $oldtok
771 set ka 0
772 set kid [last_real_child $v,$id]
773 if {$kid ne {}} {
774 set k $varcid($v,$kid)
775 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
776 set ki $kid
777 set ka $k
778 set tok [lindex $varctok($v) $k]
781 if {$ka != 0} {
782 set i [lsearch -exact $parents($v,$ki) $id]
783 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
784 append tok [strrep $j]
786 if {$tok eq $oldtok} {
787 continue
789 set id [lindex $varccommits($v,$a) end]
790 foreach p $parents($v,$id) {
791 if {[info exists varcid($v,$p)]} {
792 set kidchanged($varcid($v,$p)) 1
793 } else {
794 set sortkids($p) 1
797 lset varctok($v) $a $tok
798 set b [lindex $vupptr($v) $a]
799 if {$b != $ka} {
800 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
801 modify_arc $v $ka
803 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
804 modify_arc $v $b
806 set c [lindex $vbackptr($v) $a]
807 set d [lindex $vleftptr($v) $a]
808 if {$c == 0} {
809 lset vdownptr($v) $b $d
810 } else {
811 lset vleftptr($v) $c $d
813 if {$d != 0} {
814 lset vbackptr($v) $d $c
816 if {[lindex $vlastins($v) $b] == $a} {
817 lset vlastins($v) $b $c
819 lset vupptr($v) $a $ka
820 set c [lindex $vlastins($v) $ka]
821 if {$c == 0 || \
822 [string compare $tok [lindex $varctok($v) $c]] < 0} {
823 set c $ka
824 set b [lindex $vdownptr($v) $ka]
825 } else {
826 set b [lindex $vleftptr($v) $c]
828 while {$b != 0 && \
829 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
830 set c $b
831 set b [lindex $vleftptr($v) $c]
833 if {$c == $ka} {
834 lset vdownptr($v) $ka $a
835 lset vbackptr($v) $a 0
836 } else {
837 lset vleftptr($v) $c $a
838 lset vbackptr($v) $a $c
840 lset vleftptr($v) $a $b
841 if {$b != 0} {
842 lset vbackptr($v) $b $a
844 lset vlastins($v) $ka $a
847 foreach id [array names sortkids] {
848 if {[llength $children($v,$id)] > 1} {
849 set children($v,$id) [lsort -command [list vtokcmp $v] \
850 $children($v,$id)]
853 set t2 [clock clicks -milliseconds]
854 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
857 # Fix up the graph after we have found out that in view $v,
858 # $p (a commit that we have already seen) is actually the parent
859 # of the last commit in arc $a.
860 proc fix_reversal {p a v} {
861 global varcid varcstart varctok vupptr
863 set pa $varcid($v,$p)
864 if {$p ne [lindex $varcstart($v) $pa]} {
865 splitvarc $p $v
866 set pa $varcid($v,$p)
868 # seeds always need to be renumbered
869 if {[lindex $vupptr($v) $pa] == 0 ||
870 [string compare [lindex $varctok($v) $a] \
871 [lindex $varctok($v) $pa]] > 0} {
872 renumbervarc $pa $v
876 proc insertrow {id p v} {
877 global cmitlisted children parents varcid varctok vtokmod
878 global varccommits ordertok commitidx numcommits curview
879 global targetid targetrow
881 readcommit $id
882 set vid $v,$id
883 set cmitlisted($vid) 1
884 set children($vid) {}
885 set parents($vid) [list $p]
886 set a [newvarc $v $id]
887 set varcid($vid) $a
888 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
889 modify_arc $v $a
891 lappend varccommits($v,$a) $id
892 set vp $v,$p
893 if {[llength [lappend children($vp) $id]] > 1} {
894 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
895 catch {unset ordertok}
897 fix_reversal $p $a $v
898 incr commitidx($v)
899 if {$v == $curview} {
900 set numcommits $commitidx($v)
901 setcanvscroll
902 if {[info exists targetid]} {
903 if {![comes_before $targetid $p]} {
904 incr targetrow
910 proc insertfakerow {id p} {
911 global varcid varccommits parents children cmitlisted
912 global commitidx varctok vtokmod targetid targetrow curview numcommits
914 set v $curview
915 set a $varcid($v,$p)
916 set i [lsearch -exact $varccommits($v,$a) $p]
917 if {$i < 0} {
918 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
919 return
921 set children($v,$id) {}
922 set parents($v,$id) [list $p]
923 set varcid($v,$id) $a
924 lappend children($v,$p) $id
925 set cmitlisted($v,$id) 1
926 set numcommits [incr commitidx($v)]
927 # note we deliberately don't update varcstart($v) even if $i == 0
928 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
929 modify_arc $v $a $i
930 if {[info exists targetid]} {
931 if {![comes_before $targetid $p]} {
932 incr targetrow
935 setcanvscroll
936 drawvisible
939 proc removefakerow {id} {
940 global varcid varccommits parents children commitidx
941 global varctok vtokmod cmitlisted currentid selectedline
942 global targetid curview numcommits
944 set v $curview
945 if {[llength $parents($v,$id)] != 1} {
946 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
947 return
949 set p [lindex $parents($v,$id) 0]
950 set a $varcid($v,$id)
951 set i [lsearch -exact $varccommits($v,$a) $id]
952 if {$i < 0} {
953 puts "oops: removefakerow can't find [shortids $id] on arc $a"
954 return
956 unset varcid($v,$id)
957 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
958 unset parents($v,$id)
959 unset children($v,$id)
960 unset cmitlisted($v,$id)
961 set numcommits [incr commitidx($v) -1]
962 set j [lsearch -exact $children($v,$p) $id]
963 if {$j >= 0} {
964 set children($v,$p) [lreplace $children($v,$p) $j $j]
966 modify_arc $v $a $i
967 if {[info exist currentid] && $id eq $currentid} {
968 unset currentid
969 set selectedline {}
971 if {[info exists targetid] && $targetid eq $id} {
972 set targetid $p
974 setcanvscroll
975 drawvisible
978 proc first_real_child {vp} {
979 global children nullid nullid2
981 foreach id $children($vp) {
982 if {$id ne $nullid && $id ne $nullid2} {
983 return $id
986 return {}
989 proc last_real_child {vp} {
990 global children nullid nullid2
992 set kids $children($vp)
993 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
994 set id [lindex $kids $i]
995 if {$id ne $nullid && $id ne $nullid2} {
996 return $id
999 return {}
1002 proc vtokcmp {v a b} {
1003 global varctok varcid
1005 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1006 [lindex $varctok($v) $varcid($v,$b)]]
1009 # This assumes that if lim is not given, the caller has checked that
1010 # arc a's token is less than $vtokmod($v)
1011 proc modify_arc {v a {lim {}}} {
1012 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1014 if {$lim ne {}} {
1015 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1016 if {$c > 0} return
1017 if {$c == 0} {
1018 set r [lindex $varcrow($v) $a]
1019 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1022 set vtokmod($v) [lindex $varctok($v) $a]
1023 set varcmod($v) $a
1024 if {$v == $curview} {
1025 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1026 set a [lindex $vupptr($v) $a]
1027 set lim {}
1029 set r 0
1030 if {$a != 0} {
1031 if {$lim eq {}} {
1032 set lim [llength $varccommits($v,$a)]
1034 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1036 set vrowmod($v) $r
1037 undolayout $r
1041 proc update_arcrows {v} {
1042 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1043 global varcid vrownum varcorder varcix varccommits
1044 global vupptr vdownptr vleftptr varctok
1045 global displayorder parentlist curview cached_commitrow
1047 if {$vrowmod($v) == $commitidx($v)} return
1048 if {$v == $curview} {
1049 if {[llength $displayorder] > $vrowmod($v)} {
1050 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1051 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1053 catch {unset cached_commitrow}
1055 set narctot [expr {[llength $varctok($v)] - 1}]
1056 set a $varcmod($v)
1057 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1058 # go up the tree until we find something that has a row number,
1059 # or we get to a seed
1060 set a [lindex $vupptr($v) $a]
1062 if {$a == 0} {
1063 set a [lindex $vdownptr($v) 0]
1064 if {$a == 0} return
1065 set vrownum($v) {0}
1066 set varcorder($v) [list $a]
1067 lset varcix($v) $a 0
1068 lset varcrow($v) $a 0
1069 set arcn 0
1070 set row 0
1071 } else {
1072 set arcn [lindex $varcix($v) $a]
1073 if {[llength $vrownum($v)] > $arcn + 1} {
1074 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1075 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1077 set row [lindex $varcrow($v) $a]
1079 while {1} {
1080 set p $a
1081 incr row [llength $varccommits($v,$a)]
1082 # go down if possible
1083 set b [lindex $vdownptr($v) $a]
1084 if {$b == 0} {
1085 # if not, go left, or go up until we can go left
1086 while {$a != 0} {
1087 set b [lindex $vleftptr($v) $a]
1088 if {$b != 0} break
1089 set a [lindex $vupptr($v) $a]
1091 if {$a == 0} break
1093 set a $b
1094 incr arcn
1095 lappend vrownum($v) $row
1096 lappend varcorder($v) $a
1097 lset varcix($v) $a $arcn
1098 lset varcrow($v) $a $row
1100 set vtokmod($v) [lindex $varctok($v) $p]
1101 set varcmod($v) $p
1102 set vrowmod($v) $row
1103 if {[info exists currentid]} {
1104 set selectedline [rowofcommit $currentid]
1108 # Test whether view $v contains commit $id
1109 proc commitinview {id v} {
1110 global varcid
1112 return [info exists varcid($v,$id)]
1115 # Return the row number for commit $id in the current view
1116 proc rowofcommit {id} {
1117 global varcid varccommits varcrow curview cached_commitrow
1118 global varctok vtokmod
1120 set v $curview
1121 if {![info exists varcid($v,$id)]} {
1122 puts "oops rowofcommit no arc for [shortids $id]"
1123 return {}
1125 set a $varcid($v,$id)
1126 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1127 update_arcrows $v
1129 if {[info exists cached_commitrow($id)]} {
1130 return $cached_commitrow($id)
1132 set i [lsearch -exact $varccommits($v,$a) $id]
1133 if {$i < 0} {
1134 puts "oops didn't find commit [shortids $id] in arc $a"
1135 return {}
1137 incr i [lindex $varcrow($v) $a]
1138 set cached_commitrow($id) $i
1139 return $i
1142 # Returns 1 if a is on an earlier row than b, otherwise 0
1143 proc comes_before {a b} {
1144 global varcid varctok curview
1146 set v $curview
1147 if {$a eq $b || ![info exists varcid($v,$a)] || \
1148 ![info exists varcid($v,$b)]} {
1149 return 0
1151 if {$varcid($v,$a) != $varcid($v,$b)} {
1152 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1153 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1155 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1158 proc bsearch {l elt} {
1159 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1160 return 0
1162 set lo 0
1163 set hi [llength $l]
1164 while {$hi - $lo > 1} {
1165 set mid [expr {int(($lo + $hi) / 2)}]
1166 set t [lindex $l $mid]
1167 if {$elt < $t} {
1168 set hi $mid
1169 } elseif {$elt > $t} {
1170 set lo $mid
1171 } else {
1172 return $mid
1175 return $lo
1178 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1179 proc make_disporder {start end} {
1180 global vrownum curview commitidx displayorder parentlist
1181 global varccommits varcorder parents vrowmod varcrow
1182 global d_valid_start d_valid_end
1184 if {$end > $vrowmod($curview)} {
1185 update_arcrows $curview
1187 set ai [bsearch $vrownum($curview) $start]
1188 set start [lindex $vrownum($curview) $ai]
1189 set narc [llength $vrownum($curview)]
1190 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1191 set a [lindex $varcorder($curview) $ai]
1192 set l [llength $displayorder]
1193 set al [llength $varccommits($curview,$a)]
1194 if {$l < $r + $al} {
1195 if {$l < $r} {
1196 set pad [ntimes [expr {$r - $l}] {}]
1197 set displayorder [concat $displayorder $pad]
1198 set parentlist [concat $parentlist $pad]
1199 } elseif {$l > $r} {
1200 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1201 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1203 foreach id $varccommits($curview,$a) {
1204 lappend displayorder $id
1205 lappend parentlist $parents($curview,$id)
1207 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1208 set i $r
1209 foreach id $varccommits($curview,$a) {
1210 lset displayorder $i $id
1211 lset parentlist $i $parents($curview,$id)
1212 incr i
1215 incr r $al
1219 proc commitonrow {row} {
1220 global displayorder
1222 set id [lindex $displayorder $row]
1223 if {$id eq {}} {
1224 make_disporder $row [expr {$row + 1}]
1225 set id [lindex $displayorder $row]
1227 return $id
1230 proc closevarcs {v} {
1231 global varctok varccommits varcid parents children
1232 global cmitlisted commitidx commitinterest vtokmod
1234 set missing_parents 0
1235 set scripts {}
1236 set narcs [llength $varctok($v)]
1237 for {set a 1} {$a < $narcs} {incr a} {
1238 set id [lindex $varccommits($v,$a) end]
1239 foreach p $parents($v,$id) {
1240 if {[info exists varcid($v,$p)]} continue
1241 # add p as a new commit
1242 incr missing_parents
1243 set cmitlisted($v,$p) 0
1244 set parents($v,$p) {}
1245 if {[llength $children($v,$p)] == 1 &&
1246 [llength $parents($v,$id)] == 1} {
1247 set b $a
1248 } else {
1249 set b [newvarc $v $p]
1251 set varcid($v,$p) $b
1252 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1253 modify_arc $v $b
1255 lappend varccommits($v,$b) $p
1256 incr commitidx($v)
1257 if {[info exists commitinterest($p)]} {
1258 foreach script $commitinterest($p) {
1259 lappend scripts [string map [list "%I" $p] $script]
1261 unset commitinterest($id)
1265 if {$missing_parents > 0} {
1266 foreach s $scripts {
1267 eval $s
1272 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1273 # Assumes we already have an arc for $rwid.
1274 proc rewrite_commit {v id rwid} {
1275 global children parents varcid varctok vtokmod varccommits
1277 foreach ch $children($v,$id) {
1278 # make $rwid be $ch's parent in place of $id
1279 set i [lsearch -exact $parents($v,$ch) $id]
1280 if {$i < 0} {
1281 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1283 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1284 # add $ch to $rwid's children and sort the list if necessary
1285 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1286 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1287 $children($v,$rwid)]
1289 # fix the graph after joining $id to $rwid
1290 set a $varcid($v,$ch)
1291 fix_reversal $rwid $a $v
1292 # parentlist is wrong for the last element of arc $a
1293 # even if displayorder is right, hence the 3rd arg here
1294 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1298 proc getcommitlines {fd inst view updating} {
1299 global cmitlisted commitinterest leftover
1300 global commitidx commitdata vdatemode
1301 global parents children curview hlview
1302 global idpending ordertok
1303 global varccommits varcid varctok vtokmod vfilelimit
1305 set stuff [read $fd 500000]
1306 # git log doesn't terminate the last commit with a null...
1307 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1308 set stuff "\0"
1310 if {$stuff == {}} {
1311 if {![eof $fd]} {
1312 return 1
1314 global commfd viewcomplete viewactive viewname
1315 global viewinstances
1316 unset commfd($inst)
1317 set i [lsearch -exact $viewinstances($view) $inst]
1318 if {$i >= 0} {
1319 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1321 # set it blocking so we wait for the process to terminate
1322 fconfigure $fd -blocking 1
1323 if {[catch {close $fd} err]} {
1324 set fv {}
1325 if {$view != $curview} {
1326 set fv " for the \"$viewname($view)\" view"
1328 if {[string range $err 0 4] == "usage"} {
1329 set err "Gitk: error reading commits$fv:\
1330 bad arguments to git log."
1331 if {$viewname($view) eq "Command line"} {
1332 append err \
1333 " (Note: arguments to gitk are passed to git log\
1334 to allow selection of commits to be displayed.)"
1336 } else {
1337 set err "Error reading commits$fv: $err"
1339 error_popup $err
1341 if {[incr viewactive($view) -1] <= 0} {
1342 set viewcomplete($view) 1
1343 # Check if we have seen any ids listed as parents that haven't
1344 # appeared in the list
1345 closevarcs $view
1346 notbusy $view
1348 if {$view == $curview} {
1349 run chewcommits
1351 return 0
1353 set start 0
1354 set gotsome 0
1355 set scripts {}
1356 while 1 {
1357 set i [string first "\0" $stuff $start]
1358 if {$i < 0} {
1359 append leftover($inst) [string range $stuff $start end]
1360 break
1362 if {$start == 0} {
1363 set cmit $leftover($inst)
1364 append cmit [string range $stuff 0 [expr {$i - 1}]]
1365 set leftover($inst) {}
1366 } else {
1367 set cmit [string range $stuff $start [expr {$i - 1}]]
1369 set start [expr {$i + 1}]
1370 set j [string first "\n" $cmit]
1371 set ok 0
1372 set listed 1
1373 if {$j >= 0 && [string match "commit *" $cmit]} {
1374 set ids [string range $cmit 7 [expr {$j - 1}]]
1375 if {[string match {[-^<>]*} $ids]} {
1376 switch -- [string index $ids 0] {
1377 "-" {set listed 0}
1378 "^" {set listed 2}
1379 "<" {set listed 3}
1380 ">" {set listed 4}
1382 set ids [string range $ids 1 end]
1384 set ok 1
1385 foreach id $ids {
1386 if {[string length $id] != 40} {
1387 set ok 0
1388 break
1392 if {!$ok} {
1393 set shortcmit $cmit
1394 if {[string length $shortcmit] > 80} {
1395 set shortcmit "[string range $shortcmit 0 80]..."
1397 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1398 exit 1
1400 set id [lindex $ids 0]
1401 set vid $view,$id
1403 if {!$listed && $updating && ![info exists varcid($vid)] &&
1404 $vfilelimit($view) ne {}} {
1405 # git log doesn't rewrite parents for unlisted commits
1406 # when doing path limiting, so work around that here
1407 # by working out the rewritten parent with git rev-list
1408 # and if we already know about it, using the rewritten
1409 # parent as a substitute parent for $id's children.
1410 if {![catch {
1411 set rwid [exec git rev-list --first-parent --max-count=1 \
1412 $id -- $vfilelimit($view)]
1413 }]} {
1414 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1415 # use $rwid in place of $id
1416 rewrite_commit $view $id $rwid
1417 continue
1422 set a 0
1423 if {[info exists varcid($vid)]} {
1424 if {$cmitlisted($vid) || !$listed} continue
1425 set a $varcid($vid)
1427 if {$listed} {
1428 set olds [lrange $ids 1 end]
1429 } else {
1430 set olds {}
1432 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1433 set cmitlisted($vid) $listed
1434 set parents($vid) $olds
1435 if {![info exists children($vid)]} {
1436 set children($vid) {}
1437 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1438 set k [lindex $children($vid) 0]
1439 if {[llength $parents($view,$k)] == 1 &&
1440 (!$vdatemode($view) ||
1441 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1442 set a $varcid($view,$k)
1445 if {$a == 0} {
1446 # new arc
1447 set a [newvarc $view $id]
1449 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1450 modify_arc $view $a
1452 if {![info exists varcid($vid)]} {
1453 set varcid($vid) $a
1454 lappend varccommits($view,$a) $id
1455 incr commitidx($view)
1458 set i 0
1459 foreach p $olds {
1460 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1461 set vp $view,$p
1462 if {[llength [lappend children($vp) $id]] > 1 &&
1463 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1464 set children($vp) [lsort -command [list vtokcmp $view] \
1465 $children($vp)]
1466 catch {unset ordertok}
1468 if {[info exists varcid($view,$p)]} {
1469 fix_reversal $p $a $view
1472 incr i
1475 if {[info exists commitinterest($id)]} {
1476 foreach script $commitinterest($id) {
1477 lappend scripts [string map [list "%I" $id] $script]
1479 unset commitinterest($id)
1481 set gotsome 1
1483 if {$gotsome} {
1484 global numcommits hlview
1486 if {$view == $curview} {
1487 set numcommits $commitidx($view)
1488 run chewcommits
1490 if {[info exists hlview] && $view == $hlview} {
1491 # we never actually get here...
1492 run vhighlightmore
1494 foreach s $scripts {
1495 eval $s
1498 return 2
1501 proc chewcommits {} {
1502 global curview hlview viewcomplete
1503 global pending_select
1505 layoutmore
1506 if {$viewcomplete($curview)} {
1507 global commitidx varctok
1508 global numcommits startmsecs
1510 if {[info exists pending_select]} {
1511 update
1512 reset_pending_select {}
1514 if {[commitinview $pending_select $curview]} {
1515 selectline [rowofcommit $pending_select] 1
1516 } else {
1517 set row [first_real_row]
1518 selectline $row 1
1521 if {$commitidx($curview) > 0} {
1522 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1523 #puts "overall $ms ms for $numcommits commits"
1524 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1525 } else {
1526 show_status [mc "No commits selected"]
1528 notbusy layout
1530 return 0
1533 proc readcommit {id} {
1534 if {[catch {set contents [exec git cat-file commit $id]}]} return
1535 parsecommit $id $contents 0
1538 proc parsecommit {id contents listed} {
1539 global commitinfo cdate
1541 set inhdr 1
1542 set comment {}
1543 set headline {}
1544 set auname {}
1545 set audate {}
1546 set comname {}
1547 set comdate {}
1548 set hdrend [string first "\n\n" $contents]
1549 if {$hdrend < 0} {
1550 # should never happen...
1551 set hdrend [string length $contents]
1553 set header [string range $contents 0 [expr {$hdrend - 1}]]
1554 set comment [string range $contents [expr {$hdrend + 2}] end]
1555 foreach line [split $header "\n"] {
1556 set tag [lindex $line 0]
1557 if {$tag == "author"} {
1558 set audate [lindex $line end-1]
1559 set auname [lrange $line 1 end-2]
1560 } elseif {$tag == "committer"} {
1561 set comdate [lindex $line end-1]
1562 set comname [lrange $line 1 end-2]
1565 set headline {}
1566 # take the first non-blank line of the comment as the headline
1567 set headline [string trimleft $comment]
1568 set i [string first "\n" $headline]
1569 if {$i >= 0} {
1570 set headline [string range $headline 0 $i]
1572 set headline [string trimright $headline]
1573 set i [string first "\r" $headline]
1574 if {$i >= 0} {
1575 set headline [string trimright [string range $headline 0 $i]]
1577 if {!$listed} {
1578 # git log indents the comment by 4 spaces;
1579 # if we got this via git cat-file, add the indentation
1580 set newcomment {}
1581 foreach line [split $comment "\n"] {
1582 append newcomment " "
1583 append newcomment $line
1584 append newcomment "\n"
1586 set comment $newcomment
1588 if {$comdate != {}} {
1589 set cdate($id) $comdate
1591 set commitinfo($id) [list $headline $auname $audate \
1592 $comname $comdate $comment]
1595 proc getcommit {id} {
1596 global commitdata commitinfo
1598 if {[info exists commitdata($id)]} {
1599 parsecommit $id $commitdata($id) 1
1600 } else {
1601 readcommit $id
1602 if {![info exists commitinfo($id)]} {
1603 set commitinfo($id) [list [mc "No commit information available"]]
1606 return 1
1609 proc readrefs {} {
1610 global tagids idtags headids idheads tagobjid
1611 global otherrefids idotherrefs mainhead mainheadid
1613 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1614 catch {unset $v}
1616 set refd [open [list | git show-ref -d] r]
1617 while {[gets $refd line] >= 0} {
1618 if {[string index $line 40] ne " "} continue
1619 set id [string range $line 0 39]
1620 set ref [string range $line 41 end]
1621 if {![string match "refs/*" $ref]} continue
1622 set name [string range $ref 5 end]
1623 if {[string match "remotes/*" $name]} {
1624 if {![string match "*/HEAD" $name]} {
1625 set headids($name) $id
1626 lappend idheads($id) $name
1628 } elseif {[string match "heads/*" $name]} {
1629 set name [string range $name 6 end]
1630 set headids($name) $id
1631 lappend idheads($id) $name
1632 } elseif {[string match "tags/*" $name]} {
1633 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1634 # which is what we want since the former is the commit ID
1635 set name [string range $name 5 end]
1636 if {[string match "*^{}" $name]} {
1637 set name [string range $name 0 end-3]
1638 } else {
1639 set tagobjid($name) $id
1641 set tagids($name) $id
1642 lappend idtags($id) $name
1643 } else {
1644 set otherrefids($name) $id
1645 lappend idotherrefs($id) $name
1648 catch {close $refd}
1649 set mainhead {}
1650 set mainheadid {}
1651 catch {
1652 set mainheadid [exec git rev-parse HEAD]
1653 set thehead [exec git symbolic-ref HEAD]
1654 if {[string match "refs/heads/*" $thehead]} {
1655 set mainhead [string range $thehead 11 end]
1660 # skip over fake commits
1661 proc first_real_row {} {
1662 global nullid nullid2 numcommits
1664 for {set row 0} {$row < $numcommits} {incr row} {
1665 set id [commitonrow $row]
1666 if {$id ne $nullid && $id ne $nullid2} {
1667 break
1670 return $row
1673 # update things for a head moved to a child of its previous location
1674 proc movehead {id name} {
1675 global headids idheads
1677 removehead $headids($name) $name
1678 set headids($name) $id
1679 lappend idheads($id) $name
1682 # update things when a head has been removed
1683 proc removehead {id name} {
1684 global headids idheads
1686 if {$idheads($id) eq $name} {
1687 unset idheads($id)
1688 } else {
1689 set i [lsearch -exact $idheads($id) $name]
1690 if {$i >= 0} {
1691 set idheads($id) [lreplace $idheads($id) $i $i]
1694 unset headids($name)
1697 proc show_error {w top msg} {
1698 message $w.m -text $msg -justify center -aspect 400
1699 pack $w.m -side top -fill x -padx 20 -pady 20
1700 button $w.ok -text [mc OK] -command "destroy $top"
1701 pack $w.ok -side bottom -fill x
1702 bind $top <Visibility> "grab $top; focus $top"
1703 bind $top <Key-Return> "destroy $top"
1704 tkwait window $top
1707 proc error_popup msg {
1708 set w .error
1709 toplevel $w
1710 wm transient $w .
1711 show_error $w $w $msg
1714 proc confirm_popup msg {
1715 global confirm_ok
1716 set confirm_ok 0
1717 set w .confirm
1718 toplevel $w
1719 wm transient $w .
1720 message $w.m -text $msg -justify center -aspect 400
1721 pack $w.m -side top -fill x -padx 20 -pady 20
1722 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1723 pack $w.ok -side left -fill x
1724 button $w.cancel -text [mc Cancel] -command "destroy $w"
1725 pack $w.cancel -side right -fill x
1726 bind $w <Visibility> "grab $w; focus $w"
1727 tkwait window $w
1728 return $confirm_ok
1731 proc setoptions {} {
1732 option add *Panedwindow.showHandle 1 startupFile
1733 option add *Panedwindow.sashRelief raised startupFile
1734 option add *Button.font uifont startupFile
1735 option add *Checkbutton.font uifont startupFile
1736 option add *Radiobutton.font uifont startupFile
1737 option add *Menu.font uifont startupFile
1738 option add *Menubutton.font uifont startupFile
1739 option add *Label.font uifont startupFile
1740 option add *Message.font uifont startupFile
1741 option add *Entry.font uifont startupFile
1744 proc makewindow {} {
1745 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1746 global tabstop
1747 global findtype findtypemenu findloc findstring fstring geometry
1748 global entries sha1entry sha1string sha1but
1749 global diffcontextstring diffcontext
1750 global ignorespace
1751 global maincursor textcursor curtextcursor
1752 global rowctxmenu fakerowmenu mergemax wrapcomment
1753 global highlight_files gdttype
1754 global searchstring sstring
1755 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1756 global headctxmenu progresscanv progressitem progresscoords statusw
1757 global fprogitem fprogcoord lastprogupdate progupdatepending
1758 global rprogitem rprogcoord rownumsel numcommits
1759 global have_tk85
1761 menu .bar
1762 .bar add cascade -label [mc "File"] -menu .bar.file
1763 menu .bar.file
1764 .bar.file add command -label [mc "Update"] -command updatecommits
1765 .bar.file add command -label [mc "Reload"] -command reloadcommits
1766 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1767 .bar.file add command -label [mc "List references"] -command showrefs
1768 .bar.file add command -label [mc "Quit"] -command doquit
1769 menu .bar.edit
1770 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1771 .bar.edit add command -label [mc "Preferences"] -command doprefs
1773 menu .bar.view
1774 .bar add cascade -label [mc "View"] -menu .bar.view
1775 .bar.view add command -label [mc "New view..."] -command {newview 0}
1776 .bar.view add command -label [mc "Edit view..."] -command editview \
1777 -state disabled
1778 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1779 .bar.view add separator
1780 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1781 -variable selectedview -value 0
1783 menu .bar.help
1784 .bar add cascade -label [mc "Help"] -menu .bar.help
1785 .bar.help add command -label [mc "About gitk"] -command about
1786 .bar.help add command -label [mc "Key bindings"] -command keys
1787 .bar.help configure
1788 . configure -menu .bar
1790 # the gui has upper and lower half, parts of a paned window.
1791 panedwindow .ctop -orient vertical
1793 # possibly use assumed geometry
1794 if {![info exists geometry(pwsash0)]} {
1795 set geometry(topheight) [expr {15 * $linespc}]
1796 set geometry(topwidth) [expr {80 * $charspc}]
1797 set geometry(botheight) [expr {15 * $linespc}]
1798 set geometry(botwidth) [expr {50 * $charspc}]
1799 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1800 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1803 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1804 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1805 frame .tf.histframe
1806 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1808 # create three canvases
1809 set cscroll .tf.histframe.csb
1810 set canv .tf.histframe.pwclist.canv
1811 canvas $canv \
1812 -selectbackground $selectbgcolor \
1813 -background $bgcolor -bd 0 \
1814 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1815 .tf.histframe.pwclist add $canv
1816 set canv2 .tf.histframe.pwclist.canv2
1817 canvas $canv2 \
1818 -selectbackground $selectbgcolor \
1819 -background $bgcolor -bd 0 -yscrollincr $linespc
1820 .tf.histframe.pwclist add $canv2
1821 set canv3 .tf.histframe.pwclist.canv3
1822 canvas $canv3 \
1823 -selectbackground $selectbgcolor \
1824 -background $bgcolor -bd 0 -yscrollincr $linespc
1825 .tf.histframe.pwclist add $canv3
1826 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1827 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1829 # a scroll bar to rule them
1830 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1831 pack $cscroll -side right -fill y
1832 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1833 lappend bglist $canv $canv2 $canv3
1834 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1836 # we have two button bars at bottom of top frame. Bar 1
1837 frame .tf.bar
1838 frame .tf.lbar -height 15
1840 set sha1entry .tf.bar.sha1
1841 set entries $sha1entry
1842 set sha1but .tf.bar.sha1label
1843 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1844 -command gotocommit -width 8
1845 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1846 pack .tf.bar.sha1label -side left
1847 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1848 trace add variable sha1string write sha1change
1849 pack $sha1entry -side left -pady 2
1851 image create bitmap bm-left -data {
1852 #define left_width 16
1853 #define left_height 16
1854 static unsigned char left_bits[] = {
1855 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1856 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1857 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1859 image create bitmap bm-right -data {
1860 #define right_width 16
1861 #define right_height 16
1862 static unsigned char right_bits[] = {
1863 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1864 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1865 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1867 button .tf.bar.leftbut -image bm-left -command goback \
1868 -state disabled -width 26
1869 pack .tf.bar.leftbut -side left -fill y
1870 button .tf.bar.rightbut -image bm-right -command goforw \
1871 -state disabled -width 26
1872 pack .tf.bar.rightbut -side left -fill y
1874 label .tf.bar.rowlabel -text [mc "Row"]
1875 set rownumsel {}
1876 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1877 -relief sunken -anchor e
1878 label .tf.bar.rowlabel2 -text "/"
1879 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1880 -relief sunken -anchor e
1881 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1882 -side left
1883 global selectedline
1884 trace add variable selectedline write selectedline_change
1886 # Status label and progress bar
1887 set statusw .tf.bar.status
1888 label $statusw -width 15 -relief sunken
1889 pack $statusw -side left -padx 5
1890 set h [expr {[font metrics uifont -linespace] + 2}]
1891 set progresscanv .tf.bar.progress
1892 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1893 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1894 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1895 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1896 pack $progresscanv -side right -expand 1 -fill x
1897 set progresscoords {0 0}
1898 set fprogcoord 0
1899 set rprogcoord 0
1900 bind $progresscanv <Configure> adjustprogress
1901 set lastprogupdate [clock clicks -milliseconds]
1902 set progupdatepending 0
1904 # build up the bottom bar of upper window
1905 label .tf.lbar.flabel -text "[mc "Find"] "
1906 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1907 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1908 label .tf.lbar.flab2 -text " [mc "commit"] "
1909 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1910 -side left -fill y
1911 set gdttype [mc "containing:"]
1912 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1913 [mc "containing:"] \
1914 [mc "touching paths:"] \
1915 [mc "adding/removing string:"]]
1916 trace add variable gdttype write gdttype_change
1917 pack .tf.lbar.gdttype -side left -fill y
1919 set findstring {}
1920 set fstring .tf.lbar.findstring
1921 lappend entries $fstring
1922 entry $fstring -width 30 -font textfont -textvariable findstring
1923 trace add variable findstring write find_change
1924 set findtype [mc "Exact"]
1925 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1926 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1927 trace add variable findtype write findcom_change
1928 set findloc [mc "All fields"]
1929 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1930 [mc "Comments"] [mc "Author"] [mc "Committer"]
1931 trace add variable findloc write find_change
1932 pack .tf.lbar.findloc -side right
1933 pack .tf.lbar.findtype -side right
1934 pack $fstring -side left -expand 1 -fill x
1936 # Finish putting the upper half of the viewer together
1937 pack .tf.lbar -in .tf -side bottom -fill x
1938 pack .tf.bar -in .tf -side bottom -fill x
1939 pack .tf.histframe -fill both -side top -expand 1
1940 .ctop add .tf
1941 .ctop paneconfigure .tf -height $geometry(topheight)
1942 .ctop paneconfigure .tf -width $geometry(topwidth)
1944 # now build up the bottom
1945 panedwindow .pwbottom -orient horizontal
1947 # lower left, a text box over search bar, scroll bar to the right
1948 # if we know window height, then that will set the lower text height, otherwise
1949 # we set lower text height which will drive window height
1950 if {[info exists geometry(main)]} {
1951 frame .bleft -width $geometry(botwidth)
1952 } else {
1953 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1955 frame .bleft.top
1956 frame .bleft.mid
1957 frame .bleft.bottom
1959 button .bleft.top.search -text [mc "Search"] -command dosearch
1960 pack .bleft.top.search -side left -padx 5
1961 set sstring .bleft.top.sstring
1962 entry $sstring -width 20 -font textfont -textvariable searchstring
1963 lappend entries $sstring
1964 trace add variable searchstring write incrsearch
1965 pack $sstring -side left -expand 1 -fill x
1966 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1967 -command changediffdisp -variable diffelide -value {0 0}
1968 radiobutton .bleft.mid.old -text [mc "Old version"] \
1969 -command changediffdisp -variable diffelide -value {0 1}
1970 radiobutton .bleft.mid.new -text [mc "New version"] \
1971 -command changediffdisp -variable diffelide -value {1 0}
1972 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1973 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1974 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1975 -from 1 -increment 1 -to 10000000 \
1976 -validate all -validatecommand "diffcontextvalidate %P" \
1977 -textvariable diffcontextstring
1978 .bleft.mid.diffcontext set $diffcontext
1979 trace add variable diffcontextstring write diffcontextchange
1980 lappend entries .bleft.mid.diffcontext
1981 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1982 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1983 -command changeignorespace -variable ignorespace
1984 pack .bleft.mid.ignspace -side left -padx 5
1985 set ctext .bleft.bottom.ctext
1986 text $ctext -background $bgcolor -foreground $fgcolor \
1987 -state disabled -font textfont \
1988 -yscrollcommand scrolltext -wrap none \
1989 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1990 if {$have_tk85} {
1991 $ctext conf -tabstyle wordprocessor
1993 scrollbar .bleft.bottom.sb -command "$ctext yview"
1994 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
1995 -width 10
1996 pack .bleft.top -side top -fill x
1997 pack .bleft.mid -side top -fill x
1998 grid $ctext .bleft.bottom.sb -sticky nsew
1999 grid .bleft.bottom.sbhorizontal -sticky ew
2000 grid columnconfigure .bleft.bottom 0 -weight 1
2001 grid rowconfigure .bleft.bottom 0 -weight 1
2002 grid rowconfigure .bleft.bottom 1 -weight 0
2003 pack .bleft.bottom -side top -fill both -expand 1
2004 lappend bglist $ctext
2005 lappend fglist $ctext
2007 $ctext tag conf comment -wrap $wrapcomment
2008 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2009 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2010 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2011 $ctext tag conf d1 -fore [lindex $diffcolors 1]
2012 $ctext tag conf m0 -fore red
2013 $ctext tag conf m1 -fore blue
2014 $ctext tag conf m2 -fore green
2015 $ctext tag conf m3 -fore purple
2016 $ctext tag conf m4 -fore brown
2017 $ctext tag conf m5 -fore "#009090"
2018 $ctext tag conf m6 -fore magenta
2019 $ctext tag conf m7 -fore "#808000"
2020 $ctext tag conf m8 -fore "#009000"
2021 $ctext tag conf m9 -fore "#ff0080"
2022 $ctext tag conf m10 -fore cyan
2023 $ctext tag conf m11 -fore "#b07070"
2024 $ctext tag conf m12 -fore "#70b0f0"
2025 $ctext tag conf m13 -fore "#70f0b0"
2026 $ctext tag conf m14 -fore "#f0b070"
2027 $ctext tag conf m15 -fore "#ff70b0"
2028 $ctext tag conf mmax -fore darkgrey
2029 set mergemax 16
2030 $ctext tag conf mresult -font textfontbold
2031 $ctext tag conf msep -font textfontbold
2032 $ctext tag conf found -back yellow
2034 .pwbottom add .bleft
2035 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2037 # lower right
2038 frame .bright
2039 frame .bright.mode
2040 radiobutton .bright.mode.patch -text [mc "Patch"] \
2041 -command reselectline -variable cmitmode -value "patch"
2042 radiobutton .bright.mode.tree -text [mc "Tree"] \
2043 -command reselectline -variable cmitmode -value "tree"
2044 grid .bright.mode.patch .bright.mode.tree -sticky ew
2045 pack .bright.mode -side top -fill x
2046 set cflist .bright.cfiles
2047 set indent [font measure mainfont "nn"]
2048 text $cflist \
2049 -selectbackground $selectbgcolor \
2050 -background $bgcolor -foreground $fgcolor \
2051 -font mainfont \
2052 -tabs [list $indent [expr {2 * $indent}]] \
2053 -yscrollcommand ".bright.sb set" \
2054 -cursor [. cget -cursor] \
2055 -spacing1 1 -spacing3 1
2056 lappend bglist $cflist
2057 lappend fglist $cflist
2058 scrollbar .bright.sb -command "$cflist yview"
2059 pack .bright.sb -side right -fill y
2060 pack $cflist -side left -fill both -expand 1
2061 $cflist tag configure highlight \
2062 -background [$cflist cget -selectbackground]
2063 $cflist tag configure bold -font mainfontbold
2065 .pwbottom add .bright
2066 .ctop add .pwbottom
2068 # restore window width & height if known
2069 if {[info exists geometry(main)]} {
2070 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2071 if {$w > [winfo screenwidth .]} {
2072 set w [winfo screenwidth .]
2074 if {$h > [winfo screenheight .]} {
2075 set h [winfo screenheight .]
2077 wm geometry . "${w}x$h"
2081 if {[tk windowingsystem] eq {aqua}} {
2082 set M1B M1
2083 } else {
2084 set M1B Control
2087 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2088 pack .ctop -fill both -expand 1
2089 bindall <1> {selcanvline %W %x %y}
2090 #bindall <B1-Motion> {selcanvline %W %x %y}
2091 if {[tk windowingsystem] == "win32"} {
2092 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2093 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2094 } else {
2095 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2096 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2097 if {[tk windowingsystem] eq "aqua"} {
2098 bindall <MouseWheel> {
2099 set delta [expr {- (%D)}]
2100 allcanvs yview scroll $delta units
2104 bindall <2> "canvscan mark %W %x %y"
2105 bindall <B2-Motion> "canvscan dragto %W %x %y"
2106 bindkey <Home> selfirstline
2107 bindkey <End> sellastline
2108 bind . <Key-Up> "selnextline -1"
2109 bind . <Key-Down> "selnextline 1"
2110 bind . <Shift-Key-Up> "dofind -1 0"
2111 bind . <Shift-Key-Down> "dofind 1 0"
2112 bindkey <Key-Right> "goforw"
2113 bindkey <Key-Left> "goback"
2114 bind . <Key-Prior> "selnextpage -1"
2115 bind . <Key-Next> "selnextpage 1"
2116 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2117 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2118 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2119 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2120 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2121 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2122 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2123 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2124 bindkey <Key-space> "$ctext yview scroll 1 pages"
2125 bindkey p "selnextline -1"
2126 bindkey n "selnextline 1"
2127 bindkey z "goback"
2128 bindkey x "goforw"
2129 bindkey i "selnextline -1"
2130 bindkey k "selnextline 1"
2131 bindkey j "goback"
2132 bindkey l "goforw"
2133 bindkey b prevfile
2134 bindkey d "$ctext yview scroll 18 units"
2135 bindkey u "$ctext yview scroll -18 units"
2136 bindkey / {dofind 1 1}
2137 bindkey <Key-Return> {dofind 1 1}
2138 bindkey ? {dofind -1 1}
2139 bindkey f nextfile
2140 bindkey <F5> updatecommits
2141 bind . <$M1B-q> doquit
2142 bind . <$M1B-f> {dofind 1 1}
2143 bind . <$M1B-g> {dofind 1 0}
2144 bind . <$M1B-r> dosearchback
2145 bind . <$M1B-s> dosearch
2146 bind . <$M1B-equal> {incrfont 1}
2147 bind . <$M1B-plus> {incrfont 1}
2148 bind . <$M1B-KP_Add> {incrfont 1}
2149 bind . <$M1B-minus> {incrfont -1}
2150 bind . <$M1B-KP_Subtract> {incrfont -1}
2151 wm protocol . WM_DELETE_WINDOW doquit
2152 bind . <Destroy> {stop_backends}
2153 bind . <Button-1> "click %W"
2154 bind $fstring <Key-Return> {dofind 1 1}
2155 bind $sha1entry <Key-Return> gotocommit
2156 bind $sha1entry <<PasteSelection>> clearsha1
2157 bind $cflist <1> {sel_flist %W %x %y; break}
2158 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2159 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2160 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
2162 set maincursor [. cget -cursor]
2163 set textcursor [$ctext cget -cursor]
2164 set curtextcursor $textcursor
2166 set rowctxmenu .rowctxmenu
2167 menu $rowctxmenu -tearoff 0
2168 $rowctxmenu add command -label [mc "Diff this -> selected"] \
2169 -command {diffvssel 0}
2170 $rowctxmenu add command -label [mc "Diff selected -> this"] \
2171 -command {diffvssel 1}
2172 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2173 $rowctxmenu add command -label [mc "Create tag"] -command mktag
2174 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2175 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2176 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2177 -command cherrypick
2178 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2179 -command resethead
2181 set fakerowmenu .fakerowmenu
2182 menu $fakerowmenu -tearoff 0
2183 $fakerowmenu add command -label [mc "Diff this -> selected"] \
2184 -command {diffvssel 0}
2185 $fakerowmenu add command -label [mc "Diff selected -> this"] \
2186 -command {diffvssel 1}
2187 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2188 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2189 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2190 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2192 set headctxmenu .headctxmenu
2193 menu $headctxmenu -tearoff 0
2194 $headctxmenu add command -label [mc "Check out this branch"] \
2195 -command cobranch
2196 $headctxmenu add command -label [mc "Remove this branch"] \
2197 -command rmbranch
2199 global flist_menu
2200 set flist_menu .flistctxmenu
2201 menu $flist_menu -tearoff 0
2202 $flist_menu add command -label [mc "Highlight this too"] \
2203 -command {flist_hl 0}
2204 $flist_menu add command -label [mc "Highlight this only"] \
2205 -command {flist_hl 1}
2206 $flist_menu add command -label [mc "External diff"] \
2207 -command {external_diff}
2210 # Windows sends all mouse wheel events to the current focused window, not
2211 # the one where the mouse hovers, so bind those events here and redirect
2212 # to the correct window
2213 proc windows_mousewheel_redirector {W X Y D} {
2214 global canv canv2 canv3
2215 set w [winfo containing -displayof $W $X $Y]
2216 if {$w ne ""} {
2217 set u [expr {$D < 0 ? 5 : -5}]
2218 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2219 allcanvs yview scroll $u units
2220 } else {
2221 catch {
2222 $w yview scroll $u units
2228 # Update row number label when selectedline changes
2229 proc selectedline_change {n1 n2 op} {
2230 global selectedline rownumsel
2232 if {$selectedline eq {}} {
2233 set rownumsel {}
2234 } else {
2235 set rownumsel [expr {$selectedline + 1}]
2239 # mouse-2 makes all windows scan vertically, but only the one
2240 # the cursor is in scans horizontally
2241 proc canvscan {op w x y} {
2242 global canv canv2 canv3
2243 foreach c [list $canv $canv2 $canv3] {
2244 if {$c == $w} {
2245 $c scan $op $x $y
2246 } else {
2247 $c scan $op 0 $y
2252 proc scrollcanv {cscroll f0 f1} {
2253 $cscroll set $f0 $f1
2254 drawvisible
2255 flushhighlights
2258 # when we make a key binding for the toplevel, make sure
2259 # it doesn't get triggered when that key is pressed in the
2260 # find string entry widget.
2261 proc bindkey {ev script} {
2262 global entries
2263 bind . $ev $script
2264 set escript [bind Entry $ev]
2265 if {$escript == {}} {
2266 set escript [bind Entry <Key>]
2268 foreach e $entries {
2269 bind $e $ev "$escript; break"
2273 # set the focus back to the toplevel for any click outside
2274 # the entry widgets
2275 proc click {w} {
2276 global ctext entries
2277 foreach e [concat $entries $ctext] {
2278 if {$w == $e} return
2280 focus .
2283 # Adjust the progress bar for a change in requested extent or canvas size
2284 proc adjustprogress {} {
2285 global progresscanv progressitem progresscoords
2286 global fprogitem fprogcoord lastprogupdate progupdatepending
2287 global rprogitem rprogcoord
2289 set w [expr {[winfo width $progresscanv] - 4}]
2290 set x0 [expr {$w * [lindex $progresscoords 0]}]
2291 set x1 [expr {$w * [lindex $progresscoords 1]}]
2292 set h [winfo height $progresscanv]
2293 $progresscanv coords $progressitem $x0 0 $x1 $h
2294 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2295 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2296 set now [clock clicks -milliseconds]
2297 if {$now >= $lastprogupdate + 100} {
2298 set progupdatepending 0
2299 update
2300 } elseif {!$progupdatepending} {
2301 set progupdatepending 1
2302 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2306 proc doprogupdate {} {
2307 global lastprogupdate progupdatepending
2309 if {$progupdatepending} {
2310 set progupdatepending 0
2311 set lastprogupdate [clock clicks -milliseconds]
2312 update
2316 proc savestuff {w} {
2317 global canv canv2 canv3 mainfont textfont uifont tabstop
2318 global stuffsaved findmergefiles maxgraphpct
2319 global maxwidth showneartags showlocalchanges
2320 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2321 global cmitmode wrapcomment datetimeformat limitdiffs
2322 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2323 global autoselect extdifftool
2325 if {$stuffsaved} return
2326 if {![winfo viewable .]} return
2327 catch {
2328 set f [open "~/.gitk-new" w]
2329 puts $f [list set mainfont $mainfont]
2330 puts $f [list set textfont $textfont]
2331 puts $f [list set uifont $uifont]
2332 puts $f [list set tabstop $tabstop]
2333 puts $f [list set findmergefiles $findmergefiles]
2334 puts $f [list set maxgraphpct $maxgraphpct]
2335 puts $f [list set maxwidth $maxwidth]
2336 puts $f [list set cmitmode $cmitmode]
2337 puts $f [list set wrapcomment $wrapcomment]
2338 puts $f [list set autoselect $autoselect]
2339 puts $f [list set showneartags $showneartags]
2340 puts $f [list set showlocalchanges $showlocalchanges]
2341 puts $f [list set datetimeformat $datetimeformat]
2342 puts $f [list set limitdiffs $limitdiffs]
2343 puts $f [list set bgcolor $bgcolor]
2344 puts $f [list set fgcolor $fgcolor]
2345 puts $f [list set colors $colors]
2346 puts $f [list set diffcolors $diffcolors]
2347 puts $f [list set diffcontext $diffcontext]
2348 puts $f [list set selectbgcolor $selectbgcolor]
2349 puts $f [list set extdifftool $extdifftool]
2351 puts $f "set geometry(main) [wm geometry .]"
2352 puts $f "set geometry(topwidth) [winfo width .tf]"
2353 puts $f "set geometry(topheight) [winfo height .tf]"
2354 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2355 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2356 puts $f "set geometry(botwidth) [winfo width .bleft]"
2357 puts $f "set geometry(botheight) [winfo height .bleft]"
2359 puts -nonewline $f "set permviews {"
2360 for {set v 0} {$v < $nextviewnum} {incr v} {
2361 if {$viewperm($v)} {
2362 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2365 puts $f "}"
2366 close $f
2367 file rename -force "~/.gitk-new" "~/.gitk"
2369 set stuffsaved 1
2372 proc resizeclistpanes {win w} {
2373 global oldwidth
2374 if {[info exists oldwidth($win)]} {
2375 set s0 [$win sash coord 0]
2376 set s1 [$win sash coord 1]
2377 if {$w < 60} {
2378 set sash0 [expr {int($w/2 - 2)}]
2379 set sash1 [expr {int($w*5/6 - 2)}]
2380 } else {
2381 set factor [expr {1.0 * $w / $oldwidth($win)}]
2382 set sash0 [expr {int($factor * [lindex $s0 0])}]
2383 set sash1 [expr {int($factor * [lindex $s1 0])}]
2384 if {$sash0 < 30} {
2385 set sash0 30
2387 if {$sash1 < $sash0 + 20} {
2388 set sash1 [expr {$sash0 + 20}]
2390 if {$sash1 > $w - 10} {
2391 set sash1 [expr {$w - 10}]
2392 if {$sash0 > $sash1 - 20} {
2393 set sash0 [expr {$sash1 - 20}]
2397 $win sash place 0 $sash0 [lindex $s0 1]
2398 $win sash place 1 $sash1 [lindex $s1 1]
2400 set oldwidth($win) $w
2403 proc resizecdetpanes {win w} {
2404 global oldwidth
2405 if {[info exists oldwidth($win)]} {
2406 set s0 [$win sash coord 0]
2407 if {$w < 60} {
2408 set sash0 [expr {int($w*3/4 - 2)}]
2409 } else {
2410 set factor [expr {1.0 * $w / $oldwidth($win)}]
2411 set sash0 [expr {int($factor * [lindex $s0 0])}]
2412 if {$sash0 < 45} {
2413 set sash0 45
2415 if {$sash0 > $w - 15} {
2416 set sash0 [expr {$w - 15}]
2419 $win sash place 0 $sash0 [lindex $s0 1]
2421 set oldwidth($win) $w
2424 proc allcanvs args {
2425 global canv canv2 canv3
2426 eval $canv $args
2427 eval $canv2 $args
2428 eval $canv3 $args
2431 proc bindall {event action} {
2432 global canv canv2 canv3
2433 bind $canv $event $action
2434 bind $canv2 $event $action
2435 bind $canv3 $event $action
2438 proc about {} {
2439 global uifont
2440 set w .about
2441 if {[winfo exists $w]} {
2442 raise $w
2443 return
2445 toplevel $w
2446 wm title $w [mc "About gitk"]
2447 message $w.m -text [mc "
2448 Gitk - a commit viewer for git
2450 Copyright © 2005-2008 Paul Mackerras
2452 Use and redistribute under the terms of the GNU General Public License"] \
2453 -justify center -aspect 400 -border 2 -bg white -relief groove
2454 pack $w.m -side top -fill x -padx 2 -pady 2
2455 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2456 pack $w.ok -side bottom
2457 bind $w <Visibility> "focus $w.ok"
2458 bind $w <Key-Escape> "destroy $w"
2459 bind $w <Key-Return> "destroy $w"
2462 proc keys {} {
2463 set w .keys
2464 if {[winfo exists $w]} {
2465 raise $w
2466 return
2468 if {[tk windowingsystem] eq {aqua}} {
2469 set M1T Cmd
2470 } else {
2471 set M1T Ctrl
2473 toplevel $w
2474 wm title $w [mc "Gitk key bindings"]
2475 message $w.m -text "
2476 [mc "Gitk key bindings:"]
2478 [mc "<%s-Q> Quit" $M1T]
2479 [mc "<Home> Move to first commit"]
2480 [mc "<End> Move to last commit"]
2481 [mc "<Up>, p, i Move up one commit"]
2482 [mc "<Down>, n, k Move down one commit"]
2483 [mc "<Left>, z, j Go back in history list"]
2484 [mc "<Right>, x, l Go forward in history list"]
2485 [mc "<PageUp> Move up one page in commit list"]
2486 [mc "<PageDown> Move down one page in commit list"]
2487 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2488 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2489 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2490 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2491 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2492 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2493 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2494 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2495 [mc "<Delete>, b Scroll diff view up one page"]
2496 [mc "<Backspace> Scroll diff view up one page"]
2497 [mc "<Space> Scroll diff view down one page"]
2498 [mc "u Scroll diff view up 18 lines"]
2499 [mc "d Scroll diff view down 18 lines"]
2500 [mc "<%s-F> Find" $M1T]
2501 [mc "<%s-G> Move to next find hit" $M1T]
2502 [mc "<Return> Move to next find hit"]
2503 [mc "/ Move to next find hit, or redo find"]
2504 [mc "? Move to previous find hit"]
2505 [mc "f Scroll diff view to next file"]
2506 [mc "<%s-S> Search for next hit in diff view" $M1T]
2507 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2508 [mc "<%s-KP+> Increase font size" $M1T]
2509 [mc "<%s-plus> Increase font size" $M1T]
2510 [mc "<%s-KP-> Decrease font size" $M1T]
2511 [mc "<%s-minus> Decrease font size" $M1T]
2512 [mc "<F5> Update"]
2514 -justify left -bg white -border 2 -relief groove
2515 pack $w.m -side top -fill both -padx 2 -pady 2
2516 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2517 pack $w.ok -side bottom
2518 bind $w <Visibility> "focus $w.ok"
2519 bind $w <Key-Escape> "destroy $w"
2520 bind $w <Key-Return> "destroy $w"
2523 # Procedures for manipulating the file list window at the
2524 # bottom right of the overall window.
2526 proc treeview {w l openlevs} {
2527 global treecontents treediropen treeheight treeparent treeindex
2529 set ix 0
2530 set treeindex() 0
2531 set lev 0
2532 set prefix {}
2533 set prefixend -1
2534 set prefendstack {}
2535 set htstack {}
2536 set ht 0
2537 set treecontents() {}
2538 $w conf -state normal
2539 foreach f $l {
2540 while {[string range $f 0 $prefixend] ne $prefix} {
2541 if {$lev <= $openlevs} {
2542 $w mark set e:$treeindex($prefix) "end -1c"
2543 $w mark gravity e:$treeindex($prefix) left
2545 set treeheight($prefix) $ht
2546 incr ht [lindex $htstack end]
2547 set htstack [lreplace $htstack end end]
2548 set prefixend [lindex $prefendstack end]
2549 set prefendstack [lreplace $prefendstack end end]
2550 set prefix [string range $prefix 0 $prefixend]
2551 incr lev -1
2553 set tail [string range $f [expr {$prefixend+1}] end]
2554 while {[set slash [string first "/" $tail]] >= 0} {
2555 lappend htstack $ht
2556 set ht 0
2557 lappend prefendstack $prefixend
2558 incr prefixend [expr {$slash + 1}]
2559 set d [string range $tail 0 $slash]
2560 lappend treecontents($prefix) $d
2561 set oldprefix $prefix
2562 append prefix $d
2563 set treecontents($prefix) {}
2564 set treeindex($prefix) [incr ix]
2565 set treeparent($prefix) $oldprefix
2566 set tail [string range $tail [expr {$slash+1}] end]
2567 if {$lev <= $openlevs} {
2568 set ht 1
2569 set treediropen($prefix) [expr {$lev < $openlevs}]
2570 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2571 $w mark set d:$ix "end -1c"
2572 $w mark gravity d:$ix left
2573 set str "\n"
2574 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2575 $w insert end $str
2576 $w image create end -align center -image $bm -padx 1 \
2577 -name a:$ix
2578 $w insert end $d [highlight_tag $prefix]
2579 $w mark set s:$ix "end -1c"
2580 $w mark gravity s:$ix left
2582 incr lev
2584 if {$tail ne {}} {
2585 if {$lev <= $openlevs} {
2586 incr ht
2587 set str "\n"
2588 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2589 $w insert end $str
2590 $w insert end $tail [highlight_tag $f]
2592 lappend treecontents($prefix) $tail
2595 while {$htstack ne {}} {
2596 set treeheight($prefix) $ht
2597 incr ht [lindex $htstack end]
2598 set htstack [lreplace $htstack end end]
2599 set prefixend [lindex $prefendstack end]
2600 set prefendstack [lreplace $prefendstack end end]
2601 set prefix [string range $prefix 0 $prefixend]
2603 $w conf -state disabled
2606 proc linetoelt {l} {
2607 global treeheight treecontents
2609 set y 2
2610 set prefix {}
2611 while {1} {
2612 foreach e $treecontents($prefix) {
2613 if {$y == $l} {
2614 return "$prefix$e"
2616 set n 1
2617 if {[string index $e end] eq "/"} {
2618 set n $treeheight($prefix$e)
2619 if {$y + $n > $l} {
2620 append prefix $e
2621 incr y
2622 break
2625 incr y $n
2630 proc highlight_tree {y prefix} {
2631 global treeheight treecontents cflist
2633 foreach e $treecontents($prefix) {
2634 set path $prefix$e
2635 if {[highlight_tag $path] ne {}} {
2636 $cflist tag add bold $y.0 "$y.0 lineend"
2638 incr y
2639 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2640 set y [highlight_tree $y $path]
2643 return $y
2646 proc treeclosedir {w dir} {
2647 global treediropen treeheight treeparent treeindex
2649 set ix $treeindex($dir)
2650 $w conf -state normal
2651 $w delete s:$ix e:$ix
2652 set treediropen($dir) 0
2653 $w image configure a:$ix -image tri-rt
2654 $w conf -state disabled
2655 set n [expr {1 - $treeheight($dir)}]
2656 while {$dir ne {}} {
2657 incr treeheight($dir) $n
2658 set dir $treeparent($dir)
2662 proc treeopendir {w dir} {
2663 global treediropen treeheight treeparent treecontents treeindex
2665 set ix $treeindex($dir)
2666 $w conf -state normal
2667 $w image configure a:$ix -image tri-dn
2668 $w mark set e:$ix s:$ix
2669 $w mark gravity e:$ix right
2670 set lev 0
2671 set str "\n"
2672 set n [llength $treecontents($dir)]
2673 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2674 incr lev
2675 append str "\t"
2676 incr treeheight($x) $n
2678 foreach e $treecontents($dir) {
2679 set de $dir$e
2680 if {[string index $e end] eq "/"} {
2681 set iy $treeindex($de)
2682 $w mark set d:$iy e:$ix
2683 $w mark gravity d:$iy left
2684 $w insert e:$ix $str
2685 set treediropen($de) 0
2686 $w image create e:$ix -align center -image tri-rt -padx 1 \
2687 -name a:$iy
2688 $w insert e:$ix $e [highlight_tag $de]
2689 $w mark set s:$iy e:$ix
2690 $w mark gravity s:$iy left
2691 set treeheight($de) 1
2692 } else {
2693 $w insert e:$ix $str
2694 $w insert e:$ix $e [highlight_tag $de]
2697 $w mark gravity e:$ix left
2698 $w conf -state disabled
2699 set treediropen($dir) 1
2700 set top [lindex [split [$w index @0,0] .] 0]
2701 set ht [$w cget -height]
2702 set l [lindex [split [$w index s:$ix] .] 0]
2703 if {$l < $top} {
2704 $w yview $l.0
2705 } elseif {$l + $n + 1 > $top + $ht} {
2706 set top [expr {$l + $n + 2 - $ht}]
2707 if {$l < $top} {
2708 set top $l
2710 $w yview $top.0
2714 proc treeclick {w x y} {
2715 global treediropen cmitmode ctext cflist cflist_top
2717 if {$cmitmode ne "tree"} return
2718 if {![info exists cflist_top]} return
2719 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2720 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2721 $cflist tag add highlight $l.0 "$l.0 lineend"
2722 set cflist_top $l
2723 if {$l == 1} {
2724 $ctext yview 1.0
2725 return
2727 set e [linetoelt $l]
2728 if {[string index $e end] ne "/"} {
2729 showfile $e
2730 } elseif {$treediropen($e)} {
2731 treeclosedir $w $e
2732 } else {
2733 treeopendir $w $e
2737 proc setfilelist {id} {
2738 global treefilelist cflist
2740 treeview $cflist $treefilelist($id) 0
2743 image create bitmap tri-rt -background black -foreground blue -data {
2744 #define tri-rt_width 13
2745 #define tri-rt_height 13
2746 static unsigned char tri-rt_bits[] = {
2747 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2748 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2749 0x00, 0x00};
2750 } -maskdata {
2751 #define tri-rt-mask_width 13
2752 #define tri-rt-mask_height 13
2753 static unsigned char tri-rt-mask_bits[] = {
2754 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2755 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2756 0x08, 0x00};
2758 image create bitmap tri-dn -background black -foreground blue -data {
2759 #define tri-dn_width 13
2760 #define tri-dn_height 13
2761 static unsigned char tri-dn_bits[] = {
2762 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2763 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2764 0x00, 0x00};
2765 } -maskdata {
2766 #define tri-dn-mask_width 13
2767 #define tri-dn-mask_height 13
2768 static unsigned char tri-dn-mask_bits[] = {
2769 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2770 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2771 0x00, 0x00};
2774 image create bitmap reficon-T -background black -foreground yellow -data {
2775 #define tagicon_width 13
2776 #define tagicon_height 9
2777 static unsigned char tagicon_bits[] = {
2778 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2779 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2780 } -maskdata {
2781 #define tagicon-mask_width 13
2782 #define tagicon-mask_height 9
2783 static unsigned char tagicon-mask_bits[] = {
2784 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2785 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2787 set rectdata {
2788 #define headicon_width 13
2789 #define headicon_height 9
2790 static unsigned char headicon_bits[] = {
2791 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2792 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2794 set rectmask {
2795 #define headicon-mask_width 13
2796 #define headicon-mask_height 9
2797 static unsigned char headicon-mask_bits[] = {
2798 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2799 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2801 image create bitmap reficon-H -background black -foreground green \
2802 -data $rectdata -maskdata $rectmask
2803 image create bitmap reficon-o -background black -foreground "#ddddff" \
2804 -data $rectdata -maskdata $rectmask
2806 proc init_flist {first} {
2807 global cflist cflist_top difffilestart
2809 $cflist conf -state normal
2810 $cflist delete 0.0 end
2811 if {$first ne {}} {
2812 $cflist insert end $first
2813 set cflist_top 1
2814 $cflist tag add highlight 1.0 "1.0 lineend"
2815 } else {
2816 catch {unset cflist_top}
2818 $cflist conf -state disabled
2819 set difffilestart {}
2822 proc highlight_tag {f} {
2823 global highlight_paths
2825 foreach p $highlight_paths {
2826 if {[string match $p $f]} {
2827 return "bold"
2830 return {}
2833 proc highlight_filelist {} {
2834 global cmitmode cflist
2836 $cflist conf -state normal
2837 if {$cmitmode ne "tree"} {
2838 set end [lindex [split [$cflist index end] .] 0]
2839 for {set l 2} {$l < $end} {incr l} {
2840 set line [$cflist get $l.0 "$l.0 lineend"]
2841 if {[highlight_tag $line] ne {}} {
2842 $cflist tag add bold $l.0 "$l.0 lineend"
2845 } else {
2846 highlight_tree 2 {}
2848 $cflist conf -state disabled
2851 proc unhighlight_filelist {} {
2852 global cflist
2854 $cflist conf -state normal
2855 $cflist tag remove bold 1.0 end
2856 $cflist conf -state disabled
2859 proc add_flist {fl} {
2860 global cflist
2862 $cflist conf -state normal
2863 foreach f $fl {
2864 $cflist insert end "\n"
2865 $cflist insert end $f [highlight_tag $f]
2867 $cflist conf -state disabled
2870 proc sel_flist {w x y} {
2871 global ctext difffilestart cflist cflist_top cmitmode
2873 if {$cmitmode eq "tree"} return
2874 if {![info exists cflist_top]} return
2875 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2876 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2877 $cflist tag add highlight $l.0 "$l.0 lineend"
2878 set cflist_top $l
2879 if {$l == 1} {
2880 $ctext yview 1.0
2881 } else {
2882 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2886 proc pop_flist_menu {w X Y x y} {
2887 global ctext cflist cmitmode flist_menu flist_menu_file
2888 global treediffs diffids
2890 stopfinding
2891 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2892 if {$l <= 1} return
2893 if {$cmitmode eq "tree"} {
2894 set e [linetoelt $l]
2895 if {[string index $e end] eq "/"} return
2896 } else {
2897 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2899 set flist_menu_file $e
2900 set xdiffstate "normal"
2901 if {$cmitmode eq "tree"} {
2902 set xdiffstate "disabled"
2904 # Disable "External diff" item in tree mode
2905 $flist_menu entryconf 2 -state $xdiffstate
2906 tk_popup $flist_menu $X $Y
2909 proc flist_hl {only} {
2910 global flist_menu_file findstring gdttype
2912 set x [shellquote $flist_menu_file]
2913 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2914 set findstring $x
2915 } else {
2916 append findstring " " $x
2918 set gdttype [mc "touching paths:"]
2921 proc save_file_from_commit {filename output what} {
2922 global nullfile
2924 if {[catch {exec git show $filename -- > $output} err]} {
2925 if {[string match "fatal: bad revision *" $err]} {
2926 return $nullfile
2928 error_popup "Error getting \"$filename\" from $what: $err"
2929 return {}
2931 return $output
2934 proc external_diff_get_one_file {diffid filename diffdir} {
2935 global nullid nullid2 nullfile
2936 global gitdir
2938 if {$diffid == $nullid} {
2939 set difffile [file join [file dirname $gitdir] $filename]
2940 if {[file exists $difffile]} {
2941 return $difffile
2943 return $nullfile
2945 if {$diffid == $nullid2} {
2946 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2947 return [save_file_from_commit :$filename $difffile index]
2949 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2950 return [save_file_from_commit $diffid:$filename $difffile \
2951 "revision $diffid"]
2954 proc external_diff {} {
2955 global gitktmpdir nullid nullid2
2956 global flist_menu_file
2957 global diffids
2958 global diffnum
2959 global gitdir extdifftool
2961 if {[llength $diffids] == 1} {
2962 # no reference commit given
2963 set diffidto [lindex $diffids 0]
2964 if {$diffidto eq $nullid} {
2965 # diffing working copy with index
2966 set diffidfrom $nullid2
2967 } elseif {$diffidto eq $nullid2} {
2968 # diffing index with HEAD
2969 set diffidfrom "HEAD"
2970 } else {
2971 # use first parent commit
2972 global parentlist selectedline
2973 set diffidfrom [lindex $parentlist $selectedline 0]
2975 } else {
2976 set diffidfrom [lindex $diffids 0]
2977 set diffidto [lindex $diffids 1]
2980 # make sure that several diffs wont collide
2981 if {![info exists gitktmpdir]} {
2982 set gitktmpdir [file join [file dirname $gitdir] \
2983 [format ".gitk-tmp.%s" [pid]]]
2984 if {[catch {file mkdir $gitktmpdir} err]} {
2985 error_popup "Error creating temporary directory $gitktmpdir: $err"
2986 unset gitktmpdir
2987 return
2989 set diffnum 0
2991 incr diffnum
2992 set diffdir [file join $gitktmpdir $diffnum]
2993 if {[catch {file mkdir $diffdir} err]} {
2994 error_popup "Error creating temporary directory $diffdir: $err"
2995 return
2998 # gather files to diff
2999 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3000 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3002 if {$difffromfile ne {} && $difftofile ne {}} {
3003 set cmd [concat | [shellsplit $extdifftool] \
3004 [list $difffromfile $difftofile]]
3005 if {[catch {set fl [open $cmd r]} err]} {
3006 file delete -force $diffdir
3007 error_popup [mc "$extdifftool: command failed: $err"]
3008 } else {
3009 fconfigure $fl -blocking 0
3010 filerun $fl [list delete_at_eof $fl $diffdir]
3015 # delete $dir when we see eof on $f (presumably because the child has exited)
3016 proc delete_at_eof {f dir} {
3017 while {[gets $f line] >= 0} {}
3018 if {[eof $f]} {
3019 if {[catch {close $f} err]} {
3020 error_popup "External diff viewer failed: $err"
3022 file delete -force $dir
3023 return 0
3025 return 1
3028 # Functions for adding and removing shell-type quoting
3030 proc shellquote {str} {
3031 if {![string match "*\['\"\\ \t]*" $str]} {
3032 return $str
3034 if {![string match "*\['\"\\]*" $str]} {
3035 return "\"$str\""
3037 if {![string match "*'*" $str]} {
3038 return "'$str'"
3040 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3043 proc shellarglist {l} {
3044 set str {}
3045 foreach a $l {
3046 if {$str ne {}} {
3047 append str " "
3049 append str [shellquote $a]
3051 return $str
3054 proc shelldequote {str} {
3055 set ret {}
3056 set used -1
3057 while {1} {
3058 incr used
3059 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3060 append ret [string range $str $used end]
3061 set used [string length $str]
3062 break
3064 set first [lindex $first 0]
3065 set ch [string index $str $first]
3066 if {$first > $used} {
3067 append ret [string range $str $used [expr {$first - 1}]]
3068 set used $first
3070 if {$ch eq " " || $ch eq "\t"} break
3071 incr used
3072 if {$ch eq "'"} {
3073 set first [string first "'" $str $used]
3074 if {$first < 0} {
3075 error "unmatched single-quote"
3077 append ret [string range $str $used [expr {$first - 1}]]
3078 set used $first
3079 continue
3081 if {$ch eq "\\"} {
3082 if {$used >= [string length $str]} {
3083 error "trailing backslash"
3085 append ret [string index $str $used]
3086 continue
3088 # here ch == "\""
3089 while {1} {
3090 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3091 error "unmatched double-quote"
3093 set first [lindex $first 0]
3094 set ch [string index $str $first]
3095 if {$first > $used} {
3096 append ret [string range $str $used [expr {$first - 1}]]
3097 set used $first
3099 if {$ch eq "\""} break
3100 incr used
3101 append ret [string index $str $used]
3102 incr used
3105 return [list $used $ret]
3108 proc shellsplit {str} {
3109 set l {}
3110 while {1} {
3111 set str [string trimleft $str]
3112 if {$str eq {}} break
3113 set dq [shelldequote $str]
3114 set n [lindex $dq 0]
3115 set word [lindex $dq 1]
3116 set str [string range $str $n end]
3117 lappend l $word
3119 return $l
3122 # Code to implement multiple views
3124 proc newview {ishighlight} {
3125 global nextviewnum newviewname newviewperm newishighlight
3126 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3128 set newishighlight $ishighlight
3129 set top .gitkview
3130 if {[winfo exists $top]} {
3131 raise $top
3132 return
3134 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3135 set newviewperm($nextviewnum) 0
3136 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3137 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3138 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3141 proc editview {} {
3142 global curview
3143 global viewname viewperm newviewname newviewperm
3144 global viewargs newviewargs viewargscmd newviewargscmd
3146 set top .gitkvedit-$curview
3147 if {[winfo exists $top]} {
3148 raise $top
3149 return
3151 set newviewname($curview) $viewname($curview)
3152 set newviewperm($curview) $viewperm($curview)
3153 set newviewargs($curview) [shellarglist $viewargs($curview)]
3154 set newviewargscmd($curview) $viewargscmd($curview)
3155 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3158 proc vieweditor {top n title} {
3159 global newviewname newviewperm viewfiles bgcolor
3161 toplevel $top
3162 wm title $top $title
3163 label $top.nl -text [mc "Name"]
3164 entry $top.name -width 20 -textvariable newviewname($n)
3165 grid $top.nl $top.name -sticky w -pady 5
3166 checkbutton $top.perm -text [mc "Remember this view"] \
3167 -variable newviewperm($n)
3168 grid $top.perm - -pady 5 -sticky w
3169 message $top.al -aspect 1000 \
3170 -text [mc "Commits to include (arguments to git log):"]
3171 grid $top.al - -sticky w -pady 5
3172 entry $top.args -width 50 -textvariable newviewargs($n) \
3173 -background $bgcolor
3174 grid $top.args - -sticky ew -padx 5
3176 message $top.ac -aspect 1000 \
3177 -text [mc "Command to generate more commits to include:"]
3178 grid $top.ac - -sticky w -pady 5
3179 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3180 -background white
3181 grid $top.argscmd - -sticky ew -padx 5
3183 message $top.l -aspect 1000 \
3184 -text [mc "Enter files and directories to include, one per line:"]
3185 grid $top.l - -sticky w
3186 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3187 if {[info exists viewfiles($n)]} {
3188 foreach f $viewfiles($n) {
3189 $top.t insert end $f
3190 $top.t insert end "\n"
3192 $top.t delete {end - 1c} end
3193 $top.t mark set insert 0.0
3195 grid $top.t - -sticky ew -padx 5
3196 frame $top.buts
3197 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3198 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3199 grid $top.buts.ok $top.buts.can
3200 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3201 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3202 grid $top.buts - -pady 10 -sticky ew
3203 focus $top.t
3206 proc doviewmenu {m first cmd op argv} {
3207 set nmenu [$m index end]
3208 for {set i $first} {$i <= $nmenu} {incr i} {
3209 if {[$m entrycget $i -command] eq $cmd} {
3210 eval $m $op $i $argv
3211 break
3216 proc allviewmenus {n op args} {
3217 # global viewhlmenu
3219 doviewmenu .bar.view 5 [list showview $n] $op $args
3220 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3223 proc newviewok {top n} {
3224 global nextviewnum newviewperm newviewname newishighlight
3225 global viewname viewfiles viewperm selectedview curview
3226 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3228 if {[catch {
3229 set newargs [shellsplit $newviewargs($n)]
3230 } err]} {
3231 error_popup "[mc "Error in commit selection arguments:"] $err"
3232 wm raise $top
3233 focus $top
3234 return
3236 set files {}
3237 foreach f [split [$top.t get 0.0 end] "\n"] {
3238 set ft [string trim $f]
3239 if {$ft ne {}} {
3240 lappend files $ft
3243 if {![info exists viewfiles($n)]} {
3244 # creating a new view
3245 incr nextviewnum
3246 set viewname($n) $newviewname($n)
3247 set viewperm($n) $newviewperm($n)
3248 set viewfiles($n) $files
3249 set viewargs($n) $newargs
3250 set viewargscmd($n) $newviewargscmd($n)
3251 addviewmenu $n
3252 if {!$newishighlight} {
3253 run showview $n
3254 } else {
3255 run addvhighlight $n
3257 } else {
3258 # editing an existing view
3259 set viewperm($n) $newviewperm($n)
3260 if {$newviewname($n) ne $viewname($n)} {
3261 set viewname($n) $newviewname($n)
3262 doviewmenu .bar.view 5 [list showview $n] \
3263 entryconf [list -label $viewname($n)]
3264 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3265 # entryconf [list -label $viewname($n) -value $viewname($n)]
3267 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3268 $newviewargscmd($n) ne $viewargscmd($n)} {
3269 set viewfiles($n) $files
3270 set viewargs($n) $newargs
3271 set viewargscmd($n) $newviewargscmd($n)
3272 if {$curview == $n} {
3273 run reloadcommits
3277 catch {destroy $top}
3280 proc delview {} {
3281 global curview viewperm hlview selectedhlview
3283 if {$curview == 0} return
3284 if {[info exists hlview] && $hlview == $curview} {
3285 set selectedhlview [mc "None"]
3286 unset hlview
3288 allviewmenus $curview delete
3289 set viewperm($curview) 0
3290 showview 0
3293 proc addviewmenu {n} {
3294 global viewname viewhlmenu
3296 .bar.view add radiobutton -label $viewname($n) \
3297 -command [list showview $n] -variable selectedview -value $n
3298 #$viewhlmenu add radiobutton -label $viewname($n) \
3299 # -command [list addvhighlight $n] -variable selectedhlview
3302 proc showview {n} {
3303 global curview cached_commitrow ordertok
3304 global displayorder parentlist rowidlist rowisopt rowfinal
3305 global colormap rowtextx nextcolor canvxmax
3306 global numcommits viewcomplete
3307 global selectedline currentid canv canvy0
3308 global treediffs
3309 global pending_select mainheadid
3310 global commitidx
3311 global selectedview
3312 global hlview selectedhlview commitinterest
3314 if {$n == $curview} return
3315 set selid {}
3316 set ymax [lindex [$canv cget -scrollregion] 3]
3317 set span [$canv yview]
3318 set ytop [expr {[lindex $span 0] * $ymax}]
3319 set ybot [expr {[lindex $span 1] * $ymax}]
3320 set yscreen [expr {($ybot - $ytop) / 2}]
3321 if {$selectedline ne {}} {
3322 set selid $currentid
3323 set y [yc $selectedline]
3324 if {$ytop < $y && $y < $ybot} {
3325 set yscreen [expr {$y - $ytop}]
3327 } elseif {[info exists pending_select]} {
3328 set selid $pending_select
3329 unset pending_select
3331 unselectline
3332 normalline
3333 catch {unset treediffs}
3334 clear_display
3335 if {[info exists hlview] && $hlview == $n} {
3336 unset hlview
3337 set selectedhlview [mc "None"]
3339 catch {unset commitinterest}
3340 catch {unset cached_commitrow}
3341 catch {unset ordertok}
3343 set curview $n
3344 set selectedview $n
3345 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3346 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3348 run refill_reflist
3349 if {![info exists viewcomplete($n)]} {
3350 getcommits $selid
3351 return
3354 set displayorder {}
3355 set parentlist {}
3356 set rowidlist {}
3357 set rowisopt {}
3358 set rowfinal {}
3359 set numcommits $commitidx($n)
3361 catch {unset colormap}
3362 catch {unset rowtextx}
3363 set nextcolor 0
3364 set canvxmax [$canv cget -width]
3365 set curview $n
3366 set row 0
3367 setcanvscroll
3368 set yf 0
3369 set row {}
3370 if {$selid ne {} && [commitinview $selid $n]} {
3371 set row [rowofcommit $selid]
3372 # try to get the selected row in the same position on the screen
3373 set ymax [lindex [$canv cget -scrollregion] 3]
3374 set ytop [expr {[yc $row] - $yscreen}]
3375 if {$ytop < 0} {
3376 set ytop 0
3378 set yf [expr {$ytop * 1.0 / $ymax}]
3380 allcanvs yview moveto $yf
3381 drawvisible
3382 if {$row ne {}} {
3383 selectline $row 0
3384 } elseif {!$viewcomplete($n)} {
3385 reset_pending_select $selid
3386 } else {
3387 reset_pending_select {}
3389 if {[commitinview $pending_select $curview]} {
3390 selectline [rowofcommit $pending_select] 1
3391 } else {
3392 set row [first_real_row]
3393 if {$row < $numcommits} {
3394 selectline $row 0
3398 if {!$viewcomplete($n)} {
3399 if {$numcommits == 0} {
3400 show_status [mc "Reading commits..."]
3402 } elseif {$numcommits == 0} {
3403 show_status [mc "No commits selected"]
3407 # Stuff relating to the highlighting facility
3409 proc ishighlighted {id} {
3410 global vhighlights fhighlights nhighlights rhighlights
3412 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3413 return $nhighlights($id)
3415 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3416 return $vhighlights($id)
3418 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3419 return $fhighlights($id)
3421 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3422 return $rhighlights($id)
3424 return 0
3427 proc bolden {row font} {
3428 global canv linehtag selectedline boldrows
3430 lappend boldrows $row
3431 $canv itemconf $linehtag($row) -font $font
3432 if {$row == $selectedline} {
3433 $canv delete secsel
3434 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3435 -outline {{}} -tags secsel \
3436 -fill [$canv cget -selectbackground]]
3437 $canv lower $t
3441 proc bolden_name {row font} {
3442 global canv2 linentag selectedline boldnamerows
3444 lappend boldnamerows $row
3445 $canv2 itemconf $linentag($row) -font $font
3446 if {$row == $selectedline} {
3447 $canv2 delete secsel
3448 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3449 -outline {{}} -tags secsel \
3450 -fill [$canv2 cget -selectbackground]]
3451 $canv2 lower $t
3455 proc unbolden {} {
3456 global boldrows
3458 set stillbold {}
3459 foreach row $boldrows {
3460 if {![ishighlighted [commitonrow $row]]} {
3461 bolden $row mainfont
3462 } else {
3463 lappend stillbold $row
3466 set boldrows $stillbold
3469 proc addvhighlight {n} {
3470 global hlview viewcomplete curview vhl_done commitidx
3472 if {[info exists hlview]} {
3473 delvhighlight
3475 set hlview $n
3476 if {$n != $curview && ![info exists viewcomplete($n)]} {
3477 start_rev_list $n
3479 set vhl_done $commitidx($hlview)
3480 if {$vhl_done > 0} {
3481 drawvisible
3485 proc delvhighlight {} {
3486 global hlview vhighlights
3488 if {![info exists hlview]} return
3489 unset hlview
3490 catch {unset vhighlights}
3491 unbolden
3494 proc vhighlightmore {} {
3495 global hlview vhl_done commitidx vhighlights curview
3497 set max $commitidx($hlview)
3498 set vr [visiblerows]
3499 set r0 [lindex $vr 0]
3500 set r1 [lindex $vr 1]
3501 for {set i $vhl_done} {$i < $max} {incr i} {
3502 set id [commitonrow $i $hlview]
3503 if {[commitinview $id $curview]} {
3504 set row [rowofcommit $id]
3505 if {$r0 <= $row && $row <= $r1} {
3506 if {![highlighted $row]} {
3507 bolden $row mainfontbold
3509 set vhighlights($id) 1
3513 set vhl_done $max
3514 return 0
3517 proc askvhighlight {row id} {
3518 global hlview vhighlights iddrawn
3520 if {[commitinview $id $hlview]} {
3521 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3522 bolden $row mainfontbold
3524 set vhighlights($id) 1
3525 } else {
3526 set vhighlights($id) 0
3530 proc hfiles_change {} {
3531 global highlight_files filehighlight fhighlights fh_serial
3532 global highlight_paths gdttype
3534 if {[info exists filehighlight]} {
3535 # delete previous highlights
3536 catch {close $filehighlight}
3537 unset filehighlight
3538 catch {unset fhighlights}
3539 unbolden
3540 unhighlight_filelist
3542 set highlight_paths {}
3543 after cancel do_file_hl $fh_serial
3544 incr fh_serial
3545 if {$highlight_files ne {}} {
3546 after 300 do_file_hl $fh_serial
3550 proc gdttype_change {name ix op} {
3551 global gdttype highlight_files findstring findpattern
3553 stopfinding
3554 if {$findstring ne {}} {
3555 if {$gdttype eq [mc "containing:"]} {
3556 if {$highlight_files ne {}} {
3557 set highlight_files {}
3558 hfiles_change
3560 findcom_change
3561 } else {
3562 if {$findpattern ne {}} {
3563 set findpattern {}
3564 findcom_change
3566 set highlight_files $findstring
3567 hfiles_change
3569 drawvisible
3571 # enable/disable findtype/findloc menus too
3574 proc find_change {name ix op} {
3575 global gdttype findstring highlight_files
3577 stopfinding
3578 if {$gdttype eq [mc "containing:"]} {
3579 findcom_change
3580 } else {
3581 if {$highlight_files ne $findstring} {
3582 set highlight_files $findstring
3583 hfiles_change
3586 drawvisible
3589 proc findcom_change args {
3590 global nhighlights boldnamerows
3591 global findpattern findtype findstring gdttype
3593 stopfinding
3594 # delete previous highlights, if any
3595 foreach row $boldnamerows {
3596 bolden_name $row mainfont
3598 set boldnamerows {}
3599 catch {unset nhighlights}
3600 unbolden
3601 unmarkmatches
3602 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3603 set findpattern {}
3604 } elseif {$findtype eq [mc "Regexp"]} {
3605 set findpattern $findstring
3606 } else {
3607 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3608 $findstring]
3609 set findpattern "*$e*"
3613 proc makepatterns {l} {
3614 set ret {}
3615 foreach e $l {
3616 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3617 if {[string index $ee end] eq "/"} {
3618 lappend ret "$ee*"
3619 } else {
3620 lappend ret $ee
3621 lappend ret "$ee/*"
3624 return $ret
3627 proc do_file_hl {serial} {
3628 global highlight_files filehighlight highlight_paths gdttype fhl_list
3630 if {$gdttype eq [mc "touching paths:"]} {
3631 if {[catch {set paths [shellsplit $highlight_files]}]} return
3632 set highlight_paths [makepatterns $paths]
3633 highlight_filelist
3634 set gdtargs [concat -- $paths]
3635 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3636 set gdtargs [list "-S$highlight_files"]
3637 } else {
3638 # must be "containing:", i.e. we're searching commit info
3639 return
3641 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3642 set filehighlight [open $cmd r+]
3643 fconfigure $filehighlight -blocking 0
3644 filerun $filehighlight readfhighlight
3645 set fhl_list {}
3646 drawvisible
3647 flushhighlights
3650 proc flushhighlights {} {
3651 global filehighlight fhl_list
3653 if {[info exists filehighlight]} {
3654 lappend fhl_list {}
3655 puts $filehighlight ""
3656 flush $filehighlight
3660 proc askfilehighlight {row id} {
3661 global filehighlight fhighlights fhl_list
3663 lappend fhl_list $id
3664 set fhighlights($id) -1
3665 puts $filehighlight $id
3668 proc readfhighlight {} {
3669 global filehighlight fhighlights curview iddrawn
3670 global fhl_list find_dirn
3672 if {![info exists filehighlight]} {
3673 return 0
3675 set nr 0
3676 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3677 set line [string trim $line]
3678 set i [lsearch -exact $fhl_list $line]
3679 if {$i < 0} continue
3680 for {set j 0} {$j < $i} {incr j} {
3681 set id [lindex $fhl_list $j]
3682 set fhighlights($id) 0
3684 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3685 if {$line eq {}} continue
3686 if {![commitinview $line $curview]} continue
3687 set row [rowofcommit $line]
3688 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3689 bolden $row mainfontbold
3691 set fhighlights($line) 1
3693 if {[eof $filehighlight]} {
3694 # strange...
3695 puts "oops, git diff-tree died"
3696 catch {close $filehighlight}
3697 unset filehighlight
3698 return 0
3700 if {[info exists find_dirn]} {
3701 run findmore
3703 return 1
3706 proc doesmatch {f} {
3707 global findtype findpattern
3709 if {$findtype eq [mc "Regexp"]} {
3710 return [regexp $findpattern $f]
3711 } elseif {$findtype eq [mc "IgnCase"]} {
3712 return [string match -nocase $findpattern $f]
3713 } else {
3714 return [string match $findpattern $f]
3718 proc askfindhighlight {row id} {
3719 global nhighlights commitinfo iddrawn
3720 global findloc
3721 global markingmatches
3723 if {![info exists commitinfo($id)]} {
3724 getcommit $id
3726 set info $commitinfo($id)
3727 set isbold 0
3728 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3729 foreach f $info ty $fldtypes {
3730 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3731 [doesmatch $f]} {
3732 if {$ty eq [mc "Author"]} {
3733 set isbold 2
3734 break
3736 set isbold 1
3739 if {$isbold && [info exists iddrawn($id)]} {
3740 if {![ishighlighted $id]} {
3741 bolden $row mainfontbold
3742 if {$isbold > 1} {
3743 bolden_name $row mainfontbold
3746 if {$markingmatches} {
3747 markrowmatches $row $id
3750 set nhighlights($id) $isbold
3753 proc markrowmatches {row id} {
3754 global canv canv2 linehtag linentag commitinfo findloc
3756 set headline [lindex $commitinfo($id) 0]
3757 set author [lindex $commitinfo($id) 1]
3758 $canv delete match$row
3759 $canv2 delete match$row
3760 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3761 set m [findmatches $headline]
3762 if {$m ne {}} {
3763 markmatches $canv $row $headline $linehtag($row) $m \
3764 [$canv itemcget $linehtag($row) -font] $row
3767 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3768 set m [findmatches $author]
3769 if {$m ne {}} {
3770 markmatches $canv2 $row $author $linentag($row) $m \
3771 [$canv2 itemcget $linentag($row) -font] $row
3776 proc vrel_change {name ix op} {
3777 global highlight_related
3779 rhighlight_none
3780 if {$highlight_related ne [mc "None"]} {
3781 run drawvisible
3785 # prepare for testing whether commits are descendents or ancestors of a
3786 proc rhighlight_sel {a} {
3787 global descendent desc_todo ancestor anc_todo
3788 global highlight_related
3790 catch {unset descendent}
3791 set desc_todo [list $a]
3792 catch {unset ancestor}
3793 set anc_todo [list $a]
3794 if {$highlight_related ne [mc "None"]} {
3795 rhighlight_none
3796 run drawvisible
3800 proc rhighlight_none {} {
3801 global rhighlights
3803 catch {unset rhighlights}
3804 unbolden
3807 proc is_descendent {a} {
3808 global curview children descendent desc_todo
3810 set v $curview
3811 set la [rowofcommit $a]
3812 set todo $desc_todo
3813 set leftover {}
3814 set done 0
3815 for {set i 0} {$i < [llength $todo]} {incr i} {
3816 set do [lindex $todo $i]
3817 if {[rowofcommit $do] < $la} {
3818 lappend leftover $do
3819 continue
3821 foreach nk $children($v,$do) {
3822 if {![info exists descendent($nk)]} {
3823 set descendent($nk) 1
3824 lappend todo $nk
3825 if {$nk eq $a} {
3826 set done 1
3830 if {$done} {
3831 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3832 return
3835 set descendent($a) 0
3836 set desc_todo $leftover
3839 proc is_ancestor {a} {
3840 global curview parents ancestor anc_todo
3842 set v $curview
3843 set la [rowofcommit $a]
3844 set todo $anc_todo
3845 set leftover {}
3846 set done 0
3847 for {set i 0} {$i < [llength $todo]} {incr i} {
3848 set do [lindex $todo $i]
3849 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3850 lappend leftover $do
3851 continue
3853 foreach np $parents($v,$do) {
3854 if {![info exists ancestor($np)]} {
3855 set ancestor($np) 1
3856 lappend todo $np
3857 if {$np eq $a} {
3858 set done 1
3862 if {$done} {
3863 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3864 return
3867 set ancestor($a) 0
3868 set anc_todo $leftover
3871 proc askrelhighlight {row id} {
3872 global descendent highlight_related iddrawn rhighlights
3873 global selectedline ancestor
3875 if {$selectedline eq {}} return
3876 set isbold 0
3877 if {$highlight_related eq [mc "Descendant"] ||
3878 $highlight_related eq [mc "Not descendant"]} {
3879 if {![info exists descendent($id)]} {
3880 is_descendent $id
3882 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3883 set isbold 1
3885 } elseif {$highlight_related eq [mc "Ancestor"] ||
3886 $highlight_related eq [mc "Not ancestor"]} {
3887 if {![info exists ancestor($id)]} {
3888 is_ancestor $id
3890 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3891 set isbold 1
3894 if {[info exists iddrawn($id)]} {
3895 if {$isbold && ![ishighlighted $id]} {
3896 bolden $row mainfontbold
3899 set rhighlights($id) $isbold
3902 # Graph layout functions
3904 proc shortids {ids} {
3905 set res {}
3906 foreach id $ids {
3907 if {[llength $id] > 1} {
3908 lappend res [shortids $id]
3909 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3910 lappend res [string range $id 0 7]
3911 } else {
3912 lappend res $id
3915 return $res
3918 proc ntimes {n o} {
3919 set ret {}
3920 set o [list $o]
3921 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3922 if {($n & $mask) != 0} {
3923 set ret [concat $ret $o]
3925 set o [concat $o $o]
3927 return $ret
3930 proc ordertoken {id} {
3931 global ordertok curview varcid varcstart varctok curview parents children
3932 global nullid nullid2
3934 if {[info exists ordertok($id)]} {
3935 return $ordertok($id)
3937 set origid $id
3938 set todo {}
3939 while {1} {
3940 if {[info exists varcid($curview,$id)]} {
3941 set a $varcid($curview,$id)
3942 set p [lindex $varcstart($curview) $a]
3943 } else {
3944 set p [lindex $children($curview,$id) 0]
3946 if {[info exists ordertok($p)]} {
3947 set tok $ordertok($p)
3948 break
3950 set id [first_real_child $curview,$p]
3951 if {$id eq {}} {
3952 # it's a root
3953 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3954 break
3956 if {[llength $parents($curview,$id)] == 1} {
3957 lappend todo [list $p {}]
3958 } else {
3959 set j [lsearch -exact $parents($curview,$id) $p]
3960 if {$j < 0} {
3961 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3963 lappend todo [list $p [strrep $j]]
3966 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3967 set p [lindex $todo $i 0]
3968 append tok [lindex $todo $i 1]
3969 set ordertok($p) $tok
3971 set ordertok($origid) $tok
3972 return $tok
3975 # Work out where id should go in idlist so that order-token
3976 # values increase from left to right
3977 proc idcol {idlist id {i 0}} {
3978 set t [ordertoken $id]
3979 if {$i < 0} {
3980 set i 0
3982 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3983 if {$i > [llength $idlist]} {
3984 set i [llength $idlist]
3986 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3987 incr i
3988 } else {
3989 if {$t > [ordertoken [lindex $idlist $i]]} {
3990 while {[incr i] < [llength $idlist] &&
3991 $t >= [ordertoken [lindex $idlist $i]]} {}
3994 return $i
3997 proc initlayout {} {
3998 global rowidlist rowisopt rowfinal displayorder parentlist
3999 global numcommits canvxmax canv
4000 global nextcolor
4001 global colormap rowtextx
4003 set numcommits 0
4004 set displayorder {}
4005 set parentlist {}
4006 set nextcolor 0
4007 set rowidlist {}
4008 set rowisopt {}
4009 set rowfinal {}
4010 set canvxmax [$canv cget -width]
4011 catch {unset colormap}
4012 catch {unset rowtextx}
4013 setcanvscroll
4016 proc setcanvscroll {} {
4017 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4018 global lastscrollset lastscrollrows
4020 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4021 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4022 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4023 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4024 set lastscrollset [clock clicks -milliseconds]
4025 set lastscrollrows $numcommits
4028 proc visiblerows {} {
4029 global canv numcommits linespc
4031 set ymax [lindex [$canv cget -scrollregion] 3]
4032 if {$ymax eq {} || $ymax == 0} return
4033 set f [$canv yview]
4034 set y0 [expr {int([lindex $f 0] * $ymax)}]
4035 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4036 if {$r0 < 0} {
4037 set r0 0
4039 set y1 [expr {int([lindex $f 1] * $ymax)}]
4040 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4041 if {$r1 >= $numcommits} {
4042 set r1 [expr {$numcommits - 1}]
4044 return [list $r0 $r1]
4047 proc layoutmore {} {
4048 global commitidx viewcomplete curview
4049 global numcommits pending_select curview
4050 global lastscrollset lastscrollrows commitinterest
4052 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4053 [clock clicks -milliseconds] - $lastscrollset > 500} {
4054 setcanvscroll
4056 if {[info exists pending_select] &&
4057 [commitinview $pending_select $curview]} {
4058 update
4059 selectline [rowofcommit $pending_select] 1
4061 drawvisible
4064 proc doshowlocalchanges {} {
4065 global curview mainheadid
4067 if {$mainheadid eq {}} return
4068 if {[commitinview $mainheadid $curview]} {
4069 dodiffindex
4070 } else {
4071 lappend commitinterest($mainheadid) {dodiffindex}
4075 proc dohidelocalchanges {} {
4076 global nullid nullid2 lserial curview
4078 if {[commitinview $nullid $curview]} {
4079 removefakerow $nullid
4081 if {[commitinview $nullid2 $curview]} {
4082 removefakerow $nullid2
4084 incr lserial
4087 # spawn off a process to do git diff-index --cached HEAD
4088 proc dodiffindex {} {
4089 global lserial showlocalchanges
4090 global isworktree
4092 if {!$showlocalchanges || !$isworktree} return
4093 incr lserial
4094 set fd [open "|git diff-index --cached HEAD" r]
4095 fconfigure $fd -blocking 0
4096 set i [reg_instance $fd]
4097 filerun $fd [list readdiffindex $fd $lserial $i]
4100 proc readdiffindex {fd serial inst} {
4101 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4103 set isdiff 1
4104 if {[gets $fd line] < 0} {
4105 if {![eof $fd]} {
4106 return 1
4108 set isdiff 0
4110 # we only need to see one line and we don't really care what it says...
4111 stop_instance $inst
4113 if {$serial != $lserial} {
4114 return 0
4117 # now see if there are any local changes not checked in to the index
4118 set fd [open "|git diff-files" r]
4119 fconfigure $fd -blocking 0
4120 set i [reg_instance $fd]
4121 filerun $fd [list readdifffiles $fd $serial $i]
4123 if {$isdiff && ![commitinview $nullid2 $curview]} {
4124 # add the line for the changes in the index to the graph
4125 set hl [mc "Local changes checked in to index but not committed"]
4126 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4127 set commitdata($nullid2) "\n $hl\n"
4128 if {[commitinview $nullid $curview]} {
4129 removefakerow $nullid
4131 insertfakerow $nullid2 $mainheadid
4132 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4133 removefakerow $nullid2
4135 return 0
4138 proc readdifffiles {fd serial inst} {
4139 global mainheadid nullid nullid2 curview
4140 global commitinfo commitdata lserial
4142 set isdiff 1
4143 if {[gets $fd line] < 0} {
4144 if {![eof $fd]} {
4145 return 1
4147 set isdiff 0
4149 # we only need to see one line and we don't really care what it says...
4150 stop_instance $inst
4152 if {$serial != $lserial} {
4153 return 0
4156 if {$isdiff && ![commitinview $nullid $curview]} {
4157 # add the line for the local diff to the graph
4158 set hl [mc "Local uncommitted changes, not checked in to index"]
4159 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4160 set commitdata($nullid) "\n $hl\n"
4161 if {[commitinview $nullid2 $curview]} {
4162 set p $nullid2
4163 } else {
4164 set p $mainheadid
4166 insertfakerow $nullid $p
4167 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4168 removefakerow $nullid
4170 return 0
4173 proc nextuse {id row} {
4174 global curview children
4176 if {[info exists children($curview,$id)]} {
4177 foreach kid $children($curview,$id) {
4178 if {![commitinview $kid $curview]} {
4179 return -1
4181 if {[rowofcommit $kid] > $row} {
4182 return [rowofcommit $kid]
4186 if {[commitinview $id $curview]} {
4187 return [rowofcommit $id]
4189 return -1
4192 proc prevuse {id row} {
4193 global curview children
4195 set ret -1
4196 if {[info exists children($curview,$id)]} {
4197 foreach kid $children($curview,$id) {
4198 if {![commitinview $kid $curview]} break
4199 if {[rowofcommit $kid] < $row} {
4200 set ret [rowofcommit $kid]
4204 return $ret
4207 proc make_idlist {row} {
4208 global displayorder parentlist uparrowlen downarrowlen mingaplen
4209 global commitidx curview children
4211 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4212 if {$r < 0} {
4213 set r 0
4215 set ra [expr {$row - $downarrowlen}]
4216 if {$ra < 0} {
4217 set ra 0
4219 set rb [expr {$row + $uparrowlen}]
4220 if {$rb > $commitidx($curview)} {
4221 set rb $commitidx($curview)
4223 make_disporder $r [expr {$rb + 1}]
4224 set ids {}
4225 for {} {$r < $ra} {incr r} {
4226 set nextid [lindex $displayorder [expr {$r + 1}]]
4227 foreach p [lindex $parentlist $r] {
4228 if {$p eq $nextid} continue
4229 set rn [nextuse $p $r]
4230 if {$rn >= $row &&
4231 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4232 lappend ids [list [ordertoken $p] $p]
4236 for {} {$r < $row} {incr r} {
4237 set nextid [lindex $displayorder [expr {$r + 1}]]
4238 foreach p [lindex $parentlist $r] {
4239 if {$p eq $nextid} continue
4240 set rn [nextuse $p $r]
4241 if {$rn < 0 || $rn >= $row} {
4242 lappend ids [list [ordertoken $p] $p]
4246 set id [lindex $displayorder $row]
4247 lappend ids [list [ordertoken $id] $id]
4248 while {$r < $rb} {
4249 foreach p [lindex $parentlist $r] {
4250 set firstkid [lindex $children($curview,$p) 0]
4251 if {[rowofcommit $firstkid] < $row} {
4252 lappend ids [list [ordertoken $p] $p]
4255 incr r
4256 set id [lindex $displayorder $r]
4257 if {$id ne {}} {
4258 set firstkid [lindex $children($curview,$id) 0]
4259 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4260 lappend ids [list [ordertoken $id] $id]
4264 set idlist {}
4265 foreach idx [lsort -unique $ids] {
4266 lappend idlist [lindex $idx 1]
4268 return $idlist
4271 proc rowsequal {a b} {
4272 while {[set i [lsearch -exact $a {}]] >= 0} {
4273 set a [lreplace $a $i $i]
4275 while {[set i [lsearch -exact $b {}]] >= 0} {
4276 set b [lreplace $b $i $i]
4278 return [expr {$a eq $b}]
4281 proc makeupline {id row rend col} {
4282 global rowidlist uparrowlen downarrowlen mingaplen
4284 for {set r $rend} {1} {set r $rstart} {
4285 set rstart [prevuse $id $r]
4286 if {$rstart < 0} return
4287 if {$rstart < $row} break
4289 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4290 set rstart [expr {$rend - $uparrowlen - 1}]
4292 for {set r $rstart} {[incr r] <= $row} {} {
4293 set idlist [lindex $rowidlist $r]
4294 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4295 set col [idcol $idlist $id $col]
4296 lset rowidlist $r [linsert $idlist $col $id]
4297 changedrow $r
4302 proc layoutrows {row endrow} {
4303 global rowidlist rowisopt rowfinal displayorder
4304 global uparrowlen downarrowlen maxwidth mingaplen
4305 global children parentlist
4306 global commitidx viewcomplete curview
4308 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4309 set idlist {}
4310 if {$row > 0} {
4311 set rm1 [expr {$row - 1}]
4312 foreach id [lindex $rowidlist $rm1] {
4313 if {$id ne {}} {
4314 lappend idlist $id
4317 set final [lindex $rowfinal $rm1]
4319 for {} {$row < $endrow} {incr row} {
4320 set rm1 [expr {$row - 1}]
4321 if {$rm1 < 0 || $idlist eq {}} {
4322 set idlist [make_idlist $row]
4323 set final 1
4324 } else {
4325 set id [lindex $displayorder $rm1]
4326 set col [lsearch -exact $idlist $id]
4327 set idlist [lreplace $idlist $col $col]
4328 foreach p [lindex $parentlist $rm1] {
4329 if {[lsearch -exact $idlist $p] < 0} {
4330 set col [idcol $idlist $p $col]
4331 set idlist [linsert $idlist $col $p]
4332 # if not the first child, we have to insert a line going up
4333 if {$id ne [lindex $children($curview,$p) 0]} {
4334 makeupline $p $rm1 $row $col
4338 set id [lindex $displayorder $row]
4339 if {$row > $downarrowlen} {
4340 set termrow [expr {$row - $downarrowlen - 1}]
4341 foreach p [lindex $parentlist $termrow] {
4342 set i [lsearch -exact $idlist $p]
4343 if {$i < 0} continue
4344 set nr [nextuse $p $termrow]
4345 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4346 set idlist [lreplace $idlist $i $i]
4350 set col [lsearch -exact $idlist $id]
4351 if {$col < 0} {
4352 set col [idcol $idlist $id]
4353 set idlist [linsert $idlist $col $id]
4354 if {$children($curview,$id) ne {}} {
4355 makeupline $id $rm1 $row $col
4358 set r [expr {$row + $uparrowlen - 1}]
4359 if {$r < $commitidx($curview)} {
4360 set x $col
4361 foreach p [lindex $parentlist $r] {
4362 if {[lsearch -exact $idlist $p] >= 0} continue
4363 set fk [lindex $children($curview,$p) 0]
4364 if {[rowofcommit $fk] < $row} {
4365 set x [idcol $idlist $p $x]
4366 set idlist [linsert $idlist $x $p]
4369 if {[incr r] < $commitidx($curview)} {
4370 set p [lindex $displayorder $r]
4371 if {[lsearch -exact $idlist $p] < 0} {
4372 set fk [lindex $children($curview,$p) 0]
4373 if {$fk ne {} && [rowofcommit $fk] < $row} {
4374 set x [idcol $idlist $p $x]
4375 set idlist [linsert $idlist $x $p]
4381 if {$final && !$viewcomplete($curview) &&
4382 $row + $uparrowlen + $mingaplen + $downarrowlen
4383 >= $commitidx($curview)} {
4384 set final 0
4386 set l [llength $rowidlist]
4387 if {$row == $l} {
4388 lappend rowidlist $idlist
4389 lappend rowisopt 0
4390 lappend rowfinal $final
4391 } elseif {$row < $l} {
4392 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4393 lset rowidlist $row $idlist
4394 changedrow $row
4396 lset rowfinal $row $final
4397 } else {
4398 set pad [ntimes [expr {$row - $l}] {}]
4399 set rowidlist [concat $rowidlist $pad]
4400 lappend rowidlist $idlist
4401 set rowfinal [concat $rowfinal $pad]
4402 lappend rowfinal $final
4403 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4406 return $row
4409 proc changedrow {row} {
4410 global displayorder iddrawn rowisopt need_redisplay
4412 set l [llength $rowisopt]
4413 if {$row < $l} {
4414 lset rowisopt $row 0
4415 if {$row + 1 < $l} {
4416 lset rowisopt [expr {$row + 1}] 0
4417 if {$row + 2 < $l} {
4418 lset rowisopt [expr {$row + 2}] 0
4422 set id [lindex $displayorder $row]
4423 if {[info exists iddrawn($id)]} {
4424 set need_redisplay 1
4428 proc insert_pad {row col npad} {
4429 global rowidlist
4431 set pad [ntimes $npad {}]
4432 set idlist [lindex $rowidlist $row]
4433 set bef [lrange $idlist 0 [expr {$col - 1}]]
4434 set aft [lrange $idlist $col end]
4435 set i [lsearch -exact $aft {}]
4436 if {$i > 0} {
4437 set aft [lreplace $aft $i $i]
4439 lset rowidlist $row [concat $bef $pad $aft]
4440 changedrow $row
4443 proc optimize_rows {row col endrow} {
4444 global rowidlist rowisopt displayorder curview children
4446 if {$row < 1} {
4447 set row 1
4449 for {} {$row < $endrow} {incr row; set col 0} {
4450 if {[lindex $rowisopt $row]} continue
4451 set haspad 0
4452 set y0 [expr {$row - 1}]
4453 set ym [expr {$row - 2}]
4454 set idlist [lindex $rowidlist $row]
4455 set previdlist [lindex $rowidlist $y0]
4456 if {$idlist eq {} || $previdlist eq {}} continue
4457 if {$ym >= 0} {
4458 set pprevidlist [lindex $rowidlist $ym]
4459 if {$pprevidlist eq {}} continue
4460 } else {
4461 set pprevidlist {}
4463 set x0 -1
4464 set xm -1
4465 for {} {$col < [llength $idlist]} {incr col} {
4466 set id [lindex $idlist $col]
4467 if {[lindex $previdlist $col] eq $id} continue
4468 if {$id eq {}} {
4469 set haspad 1
4470 continue
4472 set x0 [lsearch -exact $previdlist $id]
4473 if {$x0 < 0} continue
4474 set z [expr {$x0 - $col}]
4475 set isarrow 0
4476 set z0 {}
4477 if {$ym >= 0} {
4478 set xm [lsearch -exact $pprevidlist $id]
4479 if {$xm >= 0} {
4480 set z0 [expr {$xm - $x0}]
4483 if {$z0 eq {}} {
4484 # if row y0 is the first child of $id then it's not an arrow
4485 if {[lindex $children($curview,$id) 0] ne
4486 [lindex $displayorder $y0]} {
4487 set isarrow 1
4490 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4491 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4492 set isarrow 1
4494 # Looking at lines from this row to the previous row,
4495 # make them go straight up if they end in an arrow on
4496 # the previous row; otherwise make them go straight up
4497 # or at 45 degrees.
4498 if {$z < -1 || ($z < 0 && $isarrow)} {
4499 # Line currently goes left too much;
4500 # insert pads in the previous row, then optimize it
4501 set npad [expr {-1 - $z + $isarrow}]
4502 insert_pad $y0 $x0 $npad
4503 if {$y0 > 0} {
4504 optimize_rows $y0 $x0 $row
4506 set previdlist [lindex $rowidlist $y0]
4507 set x0 [lsearch -exact $previdlist $id]
4508 set z [expr {$x0 - $col}]
4509 if {$z0 ne {}} {
4510 set pprevidlist [lindex $rowidlist $ym]
4511 set xm [lsearch -exact $pprevidlist $id]
4512 set z0 [expr {$xm - $x0}]
4514 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4515 # Line currently goes right too much;
4516 # insert pads in this line
4517 set npad [expr {$z - 1 + $isarrow}]
4518 insert_pad $row $col $npad
4519 set idlist [lindex $rowidlist $row]
4520 incr col $npad
4521 set z [expr {$x0 - $col}]
4522 set haspad 1
4524 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4525 # this line links to its first child on row $row-2
4526 set id [lindex $displayorder $ym]
4527 set xc [lsearch -exact $pprevidlist $id]
4528 if {$xc >= 0} {
4529 set z0 [expr {$xc - $x0}]
4532 # avoid lines jigging left then immediately right
4533 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4534 insert_pad $y0 $x0 1
4535 incr x0
4536 optimize_rows $y0 $x0 $row
4537 set previdlist [lindex $rowidlist $y0]
4540 if {!$haspad} {
4541 # Find the first column that doesn't have a line going right
4542 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4543 set id [lindex $idlist $col]
4544 if {$id eq {}} break
4545 set x0 [lsearch -exact $previdlist $id]
4546 if {$x0 < 0} {
4547 # check if this is the link to the first child
4548 set kid [lindex $displayorder $y0]
4549 if {[lindex $children($curview,$id) 0] eq $kid} {
4550 # it is, work out offset to child
4551 set x0 [lsearch -exact $previdlist $kid]
4554 if {$x0 <= $col} break
4556 # Insert a pad at that column as long as it has a line and
4557 # isn't the last column
4558 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4559 set idlist [linsert $idlist $col {}]
4560 lset rowidlist $row $idlist
4561 changedrow $row
4567 proc xc {row col} {
4568 global canvx0 linespc
4569 return [expr {$canvx0 + $col * $linespc}]
4572 proc yc {row} {
4573 global canvy0 linespc
4574 return [expr {$canvy0 + $row * $linespc}]
4577 proc linewidth {id} {
4578 global thickerline lthickness
4580 set wid $lthickness
4581 if {[info exists thickerline] && $id eq $thickerline} {
4582 set wid [expr {2 * $lthickness}]
4584 return $wid
4587 proc rowranges {id} {
4588 global curview children uparrowlen downarrowlen
4589 global rowidlist
4591 set kids $children($curview,$id)
4592 if {$kids eq {}} {
4593 return {}
4595 set ret {}
4596 lappend kids $id
4597 foreach child $kids {
4598 if {![commitinview $child $curview]} break
4599 set row [rowofcommit $child]
4600 if {![info exists prev]} {
4601 lappend ret [expr {$row + 1}]
4602 } else {
4603 if {$row <= $prevrow} {
4604 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4606 # see if the line extends the whole way from prevrow to row
4607 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4608 [lsearch -exact [lindex $rowidlist \
4609 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4610 # it doesn't, see where it ends
4611 set r [expr {$prevrow + $downarrowlen}]
4612 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4613 while {[incr r -1] > $prevrow &&
4614 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4615 } else {
4616 while {[incr r] <= $row &&
4617 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4618 incr r -1
4620 lappend ret $r
4621 # see where it starts up again
4622 set r [expr {$row - $uparrowlen}]
4623 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4624 while {[incr r] < $row &&
4625 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4626 } else {
4627 while {[incr r -1] >= $prevrow &&
4628 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4629 incr r
4631 lappend ret $r
4634 if {$child eq $id} {
4635 lappend ret $row
4637 set prev $child
4638 set prevrow $row
4640 return $ret
4643 proc drawlineseg {id row endrow arrowlow} {
4644 global rowidlist displayorder iddrawn linesegs
4645 global canv colormap linespc curview maxlinelen parentlist
4647 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4648 set le [expr {$row + 1}]
4649 set arrowhigh 1
4650 while {1} {
4651 set c [lsearch -exact [lindex $rowidlist $le] $id]
4652 if {$c < 0} {
4653 incr le -1
4654 break
4656 lappend cols $c
4657 set x [lindex $displayorder $le]
4658 if {$x eq $id} {
4659 set arrowhigh 0
4660 break
4662 if {[info exists iddrawn($x)] || $le == $endrow} {
4663 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4664 if {$c >= 0} {
4665 lappend cols $c
4666 set arrowhigh 0
4668 break
4670 incr le
4672 if {$le <= $row} {
4673 return $row
4676 set lines {}
4677 set i 0
4678 set joinhigh 0
4679 if {[info exists linesegs($id)]} {
4680 set lines $linesegs($id)
4681 foreach li $lines {
4682 set r0 [lindex $li 0]
4683 if {$r0 > $row} {
4684 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4685 set joinhigh 1
4687 break
4689 incr i
4692 set joinlow 0
4693 if {$i > 0} {
4694 set li [lindex $lines [expr {$i-1}]]
4695 set r1 [lindex $li 1]
4696 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4697 set joinlow 1
4701 set x [lindex $cols [expr {$le - $row}]]
4702 set xp [lindex $cols [expr {$le - 1 - $row}]]
4703 set dir [expr {$xp - $x}]
4704 if {$joinhigh} {
4705 set ith [lindex $lines $i 2]
4706 set coords [$canv coords $ith]
4707 set ah [$canv itemcget $ith -arrow]
4708 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4709 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4710 if {$x2 ne {} && $x - $x2 == $dir} {
4711 set coords [lrange $coords 0 end-2]
4713 } else {
4714 set coords [list [xc $le $x] [yc $le]]
4716 if {$joinlow} {
4717 set itl [lindex $lines [expr {$i-1}] 2]
4718 set al [$canv itemcget $itl -arrow]
4719 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4720 } elseif {$arrowlow} {
4721 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4722 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4723 set arrowlow 0
4726 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4727 for {set y $le} {[incr y -1] > $row} {} {
4728 set x $xp
4729 set xp [lindex $cols [expr {$y - 1 - $row}]]
4730 set ndir [expr {$xp - $x}]
4731 if {$dir != $ndir || $xp < 0} {
4732 lappend coords [xc $y $x] [yc $y]
4734 set dir $ndir
4736 if {!$joinlow} {
4737 if {$xp < 0} {
4738 # join parent line to first child
4739 set ch [lindex $displayorder $row]
4740 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4741 if {$xc < 0} {
4742 puts "oops: drawlineseg: child $ch not on row $row"
4743 } elseif {$xc != $x} {
4744 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4745 set d [expr {int(0.5 * $linespc)}]
4746 set x1 [xc $row $x]
4747 if {$xc < $x} {
4748 set x2 [expr {$x1 - $d}]
4749 } else {
4750 set x2 [expr {$x1 + $d}]
4752 set y2 [yc $row]
4753 set y1 [expr {$y2 + $d}]
4754 lappend coords $x1 $y1 $x2 $y2
4755 } elseif {$xc < $x - 1} {
4756 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4757 } elseif {$xc > $x + 1} {
4758 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4760 set x $xc
4762 lappend coords [xc $row $x] [yc $row]
4763 } else {
4764 set xn [xc $row $xp]
4765 set yn [yc $row]
4766 lappend coords $xn $yn
4768 if {!$joinhigh} {
4769 assigncolor $id
4770 set t [$canv create line $coords -width [linewidth $id] \
4771 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4772 $canv lower $t
4773 bindline $t $id
4774 set lines [linsert $lines $i [list $row $le $t]]
4775 } else {
4776 $canv coords $ith $coords
4777 if {$arrow ne $ah} {
4778 $canv itemconf $ith -arrow $arrow
4780 lset lines $i 0 $row
4782 } else {
4783 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4784 set ndir [expr {$xo - $xp}]
4785 set clow [$canv coords $itl]
4786 if {$dir == $ndir} {
4787 set clow [lrange $clow 2 end]
4789 set coords [concat $coords $clow]
4790 if {!$joinhigh} {
4791 lset lines [expr {$i-1}] 1 $le
4792 } else {
4793 # coalesce two pieces
4794 $canv delete $ith
4795 set b [lindex $lines [expr {$i-1}] 0]
4796 set e [lindex $lines $i 1]
4797 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4799 $canv coords $itl $coords
4800 if {$arrow ne $al} {
4801 $canv itemconf $itl -arrow $arrow
4805 set linesegs($id) $lines
4806 return $le
4809 proc drawparentlinks {id row} {
4810 global rowidlist canv colormap curview parentlist
4811 global idpos linespc
4813 set rowids [lindex $rowidlist $row]
4814 set col [lsearch -exact $rowids $id]
4815 if {$col < 0} return
4816 set olds [lindex $parentlist $row]
4817 set row2 [expr {$row + 1}]
4818 set x [xc $row $col]
4819 set y [yc $row]
4820 set y2 [yc $row2]
4821 set d [expr {int(0.5 * $linespc)}]
4822 set ymid [expr {$y + $d}]
4823 set ids [lindex $rowidlist $row2]
4824 # rmx = right-most X coord used
4825 set rmx 0
4826 foreach p $olds {
4827 set i [lsearch -exact $ids $p]
4828 if {$i < 0} {
4829 puts "oops, parent $p of $id not in list"
4830 continue
4832 set x2 [xc $row2 $i]
4833 if {$x2 > $rmx} {
4834 set rmx $x2
4836 set j [lsearch -exact $rowids $p]
4837 if {$j < 0} {
4838 # drawlineseg will do this one for us
4839 continue
4841 assigncolor $p
4842 # should handle duplicated parents here...
4843 set coords [list $x $y]
4844 if {$i != $col} {
4845 # if attaching to a vertical segment, draw a smaller
4846 # slant for visual distinctness
4847 if {$i == $j} {
4848 if {$i < $col} {
4849 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4850 } else {
4851 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4853 } elseif {$i < $col && $i < $j} {
4854 # segment slants towards us already
4855 lappend coords [xc $row $j] $y
4856 } else {
4857 if {$i < $col - 1} {
4858 lappend coords [expr {$x2 + $linespc}] $y
4859 } elseif {$i > $col + 1} {
4860 lappend coords [expr {$x2 - $linespc}] $y
4862 lappend coords $x2 $y2
4864 } else {
4865 lappend coords $x2 $y2
4867 set t [$canv create line $coords -width [linewidth $p] \
4868 -fill $colormap($p) -tags lines.$p]
4869 $canv lower $t
4870 bindline $t $p
4872 if {$rmx > [lindex $idpos($id) 1]} {
4873 lset idpos($id) 1 $rmx
4874 redrawtags $id
4878 proc drawlines {id} {
4879 global canv
4881 $canv itemconf lines.$id -width [linewidth $id]
4884 proc drawcmittext {id row col} {
4885 global linespc canv canv2 canv3 fgcolor curview
4886 global cmitlisted commitinfo rowidlist parentlist
4887 global rowtextx idpos idtags idheads idotherrefs
4888 global linehtag linentag linedtag selectedline
4889 global canvxmax boldrows boldnamerows fgcolor
4890 global mainheadid nullid nullid2 circleitem circlecolors
4892 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4893 set listed $cmitlisted($curview,$id)
4894 if {$id eq $nullid} {
4895 set ofill red
4896 } elseif {$id eq $nullid2} {
4897 set ofill green
4898 } elseif {$id eq $mainheadid} {
4899 set ofill yellow
4900 } else {
4901 set ofill [lindex $circlecolors $listed]
4903 set x [xc $row $col]
4904 set y [yc $row]
4905 set orad [expr {$linespc / 3}]
4906 if {$listed <= 2} {
4907 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4908 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4909 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4910 } elseif {$listed == 3} {
4911 # triangle pointing left for left-side commits
4912 set t [$canv create polygon \
4913 [expr {$x - $orad}] $y \
4914 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4915 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4916 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4917 } else {
4918 # triangle pointing right for right-side commits
4919 set t [$canv create polygon \
4920 [expr {$x + $orad - 1}] $y \
4921 [expr {$x - $orad}] [expr {$y - $orad}] \
4922 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4923 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4925 set circleitem($row) $t
4926 $canv raise $t
4927 $canv bind $t <1> {selcanvline {} %x %y}
4928 set rmx [llength [lindex $rowidlist $row]]
4929 set olds [lindex $parentlist $row]
4930 if {$olds ne {}} {
4931 set nextids [lindex $rowidlist [expr {$row + 1}]]
4932 foreach p $olds {
4933 set i [lsearch -exact $nextids $p]
4934 if {$i > $rmx} {
4935 set rmx $i
4939 set xt [xc $row $rmx]
4940 set rowtextx($row) $xt
4941 set idpos($id) [list $x $xt $y]
4942 if {[info exists idtags($id)] || [info exists idheads($id)]
4943 || [info exists idotherrefs($id)]} {
4944 set xt [drawtags $id $x $xt $y]
4946 set headline [lindex $commitinfo($id) 0]
4947 set name [lindex $commitinfo($id) 1]
4948 set date [lindex $commitinfo($id) 2]
4949 set date [formatdate $date]
4950 set font mainfont
4951 set nfont mainfont
4952 set isbold [ishighlighted $id]
4953 if {$isbold > 0} {
4954 lappend boldrows $row
4955 set font mainfontbold
4956 if {$isbold > 1} {
4957 lappend boldnamerows $row
4958 set nfont mainfontbold
4961 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4962 -text $headline -font $font -tags text]
4963 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4964 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4965 -text $name -font $nfont -tags text]
4966 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4967 -text $date -font mainfont -tags text]
4968 if {$selectedline == $row} {
4969 make_secsel $row
4971 set xr [expr {$xt + [font measure $font $headline]}]
4972 if {$xr > $canvxmax} {
4973 set canvxmax $xr
4974 setcanvscroll
4978 proc drawcmitrow {row} {
4979 global displayorder rowidlist nrows_drawn
4980 global iddrawn markingmatches
4981 global commitinfo numcommits
4982 global filehighlight fhighlights findpattern nhighlights
4983 global hlview vhighlights
4984 global highlight_related rhighlights
4986 if {$row >= $numcommits} return
4988 set id [lindex $displayorder $row]
4989 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4990 askvhighlight $row $id
4992 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4993 askfilehighlight $row $id
4995 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4996 askfindhighlight $row $id
4998 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4999 askrelhighlight $row $id
5001 if {![info exists iddrawn($id)]} {
5002 set col [lsearch -exact [lindex $rowidlist $row] $id]
5003 if {$col < 0} {
5004 puts "oops, row $row id $id not in list"
5005 return
5007 if {![info exists commitinfo($id)]} {
5008 getcommit $id
5010 assigncolor $id
5011 drawcmittext $id $row $col
5012 set iddrawn($id) 1
5013 incr nrows_drawn
5015 if {$markingmatches} {
5016 markrowmatches $row $id
5020 proc drawcommits {row {endrow {}}} {
5021 global numcommits iddrawn displayorder curview need_redisplay
5022 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5024 if {$row < 0} {
5025 set row 0
5027 if {$endrow eq {}} {
5028 set endrow $row
5030 if {$endrow >= $numcommits} {
5031 set endrow [expr {$numcommits - 1}]
5034 set rl1 [expr {$row - $downarrowlen - 3}]
5035 if {$rl1 < 0} {
5036 set rl1 0
5038 set ro1 [expr {$row - 3}]
5039 if {$ro1 < 0} {
5040 set ro1 0
5042 set r2 [expr {$endrow + $uparrowlen + 3}]
5043 if {$r2 > $numcommits} {
5044 set r2 $numcommits
5046 for {set r $rl1} {$r < $r2} {incr r} {
5047 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5048 if {$rl1 < $r} {
5049 layoutrows $rl1 $r
5051 set rl1 [expr {$r + 1}]
5054 if {$rl1 < $r} {
5055 layoutrows $rl1 $r
5057 optimize_rows $ro1 0 $r2
5058 if {$need_redisplay || $nrows_drawn > 2000} {
5059 clear_display
5060 drawvisible
5063 # make the lines join to already-drawn rows either side
5064 set r [expr {$row - 1}]
5065 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5066 set r $row
5068 set er [expr {$endrow + 1}]
5069 if {$er >= $numcommits ||
5070 ![info exists iddrawn([lindex $displayorder $er])]} {
5071 set er $endrow
5073 for {} {$r <= $er} {incr r} {
5074 set id [lindex $displayorder $r]
5075 set wasdrawn [info exists iddrawn($id)]
5076 drawcmitrow $r
5077 if {$r == $er} break
5078 set nextid [lindex $displayorder [expr {$r + 1}]]
5079 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5080 drawparentlinks $id $r
5082 set rowids [lindex $rowidlist $r]
5083 foreach lid $rowids {
5084 if {$lid eq {}} continue
5085 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5086 if {$lid eq $id} {
5087 # see if this is the first child of any of its parents
5088 foreach p [lindex $parentlist $r] {
5089 if {[lsearch -exact $rowids $p] < 0} {
5090 # make this line extend up to the child
5091 set lineend($p) [drawlineseg $p $r $er 0]
5094 } else {
5095 set lineend($lid) [drawlineseg $lid $r $er 1]
5101 proc undolayout {row} {
5102 global uparrowlen mingaplen downarrowlen
5103 global rowidlist rowisopt rowfinal need_redisplay
5105 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5106 if {$r < 0} {
5107 set r 0
5109 if {[llength $rowidlist] > $r} {
5110 incr r -1
5111 set rowidlist [lrange $rowidlist 0 $r]
5112 set rowfinal [lrange $rowfinal 0 $r]
5113 set rowisopt [lrange $rowisopt 0 $r]
5114 set need_redisplay 1
5115 run drawvisible
5119 proc drawvisible {} {
5120 global canv linespc curview vrowmod selectedline targetrow targetid
5121 global need_redisplay cscroll numcommits
5123 set fs [$canv yview]
5124 set ymax [lindex [$canv cget -scrollregion] 3]
5125 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5126 set f0 [lindex $fs 0]
5127 set f1 [lindex $fs 1]
5128 set y0 [expr {int($f0 * $ymax)}]
5129 set y1 [expr {int($f1 * $ymax)}]
5131 if {[info exists targetid]} {
5132 if {[commitinview $targetid $curview]} {
5133 set r [rowofcommit $targetid]
5134 if {$r != $targetrow} {
5135 # Fix up the scrollregion and change the scrolling position
5136 # now that our target row has moved.
5137 set diff [expr {($r - $targetrow) * $linespc}]
5138 set targetrow $r
5139 setcanvscroll
5140 set ymax [lindex [$canv cget -scrollregion] 3]
5141 incr y0 $diff
5142 incr y1 $diff
5143 set f0 [expr {$y0 / $ymax}]
5144 set f1 [expr {$y1 / $ymax}]
5145 allcanvs yview moveto $f0
5146 $cscroll set $f0 $f1
5147 set need_redisplay 1
5149 } else {
5150 unset targetid
5154 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5155 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5156 if {$endrow >= $vrowmod($curview)} {
5157 update_arcrows $curview
5159 if {$selectedline ne {} &&
5160 $row <= $selectedline && $selectedline <= $endrow} {
5161 set targetrow $selectedline
5162 } elseif {[info exists targetid]} {
5163 set targetrow [expr {int(($row + $endrow) / 2)}]
5165 if {[info exists targetrow]} {
5166 if {$targetrow >= $numcommits} {
5167 set targetrow [expr {$numcommits - 1}]
5169 set targetid [commitonrow $targetrow]
5171 drawcommits $row $endrow
5174 proc clear_display {} {
5175 global iddrawn linesegs need_redisplay nrows_drawn
5176 global vhighlights fhighlights nhighlights rhighlights
5177 global linehtag linentag linedtag boldrows boldnamerows
5179 allcanvs delete all
5180 catch {unset iddrawn}
5181 catch {unset linesegs}
5182 catch {unset linehtag}
5183 catch {unset linentag}
5184 catch {unset linedtag}
5185 set boldrows {}
5186 set boldnamerows {}
5187 catch {unset vhighlights}
5188 catch {unset fhighlights}
5189 catch {unset nhighlights}
5190 catch {unset rhighlights}
5191 set need_redisplay 0
5192 set nrows_drawn 0
5195 proc findcrossings {id} {
5196 global rowidlist parentlist numcommits displayorder
5198 set cross {}
5199 set ccross {}
5200 foreach {s e} [rowranges $id] {
5201 if {$e >= $numcommits} {
5202 set e [expr {$numcommits - 1}]
5204 if {$e <= $s} continue
5205 for {set row $e} {[incr row -1] >= $s} {} {
5206 set x [lsearch -exact [lindex $rowidlist $row] $id]
5207 if {$x < 0} break
5208 set olds [lindex $parentlist $row]
5209 set kid [lindex $displayorder $row]
5210 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5211 if {$kidx < 0} continue
5212 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5213 foreach p $olds {
5214 set px [lsearch -exact $nextrow $p]
5215 if {$px < 0} continue
5216 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5217 if {[lsearch -exact $ccross $p] >= 0} continue
5218 if {$x == $px + ($kidx < $px? -1: 1)} {
5219 lappend ccross $p
5220 } elseif {[lsearch -exact $cross $p] < 0} {
5221 lappend cross $p
5227 return [concat $ccross {{}} $cross]
5230 proc assigncolor {id} {
5231 global colormap colors nextcolor
5232 global parents children children curview
5234 if {[info exists colormap($id)]} return
5235 set ncolors [llength $colors]
5236 if {[info exists children($curview,$id)]} {
5237 set kids $children($curview,$id)
5238 } else {
5239 set kids {}
5241 if {[llength $kids] == 1} {
5242 set child [lindex $kids 0]
5243 if {[info exists colormap($child)]
5244 && [llength $parents($curview,$child)] == 1} {
5245 set colormap($id) $colormap($child)
5246 return
5249 set badcolors {}
5250 set origbad {}
5251 foreach x [findcrossings $id] {
5252 if {$x eq {}} {
5253 # delimiter between corner crossings and other crossings
5254 if {[llength $badcolors] >= $ncolors - 1} break
5255 set origbad $badcolors
5257 if {[info exists colormap($x)]
5258 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5259 lappend badcolors $colormap($x)
5262 if {[llength $badcolors] >= $ncolors} {
5263 set badcolors $origbad
5265 set origbad $badcolors
5266 if {[llength $badcolors] < $ncolors - 1} {
5267 foreach child $kids {
5268 if {[info exists colormap($child)]
5269 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5270 lappend badcolors $colormap($child)
5272 foreach p $parents($curview,$child) {
5273 if {[info exists colormap($p)]
5274 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5275 lappend badcolors $colormap($p)
5279 if {[llength $badcolors] >= $ncolors} {
5280 set badcolors $origbad
5283 for {set i 0} {$i <= $ncolors} {incr i} {
5284 set c [lindex $colors $nextcolor]
5285 if {[incr nextcolor] >= $ncolors} {
5286 set nextcolor 0
5288 if {[lsearch -exact $badcolors $c]} break
5290 set colormap($id) $c
5293 proc bindline {t id} {
5294 global canv
5296 $canv bind $t <Enter> "lineenter %x %y $id"
5297 $canv bind $t <Motion> "linemotion %x %y $id"
5298 $canv bind $t <Leave> "lineleave $id"
5299 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5302 proc drawtags {id x xt y1} {
5303 global idtags idheads idotherrefs mainhead
5304 global linespc lthickness
5305 global canv rowtextx curview fgcolor bgcolor
5307 set marks {}
5308 set ntags 0
5309 set nheads 0
5310 if {[info exists idtags($id)]} {
5311 set marks $idtags($id)
5312 set ntags [llength $marks]
5314 if {[info exists idheads($id)]} {
5315 set marks [concat $marks $idheads($id)]
5316 set nheads [llength $idheads($id)]
5318 if {[info exists idotherrefs($id)]} {
5319 set marks [concat $marks $idotherrefs($id)]
5321 if {$marks eq {}} {
5322 return $xt
5325 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5326 set yt [expr {$y1 - 0.5 * $linespc}]
5327 set yb [expr {$yt + $linespc - 1}]
5328 set xvals {}
5329 set wvals {}
5330 set i -1
5331 foreach tag $marks {
5332 incr i
5333 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5334 set wid [font measure mainfontbold $tag]
5335 } else {
5336 set wid [font measure mainfont $tag]
5338 lappend xvals $xt
5339 lappend wvals $wid
5340 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5342 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5343 -width $lthickness -fill black -tags tag.$id]
5344 $canv lower $t
5345 foreach tag $marks x $xvals wid $wvals {
5346 set xl [expr {$x + $delta}]
5347 set xr [expr {$x + $delta + $wid + $lthickness}]
5348 set font mainfont
5349 if {[incr ntags -1] >= 0} {
5350 # draw a tag
5351 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5352 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5353 -width 1 -outline black -fill yellow -tags tag.$id]
5354 $canv bind $t <1> [list showtag $tag 1]
5355 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5356 } else {
5357 # draw a head or other ref
5358 if {[incr nheads -1] >= 0} {
5359 set col green
5360 if {$tag eq $mainhead} {
5361 set font mainfontbold
5363 } else {
5364 set col "#ddddff"
5366 set xl [expr {$xl - $delta/2}]
5367 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5368 -width 1 -outline black -fill $col -tags tag.$id
5369 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5370 set rwid [font measure mainfont $remoteprefix]
5371 set xi [expr {$x + 1}]
5372 set yti [expr {$yt + 1}]
5373 set xri [expr {$x + $rwid}]
5374 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5375 -width 0 -fill "#ffddaa" -tags tag.$id
5378 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5379 -font $font -tags [list tag.$id text]]
5380 if {$ntags >= 0} {
5381 $canv bind $t <1> [list showtag $tag 1]
5382 } elseif {$nheads >= 0} {
5383 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5386 return $xt
5389 proc xcoord {i level ln} {
5390 global canvx0 xspc1 xspc2
5392 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5393 if {$i > 0 && $i == $level} {
5394 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5395 } elseif {$i > $level} {
5396 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5398 return $x
5401 proc show_status {msg} {
5402 global canv fgcolor
5404 clear_display
5405 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5406 -tags text -fill $fgcolor
5409 # Don't change the text pane cursor if it is currently the hand cursor,
5410 # showing that we are over a sha1 ID link.
5411 proc settextcursor {c} {
5412 global ctext curtextcursor
5414 if {[$ctext cget -cursor] == $curtextcursor} {
5415 $ctext config -cursor $c
5417 set curtextcursor $c
5420 proc nowbusy {what {name {}}} {
5421 global isbusy busyname statusw
5423 if {[array names isbusy] eq {}} {
5424 . config -cursor watch
5425 settextcursor watch
5427 set isbusy($what) 1
5428 set busyname($what) $name
5429 if {$name ne {}} {
5430 $statusw conf -text $name
5434 proc notbusy {what} {
5435 global isbusy maincursor textcursor busyname statusw
5437 catch {
5438 unset isbusy($what)
5439 if {$busyname($what) ne {} &&
5440 [$statusw cget -text] eq $busyname($what)} {
5441 $statusw conf -text {}
5444 if {[array names isbusy] eq {}} {
5445 . config -cursor $maincursor
5446 settextcursor $textcursor
5450 proc findmatches {f} {
5451 global findtype findstring
5452 if {$findtype == [mc "Regexp"]} {
5453 set matches [regexp -indices -all -inline $findstring $f]
5454 } else {
5455 set fs $findstring
5456 if {$findtype == [mc "IgnCase"]} {
5457 set f [string tolower $f]
5458 set fs [string tolower $fs]
5460 set matches {}
5461 set i 0
5462 set l [string length $fs]
5463 while {[set j [string first $fs $f $i]] >= 0} {
5464 lappend matches [list $j [expr {$j+$l-1}]]
5465 set i [expr {$j + $l}]
5468 return $matches
5471 proc dofind {{dirn 1} {wrap 1}} {
5472 global findstring findstartline findcurline selectedline numcommits
5473 global gdttype filehighlight fh_serial find_dirn findallowwrap
5475 if {[info exists find_dirn]} {
5476 if {$find_dirn == $dirn} return
5477 stopfinding
5479 focus .
5480 if {$findstring eq {} || $numcommits == 0} return
5481 if {$selectedline eq {}} {
5482 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5483 } else {
5484 set findstartline $selectedline
5486 set findcurline $findstartline
5487 nowbusy finding [mc "Searching"]
5488 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5489 after cancel do_file_hl $fh_serial
5490 do_file_hl $fh_serial
5492 set find_dirn $dirn
5493 set findallowwrap $wrap
5494 run findmore
5497 proc stopfinding {} {
5498 global find_dirn findcurline fprogcoord
5500 if {[info exists find_dirn]} {
5501 unset find_dirn
5502 unset findcurline
5503 notbusy finding
5504 set fprogcoord 0
5505 adjustprogress
5509 proc findmore {} {
5510 global commitdata commitinfo numcommits findpattern findloc
5511 global findstartline findcurline findallowwrap
5512 global find_dirn gdttype fhighlights fprogcoord
5513 global curview varcorder vrownum varccommits vrowmod
5515 if {![info exists find_dirn]} {
5516 return 0
5518 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5519 set l $findcurline
5520 set moretodo 0
5521 if {$find_dirn > 0} {
5522 incr l
5523 if {$l >= $numcommits} {
5524 set l 0
5526 if {$l <= $findstartline} {
5527 set lim [expr {$findstartline + 1}]
5528 } else {
5529 set lim $numcommits
5530 set moretodo $findallowwrap
5532 } else {
5533 if {$l == 0} {
5534 set l $numcommits
5536 incr l -1
5537 if {$l >= $findstartline} {
5538 set lim [expr {$findstartline - 1}]
5539 } else {
5540 set lim -1
5541 set moretodo $findallowwrap
5544 set n [expr {($lim - $l) * $find_dirn}]
5545 if {$n > 500} {
5546 set n 500
5547 set moretodo 1
5549 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5550 update_arcrows $curview
5552 set found 0
5553 set domore 1
5554 set ai [bsearch $vrownum($curview) $l]
5555 set a [lindex $varcorder($curview) $ai]
5556 set arow [lindex $vrownum($curview) $ai]
5557 set ids [lindex $varccommits($curview,$a)]
5558 set arowend [expr {$arow + [llength $ids]}]
5559 if {$gdttype eq [mc "containing:"]} {
5560 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5561 if {$l < $arow || $l >= $arowend} {
5562 incr ai $find_dirn
5563 set a [lindex $varcorder($curview) $ai]
5564 set arow [lindex $vrownum($curview) $ai]
5565 set ids [lindex $varccommits($curview,$a)]
5566 set arowend [expr {$arow + [llength $ids]}]
5568 set id [lindex $ids [expr {$l - $arow}]]
5569 # shouldn't happen unless git log doesn't give all the commits...
5570 if {![info exists commitdata($id)] ||
5571 ![doesmatch $commitdata($id)]} {
5572 continue
5574 if {![info exists commitinfo($id)]} {
5575 getcommit $id
5577 set info $commitinfo($id)
5578 foreach f $info ty $fldtypes {
5579 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5580 [doesmatch $f]} {
5581 set found 1
5582 break
5585 if {$found} break
5587 } else {
5588 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5589 if {$l < $arow || $l >= $arowend} {
5590 incr ai $find_dirn
5591 set a [lindex $varcorder($curview) $ai]
5592 set arow [lindex $vrownum($curview) $ai]
5593 set ids [lindex $varccommits($curview,$a)]
5594 set arowend [expr {$arow + [llength $ids]}]
5596 set id [lindex $ids [expr {$l - $arow}]]
5597 if {![info exists fhighlights($id)]} {
5598 # this sets fhighlights($id) to -1
5599 askfilehighlight $l $id
5601 if {$fhighlights($id) > 0} {
5602 set found $domore
5603 break
5605 if {$fhighlights($id) < 0} {
5606 if {$domore} {
5607 set domore 0
5608 set findcurline [expr {$l - $find_dirn}]
5613 if {$found || ($domore && !$moretodo)} {
5614 unset findcurline
5615 unset find_dirn
5616 notbusy finding
5617 set fprogcoord 0
5618 adjustprogress
5619 if {$found} {
5620 findselectline $l
5621 } else {
5622 bell
5624 return 0
5626 if {!$domore} {
5627 flushhighlights
5628 } else {
5629 set findcurline [expr {$l - $find_dirn}]
5631 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5632 if {$n < 0} {
5633 incr n $numcommits
5635 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5636 adjustprogress
5637 return $domore
5640 proc findselectline {l} {
5641 global findloc commentend ctext findcurline markingmatches gdttype
5643 set markingmatches 1
5644 set findcurline $l
5645 selectline $l 1
5646 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5647 # highlight the matches in the comments
5648 set f [$ctext get 1.0 $commentend]
5649 set matches [findmatches $f]
5650 foreach match $matches {
5651 set start [lindex $match 0]
5652 set end [expr {[lindex $match 1] + 1}]
5653 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5656 drawvisible
5659 # mark the bits of a headline or author that match a find string
5660 proc markmatches {canv l str tag matches font row} {
5661 global selectedline
5663 set bbox [$canv bbox $tag]
5664 set x0 [lindex $bbox 0]
5665 set y0 [lindex $bbox 1]
5666 set y1 [lindex $bbox 3]
5667 foreach match $matches {
5668 set start [lindex $match 0]
5669 set end [lindex $match 1]
5670 if {$start > $end} continue
5671 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5672 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5673 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5674 [expr {$x0+$xlen+2}] $y1 \
5675 -outline {} -tags [list match$l matches] -fill yellow]
5676 $canv lower $t
5677 if {$row == $selectedline} {
5678 $canv raise $t secsel
5683 proc unmarkmatches {} {
5684 global markingmatches
5686 allcanvs delete matches
5687 set markingmatches 0
5688 stopfinding
5691 proc selcanvline {w x y} {
5692 global canv canvy0 ctext linespc
5693 global rowtextx
5694 set ymax [lindex [$canv cget -scrollregion] 3]
5695 if {$ymax == {}} return
5696 set yfrac [lindex [$canv yview] 0]
5697 set y [expr {$y + $yfrac * $ymax}]
5698 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5699 if {$l < 0} {
5700 set l 0
5702 if {$w eq $canv} {
5703 set xmax [lindex [$canv cget -scrollregion] 2]
5704 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5705 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5707 unmarkmatches
5708 selectline $l 1
5711 proc commit_descriptor {p} {
5712 global commitinfo
5713 if {![info exists commitinfo($p)]} {
5714 getcommit $p
5716 set l "..."
5717 if {[llength $commitinfo($p)] > 1} {
5718 set l [lindex $commitinfo($p) 0]
5720 return "$p ($l)\n"
5723 # append some text to the ctext widget, and make any SHA1 ID
5724 # that we know about be a clickable link.
5725 proc appendwithlinks {text tags} {
5726 global ctext linknum curview pendinglinks
5728 set start [$ctext index "end - 1c"]
5729 $ctext insert end $text $tags
5730 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5731 foreach l $links {
5732 set s [lindex $l 0]
5733 set e [lindex $l 1]
5734 set linkid [string range $text $s $e]
5735 incr e
5736 $ctext tag delete link$linknum
5737 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5738 setlink $linkid link$linknum
5739 incr linknum
5743 proc setlink {id lk} {
5744 global curview ctext pendinglinks commitinterest
5746 if {[commitinview $id $curview]} {
5747 $ctext tag conf $lk -foreground blue -underline 1
5748 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5749 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5750 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5751 } else {
5752 lappend pendinglinks($id) $lk
5753 lappend commitinterest($id) {makelink %I}
5757 proc makelink {id} {
5758 global pendinglinks
5760 if {![info exists pendinglinks($id)]} return
5761 foreach lk $pendinglinks($id) {
5762 setlink $id $lk
5764 unset pendinglinks($id)
5767 proc linkcursor {w inc} {
5768 global linkentercount curtextcursor
5770 if {[incr linkentercount $inc] > 0} {
5771 $w configure -cursor hand2
5772 } else {
5773 $w configure -cursor $curtextcursor
5774 if {$linkentercount < 0} {
5775 set linkentercount 0
5780 proc viewnextline {dir} {
5781 global canv linespc
5783 $canv delete hover
5784 set ymax [lindex [$canv cget -scrollregion] 3]
5785 set wnow [$canv yview]
5786 set wtop [expr {[lindex $wnow 0] * $ymax}]
5787 set newtop [expr {$wtop + $dir * $linespc}]
5788 if {$newtop < 0} {
5789 set newtop 0
5790 } elseif {$newtop > $ymax} {
5791 set newtop $ymax
5793 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5796 # add a list of tag or branch names at position pos
5797 # returns the number of names inserted
5798 proc appendrefs {pos ids var} {
5799 global ctext linknum curview $var maxrefs
5801 if {[catch {$ctext index $pos}]} {
5802 return 0
5804 $ctext conf -state normal
5805 $ctext delete $pos "$pos lineend"
5806 set tags {}
5807 foreach id $ids {
5808 foreach tag [set $var\($id\)] {
5809 lappend tags [list $tag $id]
5812 if {[llength $tags] > $maxrefs} {
5813 $ctext insert $pos "many ([llength $tags])"
5814 } else {
5815 set tags [lsort -index 0 -decreasing $tags]
5816 set sep {}
5817 foreach ti $tags {
5818 set id [lindex $ti 1]
5819 set lk link$linknum
5820 incr linknum
5821 $ctext tag delete $lk
5822 $ctext insert $pos $sep
5823 $ctext insert $pos [lindex $ti 0] $lk
5824 setlink $id $lk
5825 set sep ", "
5828 $ctext conf -state disabled
5829 return [llength $tags]
5832 # called when we have finished computing the nearby tags
5833 proc dispneartags {delay} {
5834 global selectedline currentid showneartags tagphase
5836 if {$selectedline eq {} || !$showneartags} return
5837 after cancel dispnexttag
5838 if {$delay} {
5839 after 200 dispnexttag
5840 set tagphase -1
5841 } else {
5842 after idle dispnexttag
5843 set tagphase 0
5847 proc dispnexttag {} {
5848 global selectedline currentid showneartags tagphase ctext
5850 if {$selectedline eq {} || !$showneartags} return
5851 switch -- $tagphase {
5853 set dtags [desctags $currentid]
5854 if {$dtags ne {}} {
5855 appendrefs precedes $dtags idtags
5859 set atags [anctags $currentid]
5860 if {$atags ne {}} {
5861 appendrefs follows $atags idtags
5865 set dheads [descheads $currentid]
5866 if {$dheads ne {}} {
5867 if {[appendrefs branch $dheads idheads] > 1
5868 && [$ctext get "branch -3c"] eq "h"} {
5869 # turn "Branch" into "Branches"
5870 $ctext conf -state normal
5871 $ctext insert "branch -2c" "es"
5872 $ctext conf -state disabled
5877 if {[incr tagphase] <= 2} {
5878 after idle dispnexttag
5882 proc make_secsel {l} {
5883 global linehtag linentag linedtag canv canv2 canv3
5885 if {![info exists linehtag($l)]} return
5886 $canv delete secsel
5887 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5888 -tags secsel -fill [$canv cget -selectbackground]]
5889 $canv lower $t
5890 $canv2 delete secsel
5891 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5892 -tags secsel -fill [$canv2 cget -selectbackground]]
5893 $canv2 lower $t
5894 $canv3 delete secsel
5895 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5896 -tags secsel -fill [$canv3 cget -selectbackground]]
5897 $canv3 lower $t
5900 proc selectline {l isnew} {
5901 global canv ctext commitinfo selectedline
5902 global canvy0 linespc parents children curview
5903 global currentid sha1entry
5904 global commentend idtags linknum
5905 global mergemax numcommits pending_select
5906 global cmitmode showneartags allcommits
5907 global targetrow targetid lastscrollrows
5908 global autoselect
5910 catch {unset pending_select}
5911 $canv delete hover
5912 normalline
5913 unsel_reflist
5914 stopfinding
5915 if {$l < 0 || $l >= $numcommits} return
5916 set id [commitonrow $l]
5917 set targetid $id
5918 set targetrow $l
5919 set selectedline $l
5920 set currentid $id
5921 if {$lastscrollrows < $numcommits} {
5922 setcanvscroll
5925 set y [expr {$canvy0 + $l * $linespc}]
5926 set ymax [lindex [$canv cget -scrollregion] 3]
5927 set ytop [expr {$y - $linespc - 1}]
5928 set ybot [expr {$y + $linespc + 1}]
5929 set wnow [$canv yview]
5930 set wtop [expr {[lindex $wnow 0] * $ymax}]
5931 set wbot [expr {[lindex $wnow 1] * $ymax}]
5932 set wh [expr {$wbot - $wtop}]
5933 set newtop $wtop
5934 if {$ytop < $wtop} {
5935 if {$ybot < $wtop} {
5936 set newtop [expr {$y - $wh / 2.0}]
5937 } else {
5938 set newtop $ytop
5939 if {$newtop > $wtop - $linespc} {
5940 set newtop [expr {$wtop - $linespc}]
5943 } elseif {$ybot > $wbot} {
5944 if {$ytop > $wbot} {
5945 set newtop [expr {$y - $wh / 2.0}]
5946 } else {
5947 set newtop [expr {$ybot - $wh}]
5948 if {$newtop < $wtop + $linespc} {
5949 set newtop [expr {$wtop + $linespc}]
5953 if {$newtop != $wtop} {
5954 if {$newtop < 0} {
5955 set newtop 0
5957 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5958 drawvisible
5961 make_secsel $l
5963 if {$isnew} {
5964 addtohistory [list selbyid $id]
5967 $sha1entry delete 0 end
5968 $sha1entry insert 0 $id
5969 if {$autoselect} {
5970 $sha1entry selection from 0
5971 $sha1entry selection to end
5973 rhighlight_sel $id
5975 $ctext conf -state normal
5976 clear_ctext
5977 set linknum 0
5978 if {![info exists commitinfo($id)]} {
5979 getcommit $id
5981 set info $commitinfo($id)
5982 set date [formatdate [lindex $info 2]]
5983 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5984 set date [formatdate [lindex $info 4]]
5985 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5986 if {[info exists idtags($id)]} {
5987 $ctext insert end [mc "Tags:"]
5988 foreach tag $idtags($id) {
5989 $ctext insert end " $tag"
5991 $ctext insert end "\n"
5994 set headers {}
5995 set olds $parents($curview,$id)
5996 if {[llength $olds] > 1} {
5997 set np 0
5998 foreach p $olds {
5999 if {$np >= $mergemax} {
6000 set tag mmax
6001 } else {
6002 set tag m$np
6004 $ctext insert end "[mc "Parent"]: " $tag
6005 appendwithlinks [commit_descriptor $p] {}
6006 incr np
6008 } else {
6009 foreach p $olds {
6010 append headers "[mc "Parent"]: [commit_descriptor $p]"
6014 foreach c $children($curview,$id) {
6015 append headers "[mc "Child"]: [commit_descriptor $c]"
6018 # make anything that looks like a SHA1 ID be a clickable link
6019 appendwithlinks $headers {}
6020 if {$showneartags} {
6021 if {![info exists allcommits]} {
6022 getallcommits
6024 $ctext insert end "[mc "Branch"]: "
6025 $ctext mark set branch "end -1c"
6026 $ctext mark gravity branch left
6027 $ctext insert end "\n[mc "Follows"]: "
6028 $ctext mark set follows "end -1c"
6029 $ctext mark gravity follows left
6030 $ctext insert end "\n[mc "Precedes"]: "
6031 $ctext mark set precedes "end -1c"
6032 $ctext mark gravity precedes left
6033 $ctext insert end "\n"
6034 dispneartags 1
6036 $ctext insert end "\n"
6037 set comment [lindex $info 5]
6038 if {[string first "\r" $comment] >= 0} {
6039 set comment [string map {"\r" "\n "} $comment]
6041 appendwithlinks $comment {comment}
6043 $ctext tag remove found 1.0 end
6044 $ctext conf -state disabled
6045 set commentend [$ctext index "end - 1c"]
6047 init_flist [mc "Comments"]
6048 if {$cmitmode eq "tree"} {
6049 gettree $id
6050 } elseif {[llength $olds] <= 1} {
6051 startdiff $id
6052 } else {
6053 mergediff $id
6057 proc selfirstline {} {
6058 unmarkmatches
6059 selectline 0 1
6062 proc sellastline {} {
6063 global numcommits
6064 unmarkmatches
6065 set l [expr {$numcommits - 1}]
6066 selectline $l 1
6069 proc selnextline {dir} {
6070 global selectedline
6071 focus .
6072 if {$selectedline eq {}} return
6073 set l [expr {$selectedline + $dir}]
6074 unmarkmatches
6075 selectline $l 1
6078 proc selnextpage {dir} {
6079 global canv linespc selectedline numcommits
6081 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6082 if {$lpp < 1} {
6083 set lpp 1
6085 allcanvs yview scroll [expr {$dir * $lpp}] units
6086 drawvisible
6087 if {$selectedline eq {}} return
6088 set l [expr {$selectedline + $dir * $lpp}]
6089 if {$l < 0} {
6090 set l 0
6091 } elseif {$l >= $numcommits} {
6092 set l [expr $numcommits - 1]
6094 unmarkmatches
6095 selectline $l 1
6098 proc unselectline {} {
6099 global selectedline currentid
6101 set selectedline {}
6102 catch {unset currentid}
6103 allcanvs delete secsel
6104 rhighlight_none
6107 proc reselectline {} {
6108 global selectedline
6110 if {$selectedline ne {}} {
6111 selectline $selectedline 0
6115 proc addtohistory {cmd} {
6116 global history historyindex curview
6118 set elt [list $curview $cmd]
6119 if {$historyindex > 0
6120 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6121 return
6124 if {$historyindex < [llength $history]} {
6125 set history [lreplace $history $historyindex end $elt]
6126 } else {
6127 lappend history $elt
6129 incr historyindex
6130 if {$historyindex > 1} {
6131 .tf.bar.leftbut conf -state normal
6132 } else {
6133 .tf.bar.leftbut conf -state disabled
6135 .tf.bar.rightbut conf -state disabled
6138 proc godo {elt} {
6139 global curview
6141 set view [lindex $elt 0]
6142 set cmd [lindex $elt 1]
6143 if {$curview != $view} {
6144 showview $view
6146 eval $cmd
6149 proc goback {} {
6150 global history historyindex
6151 focus .
6153 if {$historyindex > 1} {
6154 incr historyindex -1
6155 godo [lindex $history [expr {$historyindex - 1}]]
6156 .tf.bar.rightbut conf -state normal
6158 if {$historyindex <= 1} {
6159 .tf.bar.leftbut conf -state disabled
6163 proc goforw {} {
6164 global history historyindex
6165 focus .
6167 if {$historyindex < [llength $history]} {
6168 set cmd [lindex $history $historyindex]
6169 incr historyindex
6170 godo $cmd
6171 .tf.bar.leftbut conf -state normal
6173 if {$historyindex >= [llength $history]} {
6174 .tf.bar.rightbut conf -state disabled
6178 proc gettree {id} {
6179 global treefilelist treeidlist diffids diffmergeid treepending
6180 global nullid nullid2
6182 set diffids $id
6183 catch {unset diffmergeid}
6184 if {![info exists treefilelist($id)]} {
6185 if {![info exists treepending]} {
6186 if {$id eq $nullid} {
6187 set cmd [list | git ls-files]
6188 } elseif {$id eq $nullid2} {
6189 set cmd [list | git ls-files --stage -t]
6190 } else {
6191 set cmd [list | git ls-tree -r $id]
6193 if {[catch {set gtf [open $cmd r]}]} {
6194 return
6196 set treepending $id
6197 set treefilelist($id) {}
6198 set treeidlist($id) {}
6199 fconfigure $gtf -blocking 0
6200 filerun $gtf [list gettreeline $gtf $id]
6202 } else {
6203 setfilelist $id
6207 proc gettreeline {gtf id} {
6208 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6210 set nl 0
6211 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6212 if {$diffids eq $nullid} {
6213 set fname $line
6214 } else {
6215 set i [string first "\t" $line]
6216 if {$i < 0} continue
6217 set fname [string range $line [expr {$i+1}] end]
6218 set line [string range $line 0 [expr {$i-1}]]
6219 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6220 set sha1 [lindex $line 2]
6221 if {[string index $fname 0] eq "\""} {
6222 set fname [lindex $fname 0]
6224 lappend treeidlist($id) $sha1
6226 lappend treefilelist($id) $fname
6228 if {![eof $gtf]} {
6229 return [expr {$nl >= 1000? 2: 1}]
6231 close $gtf
6232 unset treepending
6233 if {$cmitmode ne "tree"} {
6234 if {![info exists diffmergeid]} {
6235 gettreediffs $diffids
6237 } elseif {$id ne $diffids} {
6238 gettree $diffids
6239 } else {
6240 setfilelist $id
6242 return 0
6245 proc showfile {f} {
6246 global treefilelist treeidlist diffids nullid nullid2
6247 global ctext commentend
6249 set i [lsearch -exact $treefilelist($diffids) $f]
6250 if {$i < 0} {
6251 puts "oops, $f not in list for id $diffids"
6252 return
6254 if {$diffids eq $nullid} {
6255 if {[catch {set bf [open $f r]} err]} {
6256 puts "oops, can't read $f: $err"
6257 return
6259 } else {
6260 set blob [lindex $treeidlist($diffids) $i]
6261 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6262 puts "oops, error reading blob $blob: $err"
6263 return
6266 fconfigure $bf -blocking 0
6267 filerun $bf [list getblobline $bf $diffids]
6268 $ctext config -state normal
6269 clear_ctext $commentend
6270 $ctext insert end "\n"
6271 $ctext insert end "$f\n" filesep
6272 $ctext config -state disabled
6273 $ctext yview $commentend
6274 settabs 0
6277 proc getblobline {bf id} {
6278 global diffids cmitmode ctext
6280 if {$id ne $diffids || $cmitmode ne "tree"} {
6281 catch {close $bf}
6282 return 0
6284 $ctext config -state normal
6285 set nl 0
6286 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6287 $ctext insert end "$line\n"
6289 if {[eof $bf]} {
6290 # delete last newline
6291 $ctext delete "end - 2c" "end - 1c"
6292 close $bf
6293 return 0
6295 $ctext config -state disabled
6296 return [expr {$nl >= 1000? 2: 1}]
6299 proc mergediff {id} {
6300 global diffmergeid mdifffd
6301 global diffids
6302 global parents
6303 global diffcontext
6304 global limitdiffs vfilelimit curview
6306 set diffmergeid $id
6307 set diffids $id
6308 # this doesn't seem to actually affect anything...
6309 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6310 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6311 set cmd [concat $cmd -- $vfilelimit($curview)]
6313 if {[catch {set mdf [open $cmd r]} err]} {
6314 error_popup "[mc "Error getting merge diffs:"] $err"
6315 return
6317 fconfigure $mdf -blocking 0
6318 set mdifffd($id) $mdf
6319 set np [llength $parents($curview,$id)]
6320 settabs $np
6321 filerun $mdf [list getmergediffline $mdf $id $np]
6324 proc getmergediffline {mdf id np} {
6325 global diffmergeid ctext cflist mergemax
6326 global difffilestart mdifffd
6328 $ctext conf -state normal
6329 set nr 0
6330 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6331 if {![info exists diffmergeid] || $id != $diffmergeid
6332 || $mdf != $mdifffd($id)} {
6333 close $mdf
6334 return 0
6336 if {[regexp {^diff --cc (.*)} $line match fname]} {
6337 # start of a new file
6338 $ctext insert end "\n"
6339 set here [$ctext index "end - 1c"]
6340 lappend difffilestart $here
6341 add_flist [list $fname]
6342 set l [expr {(78 - [string length $fname]) / 2}]
6343 set pad [string range "----------------------------------------" 1 $l]
6344 $ctext insert end "$pad $fname $pad\n" filesep
6345 } elseif {[regexp {^@@} $line]} {
6346 $ctext insert end "$line\n" hunksep
6347 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6348 # do nothing
6349 } else {
6350 # parse the prefix - one ' ', '-' or '+' for each parent
6351 set spaces {}
6352 set minuses {}
6353 set pluses {}
6354 set isbad 0
6355 for {set j 0} {$j < $np} {incr j} {
6356 set c [string range $line $j $j]
6357 if {$c == " "} {
6358 lappend spaces $j
6359 } elseif {$c == "-"} {
6360 lappend minuses $j
6361 } elseif {$c == "+"} {
6362 lappend pluses $j
6363 } else {
6364 set isbad 1
6365 break
6368 set tags {}
6369 set num {}
6370 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6371 # line doesn't appear in result, parents in $minuses have the line
6372 set num [lindex $minuses 0]
6373 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6374 # line appears in result, parents in $pluses don't have the line
6375 lappend tags mresult
6376 set num [lindex $spaces 0]
6378 if {$num ne {}} {
6379 if {$num >= $mergemax} {
6380 set num "max"
6382 lappend tags m$num
6384 $ctext insert end "$line\n" $tags
6387 $ctext conf -state disabled
6388 if {[eof $mdf]} {
6389 close $mdf
6390 return 0
6392 return [expr {$nr >= 1000? 2: 1}]
6395 proc startdiff {ids} {
6396 global treediffs diffids treepending diffmergeid nullid nullid2
6398 settabs 1
6399 set diffids $ids
6400 catch {unset diffmergeid}
6401 if {![info exists treediffs($ids)] ||
6402 [lsearch -exact $ids $nullid] >= 0 ||
6403 [lsearch -exact $ids $nullid2] >= 0} {
6404 if {![info exists treepending]} {
6405 gettreediffs $ids
6407 } else {
6408 addtocflist $ids
6412 proc path_filter {filter name} {
6413 foreach p $filter {
6414 set l [string length $p]
6415 if {[string index $p end] eq "/"} {
6416 if {[string compare -length $l $p $name] == 0} {
6417 return 1
6419 } else {
6420 if {[string compare -length $l $p $name] == 0 &&
6421 ([string length $name] == $l ||
6422 [string index $name $l] eq "/")} {
6423 return 1
6427 return 0
6430 proc addtocflist {ids} {
6431 global treediffs
6433 add_flist $treediffs($ids)
6434 getblobdiffs $ids
6437 proc diffcmd {ids flags} {
6438 global nullid nullid2
6440 set i [lsearch -exact $ids $nullid]
6441 set j [lsearch -exact $ids $nullid2]
6442 if {$i >= 0} {
6443 if {[llength $ids] > 1 && $j < 0} {
6444 # comparing working directory with some specific revision
6445 set cmd [concat | git diff-index $flags]
6446 if {$i == 0} {
6447 lappend cmd -R [lindex $ids 1]
6448 } else {
6449 lappend cmd [lindex $ids 0]
6451 } else {
6452 # comparing working directory with index
6453 set cmd [concat | git diff-files $flags]
6454 if {$j == 1} {
6455 lappend cmd -R
6458 } elseif {$j >= 0} {
6459 set cmd [concat | git diff-index --cached $flags]
6460 if {[llength $ids] > 1} {
6461 # comparing index with specific revision
6462 if {$i == 0} {
6463 lappend cmd -R [lindex $ids 1]
6464 } else {
6465 lappend cmd [lindex $ids 0]
6467 } else {
6468 # comparing index with HEAD
6469 lappend cmd HEAD
6471 } else {
6472 set cmd [concat | git diff-tree -r $flags $ids]
6474 return $cmd
6477 proc gettreediffs {ids} {
6478 global treediff treepending
6480 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6482 set treepending $ids
6483 set treediff {}
6484 fconfigure $gdtf -blocking 0
6485 filerun $gdtf [list gettreediffline $gdtf $ids]
6488 proc gettreediffline {gdtf ids} {
6489 global treediff treediffs treepending diffids diffmergeid
6490 global cmitmode vfilelimit curview limitdiffs
6492 set nr 0
6493 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6494 set i [string first "\t" $line]
6495 if {$i >= 0} {
6496 set file [string range $line [expr {$i+1}] end]
6497 if {[string index $file 0] eq "\""} {
6498 set file [lindex $file 0]
6500 lappend treediff $file
6503 if {![eof $gdtf]} {
6504 return [expr {$nr >= 1000? 2: 1}]
6506 close $gdtf
6507 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6508 set flist {}
6509 foreach f $treediff {
6510 if {[path_filter $vfilelimit($curview) $f]} {
6511 lappend flist $f
6514 set treediffs($ids) $flist
6515 } else {
6516 set treediffs($ids) $treediff
6518 unset treepending
6519 if {$cmitmode eq "tree"} {
6520 gettree $diffids
6521 } elseif {$ids != $diffids} {
6522 if {![info exists diffmergeid]} {
6523 gettreediffs $diffids
6525 } else {
6526 addtocflist $ids
6528 return 0
6531 # empty string or positive integer
6532 proc diffcontextvalidate {v} {
6533 return [regexp {^(|[1-9][0-9]*)$} $v]
6536 proc diffcontextchange {n1 n2 op} {
6537 global diffcontextstring diffcontext
6539 if {[string is integer -strict $diffcontextstring]} {
6540 if {$diffcontextstring > 0} {
6541 set diffcontext $diffcontextstring
6542 reselectline
6547 proc changeignorespace {} {
6548 reselectline
6551 proc getblobdiffs {ids} {
6552 global blobdifffd diffids env
6553 global diffinhdr treediffs
6554 global diffcontext
6555 global ignorespace
6556 global limitdiffs vfilelimit curview
6558 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6559 if {$ignorespace} {
6560 append cmd " -w"
6562 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6563 set cmd [concat $cmd -- $vfilelimit($curview)]
6565 if {[catch {set bdf [open $cmd r]} err]} {
6566 puts "error getting diffs: $err"
6567 return
6569 set diffinhdr 0
6570 fconfigure $bdf -blocking 0
6571 set blobdifffd($ids) $bdf
6572 filerun $bdf [list getblobdiffline $bdf $diffids]
6575 proc setinlist {var i val} {
6576 global $var
6578 while {[llength [set $var]] < $i} {
6579 lappend $var {}
6581 if {[llength [set $var]] == $i} {
6582 lappend $var $val
6583 } else {
6584 lset $var $i $val
6588 proc makediffhdr {fname ids} {
6589 global ctext curdiffstart treediffs
6591 set i [lsearch -exact $treediffs($ids) $fname]
6592 if {$i >= 0} {
6593 setinlist difffilestart $i $curdiffstart
6595 set l [expr {(78 - [string length $fname]) / 2}]
6596 set pad [string range "----------------------------------------" 1 $l]
6597 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6600 proc getblobdiffline {bdf ids} {
6601 global diffids blobdifffd ctext curdiffstart
6602 global diffnexthead diffnextnote difffilestart
6603 global diffinhdr treediffs
6605 set nr 0
6606 $ctext conf -state normal
6607 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6608 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6609 close $bdf
6610 return 0
6612 if {![string compare -length 11 "diff --git " $line]} {
6613 # trim off "diff --git "
6614 set line [string range $line 11 end]
6615 set diffinhdr 1
6616 # start of a new file
6617 $ctext insert end "\n"
6618 set curdiffstart [$ctext index "end - 1c"]
6619 $ctext insert end "\n" filesep
6620 # If the name hasn't changed the length will be odd,
6621 # the middle char will be a space, and the two bits either
6622 # side will be a/name and b/name, or "a/name" and "b/name".
6623 # If the name has changed we'll get "rename from" and
6624 # "rename to" or "copy from" and "copy to" lines following this,
6625 # and we'll use them to get the filenames.
6626 # This complexity is necessary because spaces in the filename(s)
6627 # don't get escaped.
6628 set l [string length $line]
6629 set i [expr {$l / 2}]
6630 if {!(($l & 1) && [string index $line $i] eq " " &&
6631 [string range $line 2 [expr {$i - 1}]] eq \
6632 [string range $line [expr {$i + 3}] end])} {
6633 continue
6635 # unescape if quoted and chop off the a/ from the front
6636 if {[string index $line 0] eq "\""} {
6637 set fname [string range [lindex $line 0] 2 end]
6638 } else {
6639 set fname [string range $line 2 [expr {$i - 1}]]
6641 makediffhdr $fname $ids
6643 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6644 $line match f1l f1c f2l f2c rest]} {
6645 $ctext insert end "$line\n" hunksep
6646 set diffinhdr 0
6648 } elseif {$diffinhdr} {
6649 if {![string compare -length 12 "rename from " $line]} {
6650 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6651 if {[string index $fname 0] eq "\""} {
6652 set fname [lindex $fname 0]
6654 set i [lsearch -exact $treediffs($ids) $fname]
6655 if {$i >= 0} {
6656 setinlist difffilestart $i $curdiffstart
6658 } elseif {![string compare -length 10 $line "rename to "] ||
6659 ![string compare -length 8 $line "copy to "]} {
6660 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6661 if {[string index $fname 0] eq "\""} {
6662 set fname [lindex $fname 0]
6664 makediffhdr $fname $ids
6665 } elseif {[string compare -length 3 $line "---"] == 0} {
6666 # do nothing
6667 continue
6668 } elseif {[string compare -length 3 $line "+++"] == 0} {
6669 set diffinhdr 0
6670 continue
6672 $ctext insert end "$line\n" filesep
6674 } else {
6675 set x [string range $line 0 0]
6676 if {$x == "-" || $x == "+"} {
6677 set tag [expr {$x == "+"}]
6678 $ctext insert end "$line\n" d$tag
6679 } elseif {$x == " "} {
6680 $ctext insert end "$line\n"
6681 } else {
6682 # "\ No newline at end of file",
6683 # or something else we don't recognize
6684 $ctext insert end "$line\n" hunksep
6688 $ctext conf -state disabled
6689 if {[eof $bdf]} {
6690 close $bdf
6691 return 0
6693 return [expr {$nr >= 1000? 2: 1}]
6696 proc changediffdisp {} {
6697 global ctext diffelide
6699 $ctext tag conf d0 -elide [lindex $diffelide 0]
6700 $ctext tag conf d1 -elide [lindex $diffelide 1]
6703 proc highlightfile {loc cline} {
6704 global ctext cflist cflist_top
6706 $ctext yview $loc
6707 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6708 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6709 $cflist see $cline.0
6710 set cflist_top $cline
6713 proc prevfile {} {
6714 global difffilestart ctext cmitmode
6716 if {$cmitmode eq "tree"} return
6717 set prev 0.0
6718 set prevline 1
6719 set here [$ctext index @0,0]
6720 foreach loc $difffilestart {
6721 if {[$ctext compare $loc >= $here]} {
6722 highlightfile $prev $prevline
6723 return
6725 set prev $loc
6726 incr prevline
6728 highlightfile $prev $prevline
6731 proc nextfile {} {
6732 global difffilestart ctext cmitmode
6734 if {$cmitmode eq "tree"} return
6735 set here [$ctext index @0,0]
6736 set line 1
6737 foreach loc $difffilestart {
6738 incr line
6739 if {[$ctext compare $loc > $here]} {
6740 highlightfile $loc $line
6741 return
6746 proc clear_ctext {{first 1.0}} {
6747 global ctext smarktop smarkbot
6748 global pendinglinks
6750 set l [lindex [split $first .] 0]
6751 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6752 set smarktop $l
6754 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6755 set smarkbot $l
6757 $ctext delete $first end
6758 if {$first eq "1.0"} {
6759 catch {unset pendinglinks}
6763 proc settabs {{firstab {}}} {
6764 global firsttabstop tabstop ctext have_tk85
6766 if {$firstab ne {} && $have_tk85} {
6767 set firsttabstop $firstab
6769 set w [font measure textfont "0"]
6770 if {$firsttabstop != 0} {
6771 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6772 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6773 } elseif {$have_tk85 || $tabstop != 8} {
6774 $ctext conf -tabs [expr {$tabstop * $w}]
6775 } else {
6776 $ctext conf -tabs {}
6780 proc incrsearch {name ix op} {
6781 global ctext searchstring searchdirn
6783 $ctext tag remove found 1.0 end
6784 if {[catch {$ctext index anchor}]} {
6785 # no anchor set, use start of selection, or of visible area
6786 set sel [$ctext tag ranges sel]
6787 if {$sel ne {}} {
6788 $ctext mark set anchor [lindex $sel 0]
6789 } elseif {$searchdirn eq "-forwards"} {
6790 $ctext mark set anchor @0,0
6791 } else {
6792 $ctext mark set anchor @0,[winfo height $ctext]
6795 if {$searchstring ne {}} {
6796 set here [$ctext search $searchdirn -- $searchstring anchor]
6797 if {$here ne {}} {
6798 $ctext see $here
6800 searchmarkvisible 1
6804 proc dosearch {} {
6805 global sstring ctext searchstring searchdirn
6807 focus $sstring
6808 $sstring icursor end
6809 set searchdirn -forwards
6810 if {$searchstring ne {}} {
6811 set sel [$ctext tag ranges sel]
6812 if {$sel ne {}} {
6813 set start "[lindex $sel 0] + 1c"
6814 } elseif {[catch {set start [$ctext index anchor]}]} {
6815 set start "@0,0"
6817 set match [$ctext search -count mlen -- $searchstring $start]
6818 $ctext tag remove sel 1.0 end
6819 if {$match eq {}} {
6820 bell
6821 return
6823 $ctext see $match
6824 set mend "$match + $mlen c"
6825 $ctext tag add sel $match $mend
6826 $ctext mark unset anchor
6830 proc dosearchback {} {
6831 global sstring ctext searchstring searchdirn
6833 focus $sstring
6834 $sstring icursor end
6835 set searchdirn -backwards
6836 if {$searchstring ne {}} {
6837 set sel [$ctext tag ranges sel]
6838 if {$sel ne {}} {
6839 set start [lindex $sel 0]
6840 } elseif {[catch {set start [$ctext index anchor]}]} {
6841 set start @0,[winfo height $ctext]
6843 set match [$ctext search -backwards -count ml -- $searchstring $start]
6844 $ctext tag remove sel 1.0 end
6845 if {$match eq {}} {
6846 bell
6847 return
6849 $ctext see $match
6850 set mend "$match + $ml c"
6851 $ctext tag add sel $match $mend
6852 $ctext mark unset anchor
6856 proc searchmark {first last} {
6857 global ctext searchstring
6859 set mend $first.0
6860 while {1} {
6861 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6862 if {$match eq {}} break
6863 set mend "$match + $mlen c"
6864 $ctext tag add found $match $mend
6868 proc searchmarkvisible {doall} {
6869 global ctext smarktop smarkbot
6871 set topline [lindex [split [$ctext index @0,0] .] 0]
6872 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6873 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6874 # no overlap with previous
6875 searchmark $topline $botline
6876 set smarktop $topline
6877 set smarkbot $botline
6878 } else {
6879 if {$topline < $smarktop} {
6880 searchmark $topline [expr {$smarktop-1}]
6881 set smarktop $topline
6883 if {$botline > $smarkbot} {
6884 searchmark [expr {$smarkbot+1}] $botline
6885 set smarkbot $botline
6890 proc scrolltext {f0 f1} {
6891 global searchstring
6893 .bleft.bottom.sb set $f0 $f1
6894 if {$searchstring ne {}} {
6895 searchmarkvisible 0
6899 proc setcoords {} {
6900 global linespc charspc canvx0 canvy0
6901 global xspc1 xspc2 lthickness
6903 set linespc [font metrics mainfont -linespace]
6904 set charspc [font measure mainfont "m"]
6905 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6906 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6907 set lthickness [expr {int($linespc / 9) + 1}]
6908 set xspc1(0) $linespc
6909 set xspc2 $linespc
6912 proc redisplay {} {
6913 global canv
6914 global selectedline
6916 set ymax [lindex [$canv cget -scrollregion] 3]
6917 if {$ymax eq {} || $ymax == 0} return
6918 set span [$canv yview]
6919 clear_display
6920 setcanvscroll
6921 allcanvs yview moveto [lindex $span 0]
6922 drawvisible
6923 if {$selectedline ne {}} {
6924 selectline $selectedline 0
6925 allcanvs yview moveto [lindex $span 0]
6929 proc parsefont {f n} {
6930 global fontattr
6932 set fontattr($f,family) [lindex $n 0]
6933 set s [lindex $n 1]
6934 if {$s eq {} || $s == 0} {
6935 set s 10
6936 } elseif {$s < 0} {
6937 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6939 set fontattr($f,size) $s
6940 set fontattr($f,weight) normal
6941 set fontattr($f,slant) roman
6942 foreach style [lrange $n 2 end] {
6943 switch -- $style {
6944 "normal" -
6945 "bold" {set fontattr($f,weight) $style}
6946 "roman" -
6947 "italic" {set fontattr($f,slant) $style}
6952 proc fontflags {f {isbold 0}} {
6953 global fontattr
6955 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6956 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6957 -slant $fontattr($f,slant)]
6960 proc fontname {f} {
6961 global fontattr
6963 set n [list $fontattr($f,family) $fontattr($f,size)]
6964 if {$fontattr($f,weight) eq "bold"} {
6965 lappend n "bold"
6967 if {$fontattr($f,slant) eq "italic"} {
6968 lappend n "italic"
6970 return $n
6973 proc incrfont {inc} {
6974 global mainfont textfont ctext canv cflist showrefstop
6975 global stopped entries fontattr
6977 unmarkmatches
6978 set s $fontattr(mainfont,size)
6979 incr s $inc
6980 if {$s < 1} {
6981 set s 1
6983 set fontattr(mainfont,size) $s
6984 font config mainfont -size $s
6985 font config mainfontbold -size $s
6986 set mainfont [fontname mainfont]
6987 set s $fontattr(textfont,size)
6988 incr s $inc
6989 if {$s < 1} {
6990 set s 1
6992 set fontattr(textfont,size) $s
6993 font config textfont -size $s
6994 font config textfontbold -size $s
6995 set textfont [fontname textfont]
6996 setcoords
6997 settabs
6998 redisplay
7001 proc clearsha1 {} {
7002 global sha1entry sha1string
7003 if {[string length $sha1string] == 40} {
7004 $sha1entry delete 0 end
7008 proc sha1change {n1 n2 op} {
7009 global sha1string currentid sha1but
7010 if {$sha1string == {}
7011 || ([info exists currentid] && $sha1string == $currentid)} {
7012 set state disabled
7013 } else {
7014 set state normal
7016 if {[$sha1but cget -state] == $state} return
7017 if {$state == "normal"} {
7018 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7019 } else {
7020 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7024 proc gotocommit {} {
7025 global sha1string tagids headids curview varcid
7027 if {$sha1string == {}
7028 || ([info exists currentid] && $sha1string == $currentid)} return
7029 if {[info exists tagids($sha1string)]} {
7030 set id $tagids($sha1string)
7031 } elseif {[info exists headids($sha1string)]} {
7032 set id $headids($sha1string)
7033 } else {
7034 set id [string tolower $sha1string]
7035 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7036 set matches [array names varcid "$curview,$id*"]
7037 if {$matches ne {}} {
7038 if {[llength $matches] > 1} {
7039 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7040 return
7042 set id [lindex [split [lindex $matches 0] ","] 1]
7046 if {[commitinview $id $curview]} {
7047 selectline [rowofcommit $id] 1
7048 return
7050 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7051 set msg [mc "SHA1 id %s is not known" $sha1string]
7052 } else {
7053 set msg [mc "Tag/Head %s is not known" $sha1string]
7055 error_popup $msg
7058 proc lineenter {x y id} {
7059 global hoverx hovery hoverid hovertimer
7060 global commitinfo canv
7062 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7063 set hoverx $x
7064 set hovery $y
7065 set hoverid $id
7066 if {[info exists hovertimer]} {
7067 after cancel $hovertimer
7069 set hovertimer [after 500 linehover]
7070 $canv delete hover
7073 proc linemotion {x y id} {
7074 global hoverx hovery hoverid hovertimer
7076 if {[info exists hoverid] && $id == $hoverid} {
7077 set hoverx $x
7078 set hovery $y
7079 if {[info exists hovertimer]} {
7080 after cancel $hovertimer
7082 set hovertimer [after 500 linehover]
7086 proc lineleave {id} {
7087 global hoverid hovertimer canv
7089 if {[info exists hoverid] && $id == $hoverid} {
7090 $canv delete hover
7091 if {[info exists hovertimer]} {
7092 after cancel $hovertimer
7093 unset hovertimer
7095 unset hoverid
7099 proc linehover {} {
7100 global hoverx hovery hoverid hovertimer
7101 global canv linespc lthickness
7102 global commitinfo
7104 set text [lindex $commitinfo($hoverid) 0]
7105 set ymax [lindex [$canv cget -scrollregion] 3]
7106 if {$ymax == {}} return
7107 set yfrac [lindex [$canv yview] 0]
7108 set x [expr {$hoverx + 2 * $linespc}]
7109 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7110 set x0 [expr {$x - 2 * $lthickness}]
7111 set y0 [expr {$y - 2 * $lthickness}]
7112 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7113 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7114 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7115 -fill \#ffff80 -outline black -width 1 -tags hover]
7116 $canv raise $t
7117 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7118 -font mainfont]
7119 $canv raise $t
7122 proc clickisonarrow {id y} {
7123 global lthickness
7125 set ranges [rowranges $id]
7126 set thresh [expr {2 * $lthickness + 6}]
7127 set n [expr {[llength $ranges] - 1}]
7128 for {set i 1} {$i < $n} {incr i} {
7129 set row [lindex $ranges $i]
7130 if {abs([yc $row] - $y) < $thresh} {
7131 return $i
7134 return {}
7137 proc arrowjump {id n y} {
7138 global canv
7140 # 1 <-> 2, 3 <-> 4, etc...
7141 set n [expr {(($n - 1) ^ 1) + 1}]
7142 set row [lindex [rowranges $id] $n]
7143 set yt [yc $row]
7144 set ymax [lindex [$canv cget -scrollregion] 3]
7145 if {$ymax eq {} || $ymax <= 0} return
7146 set view [$canv yview]
7147 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7148 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7149 if {$yfrac < 0} {
7150 set yfrac 0
7152 allcanvs yview moveto $yfrac
7155 proc lineclick {x y id isnew} {
7156 global ctext commitinfo children canv thickerline curview
7158 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7159 unmarkmatches
7160 unselectline
7161 normalline
7162 $canv delete hover
7163 # draw this line thicker than normal
7164 set thickerline $id
7165 drawlines $id
7166 if {$isnew} {
7167 set ymax [lindex [$canv cget -scrollregion] 3]
7168 if {$ymax eq {}} return
7169 set yfrac [lindex [$canv yview] 0]
7170 set y [expr {$y + $yfrac * $ymax}]
7172 set dirn [clickisonarrow $id $y]
7173 if {$dirn ne {}} {
7174 arrowjump $id $dirn $y
7175 return
7178 if {$isnew} {
7179 addtohistory [list lineclick $x $y $id 0]
7181 # fill the details pane with info about this line
7182 $ctext conf -state normal
7183 clear_ctext
7184 settabs 0
7185 $ctext insert end "[mc "Parent"]:\t"
7186 $ctext insert end $id link0
7187 setlink $id link0
7188 set info $commitinfo($id)
7189 $ctext insert end "\n\t[lindex $info 0]\n"
7190 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7191 set date [formatdate [lindex $info 2]]
7192 $ctext insert end "\t[mc "Date"]:\t$date\n"
7193 set kids $children($curview,$id)
7194 if {$kids ne {}} {
7195 $ctext insert end "\n[mc "Children"]:"
7196 set i 0
7197 foreach child $kids {
7198 incr i
7199 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7200 set info $commitinfo($child)
7201 $ctext insert end "\n\t"
7202 $ctext insert end $child link$i
7203 setlink $child link$i
7204 $ctext insert end "\n\t[lindex $info 0]"
7205 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7206 set date [formatdate [lindex $info 2]]
7207 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7210 $ctext conf -state disabled
7211 init_flist {}
7214 proc normalline {} {
7215 global thickerline
7216 if {[info exists thickerline]} {
7217 set id $thickerline
7218 unset thickerline
7219 drawlines $id
7223 proc selbyid {id} {
7224 global curview
7225 if {[commitinview $id $curview]} {
7226 selectline [rowofcommit $id] 1
7230 proc mstime {} {
7231 global startmstime
7232 if {![info exists startmstime]} {
7233 set startmstime [clock clicks -milliseconds]
7235 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7238 proc rowmenu {x y id} {
7239 global rowctxmenu selectedline rowmenuid curview
7240 global nullid nullid2 fakerowmenu mainhead
7242 stopfinding
7243 set rowmenuid $id
7244 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7245 set state disabled
7246 } else {
7247 set state normal
7249 if {$id ne $nullid && $id ne $nullid2} {
7250 set menu $rowctxmenu
7251 if {$mainhead ne {}} {
7252 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7253 } else {
7254 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7256 } else {
7257 set menu $fakerowmenu
7259 $menu entryconfigure [mc "Diff this -> selected"] -state $state
7260 $menu entryconfigure [mc "Diff selected -> this"] -state $state
7261 $menu entryconfigure [mc "Make patch"] -state $state
7262 tk_popup $menu $x $y
7265 proc diffvssel {dirn} {
7266 global rowmenuid selectedline
7268 if {$selectedline eq {}} return
7269 if {$dirn} {
7270 set oldid [commitonrow $selectedline]
7271 set newid $rowmenuid
7272 } else {
7273 set oldid $rowmenuid
7274 set newid [commitonrow $selectedline]
7276 addtohistory [list doseldiff $oldid $newid]
7277 doseldiff $oldid $newid
7280 proc doseldiff {oldid newid} {
7281 global ctext
7282 global commitinfo
7284 $ctext conf -state normal
7285 clear_ctext
7286 init_flist [mc "Top"]
7287 $ctext insert end "[mc "From"] "
7288 $ctext insert end $oldid link0
7289 setlink $oldid link0
7290 $ctext insert end "\n "
7291 $ctext insert end [lindex $commitinfo($oldid) 0]
7292 $ctext insert end "\n\n[mc "To"] "
7293 $ctext insert end $newid link1
7294 setlink $newid link1
7295 $ctext insert end "\n "
7296 $ctext insert end [lindex $commitinfo($newid) 0]
7297 $ctext insert end "\n"
7298 $ctext conf -state disabled
7299 $ctext tag remove found 1.0 end
7300 startdiff [list $oldid $newid]
7303 proc mkpatch {} {
7304 global rowmenuid currentid commitinfo patchtop patchnum
7306 if {![info exists currentid]} return
7307 set oldid $currentid
7308 set oldhead [lindex $commitinfo($oldid) 0]
7309 set newid $rowmenuid
7310 set newhead [lindex $commitinfo($newid) 0]
7311 set top .patch
7312 set patchtop $top
7313 catch {destroy $top}
7314 toplevel $top
7315 label $top.title -text [mc "Generate patch"]
7316 grid $top.title - -pady 10
7317 label $top.from -text [mc "From:"]
7318 entry $top.fromsha1 -width 40 -relief flat
7319 $top.fromsha1 insert 0 $oldid
7320 $top.fromsha1 conf -state readonly
7321 grid $top.from $top.fromsha1 -sticky w
7322 entry $top.fromhead -width 60 -relief flat
7323 $top.fromhead insert 0 $oldhead
7324 $top.fromhead conf -state readonly
7325 grid x $top.fromhead -sticky w
7326 label $top.to -text [mc "To:"]
7327 entry $top.tosha1 -width 40 -relief flat
7328 $top.tosha1 insert 0 $newid
7329 $top.tosha1 conf -state readonly
7330 grid $top.to $top.tosha1 -sticky w
7331 entry $top.tohead -width 60 -relief flat
7332 $top.tohead insert 0 $newhead
7333 $top.tohead conf -state readonly
7334 grid x $top.tohead -sticky w
7335 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7336 grid $top.rev x -pady 10
7337 label $top.flab -text [mc "Output file:"]
7338 entry $top.fname -width 60
7339 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7340 incr patchnum
7341 grid $top.flab $top.fname -sticky w
7342 frame $top.buts
7343 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7344 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7345 grid $top.buts.gen $top.buts.can
7346 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7347 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7348 grid $top.buts - -pady 10 -sticky ew
7349 focus $top.fname
7352 proc mkpatchrev {} {
7353 global patchtop
7355 set oldid [$patchtop.fromsha1 get]
7356 set oldhead [$patchtop.fromhead get]
7357 set newid [$patchtop.tosha1 get]
7358 set newhead [$patchtop.tohead get]
7359 foreach e [list fromsha1 fromhead tosha1 tohead] \
7360 v [list $newid $newhead $oldid $oldhead] {
7361 $patchtop.$e conf -state normal
7362 $patchtop.$e delete 0 end
7363 $patchtop.$e insert 0 $v
7364 $patchtop.$e conf -state readonly
7368 proc mkpatchgo {} {
7369 global patchtop nullid nullid2
7371 set oldid [$patchtop.fromsha1 get]
7372 set newid [$patchtop.tosha1 get]
7373 set fname [$patchtop.fname get]
7374 set cmd [diffcmd [list $oldid $newid] -p]
7375 # trim off the initial "|"
7376 set cmd [lrange $cmd 1 end]
7377 lappend cmd >$fname &
7378 if {[catch {eval exec $cmd} err]} {
7379 error_popup "[mc "Error creating patch:"] $err"
7381 catch {destroy $patchtop}
7382 unset patchtop
7385 proc mkpatchcan {} {
7386 global patchtop
7388 catch {destroy $patchtop}
7389 unset patchtop
7392 proc mktag {} {
7393 global rowmenuid mktagtop commitinfo
7395 set top .maketag
7396 set mktagtop $top
7397 catch {destroy $top}
7398 toplevel $top
7399 label $top.title -text [mc "Create tag"]
7400 grid $top.title - -pady 10
7401 label $top.id -text [mc "ID:"]
7402 entry $top.sha1 -width 40 -relief flat
7403 $top.sha1 insert 0 $rowmenuid
7404 $top.sha1 conf -state readonly
7405 grid $top.id $top.sha1 -sticky w
7406 entry $top.head -width 60 -relief flat
7407 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7408 $top.head conf -state readonly
7409 grid x $top.head -sticky w
7410 label $top.tlab -text [mc "Tag name:"]
7411 entry $top.tag -width 60
7412 grid $top.tlab $top.tag -sticky w
7413 frame $top.buts
7414 button $top.buts.gen -text [mc "Create"] -command mktaggo
7415 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7416 grid $top.buts.gen $top.buts.can
7417 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7418 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7419 grid $top.buts - -pady 10 -sticky ew
7420 focus $top.tag
7423 proc domktag {} {
7424 global mktagtop env tagids idtags
7426 set id [$mktagtop.sha1 get]
7427 set tag [$mktagtop.tag get]
7428 if {$tag == {}} {
7429 error_popup [mc "No tag name specified"]
7430 return
7432 if {[info exists tagids($tag)]} {
7433 error_popup [mc "Tag \"%s\" already exists" $tag]
7434 return
7436 if {[catch {
7437 exec git tag $tag $id
7438 } err]} {
7439 error_popup "[mc "Error creating tag:"] $err"
7440 return
7443 set tagids($tag) $id
7444 lappend idtags($id) $tag
7445 redrawtags $id
7446 addedtag $id
7447 dispneartags 0
7448 run refill_reflist
7451 proc redrawtags {id} {
7452 global canv linehtag idpos currentid curview cmitlisted
7453 global canvxmax iddrawn circleitem mainheadid circlecolors
7455 if {![commitinview $id $curview]} return
7456 if {![info exists iddrawn($id)]} return
7457 set row [rowofcommit $id]
7458 if {$id eq $mainheadid} {
7459 set ofill yellow
7460 } else {
7461 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7463 $canv itemconf $circleitem($row) -fill $ofill
7464 $canv delete tag.$id
7465 set xt [eval drawtags $id $idpos($id)]
7466 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7467 set text [$canv itemcget $linehtag($row) -text]
7468 set font [$canv itemcget $linehtag($row) -font]
7469 set xr [expr {$xt + [font measure $font $text]}]
7470 if {$xr > $canvxmax} {
7471 set canvxmax $xr
7472 setcanvscroll
7474 if {[info exists currentid] && $currentid == $id} {
7475 make_secsel $row
7479 proc mktagcan {} {
7480 global mktagtop
7482 catch {destroy $mktagtop}
7483 unset mktagtop
7486 proc mktaggo {} {
7487 domktag
7488 mktagcan
7491 proc writecommit {} {
7492 global rowmenuid wrcomtop commitinfo wrcomcmd
7494 set top .writecommit
7495 set wrcomtop $top
7496 catch {destroy $top}
7497 toplevel $top
7498 label $top.title -text [mc "Write commit to file"]
7499 grid $top.title - -pady 10
7500 label $top.id -text [mc "ID:"]
7501 entry $top.sha1 -width 40 -relief flat
7502 $top.sha1 insert 0 $rowmenuid
7503 $top.sha1 conf -state readonly
7504 grid $top.id $top.sha1 -sticky w
7505 entry $top.head -width 60 -relief flat
7506 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7507 $top.head conf -state readonly
7508 grid x $top.head -sticky w
7509 label $top.clab -text [mc "Command:"]
7510 entry $top.cmd -width 60 -textvariable wrcomcmd
7511 grid $top.clab $top.cmd -sticky w -pady 10
7512 label $top.flab -text [mc "Output file:"]
7513 entry $top.fname -width 60
7514 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7515 grid $top.flab $top.fname -sticky w
7516 frame $top.buts
7517 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7518 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7519 grid $top.buts.gen $top.buts.can
7520 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7521 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7522 grid $top.buts - -pady 10 -sticky ew
7523 focus $top.fname
7526 proc wrcomgo {} {
7527 global wrcomtop
7529 set id [$wrcomtop.sha1 get]
7530 set cmd "echo $id | [$wrcomtop.cmd get]"
7531 set fname [$wrcomtop.fname get]
7532 if {[catch {exec sh -c $cmd >$fname &} err]} {
7533 error_popup "[mc "Error writing commit:"] $err"
7535 catch {destroy $wrcomtop}
7536 unset wrcomtop
7539 proc wrcomcan {} {
7540 global wrcomtop
7542 catch {destroy $wrcomtop}
7543 unset wrcomtop
7546 proc mkbranch {} {
7547 global rowmenuid mkbrtop
7549 set top .makebranch
7550 catch {destroy $top}
7551 toplevel $top
7552 label $top.title -text [mc "Create new branch"]
7553 grid $top.title - -pady 10
7554 label $top.id -text [mc "ID:"]
7555 entry $top.sha1 -width 40 -relief flat
7556 $top.sha1 insert 0 $rowmenuid
7557 $top.sha1 conf -state readonly
7558 grid $top.id $top.sha1 -sticky w
7559 label $top.nlab -text [mc "Name:"]
7560 entry $top.name -width 40
7561 grid $top.nlab $top.name -sticky w
7562 frame $top.buts
7563 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7564 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7565 grid $top.buts.go $top.buts.can
7566 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7567 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7568 grid $top.buts - -pady 10 -sticky ew
7569 focus $top.name
7572 proc mkbrgo {top} {
7573 global headids idheads
7575 set name [$top.name get]
7576 set id [$top.sha1 get]
7577 if {$name eq {}} {
7578 error_popup [mc "Please specify a name for the new branch"]
7579 return
7581 catch {destroy $top}
7582 nowbusy newbranch
7583 update
7584 if {[catch {
7585 exec git branch $name $id
7586 } err]} {
7587 notbusy newbranch
7588 error_popup $err
7589 } else {
7590 set headids($name) $id
7591 lappend idheads($id) $name
7592 addedhead $id $name
7593 notbusy newbranch
7594 redrawtags $id
7595 dispneartags 0
7596 run refill_reflist
7600 proc cherrypick {} {
7601 global rowmenuid curview
7602 global mainhead mainheadid
7604 set oldhead [exec git rev-parse HEAD]
7605 set dheads [descheads $rowmenuid]
7606 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7607 set ok [confirm_popup [mc "Commit %s is already\
7608 included in branch %s -- really re-apply it?" \
7609 [string range $rowmenuid 0 7] $mainhead]]
7610 if {!$ok} return
7612 nowbusy cherrypick [mc "Cherry-picking"]
7613 update
7614 # Unfortunately git-cherry-pick writes stuff to stderr even when
7615 # no error occurs, and exec takes that as an indication of error...
7616 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7617 notbusy cherrypick
7618 error_popup $err
7619 return
7621 set newhead [exec git rev-parse HEAD]
7622 if {$newhead eq $oldhead} {
7623 notbusy cherrypick
7624 error_popup [mc "No changes committed"]
7625 return
7627 addnewchild $newhead $oldhead
7628 if {[commitinview $oldhead $curview]} {
7629 insertrow $newhead $oldhead $curview
7630 if {$mainhead ne {}} {
7631 movehead $newhead $mainhead
7632 movedhead $newhead $mainhead
7634 set mainheadid $newhead
7635 redrawtags $oldhead
7636 redrawtags $newhead
7637 selbyid $newhead
7639 notbusy cherrypick
7642 proc resethead {} {
7643 global mainhead rowmenuid confirm_ok resettype
7645 set confirm_ok 0
7646 set w ".confirmreset"
7647 toplevel $w
7648 wm transient $w .
7649 wm title $w [mc "Confirm reset"]
7650 message $w.m -text \
7651 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7652 -justify center -aspect 1000
7653 pack $w.m -side top -fill x -padx 20 -pady 20
7654 frame $w.f -relief sunken -border 2
7655 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7656 grid $w.f.rt -sticky w
7657 set resettype mixed
7658 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7659 -text [mc "Soft: Leave working tree and index untouched"]
7660 grid $w.f.soft -sticky w
7661 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7662 -text [mc "Mixed: Leave working tree untouched, reset index"]
7663 grid $w.f.mixed -sticky w
7664 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7665 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7666 grid $w.f.hard -sticky w
7667 pack $w.f -side top -fill x
7668 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7669 pack $w.ok -side left -fill x -padx 20 -pady 20
7670 button $w.cancel -text [mc Cancel] -command "destroy $w"
7671 pack $w.cancel -side right -fill x -padx 20 -pady 20
7672 bind $w <Visibility> "grab $w; focus $w"
7673 tkwait window $w
7674 if {!$confirm_ok} return
7675 if {[catch {set fd [open \
7676 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7677 error_popup $err
7678 } else {
7679 dohidelocalchanges
7680 filerun $fd [list readresetstat $fd]
7681 nowbusy reset [mc "Resetting"]
7682 selbyid $rowmenuid
7686 proc readresetstat {fd} {
7687 global mainhead mainheadid showlocalchanges rprogcoord
7689 if {[gets $fd line] >= 0} {
7690 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7691 set rprogcoord [expr {1.0 * $m / $n}]
7692 adjustprogress
7694 return 1
7696 set rprogcoord 0
7697 adjustprogress
7698 notbusy reset
7699 if {[catch {close $fd} err]} {
7700 error_popup $err
7702 set oldhead $mainheadid
7703 set newhead [exec git rev-parse HEAD]
7704 if {$newhead ne $oldhead} {
7705 movehead $newhead $mainhead
7706 movedhead $newhead $mainhead
7707 set mainheadid $newhead
7708 redrawtags $oldhead
7709 redrawtags $newhead
7711 if {$showlocalchanges} {
7712 doshowlocalchanges
7714 return 0
7717 # context menu for a head
7718 proc headmenu {x y id head} {
7719 global headmenuid headmenuhead headctxmenu mainhead
7721 stopfinding
7722 set headmenuid $id
7723 set headmenuhead $head
7724 set state normal
7725 if {$head eq $mainhead} {
7726 set state disabled
7728 $headctxmenu entryconfigure 0 -state $state
7729 $headctxmenu entryconfigure 1 -state $state
7730 tk_popup $headctxmenu $x $y
7733 proc cobranch {} {
7734 global headmenuid headmenuhead headids
7735 global showlocalchanges mainheadid
7737 # check the tree is clean first??
7738 nowbusy checkout [mc "Checking out"]
7739 update
7740 dohidelocalchanges
7741 if {[catch {
7742 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7743 } err]} {
7744 notbusy checkout
7745 error_popup $err
7746 if {$showlocalchanges} {
7747 dodiffindex
7749 } else {
7750 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7754 proc readcheckoutstat {fd newhead newheadid} {
7755 global mainhead mainheadid headids showlocalchanges progresscoords
7757 if {[gets $fd line] >= 0} {
7758 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7759 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7760 adjustprogress
7762 return 1
7764 set progresscoords {0 0}
7765 adjustprogress
7766 notbusy checkout
7767 if {[catch {close $fd} err]} {
7768 error_popup $err
7770 set oldmainid $mainheadid
7771 set mainhead $newhead
7772 set mainheadid $newheadid
7773 redrawtags $oldmainid
7774 redrawtags $newheadid
7775 selbyid $newheadid
7776 if {$showlocalchanges} {
7777 dodiffindex
7781 proc rmbranch {} {
7782 global headmenuid headmenuhead mainhead
7783 global idheads
7785 set head $headmenuhead
7786 set id $headmenuid
7787 # this check shouldn't be needed any more...
7788 if {$head eq $mainhead} {
7789 error_popup [mc "Cannot delete the currently checked-out branch"]
7790 return
7792 set dheads [descheads $id]
7793 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7794 # the stuff on this branch isn't on any other branch
7795 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7796 branch.\nReally delete branch %s?" $head $head]]} return
7798 nowbusy rmbranch
7799 update
7800 if {[catch {exec git branch -D $head} err]} {
7801 notbusy rmbranch
7802 error_popup $err
7803 return
7805 removehead $id $head
7806 removedhead $id $head
7807 redrawtags $id
7808 notbusy rmbranch
7809 dispneartags 0
7810 run refill_reflist
7813 # Display a list of tags and heads
7814 proc showrefs {} {
7815 global showrefstop bgcolor fgcolor selectbgcolor
7816 global bglist fglist reflistfilter reflist maincursor
7818 set top .showrefs
7819 set showrefstop $top
7820 if {[winfo exists $top]} {
7821 raise $top
7822 refill_reflist
7823 return
7825 toplevel $top
7826 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7827 text $top.list -background $bgcolor -foreground $fgcolor \
7828 -selectbackground $selectbgcolor -font mainfont \
7829 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7830 -width 30 -height 20 -cursor $maincursor \
7831 -spacing1 1 -spacing3 1 -state disabled
7832 $top.list tag configure highlight -background $selectbgcolor
7833 lappend bglist $top.list
7834 lappend fglist $top.list
7835 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7836 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7837 grid $top.list $top.ysb -sticky nsew
7838 grid $top.xsb x -sticky ew
7839 frame $top.f
7840 label $top.f.l -text "[mc "Filter"]: "
7841 entry $top.f.e -width 20 -textvariable reflistfilter
7842 set reflistfilter "*"
7843 trace add variable reflistfilter write reflistfilter_change
7844 pack $top.f.e -side right -fill x -expand 1
7845 pack $top.f.l -side left
7846 grid $top.f - -sticky ew -pady 2
7847 button $top.close -command [list destroy $top] -text [mc "Close"]
7848 grid $top.close -
7849 grid columnconfigure $top 0 -weight 1
7850 grid rowconfigure $top 0 -weight 1
7851 bind $top.list <1> {break}
7852 bind $top.list <B1-Motion> {break}
7853 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7854 set reflist {}
7855 refill_reflist
7858 proc sel_reflist {w x y} {
7859 global showrefstop reflist headids tagids otherrefids
7861 if {![winfo exists $showrefstop]} return
7862 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7863 set ref [lindex $reflist [expr {$l-1}]]
7864 set n [lindex $ref 0]
7865 switch -- [lindex $ref 1] {
7866 "H" {selbyid $headids($n)}
7867 "T" {selbyid $tagids($n)}
7868 "o" {selbyid $otherrefids($n)}
7870 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7873 proc unsel_reflist {} {
7874 global showrefstop
7876 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7877 $showrefstop.list tag remove highlight 0.0 end
7880 proc reflistfilter_change {n1 n2 op} {
7881 global reflistfilter
7883 after cancel refill_reflist
7884 after 200 refill_reflist
7887 proc refill_reflist {} {
7888 global reflist reflistfilter showrefstop headids tagids otherrefids
7889 global curview commitinterest
7891 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7892 set refs {}
7893 foreach n [array names headids] {
7894 if {[string match $reflistfilter $n]} {
7895 if {[commitinview $headids($n) $curview]} {
7896 lappend refs [list $n H]
7897 } else {
7898 set commitinterest($headids($n)) {run refill_reflist}
7902 foreach n [array names tagids] {
7903 if {[string match $reflistfilter $n]} {
7904 if {[commitinview $tagids($n) $curview]} {
7905 lappend refs [list $n T]
7906 } else {
7907 set commitinterest($tagids($n)) {run refill_reflist}
7911 foreach n [array names otherrefids] {
7912 if {[string match $reflistfilter $n]} {
7913 if {[commitinview $otherrefids($n) $curview]} {
7914 lappend refs [list $n o]
7915 } else {
7916 set commitinterest($otherrefids($n)) {run refill_reflist}
7920 set refs [lsort -index 0 $refs]
7921 if {$refs eq $reflist} return
7923 # Update the contents of $showrefstop.list according to the
7924 # differences between $reflist (old) and $refs (new)
7925 $showrefstop.list conf -state normal
7926 $showrefstop.list insert end "\n"
7927 set i 0
7928 set j 0
7929 while {$i < [llength $reflist] || $j < [llength $refs]} {
7930 if {$i < [llength $reflist]} {
7931 if {$j < [llength $refs]} {
7932 set cmp [string compare [lindex $reflist $i 0] \
7933 [lindex $refs $j 0]]
7934 if {$cmp == 0} {
7935 set cmp [string compare [lindex $reflist $i 1] \
7936 [lindex $refs $j 1]]
7938 } else {
7939 set cmp -1
7941 } else {
7942 set cmp 1
7944 switch -- $cmp {
7945 -1 {
7946 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7947 incr i
7950 incr i
7951 incr j
7954 set l [expr {$j + 1}]
7955 $showrefstop.list image create $l.0 -align baseline \
7956 -image reficon-[lindex $refs $j 1] -padx 2
7957 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7958 incr j
7962 set reflist $refs
7963 # delete last newline
7964 $showrefstop.list delete end-2c end-1c
7965 $showrefstop.list conf -state disabled
7968 # Stuff for finding nearby tags
7969 proc getallcommits {} {
7970 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7971 global idheads idtags idotherrefs allparents tagobjid
7973 if {![info exists allcommits]} {
7974 set nextarc 0
7975 set allcommits 0
7976 set seeds {}
7977 set allcwait 0
7978 set cachedarcs 0
7979 set allccache [file join [gitdir] "gitk.cache"]
7980 if {![catch {
7981 set f [open $allccache r]
7982 set allcwait 1
7983 getcache $f
7984 }]} return
7987 if {$allcwait} {
7988 return
7990 set cmd [list | git rev-list --parents]
7991 set allcupdate [expr {$seeds ne {}}]
7992 if {!$allcupdate} {
7993 set ids "--all"
7994 } else {
7995 set refs [concat [array names idheads] [array names idtags] \
7996 [array names idotherrefs]]
7997 set ids {}
7998 set tagobjs {}
7999 foreach name [array names tagobjid] {
8000 lappend tagobjs $tagobjid($name)
8002 foreach id [lsort -unique $refs] {
8003 if {![info exists allparents($id)] &&
8004 [lsearch -exact $tagobjs $id] < 0} {
8005 lappend ids $id
8008 if {$ids ne {}} {
8009 foreach id $seeds {
8010 lappend ids "^$id"
8014 if {$ids ne {}} {
8015 set fd [open [concat $cmd $ids] r]
8016 fconfigure $fd -blocking 0
8017 incr allcommits
8018 nowbusy allcommits
8019 filerun $fd [list getallclines $fd]
8020 } else {
8021 dispneartags 0
8025 # Since most commits have 1 parent and 1 child, we group strings of
8026 # such commits into "arcs" joining branch/merge points (BMPs), which
8027 # are commits that either don't have 1 parent or don't have 1 child.
8029 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8030 # arcout(id) - outgoing arcs for BMP
8031 # arcids(a) - list of IDs on arc including end but not start
8032 # arcstart(a) - BMP ID at start of arc
8033 # arcend(a) - BMP ID at end of arc
8034 # growing(a) - arc a is still growing
8035 # arctags(a) - IDs out of arcids (excluding end) that have tags
8036 # archeads(a) - IDs out of arcids (excluding end) that have heads
8037 # The start of an arc is at the descendent end, so "incoming" means
8038 # coming from descendents, and "outgoing" means going towards ancestors.
8040 proc getallclines {fd} {
8041 global allparents allchildren idtags idheads nextarc
8042 global arcnos arcids arctags arcout arcend arcstart archeads growing
8043 global seeds allcommits cachedarcs allcupdate
8045 set nid 0
8046 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8047 set id [lindex $line 0]
8048 if {[info exists allparents($id)]} {
8049 # seen it already
8050 continue
8052 set cachedarcs 0
8053 set olds [lrange $line 1 end]
8054 set allparents($id) $olds
8055 if {![info exists allchildren($id)]} {
8056 set allchildren($id) {}
8057 set arcnos($id) {}
8058 lappend seeds $id
8059 } else {
8060 set a $arcnos($id)
8061 if {[llength $olds] == 1 && [llength $a] == 1} {
8062 lappend arcids($a) $id
8063 if {[info exists idtags($id)]} {
8064 lappend arctags($a) $id
8066 if {[info exists idheads($id)]} {
8067 lappend archeads($a) $id
8069 if {[info exists allparents($olds)]} {
8070 # seen parent already
8071 if {![info exists arcout($olds)]} {
8072 splitarc $olds
8074 lappend arcids($a) $olds
8075 set arcend($a) $olds
8076 unset growing($a)
8078 lappend allchildren($olds) $id
8079 lappend arcnos($olds) $a
8080 continue
8083 foreach a $arcnos($id) {
8084 lappend arcids($a) $id
8085 set arcend($a) $id
8086 unset growing($a)
8089 set ao {}
8090 foreach p $olds {
8091 lappend allchildren($p) $id
8092 set a [incr nextarc]
8093 set arcstart($a) $id
8094 set archeads($a) {}
8095 set arctags($a) {}
8096 set archeads($a) {}
8097 set arcids($a) {}
8098 lappend ao $a
8099 set growing($a) 1
8100 if {[info exists allparents($p)]} {
8101 # seen it already, may need to make a new branch
8102 if {![info exists arcout($p)]} {
8103 splitarc $p
8105 lappend arcids($a) $p
8106 set arcend($a) $p
8107 unset growing($a)
8109 lappend arcnos($p) $a
8111 set arcout($id) $ao
8113 if {$nid > 0} {
8114 global cached_dheads cached_dtags cached_atags
8115 catch {unset cached_dheads}
8116 catch {unset cached_dtags}
8117 catch {unset cached_atags}
8119 if {![eof $fd]} {
8120 return [expr {$nid >= 1000? 2: 1}]
8122 set cacheok 1
8123 if {[catch {
8124 fconfigure $fd -blocking 1
8125 close $fd
8126 } err]} {
8127 # got an error reading the list of commits
8128 # if we were updating, try rereading the whole thing again
8129 if {$allcupdate} {
8130 incr allcommits -1
8131 dropcache $err
8132 return
8134 error_popup "[mc "Error reading commit topology information;\
8135 branch and preceding/following tag information\
8136 will be incomplete."]\n($err)"
8137 set cacheok 0
8139 if {[incr allcommits -1] == 0} {
8140 notbusy allcommits
8141 if {$cacheok} {
8142 run savecache
8145 dispneartags 0
8146 return 0
8149 proc recalcarc {a} {
8150 global arctags archeads arcids idtags idheads
8152 set at {}
8153 set ah {}
8154 foreach id [lrange $arcids($a) 0 end-1] {
8155 if {[info exists idtags($id)]} {
8156 lappend at $id
8158 if {[info exists idheads($id)]} {
8159 lappend ah $id
8162 set arctags($a) $at
8163 set archeads($a) $ah
8166 proc splitarc {p} {
8167 global arcnos arcids nextarc arctags archeads idtags idheads
8168 global arcstart arcend arcout allparents growing
8170 set a $arcnos($p)
8171 if {[llength $a] != 1} {
8172 puts "oops splitarc called but [llength $a] arcs already"
8173 return
8175 set a [lindex $a 0]
8176 set i [lsearch -exact $arcids($a) $p]
8177 if {$i < 0} {
8178 puts "oops splitarc $p not in arc $a"
8179 return
8181 set na [incr nextarc]
8182 if {[info exists arcend($a)]} {
8183 set arcend($na) $arcend($a)
8184 } else {
8185 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8186 set j [lsearch -exact $arcnos($l) $a]
8187 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8189 set tail [lrange $arcids($a) [expr {$i+1}] end]
8190 set arcids($a) [lrange $arcids($a) 0 $i]
8191 set arcend($a) $p
8192 set arcstart($na) $p
8193 set arcout($p) $na
8194 set arcids($na) $tail
8195 if {[info exists growing($a)]} {
8196 set growing($na) 1
8197 unset growing($a)
8200 foreach id $tail {
8201 if {[llength $arcnos($id)] == 1} {
8202 set arcnos($id) $na
8203 } else {
8204 set j [lsearch -exact $arcnos($id) $a]
8205 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8209 # reconstruct tags and heads lists
8210 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8211 recalcarc $a
8212 recalcarc $na
8213 } else {
8214 set arctags($na) {}
8215 set archeads($na) {}
8219 # Update things for a new commit added that is a child of one
8220 # existing commit. Used when cherry-picking.
8221 proc addnewchild {id p} {
8222 global allparents allchildren idtags nextarc
8223 global arcnos arcids arctags arcout arcend arcstart archeads growing
8224 global seeds allcommits
8226 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8227 set allparents($id) [list $p]
8228 set allchildren($id) {}
8229 set arcnos($id) {}
8230 lappend seeds $id
8231 lappend allchildren($p) $id
8232 set a [incr nextarc]
8233 set arcstart($a) $id
8234 set archeads($a) {}
8235 set arctags($a) {}
8236 set arcids($a) [list $p]
8237 set arcend($a) $p
8238 if {![info exists arcout($p)]} {
8239 splitarc $p
8241 lappend arcnos($p) $a
8242 set arcout($id) [list $a]
8245 # This implements a cache for the topology information.
8246 # The cache saves, for each arc, the start and end of the arc,
8247 # the ids on the arc, and the outgoing arcs from the end.
8248 proc readcache {f} {
8249 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8250 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8251 global allcwait
8253 set a $nextarc
8254 set lim $cachedarcs
8255 if {$lim - $a > 500} {
8256 set lim [expr {$a + 500}]
8258 if {[catch {
8259 if {$a == $lim} {
8260 # finish reading the cache and setting up arctags, etc.
8261 set line [gets $f]
8262 if {$line ne "1"} {error "bad final version"}
8263 close $f
8264 foreach id [array names idtags] {
8265 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8266 [llength $allparents($id)] == 1} {
8267 set a [lindex $arcnos($id) 0]
8268 if {$arctags($a) eq {}} {
8269 recalcarc $a
8273 foreach id [array names idheads] {
8274 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8275 [llength $allparents($id)] == 1} {
8276 set a [lindex $arcnos($id) 0]
8277 if {$archeads($a) eq {}} {
8278 recalcarc $a
8282 foreach id [lsort -unique $possible_seeds] {
8283 if {$arcnos($id) eq {}} {
8284 lappend seeds $id
8287 set allcwait 0
8288 } else {
8289 while {[incr a] <= $lim} {
8290 set line [gets $f]
8291 if {[llength $line] != 3} {error "bad line"}
8292 set s [lindex $line 0]
8293 set arcstart($a) $s
8294 lappend arcout($s) $a
8295 if {![info exists arcnos($s)]} {
8296 lappend possible_seeds $s
8297 set arcnos($s) {}
8299 set e [lindex $line 1]
8300 if {$e eq {}} {
8301 set growing($a) 1
8302 } else {
8303 set arcend($a) $e
8304 if {![info exists arcout($e)]} {
8305 set arcout($e) {}
8308 set arcids($a) [lindex $line 2]
8309 foreach id $arcids($a) {
8310 lappend allparents($s) $id
8311 set s $id
8312 lappend arcnos($id) $a
8314 if {![info exists allparents($s)]} {
8315 set allparents($s) {}
8317 set arctags($a) {}
8318 set archeads($a) {}
8320 set nextarc [expr {$a - 1}]
8322 } err]} {
8323 dropcache $err
8324 return 0
8326 if {!$allcwait} {
8327 getallcommits
8329 return $allcwait
8332 proc getcache {f} {
8333 global nextarc cachedarcs possible_seeds
8335 if {[catch {
8336 set line [gets $f]
8337 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8338 # make sure it's an integer
8339 set cachedarcs [expr {int([lindex $line 1])}]
8340 if {$cachedarcs < 0} {error "bad number of arcs"}
8341 set nextarc 0
8342 set possible_seeds {}
8343 run readcache $f
8344 } err]} {
8345 dropcache $err
8347 return 0
8350 proc dropcache {err} {
8351 global allcwait nextarc cachedarcs seeds
8353 #puts "dropping cache ($err)"
8354 foreach v {arcnos arcout arcids arcstart arcend growing \
8355 arctags archeads allparents allchildren} {
8356 global $v
8357 catch {unset $v}
8359 set allcwait 0
8360 set nextarc 0
8361 set cachedarcs 0
8362 set seeds {}
8363 getallcommits
8366 proc writecache {f} {
8367 global cachearc cachedarcs allccache
8368 global arcstart arcend arcnos arcids arcout
8370 set a $cachearc
8371 set lim $cachedarcs
8372 if {$lim - $a > 1000} {
8373 set lim [expr {$a + 1000}]
8375 if {[catch {
8376 while {[incr a] <= $lim} {
8377 if {[info exists arcend($a)]} {
8378 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8379 } else {
8380 puts $f [list $arcstart($a) {} $arcids($a)]
8383 } err]} {
8384 catch {close $f}
8385 catch {file delete $allccache}
8386 #puts "writing cache failed ($err)"
8387 return 0
8389 set cachearc [expr {$a - 1}]
8390 if {$a > $cachedarcs} {
8391 puts $f "1"
8392 close $f
8393 return 0
8395 return 1
8398 proc savecache {} {
8399 global nextarc cachedarcs cachearc allccache
8401 if {$nextarc == $cachedarcs} return
8402 set cachearc 0
8403 set cachedarcs $nextarc
8404 catch {
8405 set f [open $allccache w]
8406 puts $f [list 1 $cachedarcs]
8407 run writecache $f
8411 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8412 # or 0 if neither is true.
8413 proc anc_or_desc {a b} {
8414 global arcout arcstart arcend arcnos cached_isanc
8416 if {$arcnos($a) eq $arcnos($b)} {
8417 # Both are on the same arc(s); either both are the same BMP,
8418 # or if one is not a BMP, the other is also not a BMP or is
8419 # the BMP at end of the arc (and it only has 1 incoming arc).
8420 # Or both can be BMPs with no incoming arcs.
8421 if {$a eq $b || $arcnos($a) eq {}} {
8422 return 0
8424 # assert {[llength $arcnos($a)] == 1}
8425 set arc [lindex $arcnos($a) 0]
8426 set i [lsearch -exact $arcids($arc) $a]
8427 set j [lsearch -exact $arcids($arc) $b]
8428 if {$i < 0 || $i > $j} {
8429 return 1
8430 } else {
8431 return -1
8435 if {![info exists arcout($a)]} {
8436 set arc [lindex $arcnos($a) 0]
8437 if {[info exists arcend($arc)]} {
8438 set aend $arcend($arc)
8439 } else {
8440 set aend {}
8442 set a $arcstart($arc)
8443 } else {
8444 set aend $a
8446 if {![info exists arcout($b)]} {
8447 set arc [lindex $arcnos($b) 0]
8448 if {[info exists arcend($arc)]} {
8449 set bend $arcend($arc)
8450 } else {
8451 set bend {}
8453 set b $arcstart($arc)
8454 } else {
8455 set bend $b
8457 if {$a eq $bend} {
8458 return 1
8460 if {$b eq $aend} {
8461 return -1
8463 if {[info exists cached_isanc($a,$bend)]} {
8464 if {$cached_isanc($a,$bend)} {
8465 return 1
8468 if {[info exists cached_isanc($b,$aend)]} {
8469 if {$cached_isanc($b,$aend)} {
8470 return -1
8472 if {[info exists cached_isanc($a,$bend)]} {
8473 return 0
8477 set todo [list $a $b]
8478 set anc($a) a
8479 set anc($b) b
8480 for {set i 0} {$i < [llength $todo]} {incr i} {
8481 set x [lindex $todo $i]
8482 if {$anc($x) eq {}} {
8483 continue
8485 foreach arc $arcnos($x) {
8486 set xd $arcstart($arc)
8487 if {$xd eq $bend} {
8488 set cached_isanc($a,$bend) 1
8489 set cached_isanc($b,$aend) 0
8490 return 1
8491 } elseif {$xd eq $aend} {
8492 set cached_isanc($b,$aend) 1
8493 set cached_isanc($a,$bend) 0
8494 return -1
8496 if {![info exists anc($xd)]} {
8497 set anc($xd) $anc($x)
8498 lappend todo $xd
8499 } elseif {$anc($xd) ne $anc($x)} {
8500 set anc($xd) {}
8504 set cached_isanc($a,$bend) 0
8505 set cached_isanc($b,$aend) 0
8506 return 0
8509 # This identifies whether $desc has an ancestor that is
8510 # a growing tip of the graph and which is not an ancestor of $anc
8511 # and returns 0 if so and 1 if not.
8512 # If we subsequently discover a tag on such a growing tip, and that
8513 # turns out to be a descendent of $anc (which it could, since we
8514 # don't necessarily see children before parents), then $desc
8515 # isn't a good choice to display as a descendent tag of
8516 # $anc (since it is the descendent of another tag which is
8517 # a descendent of $anc). Similarly, $anc isn't a good choice to
8518 # display as a ancestor tag of $desc.
8520 proc is_certain {desc anc} {
8521 global arcnos arcout arcstart arcend growing problems
8523 set certain {}
8524 if {[llength $arcnos($anc)] == 1} {
8525 # tags on the same arc are certain
8526 if {$arcnos($desc) eq $arcnos($anc)} {
8527 return 1
8529 if {![info exists arcout($anc)]} {
8530 # if $anc is partway along an arc, use the start of the arc instead
8531 set a [lindex $arcnos($anc) 0]
8532 set anc $arcstart($a)
8535 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8536 set x $desc
8537 } else {
8538 set a [lindex $arcnos($desc) 0]
8539 set x $arcend($a)
8541 if {$x == $anc} {
8542 return 1
8544 set anclist [list $x]
8545 set dl($x) 1
8546 set nnh 1
8547 set ngrowanc 0
8548 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8549 set x [lindex $anclist $i]
8550 if {$dl($x)} {
8551 incr nnh -1
8553 set done($x) 1
8554 foreach a $arcout($x) {
8555 if {[info exists growing($a)]} {
8556 if {![info exists growanc($x)] && $dl($x)} {
8557 set growanc($x) 1
8558 incr ngrowanc
8560 } else {
8561 set y $arcend($a)
8562 if {[info exists dl($y)]} {
8563 if {$dl($y)} {
8564 if {!$dl($x)} {
8565 set dl($y) 0
8566 if {![info exists done($y)]} {
8567 incr nnh -1
8569 if {[info exists growanc($x)]} {
8570 incr ngrowanc -1
8572 set xl [list $y]
8573 for {set k 0} {$k < [llength $xl]} {incr k} {
8574 set z [lindex $xl $k]
8575 foreach c $arcout($z) {
8576 if {[info exists arcend($c)]} {
8577 set v $arcend($c)
8578 if {[info exists dl($v)] && $dl($v)} {
8579 set dl($v) 0
8580 if {![info exists done($v)]} {
8581 incr nnh -1
8583 if {[info exists growanc($v)]} {
8584 incr ngrowanc -1
8586 lappend xl $v
8593 } elseif {$y eq $anc || !$dl($x)} {
8594 set dl($y) 0
8595 lappend anclist $y
8596 } else {
8597 set dl($y) 1
8598 lappend anclist $y
8599 incr nnh
8604 foreach x [array names growanc] {
8605 if {$dl($x)} {
8606 return 0
8608 return 0
8610 return 1
8613 proc validate_arctags {a} {
8614 global arctags idtags
8616 set i -1
8617 set na $arctags($a)
8618 foreach id $arctags($a) {
8619 incr i
8620 if {![info exists idtags($id)]} {
8621 set na [lreplace $na $i $i]
8622 incr i -1
8625 set arctags($a) $na
8628 proc validate_archeads {a} {
8629 global archeads idheads
8631 set i -1
8632 set na $archeads($a)
8633 foreach id $archeads($a) {
8634 incr i
8635 if {![info exists idheads($id)]} {
8636 set na [lreplace $na $i $i]
8637 incr i -1
8640 set archeads($a) $na
8643 # Return the list of IDs that have tags that are descendents of id,
8644 # ignoring IDs that are descendents of IDs already reported.
8645 proc desctags {id} {
8646 global arcnos arcstart arcids arctags idtags allparents
8647 global growing cached_dtags
8649 if {![info exists allparents($id)]} {
8650 return {}
8652 set t1 [clock clicks -milliseconds]
8653 set argid $id
8654 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8655 # part-way along an arc; check that arc first
8656 set a [lindex $arcnos($id) 0]
8657 if {$arctags($a) ne {}} {
8658 validate_arctags $a
8659 set i [lsearch -exact $arcids($a) $id]
8660 set tid {}
8661 foreach t $arctags($a) {
8662 set j [lsearch -exact $arcids($a) $t]
8663 if {$j >= $i} break
8664 set tid $t
8666 if {$tid ne {}} {
8667 return $tid
8670 set id $arcstart($a)
8671 if {[info exists idtags($id)]} {
8672 return $id
8675 if {[info exists cached_dtags($id)]} {
8676 return $cached_dtags($id)
8679 set origid $id
8680 set todo [list $id]
8681 set queued($id) 1
8682 set nc 1
8683 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8684 set id [lindex $todo $i]
8685 set done($id) 1
8686 set ta [info exists hastaggedancestor($id)]
8687 if {!$ta} {
8688 incr nc -1
8690 # ignore tags on starting node
8691 if {!$ta && $i > 0} {
8692 if {[info exists idtags($id)]} {
8693 set tagloc($id) $id
8694 set ta 1
8695 } elseif {[info exists cached_dtags($id)]} {
8696 set tagloc($id) $cached_dtags($id)
8697 set ta 1
8700 foreach a $arcnos($id) {
8701 set d $arcstart($a)
8702 if {!$ta && $arctags($a) ne {}} {
8703 validate_arctags $a
8704 if {$arctags($a) ne {}} {
8705 lappend tagloc($id) [lindex $arctags($a) end]
8708 if {$ta || $arctags($a) ne {}} {
8709 set tomark [list $d]
8710 for {set j 0} {$j < [llength $tomark]} {incr j} {
8711 set dd [lindex $tomark $j]
8712 if {![info exists hastaggedancestor($dd)]} {
8713 if {[info exists done($dd)]} {
8714 foreach b $arcnos($dd) {
8715 lappend tomark $arcstart($b)
8717 if {[info exists tagloc($dd)]} {
8718 unset tagloc($dd)
8720 } elseif {[info exists queued($dd)]} {
8721 incr nc -1
8723 set hastaggedancestor($dd) 1
8727 if {![info exists queued($d)]} {
8728 lappend todo $d
8729 set queued($d) 1
8730 if {![info exists hastaggedancestor($d)]} {
8731 incr nc
8736 set tags {}
8737 foreach id [array names tagloc] {
8738 if {![info exists hastaggedancestor($id)]} {
8739 foreach t $tagloc($id) {
8740 if {[lsearch -exact $tags $t] < 0} {
8741 lappend tags $t
8746 set t2 [clock clicks -milliseconds]
8747 set loopix $i
8749 # remove tags that are descendents of other tags
8750 for {set i 0} {$i < [llength $tags]} {incr i} {
8751 set a [lindex $tags $i]
8752 for {set j 0} {$j < $i} {incr j} {
8753 set b [lindex $tags $j]
8754 set r [anc_or_desc $a $b]
8755 if {$r == 1} {
8756 set tags [lreplace $tags $j $j]
8757 incr j -1
8758 incr i -1
8759 } elseif {$r == -1} {
8760 set tags [lreplace $tags $i $i]
8761 incr i -1
8762 break
8767 if {[array names growing] ne {}} {
8768 # graph isn't finished, need to check if any tag could get
8769 # eclipsed by another tag coming later. Simply ignore any
8770 # tags that could later get eclipsed.
8771 set ctags {}
8772 foreach t $tags {
8773 if {[is_certain $t $origid]} {
8774 lappend ctags $t
8777 if {$tags eq $ctags} {
8778 set cached_dtags($origid) $tags
8779 } else {
8780 set tags $ctags
8782 } else {
8783 set cached_dtags($origid) $tags
8785 set t3 [clock clicks -milliseconds]
8786 if {0 && $t3 - $t1 >= 100} {
8787 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8788 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8790 return $tags
8793 proc anctags {id} {
8794 global arcnos arcids arcout arcend arctags idtags allparents
8795 global growing cached_atags
8797 if {![info exists allparents($id)]} {
8798 return {}
8800 set t1 [clock clicks -milliseconds]
8801 set argid $id
8802 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8803 # part-way along an arc; check that arc first
8804 set a [lindex $arcnos($id) 0]
8805 if {$arctags($a) ne {}} {
8806 validate_arctags $a
8807 set i [lsearch -exact $arcids($a) $id]
8808 foreach t $arctags($a) {
8809 set j [lsearch -exact $arcids($a) $t]
8810 if {$j > $i} {
8811 return $t
8815 if {![info exists arcend($a)]} {
8816 return {}
8818 set id $arcend($a)
8819 if {[info exists idtags($id)]} {
8820 return $id
8823 if {[info exists cached_atags($id)]} {
8824 return $cached_atags($id)
8827 set origid $id
8828 set todo [list $id]
8829 set queued($id) 1
8830 set taglist {}
8831 set nc 1
8832 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8833 set id [lindex $todo $i]
8834 set done($id) 1
8835 set td [info exists hastaggeddescendent($id)]
8836 if {!$td} {
8837 incr nc -1
8839 # ignore tags on starting node
8840 if {!$td && $i > 0} {
8841 if {[info exists idtags($id)]} {
8842 set tagloc($id) $id
8843 set td 1
8844 } elseif {[info exists cached_atags($id)]} {
8845 set tagloc($id) $cached_atags($id)
8846 set td 1
8849 foreach a $arcout($id) {
8850 if {!$td && $arctags($a) ne {}} {
8851 validate_arctags $a
8852 if {$arctags($a) ne {}} {
8853 lappend tagloc($id) [lindex $arctags($a) 0]
8856 if {![info exists arcend($a)]} continue
8857 set d $arcend($a)
8858 if {$td || $arctags($a) ne {}} {
8859 set tomark [list $d]
8860 for {set j 0} {$j < [llength $tomark]} {incr j} {
8861 set dd [lindex $tomark $j]
8862 if {![info exists hastaggeddescendent($dd)]} {
8863 if {[info exists done($dd)]} {
8864 foreach b $arcout($dd) {
8865 if {[info exists arcend($b)]} {
8866 lappend tomark $arcend($b)
8869 if {[info exists tagloc($dd)]} {
8870 unset tagloc($dd)
8872 } elseif {[info exists queued($dd)]} {
8873 incr nc -1
8875 set hastaggeddescendent($dd) 1
8879 if {![info exists queued($d)]} {
8880 lappend todo $d
8881 set queued($d) 1
8882 if {![info exists hastaggeddescendent($d)]} {
8883 incr nc
8888 set t2 [clock clicks -milliseconds]
8889 set loopix $i
8890 set tags {}
8891 foreach id [array names tagloc] {
8892 if {![info exists hastaggeddescendent($id)]} {
8893 foreach t $tagloc($id) {
8894 if {[lsearch -exact $tags $t] < 0} {
8895 lappend tags $t
8901 # remove tags that are ancestors of other tags
8902 for {set i 0} {$i < [llength $tags]} {incr i} {
8903 set a [lindex $tags $i]
8904 for {set j 0} {$j < $i} {incr j} {
8905 set b [lindex $tags $j]
8906 set r [anc_or_desc $a $b]
8907 if {$r == -1} {
8908 set tags [lreplace $tags $j $j]
8909 incr j -1
8910 incr i -1
8911 } elseif {$r == 1} {
8912 set tags [lreplace $tags $i $i]
8913 incr i -1
8914 break
8919 if {[array names growing] ne {}} {
8920 # graph isn't finished, need to check if any tag could get
8921 # eclipsed by another tag coming later. Simply ignore any
8922 # tags that could later get eclipsed.
8923 set ctags {}
8924 foreach t $tags {
8925 if {[is_certain $origid $t]} {
8926 lappend ctags $t
8929 if {$tags eq $ctags} {
8930 set cached_atags($origid) $tags
8931 } else {
8932 set tags $ctags
8934 } else {
8935 set cached_atags($origid) $tags
8937 set t3 [clock clicks -milliseconds]
8938 if {0 && $t3 - $t1 >= 100} {
8939 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8940 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8942 return $tags
8945 # Return the list of IDs that have heads that are descendents of id,
8946 # including id itself if it has a head.
8947 proc descheads {id} {
8948 global arcnos arcstart arcids archeads idheads cached_dheads
8949 global allparents
8951 if {![info exists allparents($id)]} {
8952 return {}
8954 set aret {}
8955 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8956 # part-way along an arc; check it first
8957 set a [lindex $arcnos($id) 0]
8958 if {$archeads($a) ne {}} {
8959 validate_archeads $a
8960 set i [lsearch -exact $arcids($a) $id]
8961 foreach t $archeads($a) {
8962 set j [lsearch -exact $arcids($a) $t]
8963 if {$j > $i} break
8964 lappend aret $t
8967 set id $arcstart($a)
8969 set origid $id
8970 set todo [list $id]
8971 set seen($id) 1
8972 set ret {}
8973 for {set i 0} {$i < [llength $todo]} {incr i} {
8974 set id [lindex $todo $i]
8975 if {[info exists cached_dheads($id)]} {
8976 set ret [concat $ret $cached_dheads($id)]
8977 } else {
8978 if {[info exists idheads($id)]} {
8979 lappend ret $id
8981 foreach a $arcnos($id) {
8982 if {$archeads($a) ne {}} {
8983 validate_archeads $a
8984 if {$archeads($a) ne {}} {
8985 set ret [concat $ret $archeads($a)]
8988 set d $arcstart($a)
8989 if {![info exists seen($d)]} {
8990 lappend todo $d
8991 set seen($d) 1
8996 set ret [lsort -unique $ret]
8997 set cached_dheads($origid) $ret
8998 return [concat $ret $aret]
9001 proc addedtag {id} {
9002 global arcnos arcout cached_dtags cached_atags
9004 if {![info exists arcnos($id)]} return
9005 if {![info exists arcout($id)]} {
9006 recalcarc [lindex $arcnos($id) 0]
9008 catch {unset cached_dtags}
9009 catch {unset cached_atags}
9012 proc addedhead {hid head} {
9013 global arcnos arcout cached_dheads
9015 if {![info exists arcnos($hid)]} return
9016 if {![info exists arcout($hid)]} {
9017 recalcarc [lindex $arcnos($hid) 0]
9019 catch {unset cached_dheads}
9022 proc removedhead {hid head} {
9023 global cached_dheads
9025 catch {unset cached_dheads}
9028 proc movedhead {hid head} {
9029 global arcnos arcout cached_dheads
9031 if {![info exists arcnos($hid)]} return
9032 if {![info exists arcout($hid)]} {
9033 recalcarc [lindex $arcnos($hid) 0]
9035 catch {unset cached_dheads}
9038 proc changedrefs {} {
9039 global cached_dheads cached_dtags cached_atags
9040 global arctags archeads arcnos arcout idheads idtags
9042 foreach id [concat [array names idheads] [array names idtags]] {
9043 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9044 set a [lindex $arcnos($id) 0]
9045 if {![info exists donearc($a)]} {
9046 recalcarc $a
9047 set donearc($a) 1
9051 catch {unset cached_dtags}
9052 catch {unset cached_atags}
9053 catch {unset cached_dheads}
9056 proc rereadrefs {} {
9057 global idtags idheads idotherrefs mainheadid
9059 set refids [concat [array names idtags] \
9060 [array names idheads] [array names idotherrefs]]
9061 foreach id $refids {
9062 if {![info exists ref($id)]} {
9063 set ref($id) [listrefs $id]
9066 set oldmainhead $mainheadid
9067 readrefs
9068 changedrefs
9069 set refids [lsort -unique [concat $refids [array names idtags] \
9070 [array names idheads] [array names idotherrefs]]]
9071 foreach id $refids {
9072 set v [listrefs $id]
9073 if {![info exists ref($id)] || $ref($id) != $v} {
9074 redrawtags $id
9077 if {$oldmainhead ne $mainheadid} {
9078 redrawtags $oldmainhead
9079 redrawtags $mainheadid
9081 run refill_reflist
9084 proc listrefs {id} {
9085 global idtags idheads idotherrefs
9087 set x {}
9088 if {[info exists idtags($id)]} {
9089 set x $idtags($id)
9091 set y {}
9092 if {[info exists idheads($id)]} {
9093 set y $idheads($id)
9095 set z {}
9096 if {[info exists idotherrefs($id)]} {
9097 set z $idotherrefs($id)
9099 return [list $x $y $z]
9102 proc showtag {tag isnew} {
9103 global ctext tagcontents tagids linknum tagobjid
9105 if {$isnew} {
9106 addtohistory [list showtag $tag 0]
9108 $ctext conf -state normal
9109 clear_ctext
9110 settabs 0
9111 set linknum 0
9112 if {![info exists tagcontents($tag)]} {
9113 catch {
9114 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9117 if {[info exists tagcontents($tag)]} {
9118 set text $tagcontents($tag)
9119 } else {
9120 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9122 appendwithlinks $text {}
9123 $ctext conf -state disabled
9124 init_flist {}
9127 proc doquit {} {
9128 global stopped
9129 global gitktmpdir
9131 set stopped 100
9132 savestuff .
9133 destroy .
9135 if {[info exists gitktmpdir]} {
9136 catch {file delete -force $gitktmpdir}
9140 proc mkfontdisp {font top which} {
9141 global fontattr fontpref $font
9143 set fontpref($font) [set $font]
9144 button $top.${font}but -text $which -font optionfont \
9145 -command [list choosefont $font $which]
9146 label $top.$font -relief flat -font $font \
9147 -text $fontattr($font,family) -justify left
9148 grid x $top.${font}but $top.$font -sticky w
9151 proc choosefont {font which} {
9152 global fontparam fontlist fonttop fontattr
9154 set fontparam(which) $which
9155 set fontparam(font) $font
9156 set fontparam(family) [font actual $font -family]
9157 set fontparam(size) $fontattr($font,size)
9158 set fontparam(weight) $fontattr($font,weight)
9159 set fontparam(slant) $fontattr($font,slant)
9160 set top .gitkfont
9161 set fonttop $top
9162 if {![winfo exists $top]} {
9163 font create sample
9164 eval font config sample [font actual $font]
9165 toplevel $top
9166 wm title $top [mc "Gitk font chooser"]
9167 label $top.l -textvariable fontparam(which)
9168 pack $top.l -side top
9169 set fontlist [lsort [font families]]
9170 frame $top.f
9171 listbox $top.f.fam -listvariable fontlist \
9172 -yscrollcommand [list $top.f.sb set]
9173 bind $top.f.fam <<ListboxSelect>> selfontfam
9174 scrollbar $top.f.sb -command [list $top.f.fam yview]
9175 pack $top.f.sb -side right -fill y
9176 pack $top.f.fam -side left -fill both -expand 1
9177 pack $top.f -side top -fill both -expand 1
9178 frame $top.g
9179 spinbox $top.g.size -from 4 -to 40 -width 4 \
9180 -textvariable fontparam(size) \
9181 -validatecommand {string is integer -strict %s}
9182 checkbutton $top.g.bold -padx 5 \
9183 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9184 -variable fontparam(weight) -onvalue bold -offvalue normal
9185 checkbutton $top.g.ital -padx 5 \
9186 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9187 -variable fontparam(slant) -onvalue italic -offvalue roman
9188 pack $top.g.size $top.g.bold $top.g.ital -side left
9189 pack $top.g -side top
9190 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9191 -background white
9192 $top.c create text 100 25 -anchor center -text $which -font sample \
9193 -fill black -tags text
9194 bind $top.c <Configure> [list centertext $top.c]
9195 pack $top.c -side top -fill x
9196 frame $top.buts
9197 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9198 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9199 grid $top.buts.ok $top.buts.can
9200 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9201 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9202 pack $top.buts -side bottom -fill x
9203 trace add variable fontparam write chg_fontparam
9204 } else {
9205 raise $top
9206 $top.c itemconf text -text $which
9208 set i [lsearch -exact $fontlist $fontparam(family)]
9209 if {$i >= 0} {
9210 $top.f.fam selection set $i
9211 $top.f.fam see $i
9215 proc centertext {w} {
9216 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9219 proc fontok {} {
9220 global fontparam fontpref prefstop
9222 set f $fontparam(font)
9223 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9224 if {$fontparam(weight) eq "bold"} {
9225 lappend fontpref($f) "bold"
9227 if {$fontparam(slant) eq "italic"} {
9228 lappend fontpref($f) "italic"
9230 set w $prefstop.$f
9231 $w conf -text $fontparam(family) -font $fontpref($f)
9233 fontcan
9236 proc fontcan {} {
9237 global fonttop fontparam
9239 if {[info exists fonttop]} {
9240 catch {destroy $fonttop}
9241 catch {font delete sample}
9242 unset fonttop
9243 unset fontparam
9247 proc selfontfam {} {
9248 global fonttop fontparam
9250 set i [$fonttop.f.fam curselection]
9251 if {$i ne {}} {
9252 set fontparam(family) [$fonttop.f.fam get $i]
9256 proc chg_fontparam {v sub op} {
9257 global fontparam
9259 font config sample -$sub $fontparam($sub)
9262 proc doprefs {} {
9263 global maxwidth maxgraphpct
9264 global oldprefs prefstop showneartags showlocalchanges
9265 global bgcolor fgcolor ctext diffcolors selectbgcolor
9266 global tabstop limitdiffs autoselect extdifftool
9268 set top .gitkprefs
9269 set prefstop $top
9270 if {[winfo exists $top]} {
9271 raise $top
9272 return
9274 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9275 limitdiffs tabstop} {
9276 set oldprefs($v) [set $v]
9278 toplevel $top
9279 wm title $top [mc "Gitk preferences"]
9280 label $top.ldisp -text [mc "Commit list display options"]
9281 grid $top.ldisp - -sticky w -pady 10
9282 label $top.spacer -text " "
9283 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9284 -font optionfont
9285 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9286 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9287 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9288 -font optionfont
9289 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9290 grid x $top.maxpctl $top.maxpct -sticky w
9291 frame $top.showlocal
9292 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9293 checkbutton $top.showlocal.b -variable showlocalchanges
9294 pack $top.showlocal.b $top.showlocal.l -side left
9295 grid x $top.showlocal -sticky w
9296 frame $top.autoselect
9297 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9298 checkbutton $top.autoselect.b -variable autoselect
9299 pack $top.autoselect.b $top.autoselect.l -side left
9300 grid x $top.autoselect -sticky w
9302 label $top.ddisp -text [mc "Diff display options"]
9303 grid $top.ddisp - -sticky w -pady 10
9304 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9305 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9306 grid x $top.tabstopl $top.tabstop -sticky w
9307 frame $top.ntag
9308 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9309 checkbutton $top.ntag.b -variable showneartags
9310 pack $top.ntag.b $top.ntag.l -side left
9311 grid x $top.ntag -sticky w
9312 frame $top.ldiff
9313 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9314 checkbutton $top.ldiff.b -variable limitdiffs
9315 pack $top.ldiff.b $top.ldiff.l -side left
9316 grid x $top.ldiff -sticky w
9318 entry $top.extdifft -textvariable extdifftool
9319 frame $top.extdifff
9320 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9321 -padx 10
9322 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9323 -command choose_extdiff
9324 pack $top.extdifff.l $top.extdifff.b -side left
9325 grid x $top.extdifff $top.extdifft -sticky w
9327 label $top.cdisp -text [mc "Colors: press to choose"]
9328 grid $top.cdisp - -sticky w -pady 10
9329 label $top.bg -padx 40 -relief sunk -background $bgcolor
9330 button $top.bgbut -text [mc "Background"] -font optionfont \
9331 -command [list choosecolor bgcolor {} $top.bg background setbg]
9332 grid x $top.bgbut $top.bg -sticky w
9333 label $top.fg -padx 40 -relief sunk -background $fgcolor
9334 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9335 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9336 grid x $top.fgbut $top.fg -sticky w
9337 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9338 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9339 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9340 [list $ctext tag conf d0 -foreground]]
9341 grid x $top.diffoldbut $top.diffold -sticky w
9342 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9343 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9344 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9345 [list $ctext tag conf d1 -foreground]]
9346 grid x $top.diffnewbut $top.diffnew -sticky w
9347 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9348 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9349 -command [list choosecolor diffcolors 2 $top.hunksep \
9350 "diff hunk header" \
9351 [list $ctext tag conf hunksep -foreground]]
9352 grid x $top.hunksepbut $top.hunksep -sticky w
9353 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9354 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9355 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9356 grid x $top.selbgbut $top.selbgsep -sticky w
9358 label $top.cfont -text [mc "Fonts: press to choose"]
9359 grid $top.cfont - -sticky w -pady 10
9360 mkfontdisp mainfont $top [mc "Main font"]
9361 mkfontdisp textfont $top [mc "Diff display font"]
9362 mkfontdisp uifont $top [mc "User interface font"]
9364 frame $top.buts
9365 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9366 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9367 grid $top.buts.ok $top.buts.can
9368 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9369 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9370 grid $top.buts - - -pady 10 -sticky ew
9371 bind $top <Visibility> "focus $top.buts.ok"
9374 proc choose_extdiff {} {
9375 global extdifftool
9377 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9378 if {$prog ne {}} {
9379 set extdifftool $prog
9383 proc choosecolor {v vi w x cmd} {
9384 global $v
9386 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9387 -title [mc "Gitk: choose color for %s" $x]]
9388 if {$c eq {}} return
9389 $w conf -background $c
9390 lset $v $vi $c
9391 eval $cmd $c
9394 proc setselbg {c} {
9395 global bglist cflist
9396 foreach w $bglist {
9397 $w configure -selectbackground $c
9399 $cflist tag configure highlight \
9400 -background [$cflist cget -selectbackground]
9401 allcanvs itemconf secsel -fill $c
9404 proc setbg {c} {
9405 global bglist
9407 foreach w $bglist {
9408 $w conf -background $c
9412 proc setfg {c} {
9413 global fglist canv
9415 foreach w $fglist {
9416 $w conf -foreground $c
9418 allcanvs itemconf text -fill $c
9419 $canv itemconf circle -outline $c
9422 proc prefscan {} {
9423 global oldprefs prefstop
9425 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9426 limitdiffs tabstop} {
9427 global $v
9428 set $v $oldprefs($v)
9430 catch {destroy $prefstop}
9431 unset prefstop
9432 fontcan
9435 proc prefsok {} {
9436 global maxwidth maxgraphpct
9437 global oldprefs prefstop showneartags showlocalchanges
9438 global fontpref mainfont textfont uifont
9439 global limitdiffs treediffs
9441 catch {destroy $prefstop}
9442 unset prefstop
9443 fontcan
9444 set fontchanged 0
9445 if {$mainfont ne $fontpref(mainfont)} {
9446 set mainfont $fontpref(mainfont)
9447 parsefont mainfont $mainfont
9448 eval font configure mainfont [fontflags mainfont]
9449 eval font configure mainfontbold [fontflags mainfont 1]
9450 setcoords
9451 set fontchanged 1
9453 if {$textfont ne $fontpref(textfont)} {
9454 set textfont $fontpref(textfont)
9455 parsefont textfont $textfont
9456 eval font configure textfont [fontflags textfont]
9457 eval font configure textfontbold [fontflags textfont 1]
9459 if {$uifont ne $fontpref(uifont)} {
9460 set uifont $fontpref(uifont)
9461 parsefont uifont $uifont
9462 eval font configure uifont [fontflags uifont]
9464 settabs
9465 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9466 if {$showlocalchanges} {
9467 doshowlocalchanges
9468 } else {
9469 dohidelocalchanges
9472 if {$limitdiffs != $oldprefs(limitdiffs)} {
9473 # treediffs elements are limited by path
9474 catch {unset treediffs}
9476 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9477 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9478 redisplay
9479 } elseif {$showneartags != $oldprefs(showneartags) ||
9480 $limitdiffs != $oldprefs(limitdiffs)} {
9481 reselectline
9485 proc formatdate {d} {
9486 global datetimeformat
9487 if {$d ne {}} {
9488 set d [clock format $d -format $datetimeformat]
9490 return $d
9493 # This list of encoding names and aliases is distilled from
9494 # http://www.iana.org/assignments/character-sets.
9495 # Not all of them are supported by Tcl.
9496 set encoding_aliases {
9497 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9498 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9499 { ISO-10646-UTF-1 csISO10646UTF1 }
9500 { ISO_646.basic:1983 ref csISO646basic1983 }
9501 { INVARIANT csINVARIANT }
9502 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9503 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9504 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9505 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9506 { NATS-DANO iso-ir-9-1 csNATSDANO }
9507 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9508 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9509 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9510 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9511 { ISO-2022-KR csISO2022KR }
9512 { EUC-KR csEUCKR }
9513 { ISO-2022-JP csISO2022JP }
9514 { ISO-2022-JP-2 csISO2022JP2 }
9515 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9516 csISO13JISC6220jp }
9517 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9518 { IT iso-ir-15 ISO646-IT csISO15Italian }
9519 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9520 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9521 { greek7-old iso-ir-18 csISO18Greek7Old }
9522 { latin-greek iso-ir-19 csISO19LatinGreek }
9523 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9524 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9525 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9526 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9527 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9528 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9529 { INIS iso-ir-49 csISO49INIS }
9530 { INIS-8 iso-ir-50 csISO50INIS8 }
9531 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9532 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9533 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9534 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9535 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9536 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9537 csISO60Norwegian1 }
9538 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9539 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9540 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9541 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9542 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9543 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9544 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9545 { greek7 iso-ir-88 csISO88Greek7 }
9546 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9547 { iso-ir-90 csISO90 }
9548 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9549 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9550 csISO92JISC62991984b }
9551 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9552 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9553 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9554 csISO95JIS62291984handadd }
9555 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9556 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9557 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9558 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9559 CP819 csISOLatin1 }
9560 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9561 { T.61-7bit iso-ir-102 csISO102T617bit }
9562 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9563 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9564 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9565 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9566 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9567 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9568 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9569 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9570 arabic csISOLatinArabic }
9571 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9572 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9573 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9574 greek greek8 csISOLatinGreek }
9575 { T.101-G2 iso-ir-128 csISO128T101G2 }
9576 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9577 csISOLatinHebrew }
9578 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9579 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9580 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9581 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9582 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9583 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9584 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9585 csISOLatinCyrillic }
9586 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9587 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9588 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9589 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9590 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9591 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9592 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9593 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9594 { ISO_10367-box iso-ir-155 csISO10367Box }
9595 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9596 { latin-lap lap iso-ir-158 csISO158Lap }
9597 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9598 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9599 { us-dk csUSDK }
9600 { dk-us csDKUS }
9601 { JIS_X0201 X0201 csHalfWidthKatakana }
9602 { KSC5636 ISO646-KR csKSC5636 }
9603 { ISO-10646-UCS-2 csUnicode }
9604 { ISO-10646-UCS-4 csUCS4 }
9605 { DEC-MCS dec csDECMCS }
9606 { hp-roman8 roman8 r8 csHPRoman8 }
9607 { macintosh mac csMacintosh }
9608 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9609 csIBM037 }
9610 { IBM038 EBCDIC-INT cp038 csIBM038 }
9611 { IBM273 CP273 csIBM273 }
9612 { IBM274 EBCDIC-BE CP274 csIBM274 }
9613 { IBM275 EBCDIC-BR cp275 csIBM275 }
9614 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9615 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9616 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9617 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9618 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9619 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9620 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9621 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9622 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9623 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9624 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9625 { IBM437 cp437 437 csPC8CodePage437 }
9626 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9627 { IBM775 cp775 csPC775Baltic }
9628 { IBM850 cp850 850 csPC850Multilingual }
9629 { IBM851 cp851 851 csIBM851 }
9630 { IBM852 cp852 852 csPCp852 }
9631 { IBM855 cp855 855 csIBM855 }
9632 { IBM857 cp857 857 csIBM857 }
9633 { IBM860 cp860 860 csIBM860 }
9634 { IBM861 cp861 861 cp-is csIBM861 }
9635 { IBM862 cp862 862 csPC862LatinHebrew }
9636 { IBM863 cp863 863 csIBM863 }
9637 { IBM864 cp864 csIBM864 }
9638 { IBM865 cp865 865 csIBM865 }
9639 { IBM866 cp866 866 csIBM866 }
9640 { IBM868 CP868 cp-ar csIBM868 }
9641 { IBM869 cp869 869 cp-gr csIBM869 }
9642 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9643 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9644 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9645 { IBM891 cp891 csIBM891 }
9646 { IBM903 cp903 csIBM903 }
9647 { IBM904 cp904 904 csIBBM904 }
9648 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9649 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9650 { IBM1026 CP1026 csIBM1026 }
9651 { EBCDIC-AT-DE csIBMEBCDICATDE }
9652 { EBCDIC-AT-DE-A csEBCDICATDEA }
9653 { EBCDIC-CA-FR csEBCDICCAFR }
9654 { EBCDIC-DK-NO csEBCDICDKNO }
9655 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9656 { EBCDIC-FI-SE csEBCDICFISE }
9657 { EBCDIC-FI-SE-A csEBCDICFISEA }
9658 { EBCDIC-FR csEBCDICFR }
9659 { EBCDIC-IT csEBCDICIT }
9660 { EBCDIC-PT csEBCDICPT }
9661 { EBCDIC-ES csEBCDICES }
9662 { EBCDIC-ES-A csEBCDICESA }
9663 { EBCDIC-ES-S csEBCDICESS }
9664 { EBCDIC-UK csEBCDICUK }
9665 { EBCDIC-US csEBCDICUS }
9666 { UNKNOWN-8BIT csUnknown8BiT }
9667 { MNEMONIC csMnemonic }
9668 { MNEM csMnem }
9669 { VISCII csVISCII }
9670 { VIQR csVIQR }
9671 { KOI8-R csKOI8R }
9672 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9673 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9674 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9675 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9676 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9677 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9678 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9679 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9680 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9681 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9682 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9683 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9684 { IBM1047 IBM-1047 }
9685 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9686 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9687 { UNICODE-1-1 csUnicode11 }
9688 { CESU-8 csCESU-8 }
9689 { BOCU-1 csBOCU-1 }
9690 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9691 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9692 l8 }
9693 { ISO-8859-15 ISO_8859-15 Latin-9 }
9694 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9695 { GBK CP936 MS936 windows-936 }
9696 { JIS_Encoding csJISEncoding }
9697 { Shift_JIS MS_Kanji csShiftJIS }
9698 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9699 EUC-JP }
9700 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9701 { ISO-10646-UCS-Basic csUnicodeASCII }
9702 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9703 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9704 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9705 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9706 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9707 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9708 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9709 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9710 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9711 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9712 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9713 { Ventura-US csVenturaUS }
9714 { Ventura-International csVenturaInternational }
9715 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9716 { PC8-Turkish csPC8Turkish }
9717 { IBM-Symbols csIBMSymbols }
9718 { IBM-Thai csIBMThai }
9719 { HP-Legal csHPLegal }
9720 { HP-Pi-font csHPPiFont }
9721 { HP-Math8 csHPMath8 }
9722 { Adobe-Symbol-Encoding csHPPSMath }
9723 { HP-DeskTop csHPDesktop }
9724 { Ventura-Math csVenturaMath }
9725 { Microsoft-Publishing csMicrosoftPublishing }
9726 { Windows-31J csWindows31J }
9727 { GB2312 csGB2312 }
9728 { Big5 csBig5 }
9731 proc tcl_encoding {enc} {
9732 global encoding_aliases
9733 set names [encoding names]
9734 set lcnames [string tolower $names]
9735 set enc [string tolower $enc]
9736 set i [lsearch -exact $lcnames $enc]
9737 if {$i < 0} {
9738 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9739 if {[regsub {^iso[-_]} $enc iso encx]} {
9740 set i [lsearch -exact $lcnames $encx]
9743 if {$i < 0} {
9744 foreach l $encoding_aliases {
9745 set ll [string tolower $l]
9746 if {[lsearch -exact $ll $enc] < 0} continue
9747 # look through the aliases for one that tcl knows about
9748 foreach e $ll {
9749 set i [lsearch -exact $lcnames $e]
9750 if {$i < 0} {
9751 if {[regsub {^iso[-_]} $e iso ex]} {
9752 set i [lsearch -exact $lcnames $ex]
9755 if {$i >= 0} break
9757 break
9760 if {$i >= 0} {
9761 return [lindex $names $i]
9763 return {}
9766 # First check that Tcl/Tk is recent enough
9767 if {[catch {package require Tk 8.4} err]} {
9768 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9769 Gitk requires at least Tcl/Tk 8.4."]
9770 exit 1
9773 # defaults...
9774 set wrcomcmd "git diff-tree --stdin -p --pretty"
9776 set gitencoding {}
9777 catch {
9778 set gitencoding [exec git config --get i18n.commitencoding]
9780 if {$gitencoding == ""} {
9781 set gitencoding "utf-8"
9783 set tclencoding [tcl_encoding $gitencoding]
9784 if {$tclencoding == {}} {
9785 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9788 set mainfont {Helvetica 9}
9789 set textfont {Courier 9}
9790 set uifont {Helvetica 9 bold}
9791 set tabstop 8
9792 set findmergefiles 0
9793 set maxgraphpct 50
9794 set maxwidth 16
9795 set revlistorder 0
9796 set fastdate 0
9797 set uparrowlen 5
9798 set downarrowlen 5
9799 set mingaplen 100
9800 set cmitmode "patch"
9801 set wrapcomment "none"
9802 set showneartags 1
9803 set maxrefs 20
9804 set maxlinelen 200
9805 set showlocalchanges 1
9806 set limitdiffs 1
9807 set datetimeformat "%Y-%m-%d %H:%M:%S"
9808 set autoselect 1
9810 set extdifftool "meld"
9812 set colors {green red blue magenta darkgrey brown orange}
9813 set bgcolor white
9814 set fgcolor black
9815 set diffcolors {red "#00a000" blue}
9816 set diffcontext 3
9817 set ignorespace 0
9818 set selectbgcolor gray85
9820 set circlecolors {white blue gray blue blue}
9822 ## For msgcat loading, first locate the installation location.
9823 if { [info exists ::env(GITK_MSGSDIR)] } {
9824 ## Msgsdir was manually set in the environment.
9825 set gitk_msgsdir $::env(GITK_MSGSDIR)
9826 } else {
9827 ## Let's guess the prefix from argv0.
9828 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9829 set gitk_libdir [file join $gitk_prefix share gitk lib]
9830 set gitk_msgsdir [file join $gitk_libdir msgs]
9831 unset gitk_prefix
9834 ## Internationalization (i18n) through msgcat and gettext. See
9835 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9836 package require msgcat
9837 namespace import ::msgcat::mc
9838 ## And eventually load the actual message catalog
9839 ::msgcat::mcload $gitk_msgsdir
9841 catch {source ~/.gitk}
9843 font create optionfont -family sans-serif -size -12
9845 parsefont mainfont $mainfont
9846 eval font create mainfont [fontflags mainfont]
9847 eval font create mainfontbold [fontflags mainfont 1]
9849 parsefont textfont $textfont
9850 eval font create textfont [fontflags textfont]
9851 eval font create textfontbold [fontflags textfont 1]
9853 parsefont uifont $uifont
9854 eval font create uifont [fontflags uifont]
9856 setoptions
9858 # check that we can find a .git directory somewhere...
9859 if {[catch {set gitdir [gitdir]}]} {
9860 show_error {} . [mc "Cannot find a git repository here."]
9861 exit 1
9863 if {![file isdirectory $gitdir]} {
9864 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9865 exit 1
9868 set revtreeargs {}
9869 set cmdline_files {}
9870 set i 0
9871 set revtreeargscmd {}
9872 foreach arg $argv {
9873 switch -glob -- $arg {
9874 "" { }
9875 "--" {
9876 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9877 break
9879 "--argscmd=*" {
9880 set revtreeargscmd [string range $arg 10 end]
9882 default {
9883 lappend revtreeargs $arg
9886 incr i
9889 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9890 # no -- on command line, but some arguments (other than --argscmd)
9891 if {[catch {
9892 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9893 set cmdline_files [split $f "\n"]
9894 set n [llength $cmdline_files]
9895 set revtreeargs [lrange $revtreeargs 0 end-$n]
9896 # Unfortunately git rev-parse doesn't produce an error when
9897 # something is both a revision and a filename. To be consistent
9898 # with git log and git rev-list, check revtreeargs for filenames.
9899 foreach arg $revtreeargs {
9900 if {[file exists $arg]} {
9901 show_error {} . [mc "Ambiguous argument '%s': both revision\
9902 and filename" $arg]
9903 exit 1
9906 } err]} {
9907 # unfortunately we get both stdout and stderr in $err,
9908 # so look for "fatal:".
9909 set i [string first "fatal:" $err]
9910 if {$i > 0} {
9911 set err [string range $err [expr {$i + 6}] end]
9913 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9914 exit 1
9918 set nullid "0000000000000000000000000000000000000000"
9919 set nullid2 "0000000000000000000000000000000000000001"
9920 set nullfile "/dev/null"
9922 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9924 set runq {}
9925 set history {}
9926 set historyindex 0
9927 set fh_serial 0
9928 set nhl_names {}
9929 set highlight_paths {}
9930 set findpattern {}
9931 set searchdirn -forwards
9932 set boldrows {}
9933 set boldnamerows {}
9934 set diffelide {0 0}
9935 set markingmatches 0
9936 set linkentercount 0
9937 set need_redisplay 0
9938 set nrows_drawn 0
9939 set firsttabstop 0
9941 set nextviewnum 1
9942 set curview 0
9943 set selectedview 0
9944 set selectedhlview [mc "None"]
9945 set highlight_related [mc "None"]
9946 set highlight_files {}
9947 set viewfiles(0) {}
9948 set viewperm(0) 0
9949 set viewargs(0) {}
9950 set viewargscmd(0) {}
9952 set selectedline {}
9953 set numcommits 0
9954 set loginstance 0
9955 set cmdlineok 0
9956 set stopped 0
9957 set stuffsaved 0
9958 set patchnum 0
9959 set lserial 0
9960 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9961 setcoords
9962 makewindow
9963 # wait for the window to become visible
9964 tkwait visibility .
9965 wm title . "[file tail $argv0]: [file tail [pwd]]"
9966 readrefs
9968 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9969 # create a view for the files/dirs specified on the command line
9970 set curview 1
9971 set selectedview 1
9972 set nextviewnum 2
9973 set viewname(1) [mc "Command line"]
9974 set viewfiles(1) $cmdline_files
9975 set viewargs(1) $revtreeargs
9976 set viewargscmd(1) $revtreeargscmd
9977 set viewperm(1) 0
9978 set vdatemode(1) 0
9979 addviewmenu 1
9980 .bar.view entryconf [mc "Edit view..."] -state normal
9981 .bar.view entryconf [mc "Delete view"] -state normal
9984 if {[info exists permviews]} {
9985 foreach v $permviews {
9986 set n $nextviewnum
9987 incr nextviewnum
9988 set viewname($n) [lindex $v 0]
9989 set viewfiles($n) [lindex $v 1]
9990 set viewargs($n) [lindex $v 2]
9991 set viewargscmd($n) [lindex $v 3]
9992 set viewperm($n) 1
9993 addviewmenu $n
9996 getcommits {}