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