gitk: Update Swedish translation (290t)
[alt-git.git] / gitk
blob45e33806b0297dad46adbf9214f6498734c4c6e6
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2009 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 package require Tk
12 proc gitdir {} {
13 global env
14 if {[info exists env(GIT_DIR)]} {
15 return $env(GIT_DIR)
16 } else {
17 return [exec git rev-parse --git-dir]
21 # A simple scheduler for compute-intensive stuff.
22 # The aim is to make sure that event handlers for GUI actions can
23 # run at least every 50-100 ms. Unfortunately fileevent handlers are
24 # run before X event handlers, so reading from a fast source can
25 # make the GUI completely unresponsive.
26 proc run args {
27 global isonrunq runq currunq
29 set script $args
30 if {[info exists isonrunq($script)]} return
31 if {$runq eq {} && ![info exists currunq]} {
32 after idle dorunq
34 lappend runq [list {} $script]
35 set isonrunq($script) 1
38 proc filerun {fd script} {
39 fileevent $fd readable [list filereadable $fd $script]
42 proc filereadable {fd script} {
43 global runq currunq
45 fileevent $fd readable {}
46 if {$runq eq {} && ![info exists currunq]} {
47 after idle dorunq
49 lappend runq [list $fd $script]
52 proc nukefile {fd} {
53 global runq
55 for {set i 0} {$i < [llength $runq]} {} {
56 if {[lindex $runq $i 0] eq $fd} {
57 set runq [lreplace $runq $i $i]
58 } else {
59 incr i
64 proc dorunq {} {
65 global isonrunq runq currunq
67 set tstart [clock clicks -milliseconds]
68 set t0 $tstart
69 while {[llength $runq] > 0} {
70 set fd [lindex $runq 0 0]
71 set script [lindex $runq 0 1]
72 set currunq [lindex $runq 0]
73 set runq [lrange $runq 1 end]
74 set repeat [eval $script]
75 unset currunq
76 set t1 [clock clicks -milliseconds]
77 set t [expr {$t1 - $t0}]
78 if {$repeat ne {} && $repeat} {
79 if {$fd eq {} || $repeat == 2} {
80 # script returns 1 if it wants to be readded
81 # file readers return 2 if they could do more straight away
82 lappend runq [list $fd $script]
83 } else {
84 fileevent $fd readable [list filereadable $fd $script]
86 } elseif {$fd eq {}} {
87 unset isonrunq($script)
89 set t0 $t1
90 if {$t1 - $tstart >= 80} break
92 if {$runq ne {}} {
93 after idle dorunq
97 proc reg_instance {fd} {
98 global commfd leftover loginstance
100 set i [incr loginstance]
101 set commfd($i) $fd
102 set leftover($i) {}
103 return $i
106 proc unmerged_files {files} {
107 global nr_unmerged
109 # find the list of unmerged files
110 set mlist {}
111 set nr_unmerged 0
112 if {[catch {
113 set fd [open "| git ls-files -u" r]
114 } err]} {
115 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
116 exit 1
118 while {[gets $fd line] >= 0} {
119 set i [string first "\t" $line]
120 if {$i < 0} continue
121 set fname [string range $line [expr {$i+1}] end]
122 if {[lsearch -exact $mlist $fname] >= 0} continue
123 incr nr_unmerged
124 if {$files eq {} || [path_filter $files $fname]} {
125 lappend mlist $fname
128 catch {close $fd}
129 return $mlist
132 proc parseviewargs {n arglist} {
133 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
135 set vdatemode($n) 0
136 set vmergeonly($n) 0
137 set glflags {}
138 set diffargs {}
139 set nextisval 0
140 set revargs {}
141 set origargs $arglist
142 set allknown 1
143 set filtered 0
144 set i -1
145 foreach arg $arglist {
146 incr i
147 if {$nextisval} {
148 lappend glflags $arg
149 set nextisval 0
150 continue
152 switch -glob -- $arg {
153 "-d" -
154 "--date-order" {
155 set vdatemode($n) 1
156 # remove from origargs in case we hit an unknown option
157 set origargs [lreplace $origargs $i $i]
158 incr i -1
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 # These request or affect diff output, which we don't want.
167 # Some could be used to set our defaults for diff display.
168 lappend diffargs $arg
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" {
177 # These cause our parsing of git log's output to fail, or else
178 # they're options we want to set ourselves, so ignore them.
180 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
181 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
182 "--full-history" - "--dense" - "--sparse" -
183 "--follow" - "--left-right" - "--encoding=*" {
184 # These are harmless, and some are even useful
185 lappend glflags $arg
187 "--diff-filter=*" - "--no-merges" - "--unpacked" -
188 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
189 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
190 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
191 "--remove-empty" - "--first-parent" - "--cherry-pick" -
192 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
193 "--simplify-by-decoration" {
194 # These mean that we get a subset of the commits
195 set filtered 1
196 lappend glflags $arg
198 "-n" {
199 # This appears to be the only one that has a value as a
200 # separate word following it
201 set filtered 1
202 set nextisval 1
203 lappend glflags $arg
205 "--not" - "--all" {
206 lappend revargs $arg
208 "--merge" {
209 set vmergeonly($n) 1
210 # git rev-parse doesn't understand --merge
211 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
213 "--no-replace-objects" {
214 set env(GIT_NO_REPLACE_OBJECTS) "1"
216 "-*" {
217 # Other flag arguments including -<n>
218 if {[string is digit -strict [string range $arg 1 end]]} {
219 set filtered 1
220 } else {
221 # a flag argument that we don't recognize;
222 # that means we can't optimize
223 set allknown 0
225 lappend glflags $arg
227 default {
228 # Non-flag arguments specify commits or ranges of commits
229 if {[string match "*...*" $arg]} {
230 lappend revargs --gitk-symmetric-diff-marker
232 lappend revargs $arg
236 set vdflags($n) $diffargs
237 set vflags($n) $glflags
238 set vrevs($n) $revargs
239 set vfiltered($n) $filtered
240 set vorigargs($n) $origargs
241 return $allknown
244 proc parseviewrevs {view revs} {
245 global vposids vnegids
247 if {$revs eq {}} {
248 set revs HEAD
250 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
251 # we get stdout followed by stderr in $err
252 # for an unknown rev, git rev-parse echoes it and then errors out
253 set errlines [split $err "\n"]
254 set badrev {}
255 for {set l 0} {$l < [llength $errlines]} {incr l} {
256 set line [lindex $errlines $l]
257 if {!([string length $line] == 40 && [string is xdigit $line])} {
258 if {[string match "fatal:*" $line]} {
259 if {[string match "fatal: ambiguous argument*" $line]
260 && $badrev ne {}} {
261 if {[llength $badrev] == 1} {
262 set err "unknown revision $badrev"
263 } else {
264 set err "unknown revisions: [join $badrev ", "]"
266 } else {
267 set err [join [lrange $errlines $l end] "\n"]
269 break
271 lappend badrev $line
274 error_popup "[mc "Error parsing revisions:"] $err"
275 return {}
277 set ret {}
278 set pos {}
279 set neg {}
280 set sdm 0
281 foreach id [split $ids "\n"] {
282 if {$id eq "--gitk-symmetric-diff-marker"} {
283 set sdm 4
284 } elseif {[string match "^*" $id]} {
285 if {$sdm != 1} {
286 lappend ret $id
287 if {$sdm == 3} {
288 set sdm 0
291 lappend neg [string range $id 1 end]
292 } else {
293 if {$sdm != 2} {
294 lappend ret $id
295 } else {
296 lset ret end $id...[lindex $ret end]
298 lappend pos $id
300 incr sdm -1
302 set vposids($view) $pos
303 set vnegids($view) $neg
304 return $ret
307 # Start off a git log process and arrange to read its output
308 proc start_rev_list {view} {
309 global startmsecs commitidx viewcomplete curview
310 global tclencoding
311 global viewargs viewargscmd viewfiles vfilelimit
312 global showlocalchanges
313 global viewactive viewinstances vmergeonly
314 global mainheadid viewmainheadid viewmainheadid_orig
315 global vcanopt vflags vrevs vorigargs
316 global show_notes
318 set startmsecs [clock clicks -milliseconds]
319 set commitidx($view) 0
320 # these are set this way for the error exits
321 set viewcomplete($view) 1
322 set viewactive($view) 0
323 varcinit $view
325 set args $viewargs($view)
326 if {$viewargscmd($view) ne {}} {
327 if {[catch {
328 set str [exec sh -c $viewargscmd($view)]
329 } err]} {
330 error_popup "[mc "Error executing --argscmd command:"] $err"
331 return 0
333 set args [concat $args [split $str "\n"]]
335 set vcanopt($view) [parseviewargs $view $args]
337 set files $viewfiles($view)
338 if {$vmergeonly($view)} {
339 set files [unmerged_files $files]
340 if {$files eq {}} {
341 global nr_unmerged
342 if {$nr_unmerged == 0} {
343 error_popup [mc "No files selected: --merge specified but\
344 no files are unmerged."]
345 } else {
346 error_popup [mc "No files selected: --merge specified but\
347 no unmerged files are within file limit."]
349 return 0
352 set vfilelimit($view) $files
354 if {$vcanopt($view)} {
355 set revs [parseviewrevs $view $vrevs($view)]
356 if {$revs eq {}} {
357 return 0
359 set args [concat $vflags($view) $revs]
360 } else {
361 set args $vorigargs($view)
364 if {[catch {
365 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
366 --parents --boundary $args "--" $files] r]
367 } err]} {
368 error_popup "[mc "Error executing git log:"] $err"
369 return 0
371 set i [reg_instance $fd]
372 set viewinstances($view) [list $i]
373 set viewmainheadid($view) $mainheadid
374 set viewmainheadid_orig($view) $mainheadid
375 if {$files ne {} && $mainheadid ne {}} {
376 get_viewmainhead $view
378 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
379 interestedin $viewmainheadid($view) dodiffindex
381 fconfigure $fd -blocking 0 -translation lf -eofchar {}
382 if {$tclencoding != {}} {
383 fconfigure $fd -encoding $tclencoding
385 filerun $fd [list getcommitlines $fd $i $view 0]
386 nowbusy $view [mc "Reading"]
387 set viewcomplete($view) 0
388 set viewactive($view) 1
389 return 1
392 proc stop_instance {inst} {
393 global commfd leftover
395 set fd $commfd($inst)
396 catch {
397 set pid [pid $fd]
399 if {$::tcl_platform(platform) eq {windows}} {
400 exec kill -f $pid
401 } else {
402 exec kill $pid
405 catch {close $fd}
406 nukefile $fd
407 unset commfd($inst)
408 unset leftover($inst)
411 proc stop_backends {} {
412 global commfd
414 foreach inst [array names commfd] {
415 stop_instance $inst
419 proc stop_rev_list {view} {
420 global viewinstances
422 foreach inst $viewinstances($view) {
423 stop_instance $inst
425 set viewinstances($view) {}
428 proc reset_pending_select {selid} {
429 global pending_select mainheadid selectheadid
431 if {$selid ne {}} {
432 set pending_select $selid
433 } elseif {$selectheadid ne {}} {
434 set pending_select $selectheadid
435 } else {
436 set pending_select $mainheadid
440 proc getcommits {selid} {
441 global canv curview need_redisplay viewactive
443 initlayout
444 if {[start_rev_list $curview]} {
445 reset_pending_select $selid
446 show_status [mc "Reading commits..."]
447 set need_redisplay 1
448 } else {
449 show_status [mc "No commits selected"]
453 proc updatecommits {} {
454 global curview vcanopt vorigargs vfilelimit viewinstances
455 global viewactive viewcomplete tclencoding
456 global startmsecs showneartags showlocalchanges
457 global mainheadid viewmainheadid viewmainheadid_orig pending_select
458 global isworktree
459 global varcid vposids vnegids vflags vrevs
460 global show_notes
462 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
463 rereadrefs
464 set view $curview
465 if {$mainheadid ne $viewmainheadid_orig($view)} {
466 if {$showlocalchanges} {
467 dohidelocalchanges
469 set viewmainheadid($view) $mainheadid
470 set viewmainheadid_orig($view) $mainheadid
471 if {$vfilelimit($view) ne {}} {
472 get_viewmainhead $view
475 if {$showlocalchanges} {
476 doshowlocalchanges
478 if {$vcanopt($view)} {
479 set oldpos $vposids($view)
480 set oldneg $vnegids($view)
481 set revs [parseviewrevs $view $vrevs($view)]
482 if {$revs eq {}} {
483 return
485 # note: getting the delta when negative refs change is hard,
486 # and could require multiple git log invocations, so in that
487 # case we ask git log for all the commits (not just the delta)
488 if {$oldneg eq $vnegids($view)} {
489 set newrevs {}
490 set npos 0
491 # take out positive refs that we asked for before or
492 # that we have already seen
493 foreach rev $revs {
494 if {[string length $rev] == 40} {
495 if {[lsearch -exact $oldpos $rev] < 0
496 && ![info exists varcid($view,$rev)]} {
497 lappend newrevs $rev
498 incr npos
500 } else {
501 lappend $newrevs $rev
504 if {$npos == 0} return
505 set revs $newrevs
506 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
508 set args [concat $vflags($view) $revs --not $oldpos]
509 } else {
510 set args $vorigargs($view)
512 if {[catch {
513 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
514 --parents --boundary $args "--" $vfilelimit($view)] r]
515 } err]} {
516 error_popup "[mc "Error executing git log:"] $err"
517 return
519 if {$viewactive($view) == 0} {
520 set startmsecs [clock clicks -milliseconds]
522 set i [reg_instance $fd]
523 lappend viewinstances($view) $i
524 fconfigure $fd -blocking 0 -translation lf -eofchar {}
525 if {$tclencoding != {}} {
526 fconfigure $fd -encoding $tclencoding
528 filerun $fd [list getcommitlines $fd $i $view 1]
529 incr viewactive($view)
530 set viewcomplete($view) 0
531 reset_pending_select {}
532 nowbusy $view [mc "Reading"]
533 if {$showneartags} {
534 getallcommits
538 proc reloadcommits {} {
539 global curview viewcomplete selectedline currentid thickerline
540 global showneartags treediffs commitinterest cached_commitrow
541 global targetid
543 set selid {}
544 if {$selectedline ne {}} {
545 set selid $currentid
548 if {!$viewcomplete($curview)} {
549 stop_rev_list $curview
551 resetvarcs $curview
552 set selectedline {}
553 catch {unset currentid}
554 catch {unset thickerline}
555 catch {unset treediffs}
556 readrefs
557 changedrefs
558 if {$showneartags} {
559 getallcommits
561 clear_display
562 catch {unset commitinterest}
563 catch {unset cached_commitrow}
564 catch {unset targetid}
565 setcanvscroll
566 getcommits $selid
567 return 0
570 # This makes a string representation of a positive integer which
571 # sorts as a string in numerical order
572 proc strrep {n} {
573 if {$n < 16} {
574 return [format "%x" $n]
575 } elseif {$n < 256} {
576 return [format "x%.2x" $n]
577 } elseif {$n < 65536} {
578 return [format "y%.4x" $n]
580 return [format "z%.8x" $n]
583 # Procedures used in reordering commits from git log (without
584 # --topo-order) into the order for display.
586 proc varcinit {view} {
587 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
588 global vtokmod varcmod vrowmod varcix vlastins
590 set varcstart($view) {{}}
591 set vupptr($view) {0}
592 set vdownptr($view) {0}
593 set vleftptr($view) {0}
594 set vbackptr($view) {0}
595 set varctok($view) {{}}
596 set varcrow($view) {{}}
597 set vtokmod($view) {}
598 set varcmod($view) 0
599 set vrowmod($view) 0
600 set varcix($view) {{}}
601 set vlastins($view) {0}
604 proc resetvarcs {view} {
605 global varcid varccommits parents children vseedcount ordertok
607 foreach vid [array names varcid $view,*] {
608 unset varcid($vid)
609 unset children($vid)
610 unset parents($vid)
612 # some commits might have children but haven't been seen yet
613 foreach vid [array names children $view,*] {
614 unset children($vid)
616 foreach va [array names varccommits $view,*] {
617 unset varccommits($va)
619 foreach vd [array names vseedcount $view,*] {
620 unset vseedcount($vd)
622 catch {unset ordertok}
625 # returns a list of the commits with no children
626 proc seeds {v} {
627 global vdownptr vleftptr varcstart
629 set ret {}
630 set a [lindex $vdownptr($v) 0]
631 while {$a != 0} {
632 lappend ret [lindex $varcstart($v) $a]
633 set a [lindex $vleftptr($v) $a]
635 return $ret
638 proc newvarc {view id} {
639 global varcid varctok parents children vdatemode
640 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
641 global commitdata commitinfo vseedcount varccommits vlastins
643 set a [llength $varctok($view)]
644 set vid $view,$id
645 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
646 if {![info exists commitinfo($id)]} {
647 parsecommit $id $commitdata($id) 1
649 set cdate [lindex $commitinfo($id) 4]
650 if {![string is integer -strict $cdate]} {
651 set cdate 0
653 if {![info exists vseedcount($view,$cdate)]} {
654 set vseedcount($view,$cdate) -1
656 set c [incr vseedcount($view,$cdate)]
657 set cdate [expr {$cdate ^ 0xffffffff}]
658 set tok "s[strrep $cdate][strrep $c]"
659 } else {
660 set tok {}
662 set ka 0
663 if {[llength $children($vid)] > 0} {
664 set kid [lindex $children($vid) end]
665 set k $varcid($view,$kid)
666 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
667 set ki $kid
668 set ka $k
669 set tok [lindex $varctok($view) $k]
672 if {$ka != 0} {
673 set i [lsearch -exact $parents($view,$ki) $id]
674 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
675 append tok [strrep $j]
677 set c [lindex $vlastins($view) $ka]
678 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
679 set c $ka
680 set b [lindex $vdownptr($view) $ka]
681 } else {
682 set b [lindex $vleftptr($view) $c]
684 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
685 set c $b
686 set b [lindex $vleftptr($view) $c]
688 if {$c == $ka} {
689 lset vdownptr($view) $ka $a
690 lappend vbackptr($view) 0
691 } else {
692 lset vleftptr($view) $c $a
693 lappend vbackptr($view) $c
695 lset vlastins($view) $ka $a
696 lappend vupptr($view) $ka
697 lappend vleftptr($view) $b
698 if {$b != 0} {
699 lset vbackptr($view) $b $a
701 lappend varctok($view) $tok
702 lappend varcstart($view) $id
703 lappend vdownptr($view) 0
704 lappend varcrow($view) {}
705 lappend varcix($view) {}
706 set varccommits($view,$a) {}
707 lappend vlastins($view) 0
708 return $a
711 proc splitvarc {p v} {
712 global varcid varcstart varccommits varctok vtokmod
713 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
715 set oa $varcid($v,$p)
716 set otok [lindex $varctok($v) $oa]
717 set ac $varccommits($v,$oa)
718 set i [lsearch -exact $varccommits($v,$oa) $p]
719 if {$i <= 0} return
720 set na [llength $varctok($v)]
721 # "%" sorts before "0"...
722 set tok "$otok%[strrep $i]"
723 lappend varctok($v) $tok
724 lappend varcrow($v) {}
725 lappend varcix($v) {}
726 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
727 set varccommits($v,$na) [lrange $ac $i end]
728 lappend varcstart($v) $p
729 foreach id $varccommits($v,$na) {
730 set varcid($v,$id) $na
732 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
733 lappend vlastins($v) [lindex $vlastins($v) $oa]
734 lset vdownptr($v) $oa $na
735 lset vlastins($v) $oa 0
736 lappend vupptr($v) $oa
737 lappend vleftptr($v) 0
738 lappend vbackptr($v) 0
739 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
740 lset vupptr($v) $b $na
742 if {[string compare $otok $vtokmod($v)] <= 0} {
743 modify_arc $v $oa
747 proc renumbervarc {a v} {
748 global parents children varctok varcstart varccommits
749 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
751 set t1 [clock clicks -milliseconds]
752 set todo {}
753 set isrelated($a) 1
754 set kidchanged($a) 1
755 set ntot 0
756 while {$a != 0} {
757 if {[info exists isrelated($a)]} {
758 lappend todo $a
759 set id [lindex $varccommits($v,$a) end]
760 foreach p $parents($v,$id) {
761 if {[info exists varcid($v,$p)]} {
762 set isrelated($varcid($v,$p)) 1
766 incr ntot
767 set b [lindex $vdownptr($v) $a]
768 if {$b == 0} {
769 while {$a != 0} {
770 set b [lindex $vleftptr($v) $a]
771 if {$b != 0} break
772 set a [lindex $vupptr($v) $a]
775 set a $b
777 foreach a $todo {
778 if {![info exists kidchanged($a)]} continue
779 set id [lindex $varcstart($v) $a]
780 if {[llength $children($v,$id)] > 1} {
781 set children($v,$id) [lsort -command [list vtokcmp $v] \
782 $children($v,$id)]
784 set oldtok [lindex $varctok($v) $a]
785 if {!$vdatemode($v)} {
786 set tok {}
787 } else {
788 set tok $oldtok
790 set ka 0
791 set kid [last_real_child $v,$id]
792 if {$kid ne {}} {
793 set k $varcid($v,$kid)
794 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
795 set ki $kid
796 set ka $k
797 set tok [lindex $varctok($v) $k]
800 if {$ka != 0} {
801 set i [lsearch -exact $parents($v,$ki) $id]
802 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
803 append tok [strrep $j]
805 if {$tok eq $oldtok} {
806 continue
808 set id [lindex $varccommits($v,$a) end]
809 foreach p $parents($v,$id) {
810 if {[info exists varcid($v,$p)]} {
811 set kidchanged($varcid($v,$p)) 1
812 } else {
813 set sortkids($p) 1
816 lset varctok($v) $a $tok
817 set b [lindex $vupptr($v) $a]
818 if {$b != $ka} {
819 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
820 modify_arc $v $ka
822 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
823 modify_arc $v $b
825 set c [lindex $vbackptr($v) $a]
826 set d [lindex $vleftptr($v) $a]
827 if {$c == 0} {
828 lset vdownptr($v) $b $d
829 } else {
830 lset vleftptr($v) $c $d
832 if {$d != 0} {
833 lset vbackptr($v) $d $c
835 if {[lindex $vlastins($v) $b] == $a} {
836 lset vlastins($v) $b $c
838 lset vupptr($v) $a $ka
839 set c [lindex $vlastins($v) $ka]
840 if {$c == 0 || \
841 [string compare $tok [lindex $varctok($v) $c]] < 0} {
842 set c $ka
843 set b [lindex $vdownptr($v) $ka]
844 } else {
845 set b [lindex $vleftptr($v) $c]
847 while {$b != 0 && \
848 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
849 set c $b
850 set b [lindex $vleftptr($v) $c]
852 if {$c == $ka} {
853 lset vdownptr($v) $ka $a
854 lset vbackptr($v) $a 0
855 } else {
856 lset vleftptr($v) $c $a
857 lset vbackptr($v) $a $c
859 lset vleftptr($v) $a $b
860 if {$b != 0} {
861 lset vbackptr($v) $b $a
863 lset vlastins($v) $ka $a
866 foreach id [array names sortkids] {
867 if {[llength $children($v,$id)] > 1} {
868 set children($v,$id) [lsort -command [list vtokcmp $v] \
869 $children($v,$id)]
872 set t2 [clock clicks -milliseconds]
873 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
876 # Fix up the graph after we have found out that in view $v,
877 # $p (a commit that we have already seen) is actually the parent
878 # of the last commit in arc $a.
879 proc fix_reversal {p a v} {
880 global varcid varcstart varctok vupptr
882 set pa $varcid($v,$p)
883 if {$p ne [lindex $varcstart($v) $pa]} {
884 splitvarc $p $v
885 set pa $varcid($v,$p)
887 # seeds always need to be renumbered
888 if {[lindex $vupptr($v) $pa] == 0 ||
889 [string compare [lindex $varctok($v) $a] \
890 [lindex $varctok($v) $pa]] > 0} {
891 renumbervarc $pa $v
895 proc insertrow {id p v} {
896 global cmitlisted children parents varcid varctok vtokmod
897 global varccommits ordertok commitidx numcommits curview
898 global targetid targetrow
900 readcommit $id
901 set vid $v,$id
902 set cmitlisted($vid) 1
903 set children($vid) {}
904 set parents($vid) [list $p]
905 set a [newvarc $v $id]
906 set varcid($vid) $a
907 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
908 modify_arc $v $a
910 lappend varccommits($v,$a) $id
911 set vp $v,$p
912 if {[llength [lappend children($vp) $id]] > 1} {
913 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
914 catch {unset ordertok}
916 fix_reversal $p $a $v
917 incr commitidx($v)
918 if {$v == $curview} {
919 set numcommits $commitidx($v)
920 setcanvscroll
921 if {[info exists targetid]} {
922 if {![comes_before $targetid $p]} {
923 incr targetrow
929 proc insertfakerow {id p} {
930 global varcid varccommits parents children cmitlisted
931 global commitidx varctok vtokmod targetid targetrow curview numcommits
933 set v $curview
934 set a $varcid($v,$p)
935 set i [lsearch -exact $varccommits($v,$a) $p]
936 if {$i < 0} {
937 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
938 return
940 set children($v,$id) {}
941 set parents($v,$id) [list $p]
942 set varcid($v,$id) $a
943 lappend children($v,$p) $id
944 set cmitlisted($v,$id) 1
945 set numcommits [incr commitidx($v)]
946 # note we deliberately don't update varcstart($v) even if $i == 0
947 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
948 modify_arc $v $a $i
949 if {[info exists targetid]} {
950 if {![comes_before $targetid $p]} {
951 incr targetrow
954 setcanvscroll
955 drawvisible
958 proc removefakerow {id} {
959 global varcid varccommits parents children commitidx
960 global varctok vtokmod cmitlisted currentid selectedline
961 global targetid curview numcommits
963 set v $curview
964 if {[llength $parents($v,$id)] != 1} {
965 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
966 return
968 set p [lindex $parents($v,$id) 0]
969 set a $varcid($v,$id)
970 set i [lsearch -exact $varccommits($v,$a) $id]
971 if {$i < 0} {
972 puts "oops: removefakerow can't find [shortids $id] on arc $a"
973 return
975 unset varcid($v,$id)
976 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
977 unset parents($v,$id)
978 unset children($v,$id)
979 unset cmitlisted($v,$id)
980 set numcommits [incr commitidx($v) -1]
981 set j [lsearch -exact $children($v,$p) $id]
982 if {$j >= 0} {
983 set children($v,$p) [lreplace $children($v,$p) $j $j]
985 modify_arc $v $a $i
986 if {[info exist currentid] && $id eq $currentid} {
987 unset currentid
988 set selectedline {}
990 if {[info exists targetid] && $targetid eq $id} {
991 set targetid $p
993 setcanvscroll
994 drawvisible
997 proc real_children {vp} {
998 global children nullid nullid2
1000 set kids {}
1001 foreach id $children($vp) {
1002 if {$id ne $nullid && $id ne $nullid2} {
1003 lappend kids $id
1006 return $kids
1009 proc first_real_child {vp} {
1010 global children nullid nullid2
1012 foreach id $children($vp) {
1013 if {$id ne $nullid && $id ne $nullid2} {
1014 return $id
1017 return {}
1020 proc last_real_child {vp} {
1021 global children nullid nullid2
1023 set kids $children($vp)
1024 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1025 set id [lindex $kids $i]
1026 if {$id ne $nullid && $id ne $nullid2} {
1027 return $id
1030 return {}
1033 proc vtokcmp {v a b} {
1034 global varctok varcid
1036 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1037 [lindex $varctok($v) $varcid($v,$b)]]
1040 # This assumes that if lim is not given, the caller has checked that
1041 # arc a's token is less than $vtokmod($v)
1042 proc modify_arc {v a {lim {}}} {
1043 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1045 if {$lim ne {}} {
1046 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1047 if {$c > 0} return
1048 if {$c == 0} {
1049 set r [lindex $varcrow($v) $a]
1050 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1053 set vtokmod($v) [lindex $varctok($v) $a]
1054 set varcmod($v) $a
1055 if {$v == $curview} {
1056 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1057 set a [lindex $vupptr($v) $a]
1058 set lim {}
1060 set r 0
1061 if {$a != 0} {
1062 if {$lim eq {}} {
1063 set lim [llength $varccommits($v,$a)]
1065 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1067 set vrowmod($v) $r
1068 undolayout $r
1072 proc update_arcrows {v} {
1073 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1074 global varcid vrownum varcorder varcix varccommits
1075 global vupptr vdownptr vleftptr varctok
1076 global displayorder parentlist curview cached_commitrow
1078 if {$vrowmod($v) == $commitidx($v)} return
1079 if {$v == $curview} {
1080 if {[llength $displayorder] > $vrowmod($v)} {
1081 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1082 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1084 catch {unset cached_commitrow}
1086 set narctot [expr {[llength $varctok($v)] - 1}]
1087 set a $varcmod($v)
1088 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1089 # go up the tree until we find something that has a row number,
1090 # or we get to a seed
1091 set a [lindex $vupptr($v) $a]
1093 if {$a == 0} {
1094 set a [lindex $vdownptr($v) 0]
1095 if {$a == 0} return
1096 set vrownum($v) {0}
1097 set varcorder($v) [list $a]
1098 lset varcix($v) $a 0
1099 lset varcrow($v) $a 0
1100 set arcn 0
1101 set row 0
1102 } else {
1103 set arcn [lindex $varcix($v) $a]
1104 if {[llength $vrownum($v)] > $arcn + 1} {
1105 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1106 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1108 set row [lindex $varcrow($v) $a]
1110 while {1} {
1111 set p $a
1112 incr row [llength $varccommits($v,$a)]
1113 # go down if possible
1114 set b [lindex $vdownptr($v) $a]
1115 if {$b == 0} {
1116 # if not, go left, or go up until we can go left
1117 while {$a != 0} {
1118 set b [lindex $vleftptr($v) $a]
1119 if {$b != 0} break
1120 set a [lindex $vupptr($v) $a]
1122 if {$a == 0} break
1124 set a $b
1125 incr arcn
1126 lappend vrownum($v) $row
1127 lappend varcorder($v) $a
1128 lset varcix($v) $a $arcn
1129 lset varcrow($v) $a $row
1131 set vtokmod($v) [lindex $varctok($v) $p]
1132 set varcmod($v) $p
1133 set vrowmod($v) $row
1134 if {[info exists currentid]} {
1135 set selectedline [rowofcommit $currentid]
1139 # Test whether view $v contains commit $id
1140 proc commitinview {id v} {
1141 global varcid
1143 return [info exists varcid($v,$id)]
1146 # Return the row number for commit $id in the current view
1147 proc rowofcommit {id} {
1148 global varcid varccommits varcrow curview cached_commitrow
1149 global varctok vtokmod
1151 set v $curview
1152 if {![info exists varcid($v,$id)]} {
1153 puts "oops rowofcommit no arc for [shortids $id]"
1154 return {}
1156 set a $varcid($v,$id)
1157 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1158 update_arcrows $v
1160 if {[info exists cached_commitrow($id)]} {
1161 return $cached_commitrow($id)
1163 set i [lsearch -exact $varccommits($v,$a) $id]
1164 if {$i < 0} {
1165 puts "oops didn't find commit [shortids $id] in arc $a"
1166 return {}
1168 incr i [lindex $varcrow($v) $a]
1169 set cached_commitrow($id) $i
1170 return $i
1173 # Returns 1 if a is on an earlier row than b, otherwise 0
1174 proc comes_before {a b} {
1175 global varcid varctok curview
1177 set v $curview
1178 if {$a eq $b || ![info exists varcid($v,$a)] || \
1179 ![info exists varcid($v,$b)]} {
1180 return 0
1182 if {$varcid($v,$a) != $varcid($v,$b)} {
1183 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1184 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1186 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1189 proc bsearch {l elt} {
1190 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1191 return 0
1193 set lo 0
1194 set hi [llength $l]
1195 while {$hi - $lo > 1} {
1196 set mid [expr {int(($lo + $hi) / 2)}]
1197 set t [lindex $l $mid]
1198 if {$elt < $t} {
1199 set hi $mid
1200 } elseif {$elt > $t} {
1201 set lo $mid
1202 } else {
1203 return $mid
1206 return $lo
1209 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1210 proc make_disporder {start end} {
1211 global vrownum curview commitidx displayorder parentlist
1212 global varccommits varcorder parents vrowmod varcrow
1213 global d_valid_start d_valid_end
1215 if {$end > $vrowmod($curview)} {
1216 update_arcrows $curview
1218 set ai [bsearch $vrownum($curview) $start]
1219 set start [lindex $vrownum($curview) $ai]
1220 set narc [llength $vrownum($curview)]
1221 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1222 set a [lindex $varcorder($curview) $ai]
1223 set l [llength $displayorder]
1224 set al [llength $varccommits($curview,$a)]
1225 if {$l < $r + $al} {
1226 if {$l < $r} {
1227 set pad [ntimes [expr {$r - $l}] {}]
1228 set displayorder [concat $displayorder $pad]
1229 set parentlist [concat $parentlist $pad]
1230 } elseif {$l > $r} {
1231 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1232 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1234 foreach id $varccommits($curview,$a) {
1235 lappend displayorder $id
1236 lappend parentlist $parents($curview,$id)
1238 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1239 set i $r
1240 foreach id $varccommits($curview,$a) {
1241 lset displayorder $i $id
1242 lset parentlist $i $parents($curview,$id)
1243 incr i
1246 incr r $al
1250 proc commitonrow {row} {
1251 global displayorder
1253 set id [lindex $displayorder $row]
1254 if {$id eq {}} {
1255 make_disporder $row [expr {$row + 1}]
1256 set id [lindex $displayorder $row]
1258 return $id
1261 proc closevarcs {v} {
1262 global varctok varccommits varcid parents children
1263 global cmitlisted commitidx vtokmod
1265 set missing_parents 0
1266 set scripts {}
1267 set narcs [llength $varctok($v)]
1268 for {set a 1} {$a < $narcs} {incr a} {
1269 set id [lindex $varccommits($v,$a) end]
1270 foreach p $parents($v,$id) {
1271 if {[info exists varcid($v,$p)]} continue
1272 # add p as a new commit
1273 incr missing_parents
1274 set cmitlisted($v,$p) 0
1275 set parents($v,$p) {}
1276 if {[llength $children($v,$p)] == 1 &&
1277 [llength $parents($v,$id)] == 1} {
1278 set b $a
1279 } else {
1280 set b [newvarc $v $p]
1282 set varcid($v,$p) $b
1283 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1284 modify_arc $v $b
1286 lappend varccommits($v,$b) $p
1287 incr commitidx($v)
1288 set scripts [check_interest $p $scripts]
1291 if {$missing_parents > 0} {
1292 foreach s $scripts {
1293 eval $s
1298 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1299 # Assumes we already have an arc for $rwid.
1300 proc rewrite_commit {v id rwid} {
1301 global children parents varcid varctok vtokmod varccommits
1303 foreach ch $children($v,$id) {
1304 # make $rwid be $ch's parent in place of $id
1305 set i [lsearch -exact $parents($v,$ch) $id]
1306 if {$i < 0} {
1307 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1309 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1310 # add $ch to $rwid's children and sort the list if necessary
1311 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1312 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1313 $children($v,$rwid)]
1315 # fix the graph after joining $id to $rwid
1316 set a $varcid($v,$ch)
1317 fix_reversal $rwid $a $v
1318 # parentlist is wrong for the last element of arc $a
1319 # even if displayorder is right, hence the 3rd arg here
1320 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1324 # Mechanism for registering a command to be executed when we come
1325 # across a particular commit. To handle the case when only the
1326 # prefix of the commit is known, the commitinterest array is now
1327 # indexed by the first 4 characters of the ID. Each element is a
1328 # list of id, cmd pairs.
1329 proc interestedin {id cmd} {
1330 global commitinterest
1332 lappend commitinterest([string range $id 0 3]) $id $cmd
1335 proc check_interest {id scripts} {
1336 global commitinterest
1338 set prefix [string range $id 0 3]
1339 if {[info exists commitinterest($prefix)]} {
1340 set newlist {}
1341 foreach {i script} $commitinterest($prefix) {
1342 if {[string match "$i*" $id]} {
1343 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1344 } else {
1345 lappend newlist $i $script
1348 if {$newlist ne {}} {
1349 set commitinterest($prefix) $newlist
1350 } else {
1351 unset commitinterest($prefix)
1354 return $scripts
1357 proc getcommitlines {fd inst view updating} {
1358 global cmitlisted leftover
1359 global commitidx commitdata vdatemode
1360 global parents children curview hlview
1361 global idpending ordertok
1362 global varccommits varcid varctok vtokmod vfilelimit
1364 set stuff [read $fd 500000]
1365 # git log doesn't terminate the last commit with a null...
1366 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1367 set stuff "\0"
1369 if {$stuff == {}} {
1370 if {![eof $fd]} {
1371 return 1
1373 global commfd viewcomplete viewactive viewname
1374 global viewinstances
1375 unset commfd($inst)
1376 set i [lsearch -exact $viewinstances($view) $inst]
1377 if {$i >= 0} {
1378 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1380 # set it blocking so we wait for the process to terminate
1381 fconfigure $fd -blocking 1
1382 if {[catch {close $fd} err]} {
1383 set fv {}
1384 if {$view != $curview} {
1385 set fv " for the \"$viewname($view)\" view"
1387 if {[string range $err 0 4] == "usage"} {
1388 set err "Gitk: error reading commits$fv:\
1389 bad arguments to git log."
1390 if {$viewname($view) eq "Command line"} {
1391 append err \
1392 " (Note: arguments to gitk are passed to git log\
1393 to allow selection of commits to be displayed.)"
1395 } else {
1396 set err "Error reading commits$fv: $err"
1398 error_popup $err
1400 if {[incr viewactive($view) -1] <= 0} {
1401 set viewcomplete($view) 1
1402 # Check if we have seen any ids listed as parents that haven't
1403 # appeared in the list
1404 closevarcs $view
1405 notbusy $view
1407 if {$view == $curview} {
1408 run chewcommits
1410 return 0
1412 set start 0
1413 set gotsome 0
1414 set scripts {}
1415 while 1 {
1416 set i [string first "\0" $stuff $start]
1417 if {$i < 0} {
1418 append leftover($inst) [string range $stuff $start end]
1419 break
1421 if {$start == 0} {
1422 set cmit $leftover($inst)
1423 append cmit [string range $stuff 0 [expr {$i - 1}]]
1424 set leftover($inst) {}
1425 } else {
1426 set cmit [string range $stuff $start [expr {$i - 1}]]
1428 set start [expr {$i + 1}]
1429 set j [string first "\n" $cmit]
1430 set ok 0
1431 set listed 1
1432 if {$j >= 0 && [string match "commit *" $cmit]} {
1433 set ids [string range $cmit 7 [expr {$j - 1}]]
1434 if {[string match {[-^<>]*} $ids]} {
1435 switch -- [string index $ids 0] {
1436 "-" {set listed 0}
1437 "^" {set listed 2}
1438 "<" {set listed 3}
1439 ">" {set listed 4}
1441 set ids [string range $ids 1 end]
1443 set ok 1
1444 foreach id $ids {
1445 if {[string length $id] != 40} {
1446 set ok 0
1447 break
1451 if {!$ok} {
1452 set shortcmit $cmit
1453 if {[string length $shortcmit] > 80} {
1454 set shortcmit "[string range $shortcmit 0 80]..."
1456 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1457 exit 1
1459 set id [lindex $ids 0]
1460 set vid $view,$id
1462 if {!$listed && $updating && ![info exists varcid($vid)] &&
1463 $vfilelimit($view) ne {}} {
1464 # git log doesn't rewrite parents for unlisted commits
1465 # when doing path limiting, so work around that here
1466 # by working out the rewritten parent with git rev-list
1467 # and if we already know about it, using the rewritten
1468 # parent as a substitute parent for $id's children.
1469 if {![catch {
1470 set rwid [exec git rev-list --first-parent --max-count=1 \
1471 $id -- $vfilelimit($view)]
1472 }]} {
1473 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1474 # use $rwid in place of $id
1475 rewrite_commit $view $id $rwid
1476 continue
1481 set a 0
1482 if {[info exists varcid($vid)]} {
1483 if {$cmitlisted($vid) || !$listed} continue
1484 set a $varcid($vid)
1486 if {$listed} {
1487 set olds [lrange $ids 1 end]
1488 } else {
1489 set olds {}
1491 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1492 set cmitlisted($vid) $listed
1493 set parents($vid) $olds
1494 if {![info exists children($vid)]} {
1495 set children($vid) {}
1496 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1497 set k [lindex $children($vid) 0]
1498 if {[llength $parents($view,$k)] == 1 &&
1499 (!$vdatemode($view) ||
1500 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1501 set a $varcid($view,$k)
1504 if {$a == 0} {
1505 # new arc
1506 set a [newvarc $view $id]
1508 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1509 modify_arc $view $a
1511 if {![info exists varcid($vid)]} {
1512 set varcid($vid) $a
1513 lappend varccommits($view,$a) $id
1514 incr commitidx($view)
1517 set i 0
1518 foreach p $olds {
1519 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1520 set vp $view,$p
1521 if {[llength [lappend children($vp) $id]] > 1 &&
1522 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1523 set children($vp) [lsort -command [list vtokcmp $view] \
1524 $children($vp)]
1525 catch {unset ordertok}
1527 if {[info exists varcid($view,$p)]} {
1528 fix_reversal $p $a $view
1531 incr i
1534 set scripts [check_interest $id $scripts]
1535 set gotsome 1
1537 if {$gotsome} {
1538 global numcommits hlview
1540 if {$view == $curview} {
1541 set numcommits $commitidx($view)
1542 run chewcommits
1544 if {[info exists hlview] && $view == $hlview} {
1545 # we never actually get here...
1546 run vhighlightmore
1548 foreach s $scripts {
1549 eval $s
1552 return 2
1555 proc chewcommits {} {
1556 global curview hlview viewcomplete
1557 global pending_select
1559 layoutmore
1560 if {$viewcomplete($curview)} {
1561 global commitidx varctok
1562 global numcommits startmsecs
1564 if {[info exists pending_select]} {
1565 update
1566 reset_pending_select {}
1568 if {[commitinview $pending_select $curview]} {
1569 selectline [rowofcommit $pending_select] 1
1570 } else {
1571 set row [first_real_row]
1572 selectline $row 1
1575 if {$commitidx($curview) > 0} {
1576 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1577 #puts "overall $ms ms for $numcommits commits"
1578 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1579 } else {
1580 show_status [mc "No commits selected"]
1582 notbusy layout
1584 return 0
1587 proc do_readcommit {id} {
1588 global tclencoding
1590 # Invoke git-log to handle automatic encoding conversion
1591 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1592 # Read the results using i18n.logoutputencoding
1593 fconfigure $fd -translation lf -eofchar {}
1594 if {$tclencoding != {}} {
1595 fconfigure $fd -encoding $tclencoding
1597 set contents [read $fd]
1598 close $fd
1599 # Remove the heading line
1600 regsub {^commit [0-9a-f]+\n} $contents {} contents
1602 return $contents
1605 proc readcommit {id} {
1606 if {[catch {set contents [do_readcommit $id]}]} return
1607 parsecommit $id $contents 1
1610 proc parsecommit {id contents listed} {
1611 global commitinfo cdate
1613 set inhdr 1
1614 set comment {}
1615 set headline {}
1616 set auname {}
1617 set audate {}
1618 set comname {}
1619 set comdate {}
1620 set hdrend [string first "\n\n" $contents]
1621 if {$hdrend < 0} {
1622 # should never happen...
1623 set hdrend [string length $contents]
1625 set header [string range $contents 0 [expr {$hdrend - 1}]]
1626 set comment [string range $contents [expr {$hdrend + 2}] end]
1627 foreach line [split $header "\n"] {
1628 set line [split $line " "]
1629 set tag [lindex $line 0]
1630 if {$tag == "author"} {
1631 set audate [lindex $line end-1]
1632 set auname [join [lrange $line 1 end-2] " "]
1633 } elseif {$tag == "committer"} {
1634 set comdate [lindex $line end-1]
1635 set comname [join [lrange $line 1 end-2] " "]
1638 set headline {}
1639 # take the first non-blank line of the comment as the headline
1640 set headline [string trimleft $comment]
1641 set i [string first "\n" $headline]
1642 if {$i >= 0} {
1643 set headline [string range $headline 0 $i]
1645 set headline [string trimright $headline]
1646 set i [string first "\r" $headline]
1647 if {$i >= 0} {
1648 set headline [string trimright [string range $headline 0 $i]]
1650 if {!$listed} {
1651 # git log indents the comment by 4 spaces;
1652 # if we got this via git cat-file, add the indentation
1653 set newcomment {}
1654 foreach line [split $comment "\n"] {
1655 append newcomment " "
1656 append newcomment $line
1657 append newcomment "\n"
1659 set comment $newcomment
1661 if {$comdate != {}} {
1662 set cdate($id) $comdate
1664 set commitinfo($id) [list $headline $auname $audate \
1665 $comname $comdate $comment]
1668 proc getcommit {id} {
1669 global commitdata commitinfo
1671 if {[info exists commitdata($id)]} {
1672 parsecommit $id $commitdata($id) 1
1673 } else {
1674 readcommit $id
1675 if {![info exists commitinfo($id)]} {
1676 set commitinfo($id) [list [mc "No commit information available"]]
1679 return 1
1682 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1683 # and are present in the current view.
1684 # This is fairly slow...
1685 proc longid {prefix} {
1686 global varcid curview
1688 set ids {}
1689 foreach match [array names varcid "$curview,$prefix*"] {
1690 lappend ids [lindex [split $match ","] 1]
1692 return $ids
1695 proc readrefs {} {
1696 global tagids idtags headids idheads tagobjid
1697 global otherrefids idotherrefs mainhead mainheadid
1698 global selecthead selectheadid
1699 global hideremotes
1701 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1702 catch {unset $v}
1704 set refd [open [list | git show-ref -d] r]
1705 while {[gets $refd line] >= 0} {
1706 if {[string index $line 40] ne " "} continue
1707 set id [string range $line 0 39]
1708 set ref [string range $line 41 end]
1709 if {![string match "refs/*" $ref]} continue
1710 set name [string range $ref 5 end]
1711 if {[string match "remotes/*" $name]} {
1712 if {![string match "*/HEAD" $name] && !$hideremotes} {
1713 set headids($name) $id
1714 lappend idheads($id) $name
1716 } elseif {[string match "heads/*" $name]} {
1717 set name [string range $name 6 end]
1718 set headids($name) $id
1719 lappend idheads($id) $name
1720 } elseif {[string match "tags/*" $name]} {
1721 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1722 # which is what we want since the former is the commit ID
1723 set name [string range $name 5 end]
1724 if {[string match "*^{}" $name]} {
1725 set name [string range $name 0 end-3]
1726 } else {
1727 set tagobjid($name) $id
1729 set tagids($name) $id
1730 lappend idtags($id) $name
1731 } else {
1732 set otherrefids($name) $id
1733 lappend idotherrefs($id) $name
1736 catch {close $refd}
1737 set mainhead {}
1738 set mainheadid {}
1739 catch {
1740 set mainheadid [exec git rev-parse HEAD]
1741 set thehead [exec git symbolic-ref HEAD]
1742 if {[string match "refs/heads/*" $thehead]} {
1743 set mainhead [string range $thehead 11 end]
1746 set selectheadid {}
1747 if {$selecthead ne {}} {
1748 catch {
1749 set selectheadid [exec git rev-parse --verify $selecthead]
1754 # skip over fake commits
1755 proc first_real_row {} {
1756 global nullid nullid2 numcommits
1758 for {set row 0} {$row < $numcommits} {incr row} {
1759 set id [commitonrow $row]
1760 if {$id ne $nullid && $id ne $nullid2} {
1761 break
1764 return $row
1767 # update things for a head moved to a child of its previous location
1768 proc movehead {id name} {
1769 global headids idheads
1771 removehead $headids($name) $name
1772 set headids($name) $id
1773 lappend idheads($id) $name
1776 # update things when a head has been removed
1777 proc removehead {id name} {
1778 global headids idheads
1780 if {$idheads($id) eq $name} {
1781 unset idheads($id)
1782 } else {
1783 set i [lsearch -exact $idheads($id) $name]
1784 if {$i >= 0} {
1785 set idheads($id) [lreplace $idheads($id) $i $i]
1788 unset headids($name)
1791 proc ttk_toplevel {w args} {
1792 global use_ttk
1793 eval [linsert $args 0 ::toplevel $w]
1794 if {$use_ttk} {
1795 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1797 return $w
1800 proc make_transient {window origin} {
1801 global have_tk85
1803 # In MacOS Tk 8.4 transient appears to work by setting
1804 # overrideredirect, which is utterly useless, since the
1805 # windows get no border, and are not even kept above
1806 # the parent.
1807 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1809 wm transient $window $origin
1811 # Windows fails to place transient windows normally, so
1812 # schedule a callback to center them on the parent.
1813 if {[tk windowingsystem] eq {win32}} {
1814 after idle [list tk::PlaceWindow $window widget $origin]
1818 proc show_error {w top msg {mc mc}} {
1819 global NS
1820 if {![info exists NS]} {set NS ""}
1821 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1822 message $w.m -text $msg -justify center -aspect 400
1823 pack $w.m -side top -fill x -padx 20 -pady 20
1824 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1825 pack $w.ok -side bottom -fill x
1826 bind $top <Visibility> "grab $top; focus $top"
1827 bind $top <Key-Return> "destroy $top"
1828 bind $top <Key-space> "destroy $top"
1829 bind $top <Key-Escape> "destroy $top"
1830 tkwait window $top
1833 proc error_popup {msg {owner .}} {
1834 if {[tk windowingsystem] eq "win32"} {
1835 tk_messageBox -icon error -type ok -title [wm title .] \
1836 -parent $owner -message $msg
1837 } else {
1838 set w .error
1839 ttk_toplevel $w
1840 make_transient $w $owner
1841 show_error $w $w $msg
1845 proc confirm_popup {msg {owner .}} {
1846 global confirm_ok NS
1847 set confirm_ok 0
1848 set w .confirm
1849 ttk_toplevel $w
1850 make_transient $w $owner
1851 message $w.m -text $msg -justify center -aspect 400
1852 pack $w.m -side top -fill x -padx 20 -pady 20
1853 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1854 pack $w.ok -side left -fill x
1855 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1856 pack $w.cancel -side right -fill x
1857 bind $w <Visibility> "grab $w; focus $w"
1858 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1859 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1860 bind $w <Key-Escape> "destroy $w"
1861 tk::PlaceWindow $w widget $owner
1862 tkwait window $w
1863 return $confirm_ok
1866 proc setoptions {} {
1867 if {[tk windowingsystem] ne "win32"} {
1868 option add *Panedwindow.showHandle 1 startupFile
1869 option add *Panedwindow.sashRelief raised startupFile
1870 if {[tk windowingsystem] ne "aqua"} {
1871 option add *Menu.font uifont startupFile
1873 } else {
1874 option add *Menu.TearOff 0 startupFile
1876 option add *Button.font uifont startupFile
1877 option add *Checkbutton.font uifont startupFile
1878 option add *Radiobutton.font uifont startupFile
1879 option add *Menubutton.font uifont startupFile
1880 option add *Label.font uifont startupFile
1881 option add *Message.font uifont startupFile
1882 option add *Entry.font textfont startupFile
1883 option add *Text.font textfont startupFile
1884 option add *Labelframe.font uifont startupFile
1885 option add *Spinbox.font textfont startupFile
1886 option add *Listbox.font mainfont startupFile
1889 # Make a menu and submenus.
1890 # m is the window name for the menu, items is the list of menu items to add.
1891 # Each item is a list {mc label type description options...}
1892 # mc is ignored; it's so we can put mc there to alert xgettext
1893 # label is the string that appears in the menu
1894 # type is cascade, command or radiobutton (should add checkbutton)
1895 # description depends on type; it's the sublist for cascade, the
1896 # command to invoke for command, or {variable value} for radiobutton
1897 proc makemenu {m items} {
1898 menu $m
1899 if {[tk windowingsystem] eq {aqua}} {
1900 set Meta1 Cmd
1901 } else {
1902 set Meta1 Ctrl
1904 foreach i $items {
1905 set name [mc [lindex $i 1]]
1906 set type [lindex $i 2]
1907 set thing [lindex $i 3]
1908 set params [list $type]
1909 if {$name ne {}} {
1910 set u [string first "&" [string map {&& x} $name]]
1911 lappend params -label [string map {&& & & {}} $name]
1912 if {$u >= 0} {
1913 lappend params -underline $u
1916 switch -- $type {
1917 "cascade" {
1918 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1919 lappend params -menu $m.$submenu
1921 "command" {
1922 lappend params -command $thing
1924 "radiobutton" {
1925 lappend params -variable [lindex $thing 0] \
1926 -value [lindex $thing 1]
1929 set tail [lrange $i 4 end]
1930 regsub -all {\yMeta1\y} $tail $Meta1 tail
1931 eval $m add $params $tail
1932 if {$type eq "cascade"} {
1933 makemenu $m.$submenu $thing
1938 # translate string and remove ampersands
1939 proc mca {str} {
1940 return [string map {&& & & {}} [mc $str]]
1943 proc makedroplist {w varname args} {
1944 global use_ttk
1945 if {$use_ttk} {
1946 set width 0
1947 foreach label $args {
1948 set cx [string length $label]
1949 if {$cx > $width} {set width $cx}
1951 set gm [ttk::combobox $w -width $width -state readonly\
1952 -textvariable $varname -values $args]
1953 } else {
1954 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
1956 return $gm
1959 proc makewindow {} {
1960 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1961 global tabstop
1962 global findtype findtypemenu findloc findstring fstring geometry
1963 global entries sha1entry sha1string sha1but
1964 global diffcontextstring diffcontext
1965 global ignorespace
1966 global maincursor textcursor curtextcursor
1967 global rowctxmenu fakerowmenu mergemax wrapcomment
1968 global highlight_files gdttype
1969 global searchstring sstring
1970 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1971 global headctxmenu progresscanv progressitem progresscoords statusw
1972 global fprogitem fprogcoord lastprogupdate progupdatepending
1973 global rprogitem rprogcoord rownumsel numcommits
1974 global have_tk85 use_ttk NS
1976 # The "mc" arguments here are purely so that xgettext
1977 # sees the following string as needing to be translated
1978 set file {
1979 mc "File" cascade {
1980 {mc "Update" command updatecommits -accelerator F5}
1981 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1982 {mc "Reread references" command rereadrefs}
1983 {mc "List references" command showrefs -accelerator F2}
1984 {xx "" separator}
1985 {mc "Start git gui" command {exec git gui &}}
1986 {xx "" separator}
1987 {mc "Quit" command doquit -accelerator Meta1-Q}
1989 set edit {
1990 mc "Edit" cascade {
1991 {mc "Preferences" command doprefs}
1993 set view {
1994 mc "View" cascade {
1995 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1996 {mc "Edit view..." command editview -state disabled -accelerator F4}
1997 {mc "Delete view" command delview -state disabled}
1998 {xx "" separator}
1999 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2001 if {[tk windowingsystem] ne "aqua"} {
2002 set help {
2003 mc "Help" cascade {
2004 {mc "About gitk" command about}
2005 {mc "Key bindings" command keys}
2007 set bar [list $file $edit $view $help]
2008 } else {
2009 proc ::tk::mac::ShowPreferences {} {doprefs}
2010 proc ::tk::mac::Quit {} {doquit}
2011 lset file end [lreplace [lindex $file end] end-1 end]
2012 set apple {
2013 xx "Apple" cascade {
2014 {mc "About gitk" command about}
2015 {xx "" separator}
2017 set help {
2018 mc "Help" cascade {
2019 {mc "Key bindings" command keys}
2021 set bar [list $apple $file $view $help]
2023 makemenu .bar $bar
2024 . configure -menu .bar
2026 if {$use_ttk} {
2027 # cover the non-themed toplevel with a themed frame.
2028 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2031 # the gui has upper and lower half, parts of a paned window.
2032 ${NS}::panedwindow .ctop -orient vertical
2034 # possibly use assumed geometry
2035 if {![info exists geometry(pwsash0)]} {
2036 set geometry(topheight) [expr {15 * $linespc}]
2037 set geometry(topwidth) [expr {80 * $charspc}]
2038 set geometry(botheight) [expr {15 * $linespc}]
2039 set geometry(botwidth) [expr {50 * $charspc}]
2040 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2041 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2044 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2045 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2046 ${NS}::frame .tf.histframe
2047 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2048 if {!$use_ttk} {
2049 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2052 # create three canvases
2053 set cscroll .tf.histframe.csb
2054 set canv .tf.histframe.pwclist.canv
2055 canvas $canv \
2056 -selectbackground $selectbgcolor \
2057 -background $bgcolor -bd 0 \
2058 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2059 .tf.histframe.pwclist add $canv
2060 set canv2 .tf.histframe.pwclist.canv2
2061 canvas $canv2 \
2062 -selectbackground $selectbgcolor \
2063 -background $bgcolor -bd 0 -yscrollincr $linespc
2064 .tf.histframe.pwclist add $canv2
2065 set canv3 .tf.histframe.pwclist.canv3
2066 canvas $canv3 \
2067 -selectbackground $selectbgcolor \
2068 -background $bgcolor -bd 0 -yscrollincr $linespc
2069 .tf.histframe.pwclist add $canv3
2070 if {$use_ttk} {
2071 bind .tf.histframe.pwclist <Map> {
2072 bind %W <Map> {}
2073 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2074 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2076 } else {
2077 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2078 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2081 # a scroll bar to rule them
2082 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2083 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2084 pack $cscroll -side right -fill y
2085 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2086 lappend bglist $canv $canv2 $canv3
2087 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2089 # we have two button bars at bottom of top frame. Bar 1
2090 ${NS}::frame .tf.bar
2091 ${NS}::frame .tf.lbar -height 15
2093 set sha1entry .tf.bar.sha1
2094 set entries $sha1entry
2095 set sha1but .tf.bar.sha1label
2096 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2097 -command gotocommit -width 8
2098 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2099 pack .tf.bar.sha1label -side left
2100 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2101 trace add variable sha1string write sha1change
2102 pack $sha1entry -side left -pady 2
2104 image create bitmap bm-left -data {
2105 #define left_width 16
2106 #define left_height 16
2107 static unsigned char left_bits[] = {
2108 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2109 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2110 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2112 image create bitmap bm-right -data {
2113 #define right_width 16
2114 #define right_height 16
2115 static unsigned char right_bits[] = {
2116 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2117 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2118 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2120 ${NS}::button .tf.bar.leftbut -image bm-left -command goback \
2121 -state disabled -width 26
2122 pack .tf.bar.leftbut -side left -fill y
2123 ${NS}::button .tf.bar.rightbut -image bm-right -command goforw \
2124 -state disabled -width 26
2125 pack .tf.bar.rightbut -side left -fill y
2127 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2128 set rownumsel {}
2129 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2130 -relief sunken -anchor e
2131 ${NS}::label .tf.bar.rowlabel2 -text "/"
2132 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2133 -relief sunken -anchor e
2134 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2135 -side left
2136 if {!$use_ttk} {
2137 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2139 global selectedline
2140 trace add variable selectedline write selectedline_change
2142 # Status label and progress bar
2143 set statusw .tf.bar.status
2144 ${NS}::label $statusw -width 15 -relief sunken
2145 pack $statusw -side left -padx 5
2146 if {$use_ttk} {
2147 set progresscanv [ttk::progressbar .tf.bar.progress]
2148 } else {
2149 set h [expr {[font metrics uifont -linespace] + 2}]
2150 set progresscanv .tf.bar.progress
2151 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2152 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2153 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2154 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2156 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2157 set progresscoords {0 0}
2158 set fprogcoord 0
2159 set rprogcoord 0
2160 bind $progresscanv <Configure> adjustprogress
2161 set lastprogupdate [clock clicks -milliseconds]
2162 set progupdatepending 0
2164 # build up the bottom bar of upper window
2165 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2166 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2167 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2168 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2169 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2170 -side left -fill y
2171 set gdttype [mc "containing:"]
2172 set gm [makedroplist .tf.lbar.gdttype gdttype \
2173 [mc "containing:"] \
2174 [mc "touching paths:"] \
2175 [mc "adding/removing string:"]]
2176 trace add variable gdttype write gdttype_change
2177 pack .tf.lbar.gdttype -side left -fill y
2179 set findstring {}
2180 set fstring .tf.lbar.findstring
2181 lappend entries $fstring
2182 ${NS}::entry $fstring -width 30 -textvariable findstring
2183 trace add variable findstring write find_change
2184 set findtype [mc "Exact"]
2185 set findtypemenu [makedroplist .tf.lbar.findtype \
2186 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2187 trace add variable findtype write findcom_change
2188 set findloc [mc "All fields"]
2189 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2190 [mc "Comments"] [mc "Author"] [mc "Committer"]
2191 trace add variable findloc write find_change
2192 pack .tf.lbar.findloc -side right
2193 pack .tf.lbar.findtype -side right
2194 pack $fstring -side left -expand 1 -fill x
2196 # Finish putting the upper half of the viewer together
2197 pack .tf.lbar -in .tf -side bottom -fill x
2198 pack .tf.bar -in .tf -side bottom -fill x
2199 pack .tf.histframe -fill both -side top -expand 1
2200 .ctop add .tf
2201 if {!$use_ttk} {
2202 .ctop paneconfigure .tf -height $geometry(topheight)
2203 .ctop paneconfigure .tf -width $geometry(topwidth)
2206 # now build up the bottom
2207 ${NS}::panedwindow .pwbottom -orient horizontal
2209 # lower left, a text box over search bar, scroll bar to the right
2210 # if we know window height, then that will set the lower text height, otherwise
2211 # we set lower text height which will drive window height
2212 if {[info exists geometry(main)]} {
2213 ${NS}::frame .bleft -width $geometry(botwidth)
2214 } else {
2215 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2217 ${NS}::frame .bleft.top
2218 ${NS}::frame .bleft.mid
2219 ${NS}::frame .bleft.bottom
2221 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2222 pack .bleft.top.search -side left -padx 5
2223 set sstring .bleft.top.sstring
2224 set searchstring ""
2225 ${NS}::entry $sstring -width 20 -textvariable searchstring
2226 lappend entries $sstring
2227 trace add variable searchstring write incrsearch
2228 pack $sstring -side left -expand 1 -fill x
2229 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2230 -command changediffdisp -variable diffelide -value {0 0}
2231 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2232 -command changediffdisp -variable diffelide -value {0 1}
2233 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2234 -command changediffdisp -variable diffelide -value {1 0}
2235 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2236 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2237 spinbox .bleft.mid.diffcontext -width 5 \
2238 -from 0 -increment 1 -to 10000000 \
2239 -validate all -validatecommand "diffcontextvalidate %P" \
2240 -textvariable diffcontextstring
2241 .bleft.mid.diffcontext set $diffcontext
2242 trace add variable diffcontextstring write diffcontextchange
2243 lappend entries .bleft.mid.diffcontext
2244 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2245 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2246 -command changeignorespace -variable ignorespace
2247 pack .bleft.mid.ignspace -side left -padx 5
2248 set ctext .bleft.bottom.ctext
2249 text $ctext -background $bgcolor -foreground $fgcolor \
2250 -state disabled -font textfont \
2251 -yscrollcommand scrolltext -wrap none \
2252 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2253 if {$have_tk85} {
2254 $ctext conf -tabstyle wordprocessor
2256 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2257 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2258 pack .bleft.top -side top -fill x
2259 pack .bleft.mid -side top -fill x
2260 grid $ctext .bleft.bottom.sb -sticky nsew
2261 grid .bleft.bottom.sbhorizontal -sticky ew
2262 grid columnconfigure .bleft.bottom 0 -weight 1
2263 grid rowconfigure .bleft.bottom 0 -weight 1
2264 grid rowconfigure .bleft.bottom 1 -weight 0
2265 pack .bleft.bottom -side top -fill both -expand 1
2266 lappend bglist $ctext
2267 lappend fglist $ctext
2269 $ctext tag conf comment -wrap $wrapcomment
2270 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2271 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2272 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2273 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2274 $ctext tag conf m0 -fore red
2275 $ctext tag conf m1 -fore blue
2276 $ctext tag conf m2 -fore green
2277 $ctext tag conf m3 -fore purple
2278 $ctext tag conf m4 -fore brown
2279 $ctext tag conf m5 -fore "#009090"
2280 $ctext tag conf m6 -fore magenta
2281 $ctext tag conf m7 -fore "#808000"
2282 $ctext tag conf m8 -fore "#009000"
2283 $ctext tag conf m9 -fore "#ff0080"
2284 $ctext tag conf m10 -fore cyan
2285 $ctext tag conf m11 -fore "#b07070"
2286 $ctext tag conf m12 -fore "#70b0f0"
2287 $ctext tag conf m13 -fore "#70f0b0"
2288 $ctext tag conf m14 -fore "#f0b070"
2289 $ctext tag conf m15 -fore "#ff70b0"
2290 $ctext tag conf mmax -fore darkgrey
2291 set mergemax 16
2292 $ctext tag conf mresult -font textfontbold
2293 $ctext tag conf msep -font textfontbold
2294 $ctext tag conf found -back yellow
2296 .pwbottom add .bleft
2297 if {!$use_ttk} {
2298 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2301 # lower right
2302 ${NS}::frame .bright
2303 ${NS}::frame .bright.mode
2304 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2305 -command reselectline -variable cmitmode -value "patch"
2306 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2307 -command reselectline -variable cmitmode -value "tree"
2308 grid .bright.mode.patch .bright.mode.tree -sticky ew
2309 pack .bright.mode -side top -fill x
2310 set cflist .bright.cfiles
2311 set indent [font measure mainfont "nn"]
2312 text $cflist \
2313 -selectbackground $selectbgcolor \
2314 -background $bgcolor -foreground $fgcolor \
2315 -font mainfont \
2316 -tabs [list $indent [expr {2 * $indent}]] \
2317 -yscrollcommand ".bright.sb set" \
2318 -cursor [. cget -cursor] \
2319 -spacing1 1 -spacing3 1
2320 lappend bglist $cflist
2321 lappend fglist $cflist
2322 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2323 pack .bright.sb -side right -fill y
2324 pack $cflist -side left -fill both -expand 1
2325 $cflist tag configure highlight \
2326 -background [$cflist cget -selectbackground]
2327 $cflist tag configure bold -font mainfontbold
2329 .pwbottom add .bright
2330 .ctop add .pwbottom
2332 # restore window width & height if known
2333 if {[info exists geometry(main)]} {
2334 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2335 if {$w > [winfo screenwidth .]} {
2336 set w [winfo screenwidth .]
2338 if {$h > [winfo screenheight .]} {
2339 set h [winfo screenheight .]
2341 wm geometry . "${w}x$h"
2345 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2346 wm state . $geometry(state)
2349 if {[tk windowingsystem] eq {aqua}} {
2350 set M1B M1
2351 set ::BM "3"
2352 } else {
2353 set M1B Control
2354 set ::BM "2"
2357 if {$use_ttk} {
2358 bind .ctop <Map> {
2359 bind %W <Map> {}
2360 %W sashpos 0 $::geometry(topheight)
2362 bind .pwbottom <Map> {
2363 bind %W <Map> {}
2364 %W sashpos 0 $::geometry(botwidth)
2368 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2369 pack .ctop -fill both -expand 1
2370 bindall <1> {selcanvline %W %x %y}
2371 #bindall <B1-Motion> {selcanvline %W %x %y}
2372 if {[tk windowingsystem] == "win32"} {
2373 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2374 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2375 } else {
2376 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2377 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2378 if {[tk windowingsystem] eq "aqua"} {
2379 bindall <MouseWheel> {
2380 set delta [expr {- (%D)}]
2381 allcanvs yview scroll $delta units
2383 bindall <Shift-MouseWheel> {
2384 set delta [expr {- (%D)}]
2385 $canv xview scroll $delta units
2389 bindall <$::BM> "canvscan mark %W %x %y"
2390 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2391 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2392 bind . <$M1B-Key-w> doquit
2393 bindkey <Home> selfirstline
2394 bindkey <End> sellastline
2395 bind . <Key-Up> "selnextline -1"
2396 bind . <Key-Down> "selnextline 1"
2397 bind . <Shift-Key-Up> "dofind -1 0"
2398 bind . <Shift-Key-Down> "dofind 1 0"
2399 bindkey <Key-Right> "goforw"
2400 bindkey <Key-Left> "goback"
2401 bind . <Key-Prior> "selnextpage -1"
2402 bind . <Key-Next> "selnextpage 1"
2403 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2404 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2405 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2406 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2407 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2408 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2409 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2410 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2411 bindkey <Key-space> "$ctext yview scroll 1 pages"
2412 bindkey p "selnextline -1"
2413 bindkey n "selnextline 1"
2414 bindkey z "goback"
2415 bindkey x "goforw"
2416 bindkey i "selnextline -1"
2417 bindkey k "selnextline 1"
2418 bindkey j "goback"
2419 bindkey l "goforw"
2420 bindkey b prevfile
2421 bindkey d "$ctext yview scroll 18 units"
2422 bindkey u "$ctext yview scroll -18 units"
2423 bindkey / {focus $fstring}
2424 bindkey <Key-KP_Divide> {focus $fstring}
2425 bindkey <Key-Return> {dofind 1 1}
2426 bindkey ? {dofind -1 1}
2427 bindkey f nextfile
2428 bind . <F5> updatecommits
2429 bind . <$M1B-F5> reloadcommits
2430 bind . <F2> showrefs
2431 bind . <Shift-F4> {newview 0}
2432 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2433 bind . <F4> edit_or_newview
2434 bind . <$M1B-q> doquit
2435 bind . <$M1B-f> {dofind 1 1}
2436 bind . <$M1B-g> {dofind 1 0}
2437 bind . <$M1B-r> dosearchback
2438 bind . <$M1B-s> dosearch
2439 bind . <$M1B-equal> {incrfont 1}
2440 bind . <$M1B-plus> {incrfont 1}
2441 bind . <$M1B-KP_Add> {incrfont 1}
2442 bind . <$M1B-minus> {incrfont -1}
2443 bind . <$M1B-KP_Subtract> {incrfont -1}
2444 wm protocol . WM_DELETE_WINDOW doquit
2445 bind . <Destroy> {stop_backends}
2446 bind . <Button-1> "click %W"
2447 bind $fstring <Key-Return> {dofind 1 1}
2448 bind $sha1entry <Key-Return> {gotocommit; break}
2449 bind $sha1entry <<PasteSelection>> clearsha1
2450 bind $cflist <1> {sel_flist %W %x %y; break}
2451 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2452 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2453 global ctxbut
2454 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2455 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2457 set maincursor [. cget -cursor]
2458 set textcursor [$ctext cget -cursor]
2459 set curtextcursor $textcursor
2461 set rowctxmenu .rowctxmenu
2462 makemenu $rowctxmenu {
2463 {mc "Diff this -> selected" command {diffvssel 0}}
2464 {mc "Diff selected -> this" command {diffvssel 1}}
2465 {mc "Make patch" command mkpatch}
2466 {mc "Create tag" command mktag}
2467 {mc "Write commit to file" command writecommit}
2468 {mc "Create new branch" command mkbranch}
2469 {mc "Cherry-pick this commit" command cherrypick}
2470 {mc "Reset HEAD branch to here" command resethead}
2471 {mc "Mark this commit" command markhere}
2472 {mc "Return to mark" command gotomark}
2473 {mc "Find descendant of this and mark" command find_common_desc}
2474 {mc "Compare with marked commit" command compare_commits}
2476 $rowctxmenu configure -tearoff 0
2478 set fakerowmenu .fakerowmenu
2479 makemenu $fakerowmenu {
2480 {mc "Diff this -> selected" command {diffvssel 0}}
2481 {mc "Diff selected -> this" command {diffvssel 1}}
2482 {mc "Make patch" command mkpatch}
2484 $fakerowmenu configure -tearoff 0
2486 set headctxmenu .headctxmenu
2487 makemenu $headctxmenu {
2488 {mc "Check out this branch" command cobranch}
2489 {mc "Remove this branch" command rmbranch}
2491 $headctxmenu configure -tearoff 0
2493 global flist_menu
2494 set flist_menu .flistctxmenu
2495 makemenu $flist_menu {
2496 {mc "Highlight this too" command {flist_hl 0}}
2497 {mc "Highlight this only" command {flist_hl 1}}
2498 {mc "External diff" command {external_diff}}
2499 {mc "Blame parent commit" command {external_blame 1}}
2501 $flist_menu configure -tearoff 0
2503 global diff_menu
2504 set diff_menu .diffctxmenu
2505 makemenu $diff_menu {
2506 {mc "Show origin of this line" command show_line_source}
2507 {mc "Run git gui blame on this line" command {external_blame_diff}}
2509 $diff_menu configure -tearoff 0
2512 # Windows sends all mouse wheel events to the current focused window, not
2513 # the one where the mouse hovers, so bind those events here and redirect
2514 # to the correct window
2515 proc windows_mousewheel_redirector {W X Y D} {
2516 global canv canv2 canv3
2517 set w [winfo containing -displayof $W $X $Y]
2518 if {$w ne ""} {
2519 set u [expr {$D < 0 ? 5 : -5}]
2520 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2521 allcanvs yview scroll $u units
2522 } else {
2523 catch {
2524 $w yview scroll $u units
2530 # Update row number label when selectedline changes
2531 proc selectedline_change {n1 n2 op} {
2532 global selectedline rownumsel
2534 if {$selectedline eq {}} {
2535 set rownumsel {}
2536 } else {
2537 set rownumsel [expr {$selectedline + 1}]
2541 # mouse-2 makes all windows scan vertically, but only the one
2542 # the cursor is in scans horizontally
2543 proc canvscan {op w x y} {
2544 global canv canv2 canv3
2545 foreach c [list $canv $canv2 $canv3] {
2546 if {$c == $w} {
2547 $c scan $op $x $y
2548 } else {
2549 $c scan $op 0 $y
2554 proc scrollcanv {cscroll f0 f1} {
2555 $cscroll set $f0 $f1
2556 drawvisible
2557 flushhighlights
2560 # when we make a key binding for the toplevel, make sure
2561 # it doesn't get triggered when that key is pressed in the
2562 # find string entry widget.
2563 proc bindkey {ev script} {
2564 global entries
2565 bind . $ev $script
2566 set escript [bind Entry $ev]
2567 if {$escript == {}} {
2568 set escript [bind Entry <Key>]
2570 foreach e $entries {
2571 bind $e $ev "$escript; break"
2575 # set the focus back to the toplevel for any click outside
2576 # the entry widgets
2577 proc click {w} {
2578 global ctext entries
2579 foreach e [concat $entries $ctext] {
2580 if {$w == $e} return
2582 focus .
2585 # Adjust the progress bar for a change in requested extent or canvas size
2586 proc adjustprogress {} {
2587 global progresscanv progressitem progresscoords
2588 global fprogitem fprogcoord lastprogupdate progupdatepending
2589 global rprogitem rprogcoord use_ttk
2591 if {$use_ttk} {
2592 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2593 return
2596 set w [expr {[winfo width $progresscanv] - 4}]
2597 set x0 [expr {$w * [lindex $progresscoords 0]}]
2598 set x1 [expr {$w * [lindex $progresscoords 1]}]
2599 set h [winfo height $progresscanv]
2600 $progresscanv coords $progressitem $x0 0 $x1 $h
2601 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2602 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2603 set now [clock clicks -milliseconds]
2604 if {$now >= $lastprogupdate + 100} {
2605 set progupdatepending 0
2606 update
2607 } elseif {!$progupdatepending} {
2608 set progupdatepending 1
2609 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2613 proc doprogupdate {} {
2614 global lastprogupdate progupdatepending
2616 if {$progupdatepending} {
2617 set progupdatepending 0
2618 set lastprogupdate [clock clicks -milliseconds]
2619 update
2623 proc savestuff {w} {
2624 global canv canv2 canv3 mainfont textfont uifont tabstop
2625 global stuffsaved findmergefiles maxgraphpct
2626 global maxwidth showneartags showlocalchanges
2627 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2628 global cmitmode wrapcomment datetimeformat limitdiffs
2629 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2630 global autoselect extdifftool perfile_attrs markbgcolor use_ttk
2631 global hideremotes want_ttk
2633 if {$stuffsaved} return
2634 if {![winfo viewable .]} return
2635 catch {
2636 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2637 set f [open "~/.gitk-new" w]
2638 if {$::tcl_platform(platform) eq {windows}} {
2639 file attributes "~/.gitk-new" -hidden true
2641 puts $f [list set mainfont $mainfont]
2642 puts $f [list set textfont $textfont]
2643 puts $f [list set uifont $uifont]
2644 puts $f [list set tabstop $tabstop]
2645 puts $f [list set findmergefiles $findmergefiles]
2646 puts $f [list set maxgraphpct $maxgraphpct]
2647 puts $f [list set maxwidth $maxwidth]
2648 puts $f [list set cmitmode $cmitmode]
2649 puts $f [list set wrapcomment $wrapcomment]
2650 puts $f [list set autoselect $autoselect]
2651 puts $f [list set showneartags $showneartags]
2652 puts $f [list set hideremotes $hideremotes]
2653 puts $f [list set showlocalchanges $showlocalchanges]
2654 puts $f [list set datetimeformat $datetimeformat]
2655 puts $f [list set limitdiffs $limitdiffs]
2656 puts $f [list set uicolor $uicolor]
2657 puts $f [list set want_ttk $want_ttk]
2658 puts $f [list set bgcolor $bgcolor]
2659 puts $f [list set fgcolor $fgcolor]
2660 puts $f [list set colors $colors]
2661 puts $f [list set diffcolors $diffcolors]
2662 puts $f [list set markbgcolor $markbgcolor]
2663 puts $f [list set diffcontext $diffcontext]
2664 puts $f [list set selectbgcolor $selectbgcolor]
2665 puts $f [list set extdifftool $extdifftool]
2666 puts $f [list set perfile_attrs $perfile_attrs]
2668 puts $f "set geometry(main) [wm geometry .]"
2669 puts $f "set geometry(state) [wm state .]"
2670 puts $f "set geometry(topwidth) [winfo width .tf]"
2671 puts $f "set geometry(topheight) [winfo height .tf]"
2672 if {$use_ttk} {
2673 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2674 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2675 } else {
2676 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2677 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2679 puts $f "set geometry(botwidth) [winfo width .bleft]"
2680 puts $f "set geometry(botheight) [winfo height .bleft]"
2682 puts -nonewline $f "set permviews {"
2683 for {set v 0} {$v < $nextviewnum} {incr v} {
2684 if {$viewperm($v)} {
2685 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2688 puts $f "}"
2689 close $f
2690 file rename -force "~/.gitk-new" "~/.gitk"
2692 set stuffsaved 1
2695 proc resizeclistpanes {win w} {
2696 global oldwidth use_ttk
2697 if {[info exists oldwidth($win)]} {
2698 if {$use_ttk} {
2699 set s0 [$win sashpos 0]
2700 set s1 [$win sashpos 1]
2701 } else {
2702 set s0 [$win sash coord 0]
2703 set s1 [$win sash coord 1]
2705 if {$w < 60} {
2706 set sash0 [expr {int($w/2 - 2)}]
2707 set sash1 [expr {int($w*5/6 - 2)}]
2708 } else {
2709 set factor [expr {1.0 * $w / $oldwidth($win)}]
2710 set sash0 [expr {int($factor * [lindex $s0 0])}]
2711 set sash1 [expr {int($factor * [lindex $s1 0])}]
2712 if {$sash0 < 30} {
2713 set sash0 30
2715 if {$sash1 < $sash0 + 20} {
2716 set sash1 [expr {$sash0 + 20}]
2718 if {$sash1 > $w - 10} {
2719 set sash1 [expr {$w - 10}]
2720 if {$sash0 > $sash1 - 20} {
2721 set sash0 [expr {$sash1 - 20}]
2725 if {$use_ttk} {
2726 $win sashpos 0 $sash0
2727 $win sashpos 1 $sash1
2728 } else {
2729 $win sash place 0 $sash0 [lindex $s0 1]
2730 $win sash place 1 $sash1 [lindex $s1 1]
2733 set oldwidth($win) $w
2736 proc resizecdetpanes {win w} {
2737 global oldwidth use_ttk
2738 if {[info exists oldwidth($win)]} {
2739 if {$use_ttk} {
2740 set s0 [$win sashpos 0]
2741 } else {
2742 set s0 [$win sash coord 0]
2744 if {$w < 60} {
2745 set sash0 [expr {int($w*3/4 - 2)}]
2746 } else {
2747 set factor [expr {1.0 * $w / $oldwidth($win)}]
2748 set sash0 [expr {int($factor * [lindex $s0 0])}]
2749 if {$sash0 < 45} {
2750 set sash0 45
2752 if {$sash0 > $w - 15} {
2753 set sash0 [expr {$w - 15}]
2756 if {$use_ttk} {
2757 $win sashpos 0 $sash0
2758 } else {
2759 $win sash place 0 $sash0 [lindex $s0 1]
2762 set oldwidth($win) $w
2765 proc allcanvs args {
2766 global canv canv2 canv3
2767 eval $canv $args
2768 eval $canv2 $args
2769 eval $canv3 $args
2772 proc bindall {event action} {
2773 global canv canv2 canv3
2774 bind $canv $event $action
2775 bind $canv2 $event $action
2776 bind $canv3 $event $action
2779 proc about {} {
2780 global uifont NS
2781 set w .about
2782 if {[winfo exists $w]} {
2783 raise $w
2784 return
2786 ttk_toplevel $w
2787 wm title $w [mc "About gitk"]
2788 make_transient $w .
2789 message $w.m -text [mc "
2790 Gitk - a commit viewer for git
2792 Copyright \u00a9 2005-2010 Paul Mackerras
2794 Use and redistribute under the terms of the GNU General Public License"] \
2795 -justify center -aspect 400 -border 2 -bg white -relief groove
2796 pack $w.m -side top -fill x -padx 2 -pady 2
2797 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2798 pack $w.ok -side bottom
2799 bind $w <Visibility> "focus $w.ok"
2800 bind $w <Key-Escape> "destroy $w"
2801 bind $w <Key-Return> "destroy $w"
2802 tk::PlaceWindow $w widget .
2805 proc keys {} {
2806 global NS
2807 set w .keys
2808 if {[winfo exists $w]} {
2809 raise $w
2810 return
2812 if {[tk windowingsystem] eq {aqua}} {
2813 set M1T Cmd
2814 } else {
2815 set M1T Ctrl
2817 ttk_toplevel $w
2818 wm title $w [mc "Gitk key bindings"]
2819 make_transient $w .
2820 message $w.m -text "
2821 [mc "Gitk key bindings:"]
2823 [mc "<%s-Q> Quit" $M1T]
2824 [mc "<%s-W> Close window" $M1T]
2825 [mc "<Home> Move to first commit"]
2826 [mc "<End> Move to last commit"]
2827 [mc "<Up>, p, i Move up one commit"]
2828 [mc "<Down>, n, k Move down one commit"]
2829 [mc "<Left>, z, j Go back in history list"]
2830 [mc "<Right>, x, l Go forward in history list"]
2831 [mc "<PageUp> Move up one page in commit list"]
2832 [mc "<PageDown> Move down one page in commit list"]
2833 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2834 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2835 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2836 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2837 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2838 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2839 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2840 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2841 [mc "<Delete>, b Scroll diff view up one page"]
2842 [mc "<Backspace> Scroll diff view up one page"]
2843 [mc "<Space> Scroll diff view down one page"]
2844 [mc "u Scroll diff view up 18 lines"]
2845 [mc "d Scroll diff view down 18 lines"]
2846 [mc "<%s-F> Find" $M1T]
2847 [mc "<%s-G> Move to next find hit" $M1T]
2848 [mc "<Return> Move to next find hit"]
2849 [mc "/ Focus the search box"]
2850 [mc "? Move to previous find hit"]
2851 [mc "f Scroll diff view to next file"]
2852 [mc "<%s-S> Search for next hit in diff view" $M1T]
2853 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2854 [mc "<%s-KP+> Increase font size" $M1T]
2855 [mc "<%s-plus> Increase font size" $M1T]
2856 [mc "<%s-KP-> Decrease font size" $M1T]
2857 [mc "<%s-minus> Decrease font size" $M1T]
2858 [mc "<F5> Update"]
2860 -justify left -bg white -border 2 -relief groove
2861 pack $w.m -side top -fill both -padx 2 -pady 2
2862 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2863 bind $w <Key-Escape> [list destroy $w]
2864 pack $w.ok -side bottom
2865 bind $w <Visibility> "focus $w.ok"
2866 bind $w <Key-Escape> "destroy $w"
2867 bind $w <Key-Return> "destroy $w"
2870 # Procedures for manipulating the file list window at the
2871 # bottom right of the overall window.
2873 proc treeview {w l openlevs} {
2874 global treecontents treediropen treeheight treeparent treeindex
2876 set ix 0
2877 set treeindex() 0
2878 set lev 0
2879 set prefix {}
2880 set prefixend -1
2881 set prefendstack {}
2882 set htstack {}
2883 set ht 0
2884 set treecontents() {}
2885 $w conf -state normal
2886 foreach f $l {
2887 while {[string range $f 0 $prefixend] ne $prefix} {
2888 if {$lev <= $openlevs} {
2889 $w mark set e:$treeindex($prefix) "end -1c"
2890 $w mark gravity e:$treeindex($prefix) left
2892 set treeheight($prefix) $ht
2893 incr ht [lindex $htstack end]
2894 set htstack [lreplace $htstack end end]
2895 set prefixend [lindex $prefendstack end]
2896 set prefendstack [lreplace $prefendstack end end]
2897 set prefix [string range $prefix 0 $prefixend]
2898 incr lev -1
2900 set tail [string range $f [expr {$prefixend+1}] end]
2901 while {[set slash [string first "/" $tail]] >= 0} {
2902 lappend htstack $ht
2903 set ht 0
2904 lappend prefendstack $prefixend
2905 incr prefixend [expr {$slash + 1}]
2906 set d [string range $tail 0 $slash]
2907 lappend treecontents($prefix) $d
2908 set oldprefix $prefix
2909 append prefix $d
2910 set treecontents($prefix) {}
2911 set treeindex($prefix) [incr ix]
2912 set treeparent($prefix) $oldprefix
2913 set tail [string range $tail [expr {$slash+1}] end]
2914 if {$lev <= $openlevs} {
2915 set ht 1
2916 set treediropen($prefix) [expr {$lev < $openlevs}]
2917 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2918 $w mark set d:$ix "end -1c"
2919 $w mark gravity d:$ix left
2920 set str "\n"
2921 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2922 $w insert end $str
2923 $w image create end -align center -image $bm -padx 1 \
2924 -name a:$ix
2925 $w insert end $d [highlight_tag $prefix]
2926 $w mark set s:$ix "end -1c"
2927 $w mark gravity s:$ix left
2929 incr lev
2931 if {$tail ne {}} {
2932 if {$lev <= $openlevs} {
2933 incr ht
2934 set str "\n"
2935 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2936 $w insert end $str
2937 $w insert end $tail [highlight_tag $f]
2939 lappend treecontents($prefix) $tail
2942 while {$htstack ne {}} {
2943 set treeheight($prefix) $ht
2944 incr ht [lindex $htstack end]
2945 set htstack [lreplace $htstack end end]
2946 set prefixend [lindex $prefendstack end]
2947 set prefendstack [lreplace $prefendstack end end]
2948 set prefix [string range $prefix 0 $prefixend]
2950 $w conf -state disabled
2953 proc linetoelt {l} {
2954 global treeheight treecontents
2956 set y 2
2957 set prefix {}
2958 while {1} {
2959 foreach e $treecontents($prefix) {
2960 if {$y == $l} {
2961 return "$prefix$e"
2963 set n 1
2964 if {[string index $e end] eq "/"} {
2965 set n $treeheight($prefix$e)
2966 if {$y + $n > $l} {
2967 append prefix $e
2968 incr y
2969 break
2972 incr y $n
2977 proc highlight_tree {y prefix} {
2978 global treeheight treecontents cflist
2980 foreach e $treecontents($prefix) {
2981 set path $prefix$e
2982 if {[highlight_tag $path] ne {}} {
2983 $cflist tag add bold $y.0 "$y.0 lineend"
2985 incr y
2986 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2987 set y [highlight_tree $y $path]
2990 return $y
2993 proc treeclosedir {w dir} {
2994 global treediropen treeheight treeparent treeindex
2996 set ix $treeindex($dir)
2997 $w conf -state normal
2998 $w delete s:$ix e:$ix
2999 set treediropen($dir) 0
3000 $w image configure a:$ix -image tri-rt
3001 $w conf -state disabled
3002 set n [expr {1 - $treeheight($dir)}]
3003 while {$dir ne {}} {
3004 incr treeheight($dir) $n
3005 set dir $treeparent($dir)
3009 proc treeopendir {w dir} {
3010 global treediropen treeheight treeparent treecontents treeindex
3012 set ix $treeindex($dir)
3013 $w conf -state normal
3014 $w image configure a:$ix -image tri-dn
3015 $w mark set e:$ix s:$ix
3016 $w mark gravity e:$ix right
3017 set lev 0
3018 set str "\n"
3019 set n [llength $treecontents($dir)]
3020 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3021 incr lev
3022 append str "\t"
3023 incr treeheight($x) $n
3025 foreach e $treecontents($dir) {
3026 set de $dir$e
3027 if {[string index $e end] eq "/"} {
3028 set iy $treeindex($de)
3029 $w mark set d:$iy e:$ix
3030 $w mark gravity d:$iy left
3031 $w insert e:$ix $str
3032 set treediropen($de) 0
3033 $w image create e:$ix -align center -image tri-rt -padx 1 \
3034 -name a:$iy
3035 $w insert e:$ix $e [highlight_tag $de]
3036 $w mark set s:$iy e:$ix
3037 $w mark gravity s:$iy left
3038 set treeheight($de) 1
3039 } else {
3040 $w insert e:$ix $str
3041 $w insert e:$ix $e [highlight_tag $de]
3044 $w mark gravity e:$ix right
3045 $w conf -state disabled
3046 set treediropen($dir) 1
3047 set top [lindex [split [$w index @0,0] .] 0]
3048 set ht [$w cget -height]
3049 set l [lindex [split [$w index s:$ix] .] 0]
3050 if {$l < $top} {
3051 $w yview $l.0
3052 } elseif {$l + $n + 1 > $top + $ht} {
3053 set top [expr {$l + $n + 2 - $ht}]
3054 if {$l < $top} {
3055 set top $l
3057 $w yview $top.0
3061 proc treeclick {w x y} {
3062 global treediropen cmitmode ctext cflist cflist_top
3064 if {$cmitmode ne "tree"} return
3065 if {![info exists cflist_top]} return
3066 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3067 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3068 $cflist tag add highlight $l.0 "$l.0 lineend"
3069 set cflist_top $l
3070 if {$l == 1} {
3071 $ctext yview 1.0
3072 return
3074 set e [linetoelt $l]
3075 if {[string index $e end] ne "/"} {
3076 showfile $e
3077 } elseif {$treediropen($e)} {
3078 treeclosedir $w $e
3079 } else {
3080 treeopendir $w $e
3084 proc setfilelist {id} {
3085 global treefilelist cflist jump_to_here
3087 treeview $cflist $treefilelist($id) 0
3088 if {$jump_to_here ne {}} {
3089 set f [lindex $jump_to_here 0]
3090 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3091 showfile $f
3096 image create bitmap tri-rt -background black -foreground blue -data {
3097 #define tri-rt_width 13
3098 #define tri-rt_height 13
3099 static unsigned char tri-rt_bits[] = {
3100 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3101 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3102 0x00, 0x00};
3103 } -maskdata {
3104 #define tri-rt-mask_width 13
3105 #define tri-rt-mask_height 13
3106 static unsigned char tri-rt-mask_bits[] = {
3107 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3108 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3109 0x08, 0x00};
3111 image create bitmap tri-dn -background black -foreground blue -data {
3112 #define tri-dn_width 13
3113 #define tri-dn_height 13
3114 static unsigned char tri-dn_bits[] = {
3115 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3116 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3117 0x00, 0x00};
3118 } -maskdata {
3119 #define tri-dn-mask_width 13
3120 #define tri-dn-mask_height 13
3121 static unsigned char tri-dn-mask_bits[] = {
3122 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3123 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3124 0x00, 0x00};
3127 image create bitmap reficon-T -background black -foreground yellow -data {
3128 #define tagicon_width 13
3129 #define tagicon_height 9
3130 static unsigned char tagicon_bits[] = {
3131 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3132 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3133 } -maskdata {
3134 #define tagicon-mask_width 13
3135 #define tagicon-mask_height 9
3136 static unsigned char tagicon-mask_bits[] = {
3137 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3138 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3140 set rectdata {
3141 #define headicon_width 13
3142 #define headicon_height 9
3143 static unsigned char headicon_bits[] = {
3144 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3145 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3147 set rectmask {
3148 #define headicon-mask_width 13
3149 #define headicon-mask_height 9
3150 static unsigned char headicon-mask_bits[] = {
3151 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3152 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3154 image create bitmap reficon-H -background black -foreground green \
3155 -data $rectdata -maskdata $rectmask
3156 image create bitmap reficon-o -background black -foreground "#ddddff" \
3157 -data $rectdata -maskdata $rectmask
3159 proc init_flist {first} {
3160 global cflist cflist_top difffilestart
3162 $cflist conf -state normal
3163 $cflist delete 0.0 end
3164 if {$first ne {}} {
3165 $cflist insert end $first
3166 set cflist_top 1
3167 $cflist tag add highlight 1.0 "1.0 lineend"
3168 } else {
3169 catch {unset cflist_top}
3171 $cflist conf -state disabled
3172 set difffilestart {}
3175 proc highlight_tag {f} {
3176 global highlight_paths
3178 foreach p $highlight_paths {
3179 if {[string match $p $f]} {
3180 return "bold"
3183 return {}
3186 proc highlight_filelist {} {
3187 global cmitmode cflist
3189 $cflist conf -state normal
3190 if {$cmitmode ne "tree"} {
3191 set end [lindex [split [$cflist index end] .] 0]
3192 for {set l 2} {$l < $end} {incr l} {
3193 set line [$cflist get $l.0 "$l.0 lineend"]
3194 if {[highlight_tag $line] ne {}} {
3195 $cflist tag add bold $l.0 "$l.0 lineend"
3198 } else {
3199 highlight_tree 2 {}
3201 $cflist conf -state disabled
3204 proc unhighlight_filelist {} {
3205 global cflist
3207 $cflist conf -state normal
3208 $cflist tag remove bold 1.0 end
3209 $cflist conf -state disabled
3212 proc add_flist {fl} {
3213 global cflist
3215 $cflist conf -state normal
3216 foreach f $fl {
3217 $cflist insert end "\n"
3218 $cflist insert end $f [highlight_tag $f]
3220 $cflist conf -state disabled
3223 proc sel_flist {w x y} {
3224 global ctext difffilestart cflist cflist_top cmitmode
3226 if {$cmitmode eq "tree"} return
3227 if {![info exists cflist_top]} return
3228 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3229 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3230 $cflist tag add highlight $l.0 "$l.0 lineend"
3231 set cflist_top $l
3232 if {$l == 1} {
3233 $ctext yview 1.0
3234 } else {
3235 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3239 proc pop_flist_menu {w X Y x y} {
3240 global ctext cflist cmitmode flist_menu flist_menu_file
3241 global treediffs diffids
3243 stopfinding
3244 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3245 if {$l <= 1} return
3246 if {$cmitmode eq "tree"} {
3247 set e [linetoelt $l]
3248 if {[string index $e end] eq "/"} return
3249 } else {
3250 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3252 set flist_menu_file $e
3253 set xdiffstate "normal"
3254 if {$cmitmode eq "tree"} {
3255 set xdiffstate "disabled"
3257 # Disable "External diff" item in tree mode
3258 $flist_menu entryconf 2 -state $xdiffstate
3259 tk_popup $flist_menu $X $Y
3262 proc find_ctext_fileinfo {line} {
3263 global ctext_file_names ctext_file_lines
3265 set ok [bsearch $ctext_file_lines $line]
3266 set tline [lindex $ctext_file_lines $ok]
3268 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3269 return {}
3270 } else {
3271 return [list [lindex $ctext_file_names $ok] $tline]
3275 proc pop_diff_menu {w X Y x y} {
3276 global ctext diff_menu flist_menu_file
3277 global diff_menu_txtpos diff_menu_line
3278 global diff_menu_filebase
3280 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3281 set diff_menu_line [lindex $diff_menu_txtpos 0]
3282 # don't pop up the menu on hunk-separator or file-separator lines
3283 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3284 return
3286 stopfinding
3287 set f [find_ctext_fileinfo $diff_menu_line]
3288 if {$f eq {}} return
3289 set flist_menu_file [lindex $f 0]
3290 set diff_menu_filebase [lindex $f 1]
3291 tk_popup $diff_menu $X $Y
3294 proc flist_hl {only} {
3295 global flist_menu_file findstring gdttype
3297 set x [shellquote $flist_menu_file]
3298 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3299 set findstring $x
3300 } else {
3301 append findstring " " $x
3303 set gdttype [mc "touching paths:"]
3306 proc gitknewtmpdir {} {
3307 global diffnum gitktmpdir gitdir
3309 if {![info exists gitktmpdir]} {
3310 set gitktmpdir [file join [file dirname $gitdir] \
3311 [format ".gitk-tmp.%s" [pid]]]
3312 if {[catch {file mkdir $gitktmpdir} err]} {
3313 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3314 unset gitktmpdir
3315 return {}
3317 set diffnum 0
3319 incr diffnum
3320 set diffdir [file join $gitktmpdir $diffnum]
3321 if {[catch {file mkdir $diffdir} err]} {
3322 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3323 return {}
3325 return $diffdir
3328 proc save_file_from_commit {filename output what} {
3329 global nullfile
3331 if {[catch {exec git show $filename -- > $output} err]} {
3332 if {[string match "fatal: bad revision *" $err]} {
3333 return $nullfile
3335 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3336 return {}
3338 return $output
3341 proc external_diff_get_one_file {diffid filename diffdir} {
3342 global nullid nullid2 nullfile
3343 global gitdir
3345 if {$diffid == $nullid} {
3346 set difffile [file join [file dirname $gitdir] $filename]
3347 if {[file exists $difffile]} {
3348 return $difffile
3350 return $nullfile
3352 if {$diffid == $nullid2} {
3353 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3354 return [save_file_from_commit :$filename $difffile index]
3356 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3357 return [save_file_from_commit $diffid:$filename $difffile \
3358 "revision $diffid"]
3361 proc external_diff {} {
3362 global nullid nullid2
3363 global flist_menu_file
3364 global diffids
3365 global extdifftool
3367 if {[llength $diffids] == 1} {
3368 # no reference commit given
3369 set diffidto [lindex $diffids 0]
3370 if {$diffidto eq $nullid} {
3371 # diffing working copy with index
3372 set diffidfrom $nullid2
3373 } elseif {$diffidto eq $nullid2} {
3374 # diffing index with HEAD
3375 set diffidfrom "HEAD"
3376 } else {
3377 # use first parent commit
3378 global parentlist selectedline
3379 set diffidfrom [lindex $parentlist $selectedline 0]
3381 } else {
3382 set diffidfrom [lindex $diffids 0]
3383 set diffidto [lindex $diffids 1]
3386 # make sure that several diffs wont collide
3387 set diffdir [gitknewtmpdir]
3388 if {$diffdir eq {}} return
3390 # gather files to diff
3391 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3392 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3394 if {$difffromfile ne {} && $difftofile ne {}} {
3395 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3396 if {[catch {set fl [open |$cmd r]} err]} {
3397 file delete -force $diffdir
3398 error_popup "$extdifftool: [mc "command failed:"] $err"
3399 } else {
3400 fconfigure $fl -blocking 0
3401 filerun $fl [list delete_at_eof $fl $diffdir]
3406 proc find_hunk_blamespec {base line} {
3407 global ctext
3409 # Find and parse the hunk header
3410 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3411 if {$s_lix eq {}} return
3413 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3414 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3415 s_line old_specs osz osz1 new_line nsz]} {
3416 return
3419 # base lines for the parents
3420 set base_lines [list $new_line]
3421 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3422 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3423 old_spec old_line osz]} {
3424 return
3426 lappend base_lines $old_line
3429 # Now scan the lines to determine offset within the hunk
3430 set max_parent [expr {[llength $base_lines]-2}]
3431 set dline 0
3432 set s_lno [lindex [split $s_lix "."] 0]
3434 # Determine if the line is removed
3435 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3436 if {[string match {[-+ ]*} $chunk]} {
3437 set removed_idx [string first "-" $chunk]
3438 # Choose a parent index
3439 if {$removed_idx >= 0} {
3440 set parent $removed_idx
3441 } else {
3442 set unchanged_idx [string first " " $chunk]
3443 if {$unchanged_idx >= 0} {
3444 set parent $unchanged_idx
3445 } else {
3446 # blame the current commit
3447 set parent -1
3450 # then count other lines that belong to it
3451 for {set i $line} {[incr i -1] > $s_lno} {} {
3452 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3453 # Determine if the line is removed
3454 set removed_idx [string first "-" $chunk]
3455 if {$parent >= 0} {
3456 set code [string index $chunk $parent]
3457 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3458 incr dline
3460 } else {
3461 if {$removed_idx < 0} {
3462 incr dline
3466 incr parent
3467 } else {
3468 set parent 0
3471 incr dline [lindex $base_lines $parent]
3472 return [list $parent $dline]
3475 proc external_blame_diff {} {
3476 global currentid cmitmode
3477 global diff_menu_txtpos diff_menu_line
3478 global diff_menu_filebase flist_menu_file
3480 if {$cmitmode eq "tree"} {
3481 set parent_idx 0
3482 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3483 } else {
3484 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3485 if {$hinfo ne {}} {
3486 set parent_idx [lindex $hinfo 0]
3487 set line [lindex $hinfo 1]
3488 } else {
3489 set parent_idx 0
3490 set line 0
3494 external_blame $parent_idx $line
3497 # Find the SHA1 ID of the blob for file $fname in the index
3498 # at stage 0 or 2
3499 proc index_sha1 {fname} {
3500 set f [open [list | git ls-files -s $fname] r]
3501 while {[gets $f line] >= 0} {
3502 set info [lindex [split $line "\t"] 0]
3503 set stage [lindex $info 2]
3504 if {$stage eq "0" || $stage eq "2"} {
3505 close $f
3506 return [lindex $info 1]
3509 close $f
3510 return {}
3513 # Turn an absolute path into one relative to the current directory
3514 proc make_relative {f} {
3515 if {[file pathtype $f] eq "relative"} {
3516 return $f
3518 set elts [file split $f]
3519 set here [file split [pwd]]
3520 set ei 0
3521 set hi 0
3522 set res {}
3523 foreach d $here {
3524 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3525 lappend res ".."
3526 } else {
3527 incr ei
3529 incr hi
3531 set elts [concat $res [lrange $elts $ei end]]
3532 return [eval file join $elts]
3535 proc external_blame {parent_idx {line {}}} {
3536 global flist_menu_file gitdir
3537 global nullid nullid2
3538 global parentlist selectedline currentid
3540 if {$parent_idx > 0} {
3541 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3542 } else {
3543 set base_commit $currentid
3546 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3547 error_popup [mc "No such commit"]
3548 return
3551 set cmdline [list git gui blame]
3552 if {$line ne {} && $line > 1} {
3553 lappend cmdline "--line=$line"
3555 set f [file join [file dirname $gitdir] $flist_menu_file]
3556 # Unfortunately it seems git gui blame doesn't like
3557 # being given an absolute path...
3558 set f [make_relative $f]
3559 lappend cmdline $base_commit $f
3560 if {[catch {eval exec $cmdline &} err]} {
3561 error_popup "[mc "git gui blame: command failed:"] $err"
3565 proc show_line_source {} {
3566 global cmitmode currentid parents curview blamestuff blameinst
3567 global diff_menu_line diff_menu_filebase flist_menu_file
3568 global nullid nullid2 gitdir
3570 set from_index {}
3571 if {$cmitmode eq "tree"} {
3572 set id $currentid
3573 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3574 } else {
3575 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3576 if {$h eq {}} return
3577 set pi [lindex $h 0]
3578 if {$pi == 0} {
3579 mark_ctext_line $diff_menu_line
3580 return
3582 incr pi -1
3583 if {$currentid eq $nullid} {
3584 if {$pi > 0} {
3585 # must be a merge in progress...
3586 if {[catch {
3587 # get the last line from .git/MERGE_HEAD
3588 set f [open [file join $gitdir MERGE_HEAD] r]
3589 set id [lindex [split [read $f] "\n"] end-1]
3590 close $f
3591 } err]} {
3592 error_popup [mc "Couldn't read merge head: %s" $err]
3593 return
3595 } elseif {$parents($curview,$currentid) eq $nullid2} {
3596 # need to do the blame from the index
3597 if {[catch {
3598 set from_index [index_sha1 $flist_menu_file]
3599 } err]} {
3600 error_popup [mc "Error reading index: %s" $err]
3601 return
3603 } else {
3604 set id $parents($curview,$currentid)
3606 } else {
3607 set id [lindex $parents($curview,$currentid) $pi]
3609 set line [lindex $h 1]
3611 set blameargs {}
3612 if {$from_index ne {}} {
3613 lappend blameargs | git cat-file blob $from_index
3615 lappend blameargs | git blame -p -L$line,+1
3616 if {$from_index ne {}} {
3617 lappend blameargs --contents -
3618 } else {
3619 lappend blameargs $id
3621 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3622 if {[catch {
3623 set f [open $blameargs r]
3624 } err]} {
3625 error_popup [mc "Couldn't start git blame: %s" $err]
3626 return
3628 nowbusy blaming [mc "Searching"]
3629 fconfigure $f -blocking 0
3630 set i [reg_instance $f]
3631 set blamestuff($i) {}
3632 set blameinst $i
3633 filerun $f [list read_line_source $f $i]
3636 proc stopblaming {} {
3637 global blameinst
3639 if {[info exists blameinst]} {
3640 stop_instance $blameinst
3641 unset blameinst
3642 notbusy blaming
3646 proc read_line_source {fd inst} {
3647 global blamestuff curview commfd blameinst nullid nullid2
3649 while {[gets $fd line] >= 0} {
3650 lappend blamestuff($inst) $line
3652 if {![eof $fd]} {
3653 return 1
3655 unset commfd($inst)
3656 unset blameinst
3657 notbusy blaming
3658 fconfigure $fd -blocking 1
3659 if {[catch {close $fd} err]} {
3660 error_popup [mc "Error running git blame: %s" $err]
3661 return 0
3664 set fname {}
3665 set line [split [lindex $blamestuff($inst) 0] " "]
3666 set id [lindex $line 0]
3667 set lnum [lindex $line 1]
3668 if {[string length $id] == 40 && [string is xdigit $id] &&
3669 [string is digit -strict $lnum]} {
3670 # look for "filename" line
3671 foreach l $blamestuff($inst) {
3672 if {[string match "filename *" $l]} {
3673 set fname [string range $l 9 end]
3674 break
3678 if {$fname ne {}} {
3679 # all looks good, select it
3680 if {$id eq $nullid} {
3681 # blame uses all-zeroes to mean not committed,
3682 # which would mean a change in the index
3683 set id $nullid2
3685 if {[commitinview $id $curview]} {
3686 selectline [rowofcommit $id] 1 [list $fname $lnum]
3687 } else {
3688 error_popup [mc "That line comes from commit %s, \
3689 which is not in this view" [shortids $id]]
3691 } else {
3692 puts "oops couldn't parse git blame output"
3694 return 0
3697 # delete $dir when we see eof on $f (presumably because the child has exited)
3698 proc delete_at_eof {f dir} {
3699 while {[gets $f line] >= 0} {}
3700 if {[eof $f]} {
3701 if {[catch {close $f} err]} {
3702 error_popup "[mc "External diff viewer failed:"] $err"
3704 file delete -force $dir
3705 return 0
3707 return 1
3710 # Functions for adding and removing shell-type quoting
3712 proc shellquote {str} {
3713 if {![string match "*\['\"\\ \t]*" $str]} {
3714 return $str
3716 if {![string match "*\['\"\\]*" $str]} {
3717 return "\"$str\""
3719 if {![string match "*'*" $str]} {
3720 return "'$str'"
3722 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3725 proc shellarglist {l} {
3726 set str {}
3727 foreach a $l {
3728 if {$str ne {}} {
3729 append str " "
3731 append str [shellquote $a]
3733 return $str
3736 proc shelldequote {str} {
3737 set ret {}
3738 set used -1
3739 while {1} {
3740 incr used
3741 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3742 append ret [string range $str $used end]
3743 set used [string length $str]
3744 break
3746 set first [lindex $first 0]
3747 set ch [string index $str $first]
3748 if {$first > $used} {
3749 append ret [string range $str $used [expr {$first - 1}]]
3750 set used $first
3752 if {$ch eq " " || $ch eq "\t"} break
3753 incr used
3754 if {$ch eq "'"} {
3755 set first [string first "'" $str $used]
3756 if {$first < 0} {
3757 error "unmatched single-quote"
3759 append ret [string range $str $used [expr {$first - 1}]]
3760 set used $first
3761 continue
3763 if {$ch eq "\\"} {
3764 if {$used >= [string length $str]} {
3765 error "trailing backslash"
3767 append ret [string index $str $used]
3768 continue
3770 # here ch == "\""
3771 while {1} {
3772 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3773 error "unmatched double-quote"
3775 set first [lindex $first 0]
3776 set ch [string index $str $first]
3777 if {$first > $used} {
3778 append ret [string range $str $used [expr {$first - 1}]]
3779 set used $first
3781 if {$ch eq "\""} break
3782 incr used
3783 append ret [string index $str $used]
3784 incr used
3787 return [list $used $ret]
3790 proc shellsplit {str} {
3791 set l {}
3792 while {1} {
3793 set str [string trimleft $str]
3794 if {$str eq {}} break
3795 set dq [shelldequote $str]
3796 set n [lindex $dq 0]
3797 set word [lindex $dq 1]
3798 set str [string range $str $n end]
3799 lappend l $word
3801 return $l
3804 # Code to implement multiple views
3806 proc newview {ishighlight} {
3807 global nextviewnum newviewname newishighlight
3808 global revtreeargs viewargscmd newviewopts curview
3810 set newishighlight $ishighlight
3811 set top .gitkview
3812 if {[winfo exists $top]} {
3813 raise $top
3814 return
3816 decode_view_opts $nextviewnum $revtreeargs
3817 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3818 set newviewopts($nextviewnum,perm) 0
3819 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3820 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3823 set known_view_options {
3824 {perm b . {} {mc "Remember this view"}}
3825 {reflabel l + {} {mc "References (space separated list):"}}
3826 {refs t15 .. {} {mc "Branches & tags:"}}
3827 {allrefs b *. "--all" {mc "All refs"}}
3828 {branches b . "--branches" {mc "All (local) branches"}}
3829 {tags b . "--tags" {mc "All tags"}}
3830 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3831 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3832 {author t15 .. "--author=*" {mc "Author:"}}
3833 {committer t15 . "--committer=*" {mc "Committer:"}}
3834 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3835 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3836 {changes_l l + {} {mc "Changes to Files:"}}
3837 {pickaxe_s r0 . {} {mc "Fixed String"}}
3838 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3839 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3840 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3841 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3842 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3843 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3844 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3845 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3846 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3847 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3848 {lright b . "--left-right" {mc "Mark branch sides"}}
3849 {first b . "--first-parent" {mc "Limit to first parent"}}
3850 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3851 {args t50 *. {} {mc "Additional arguments to git log:"}}
3852 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3853 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3856 # Convert $newviewopts($n, ...) into args for git log.
3857 proc encode_view_opts {n} {
3858 global known_view_options newviewopts
3860 set rargs [list]
3861 foreach opt $known_view_options {
3862 set patterns [lindex $opt 3]
3863 if {$patterns eq {}} continue
3864 set pattern [lindex $patterns 0]
3866 if {[lindex $opt 1] eq "b"} {
3867 set val $newviewopts($n,[lindex $opt 0])
3868 if {$val} {
3869 lappend rargs $pattern
3871 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3872 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3873 set val $newviewopts($n,$button_id)
3874 if {$val eq $value} {
3875 lappend rargs $pattern
3877 } else {
3878 set val $newviewopts($n,[lindex $opt 0])
3879 set val [string trim $val]
3880 if {$val ne {}} {
3881 set pfix [string range $pattern 0 end-1]
3882 lappend rargs $pfix$val
3886 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3887 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3890 # Fill $newviewopts($n, ...) based on args for git log.
3891 proc decode_view_opts {n view_args} {
3892 global known_view_options newviewopts
3894 foreach opt $known_view_options {
3895 set id [lindex $opt 0]
3896 if {[lindex $opt 1] eq "b"} {
3897 # Checkboxes
3898 set val 0
3899 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3900 # Radiobuttons
3901 regexp {^(.*_)} $id uselessvar id
3902 set val 0
3903 } else {
3904 # Text fields
3905 set val {}
3907 set newviewopts($n,$id) $val
3909 set oargs [list]
3910 set refargs [list]
3911 foreach arg $view_args {
3912 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3913 && ![info exists found(limit)]} {
3914 set newviewopts($n,limit) $cnt
3915 set found(limit) 1
3916 continue
3918 catch { unset val }
3919 foreach opt $known_view_options {
3920 set id [lindex $opt 0]
3921 if {[info exists found($id)]} continue
3922 foreach pattern [lindex $opt 3] {
3923 if {![string match $pattern $arg]} continue
3924 if {[lindex $opt 1] eq "b"} {
3925 # Check buttons
3926 set val 1
3927 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3928 # Radio buttons
3929 regexp {^(.*_)} $id uselessvar id
3930 set val $num
3931 } else {
3932 # Text input fields
3933 set size [string length $pattern]
3934 set val [string range $arg [expr {$size-1}] end]
3936 set newviewopts($n,$id) $val
3937 set found($id) 1
3938 break
3940 if {[info exists val]} break
3942 if {[info exists val]} continue
3943 if {[regexp {^-} $arg]} {
3944 lappend oargs $arg
3945 } else {
3946 lappend refargs $arg
3949 set newviewopts($n,refs) [shellarglist $refargs]
3950 set newviewopts($n,args) [shellarglist $oargs]
3953 proc edit_or_newview {} {
3954 global curview
3956 if {$curview > 0} {
3957 editview
3958 } else {
3959 newview 0
3963 proc editview {} {
3964 global curview
3965 global viewname viewperm newviewname newviewopts
3966 global viewargs viewargscmd
3968 set top .gitkvedit-$curview
3969 if {[winfo exists $top]} {
3970 raise $top
3971 return
3973 decode_view_opts $curview $viewargs($curview)
3974 set newviewname($curview) $viewname($curview)
3975 set newviewopts($curview,perm) $viewperm($curview)
3976 set newviewopts($curview,cmd) $viewargscmd($curview)
3977 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3980 proc vieweditor {top n title} {
3981 global newviewname newviewopts viewfiles bgcolor
3982 global known_view_options NS
3984 ttk_toplevel $top
3985 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3986 make_transient $top .
3988 # View name
3989 ${NS}::frame $top.nfr
3990 ${NS}::label $top.nl -text [mc "View Name"]
3991 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
3992 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3993 pack $top.nl -in $top.nfr -side left -padx {0 5}
3994 pack $top.name -in $top.nfr -side left -padx {0 25}
3996 # View options
3997 set cframe $top.nfr
3998 set cexpand 0
3999 set cnt 0
4000 foreach opt $known_view_options {
4001 set id [lindex $opt 0]
4002 set type [lindex $opt 1]
4003 set flags [lindex $opt 2]
4004 set title [eval [lindex $opt 4]]
4005 set lxpad 0
4007 if {$flags eq "+" || $flags eq "*"} {
4008 set cframe $top.fr$cnt
4009 incr cnt
4010 ${NS}::frame $cframe
4011 pack $cframe -in $top -fill x -pady 3 -padx 3
4012 set cexpand [expr {$flags eq "*"}]
4013 } elseif {$flags eq ".." || $flags eq "*."} {
4014 set cframe $top.fr$cnt
4015 incr cnt
4016 ${NS}::frame $cframe
4017 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4018 set cexpand [expr {$flags eq "*."}]
4019 } else {
4020 set lxpad 5
4023 if {$type eq "l"} {
4024 ${NS}::label $cframe.l_$id -text $title
4025 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4026 } elseif {$type eq "b"} {
4027 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4028 pack $cframe.c_$id -in $cframe -side left \
4029 -padx [list $lxpad 0] -expand $cexpand -anchor w
4030 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4031 regexp {^(.*_)} $id uselessvar button_id
4032 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4033 pack $cframe.c_$id -in $cframe -side left \
4034 -padx [list $lxpad 0] -expand $cexpand -anchor w
4035 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4036 ${NS}::label $cframe.l_$id -text $title
4037 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4038 -textvariable newviewopts($n,$id)
4039 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4040 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4041 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4042 ${NS}::label $cframe.l_$id -text $title
4043 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4044 -textvariable newviewopts($n,$id)
4045 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4046 pack $cframe.e_$id -in $cframe -side top -fill x
4047 } elseif {$type eq "path"} {
4048 ${NS}::label $top.l -text $title
4049 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4050 text $top.t -width 40 -height 5 -background $bgcolor
4051 if {[info exists viewfiles($n)]} {
4052 foreach f $viewfiles($n) {
4053 $top.t insert end $f
4054 $top.t insert end "\n"
4056 $top.t delete {end - 1c} end
4057 $top.t mark set insert 0.0
4059 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4063 ${NS}::frame $top.buts
4064 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4065 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4066 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4067 bind $top <Control-Return> [list newviewok $top $n]
4068 bind $top <F5> [list newviewok $top $n 1]
4069 bind $top <Escape> [list destroy $top]
4070 grid $top.buts.ok $top.buts.apply $top.buts.can
4071 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4072 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4073 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4074 pack $top.buts -in $top -side top -fill x
4075 focus $top.t
4078 proc doviewmenu {m first cmd op argv} {
4079 set nmenu [$m index end]
4080 for {set i $first} {$i <= $nmenu} {incr i} {
4081 if {[$m entrycget $i -command] eq $cmd} {
4082 eval $m $op $i $argv
4083 break
4088 proc allviewmenus {n op args} {
4089 # global viewhlmenu
4091 doviewmenu .bar.view 5 [list showview $n] $op $args
4092 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4095 proc newviewok {top n {apply 0}} {
4096 global nextviewnum newviewperm newviewname newishighlight
4097 global viewname viewfiles viewperm selectedview curview
4098 global viewargs viewargscmd newviewopts viewhlmenu
4100 if {[catch {
4101 set newargs [encode_view_opts $n]
4102 } err]} {
4103 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4104 return
4106 set files {}
4107 foreach f [split [$top.t get 0.0 end] "\n"] {
4108 set ft [string trim $f]
4109 if {$ft ne {}} {
4110 lappend files $ft
4113 if {![info exists viewfiles($n)]} {
4114 # creating a new view
4115 incr nextviewnum
4116 set viewname($n) $newviewname($n)
4117 set viewperm($n) $newviewopts($n,perm)
4118 set viewfiles($n) $files
4119 set viewargs($n) $newargs
4120 set viewargscmd($n) $newviewopts($n,cmd)
4121 addviewmenu $n
4122 if {!$newishighlight} {
4123 run showview $n
4124 } else {
4125 run addvhighlight $n
4127 } else {
4128 # editing an existing view
4129 set viewperm($n) $newviewopts($n,perm)
4130 if {$newviewname($n) ne $viewname($n)} {
4131 set viewname($n) $newviewname($n)
4132 doviewmenu .bar.view 5 [list showview $n] \
4133 entryconf [list -label $viewname($n)]
4134 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4135 # entryconf [list -label $viewname($n) -value $viewname($n)]
4137 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4138 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4139 set viewfiles($n) $files
4140 set viewargs($n) $newargs
4141 set viewargscmd($n) $newviewopts($n,cmd)
4142 if {$curview == $n} {
4143 run reloadcommits
4147 if {$apply} return
4148 catch {destroy $top}
4151 proc delview {} {
4152 global curview viewperm hlview selectedhlview
4154 if {$curview == 0} return
4155 if {[info exists hlview] && $hlview == $curview} {
4156 set selectedhlview [mc "None"]
4157 unset hlview
4159 allviewmenus $curview delete
4160 set viewperm($curview) 0
4161 showview 0
4164 proc addviewmenu {n} {
4165 global viewname viewhlmenu
4167 .bar.view add radiobutton -label $viewname($n) \
4168 -command [list showview $n] -variable selectedview -value $n
4169 #$viewhlmenu add radiobutton -label $viewname($n) \
4170 # -command [list addvhighlight $n] -variable selectedhlview
4173 proc showview {n} {
4174 global curview cached_commitrow ordertok
4175 global displayorder parentlist rowidlist rowisopt rowfinal
4176 global colormap rowtextx nextcolor canvxmax
4177 global numcommits viewcomplete
4178 global selectedline currentid canv canvy0
4179 global treediffs
4180 global pending_select mainheadid
4181 global commitidx
4182 global selectedview
4183 global hlview selectedhlview commitinterest
4185 if {$n == $curview} return
4186 set selid {}
4187 set ymax [lindex [$canv cget -scrollregion] 3]
4188 set span [$canv yview]
4189 set ytop [expr {[lindex $span 0] * $ymax}]
4190 set ybot [expr {[lindex $span 1] * $ymax}]
4191 set yscreen [expr {($ybot - $ytop) / 2}]
4192 if {$selectedline ne {}} {
4193 set selid $currentid
4194 set y [yc $selectedline]
4195 if {$ytop < $y && $y < $ybot} {
4196 set yscreen [expr {$y - $ytop}]
4198 } elseif {[info exists pending_select]} {
4199 set selid $pending_select
4200 unset pending_select
4202 unselectline
4203 normalline
4204 catch {unset treediffs}
4205 clear_display
4206 if {[info exists hlview] && $hlview == $n} {
4207 unset hlview
4208 set selectedhlview [mc "None"]
4210 catch {unset commitinterest}
4211 catch {unset cached_commitrow}
4212 catch {unset ordertok}
4214 set curview $n
4215 set selectedview $n
4216 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4217 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4219 run refill_reflist
4220 if {![info exists viewcomplete($n)]} {
4221 getcommits $selid
4222 return
4225 set displayorder {}
4226 set parentlist {}
4227 set rowidlist {}
4228 set rowisopt {}
4229 set rowfinal {}
4230 set numcommits $commitidx($n)
4232 catch {unset colormap}
4233 catch {unset rowtextx}
4234 set nextcolor 0
4235 set canvxmax [$canv cget -width]
4236 set curview $n
4237 set row 0
4238 setcanvscroll
4239 set yf 0
4240 set row {}
4241 if {$selid ne {} && [commitinview $selid $n]} {
4242 set row [rowofcommit $selid]
4243 # try to get the selected row in the same position on the screen
4244 set ymax [lindex [$canv cget -scrollregion] 3]
4245 set ytop [expr {[yc $row] - $yscreen}]
4246 if {$ytop < 0} {
4247 set ytop 0
4249 set yf [expr {$ytop * 1.0 / $ymax}]
4251 allcanvs yview moveto $yf
4252 drawvisible
4253 if {$row ne {}} {
4254 selectline $row 0
4255 } elseif {!$viewcomplete($n)} {
4256 reset_pending_select $selid
4257 } else {
4258 reset_pending_select {}
4260 if {[commitinview $pending_select $curview]} {
4261 selectline [rowofcommit $pending_select] 1
4262 } else {
4263 set row [first_real_row]
4264 if {$row < $numcommits} {
4265 selectline $row 0
4269 if {!$viewcomplete($n)} {
4270 if {$numcommits == 0} {
4271 show_status [mc "Reading commits..."]
4273 } elseif {$numcommits == 0} {
4274 show_status [mc "No commits selected"]
4278 # Stuff relating to the highlighting facility
4280 proc ishighlighted {id} {
4281 global vhighlights fhighlights nhighlights rhighlights
4283 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4284 return $nhighlights($id)
4286 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4287 return $vhighlights($id)
4289 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4290 return $fhighlights($id)
4292 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4293 return $rhighlights($id)
4295 return 0
4298 proc bolden {id font} {
4299 global canv linehtag currentid boldids need_redisplay markedid
4301 # need_redisplay = 1 means the display is stale and about to be redrawn
4302 if {$need_redisplay} return
4303 lappend boldids $id
4304 $canv itemconf $linehtag($id) -font $font
4305 if {[info exists currentid] && $id eq $currentid} {
4306 $canv delete secsel
4307 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4308 -outline {{}} -tags secsel \
4309 -fill [$canv cget -selectbackground]]
4310 $canv lower $t
4312 if {[info exists markedid] && $id eq $markedid} {
4313 make_idmark $id
4317 proc bolden_name {id font} {
4318 global canv2 linentag currentid boldnameids need_redisplay
4320 if {$need_redisplay} return
4321 lappend boldnameids $id
4322 $canv2 itemconf $linentag($id) -font $font
4323 if {[info exists currentid] && $id eq $currentid} {
4324 $canv2 delete secsel
4325 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4326 -outline {{}} -tags secsel \
4327 -fill [$canv2 cget -selectbackground]]
4328 $canv2 lower $t
4332 proc unbolden {} {
4333 global boldids
4335 set stillbold {}
4336 foreach id $boldids {
4337 if {![ishighlighted $id]} {
4338 bolden $id mainfont
4339 } else {
4340 lappend stillbold $id
4343 set boldids $stillbold
4346 proc addvhighlight {n} {
4347 global hlview viewcomplete curview vhl_done commitidx
4349 if {[info exists hlview]} {
4350 delvhighlight
4352 set hlview $n
4353 if {$n != $curview && ![info exists viewcomplete($n)]} {
4354 start_rev_list $n
4356 set vhl_done $commitidx($hlview)
4357 if {$vhl_done > 0} {
4358 drawvisible
4362 proc delvhighlight {} {
4363 global hlview vhighlights
4365 if {![info exists hlview]} return
4366 unset hlview
4367 catch {unset vhighlights}
4368 unbolden
4371 proc vhighlightmore {} {
4372 global hlview vhl_done commitidx vhighlights curview
4374 set max $commitidx($hlview)
4375 set vr [visiblerows]
4376 set r0 [lindex $vr 0]
4377 set r1 [lindex $vr 1]
4378 for {set i $vhl_done} {$i < $max} {incr i} {
4379 set id [commitonrow $i $hlview]
4380 if {[commitinview $id $curview]} {
4381 set row [rowofcommit $id]
4382 if {$r0 <= $row && $row <= $r1} {
4383 if {![highlighted $row]} {
4384 bolden $id mainfontbold
4386 set vhighlights($id) 1
4390 set vhl_done $max
4391 return 0
4394 proc askvhighlight {row id} {
4395 global hlview vhighlights iddrawn
4397 if {[commitinview $id $hlview]} {
4398 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4399 bolden $id mainfontbold
4401 set vhighlights($id) 1
4402 } else {
4403 set vhighlights($id) 0
4407 proc hfiles_change {} {
4408 global highlight_files filehighlight fhighlights fh_serial
4409 global highlight_paths
4411 if {[info exists filehighlight]} {
4412 # delete previous highlights
4413 catch {close $filehighlight}
4414 unset filehighlight
4415 catch {unset fhighlights}
4416 unbolden
4417 unhighlight_filelist
4419 set highlight_paths {}
4420 after cancel do_file_hl $fh_serial
4421 incr fh_serial
4422 if {$highlight_files ne {}} {
4423 after 300 do_file_hl $fh_serial
4427 proc gdttype_change {name ix op} {
4428 global gdttype highlight_files findstring findpattern
4430 stopfinding
4431 if {$findstring ne {}} {
4432 if {$gdttype eq [mc "containing:"]} {
4433 if {$highlight_files ne {}} {
4434 set highlight_files {}
4435 hfiles_change
4437 findcom_change
4438 } else {
4439 if {$findpattern ne {}} {
4440 set findpattern {}
4441 findcom_change
4443 set highlight_files $findstring
4444 hfiles_change
4446 drawvisible
4448 # enable/disable findtype/findloc menus too
4451 proc find_change {name ix op} {
4452 global gdttype findstring highlight_files
4454 stopfinding
4455 if {$gdttype eq [mc "containing:"]} {
4456 findcom_change
4457 } else {
4458 if {$highlight_files ne $findstring} {
4459 set highlight_files $findstring
4460 hfiles_change
4463 drawvisible
4466 proc findcom_change args {
4467 global nhighlights boldnameids
4468 global findpattern findtype findstring gdttype
4470 stopfinding
4471 # delete previous highlights, if any
4472 foreach id $boldnameids {
4473 bolden_name $id mainfont
4475 set boldnameids {}
4476 catch {unset nhighlights}
4477 unbolden
4478 unmarkmatches
4479 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4480 set findpattern {}
4481 } elseif {$findtype eq [mc "Regexp"]} {
4482 set findpattern $findstring
4483 } else {
4484 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4485 $findstring]
4486 set findpattern "*$e*"
4490 proc makepatterns {l} {
4491 set ret {}
4492 foreach e $l {
4493 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4494 if {[string index $ee end] eq "/"} {
4495 lappend ret "$ee*"
4496 } else {
4497 lappend ret $ee
4498 lappend ret "$ee/*"
4501 return $ret
4504 proc do_file_hl {serial} {
4505 global highlight_files filehighlight highlight_paths gdttype fhl_list
4507 if {$gdttype eq [mc "touching paths:"]} {
4508 if {[catch {set paths [shellsplit $highlight_files]}]} return
4509 set highlight_paths [makepatterns $paths]
4510 highlight_filelist
4511 set gdtargs [concat -- $paths]
4512 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4513 set gdtargs [list "-S$highlight_files"]
4514 } else {
4515 # must be "containing:", i.e. we're searching commit info
4516 return
4518 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4519 set filehighlight [open $cmd r+]
4520 fconfigure $filehighlight -blocking 0
4521 filerun $filehighlight readfhighlight
4522 set fhl_list {}
4523 drawvisible
4524 flushhighlights
4527 proc flushhighlights {} {
4528 global filehighlight fhl_list
4530 if {[info exists filehighlight]} {
4531 lappend fhl_list {}
4532 puts $filehighlight ""
4533 flush $filehighlight
4537 proc askfilehighlight {row id} {
4538 global filehighlight fhighlights fhl_list
4540 lappend fhl_list $id
4541 set fhighlights($id) -1
4542 puts $filehighlight $id
4545 proc readfhighlight {} {
4546 global filehighlight fhighlights curview iddrawn
4547 global fhl_list find_dirn
4549 if {![info exists filehighlight]} {
4550 return 0
4552 set nr 0
4553 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4554 set line [string trim $line]
4555 set i [lsearch -exact $fhl_list $line]
4556 if {$i < 0} continue
4557 for {set j 0} {$j < $i} {incr j} {
4558 set id [lindex $fhl_list $j]
4559 set fhighlights($id) 0
4561 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4562 if {$line eq {}} continue
4563 if {![commitinview $line $curview]} continue
4564 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4565 bolden $line mainfontbold
4567 set fhighlights($line) 1
4569 if {[eof $filehighlight]} {
4570 # strange...
4571 puts "oops, git diff-tree died"
4572 catch {close $filehighlight}
4573 unset filehighlight
4574 return 0
4576 if {[info exists find_dirn]} {
4577 run findmore
4579 return 1
4582 proc doesmatch {f} {
4583 global findtype findpattern
4585 if {$findtype eq [mc "Regexp"]} {
4586 return [regexp $findpattern $f]
4587 } elseif {$findtype eq [mc "IgnCase"]} {
4588 return [string match -nocase $findpattern $f]
4589 } else {
4590 return [string match $findpattern $f]
4594 proc askfindhighlight {row id} {
4595 global nhighlights commitinfo iddrawn
4596 global findloc
4597 global markingmatches
4599 if {![info exists commitinfo($id)]} {
4600 getcommit $id
4602 set info $commitinfo($id)
4603 set isbold 0
4604 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4605 foreach f $info ty $fldtypes {
4606 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4607 [doesmatch $f]} {
4608 if {$ty eq [mc "Author"]} {
4609 set isbold 2
4610 break
4612 set isbold 1
4615 if {$isbold && [info exists iddrawn($id)]} {
4616 if {![ishighlighted $id]} {
4617 bolden $id mainfontbold
4618 if {$isbold > 1} {
4619 bolden_name $id mainfontbold
4622 if {$markingmatches} {
4623 markrowmatches $row $id
4626 set nhighlights($id) $isbold
4629 proc markrowmatches {row id} {
4630 global canv canv2 linehtag linentag commitinfo findloc
4632 set headline [lindex $commitinfo($id) 0]
4633 set author [lindex $commitinfo($id) 1]
4634 $canv delete match$row
4635 $canv2 delete match$row
4636 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4637 set m [findmatches $headline]
4638 if {$m ne {}} {
4639 markmatches $canv $row $headline $linehtag($id) $m \
4640 [$canv itemcget $linehtag($id) -font] $row
4643 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4644 set m [findmatches $author]
4645 if {$m ne {}} {
4646 markmatches $canv2 $row $author $linentag($id) $m \
4647 [$canv2 itemcget $linentag($id) -font] $row
4652 proc vrel_change {name ix op} {
4653 global highlight_related
4655 rhighlight_none
4656 if {$highlight_related ne [mc "None"]} {
4657 run drawvisible
4661 # prepare for testing whether commits are descendents or ancestors of a
4662 proc rhighlight_sel {a} {
4663 global descendent desc_todo ancestor anc_todo
4664 global highlight_related
4666 catch {unset descendent}
4667 set desc_todo [list $a]
4668 catch {unset ancestor}
4669 set anc_todo [list $a]
4670 if {$highlight_related ne [mc "None"]} {
4671 rhighlight_none
4672 run drawvisible
4676 proc rhighlight_none {} {
4677 global rhighlights
4679 catch {unset rhighlights}
4680 unbolden
4683 proc is_descendent {a} {
4684 global curview children descendent desc_todo
4686 set v $curview
4687 set la [rowofcommit $a]
4688 set todo $desc_todo
4689 set leftover {}
4690 set done 0
4691 for {set i 0} {$i < [llength $todo]} {incr i} {
4692 set do [lindex $todo $i]
4693 if {[rowofcommit $do] < $la} {
4694 lappend leftover $do
4695 continue
4697 foreach nk $children($v,$do) {
4698 if {![info exists descendent($nk)]} {
4699 set descendent($nk) 1
4700 lappend todo $nk
4701 if {$nk eq $a} {
4702 set done 1
4706 if {$done} {
4707 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4708 return
4711 set descendent($a) 0
4712 set desc_todo $leftover
4715 proc is_ancestor {a} {
4716 global curview parents ancestor anc_todo
4718 set v $curview
4719 set la [rowofcommit $a]
4720 set todo $anc_todo
4721 set leftover {}
4722 set done 0
4723 for {set i 0} {$i < [llength $todo]} {incr i} {
4724 set do [lindex $todo $i]
4725 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4726 lappend leftover $do
4727 continue
4729 foreach np $parents($v,$do) {
4730 if {![info exists ancestor($np)]} {
4731 set ancestor($np) 1
4732 lappend todo $np
4733 if {$np eq $a} {
4734 set done 1
4738 if {$done} {
4739 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4740 return
4743 set ancestor($a) 0
4744 set anc_todo $leftover
4747 proc askrelhighlight {row id} {
4748 global descendent highlight_related iddrawn rhighlights
4749 global selectedline ancestor
4751 if {$selectedline eq {}} return
4752 set isbold 0
4753 if {$highlight_related eq [mc "Descendant"] ||
4754 $highlight_related eq [mc "Not descendant"]} {
4755 if {![info exists descendent($id)]} {
4756 is_descendent $id
4758 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4759 set isbold 1
4761 } elseif {$highlight_related eq [mc "Ancestor"] ||
4762 $highlight_related eq [mc "Not ancestor"]} {
4763 if {![info exists ancestor($id)]} {
4764 is_ancestor $id
4766 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4767 set isbold 1
4770 if {[info exists iddrawn($id)]} {
4771 if {$isbold && ![ishighlighted $id]} {
4772 bolden $id mainfontbold
4775 set rhighlights($id) $isbold
4778 # Graph layout functions
4780 proc shortids {ids} {
4781 set res {}
4782 foreach id $ids {
4783 if {[llength $id] > 1} {
4784 lappend res [shortids $id]
4785 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4786 lappend res [string range $id 0 7]
4787 } else {
4788 lappend res $id
4791 return $res
4794 proc ntimes {n o} {
4795 set ret {}
4796 set o [list $o]
4797 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4798 if {($n & $mask) != 0} {
4799 set ret [concat $ret $o]
4801 set o [concat $o $o]
4803 return $ret
4806 proc ordertoken {id} {
4807 global ordertok curview varcid varcstart varctok curview parents children
4808 global nullid nullid2
4810 if {[info exists ordertok($id)]} {
4811 return $ordertok($id)
4813 set origid $id
4814 set todo {}
4815 while {1} {
4816 if {[info exists varcid($curview,$id)]} {
4817 set a $varcid($curview,$id)
4818 set p [lindex $varcstart($curview) $a]
4819 } else {
4820 set p [lindex $children($curview,$id) 0]
4822 if {[info exists ordertok($p)]} {
4823 set tok $ordertok($p)
4824 break
4826 set id [first_real_child $curview,$p]
4827 if {$id eq {}} {
4828 # it's a root
4829 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4830 break
4832 if {[llength $parents($curview,$id)] == 1} {
4833 lappend todo [list $p {}]
4834 } else {
4835 set j [lsearch -exact $parents($curview,$id) $p]
4836 if {$j < 0} {
4837 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4839 lappend todo [list $p [strrep $j]]
4842 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4843 set p [lindex $todo $i 0]
4844 append tok [lindex $todo $i 1]
4845 set ordertok($p) $tok
4847 set ordertok($origid) $tok
4848 return $tok
4851 # Work out where id should go in idlist so that order-token
4852 # values increase from left to right
4853 proc idcol {idlist id {i 0}} {
4854 set t [ordertoken $id]
4855 if {$i < 0} {
4856 set i 0
4858 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4859 if {$i > [llength $idlist]} {
4860 set i [llength $idlist]
4862 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4863 incr i
4864 } else {
4865 if {$t > [ordertoken [lindex $idlist $i]]} {
4866 while {[incr i] < [llength $idlist] &&
4867 $t >= [ordertoken [lindex $idlist $i]]} {}
4870 return $i
4873 proc initlayout {} {
4874 global rowidlist rowisopt rowfinal displayorder parentlist
4875 global numcommits canvxmax canv
4876 global nextcolor
4877 global colormap rowtextx
4879 set numcommits 0
4880 set displayorder {}
4881 set parentlist {}
4882 set nextcolor 0
4883 set rowidlist {}
4884 set rowisopt {}
4885 set rowfinal {}
4886 set canvxmax [$canv cget -width]
4887 catch {unset colormap}
4888 catch {unset rowtextx}
4889 setcanvscroll
4892 proc setcanvscroll {} {
4893 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4894 global lastscrollset lastscrollrows
4896 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4897 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4898 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4899 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4900 set lastscrollset [clock clicks -milliseconds]
4901 set lastscrollrows $numcommits
4904 proc visiblerows {} {
4905 global canv numcommits linespc
4907 set ymax [lindex [$canv cget -scrollregion] 3]
4908 if {$ymax eq {} || $ymax == 0} return
4909 set f [$canv yview]
4910 set y0 [expr {int([lindex $f 0] * $ymax)}]
4911 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4912 if {$r0 < 0} {
4913 set r0 0
4915 set y1 [expr {int([lindex $f 1] * $ymax)}]
4916 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4917 if {$r1 >= $numcommits} {
4918 set r1 [expr {$numcommits - 1}]
4920 return [list $r0 $r1]
4923 proc layoutmore {} {
4924 global commitidx viewcomplete curview
4925 global numcommits pending_select curview
4926 global lastscrollset lastscrollrows
4928 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4929 [clock clicks -milliseconds] - $lastscrollset > 500} {
4930 setcanvscroll
4932 if {[info exists pending_select] &&
4933 [commitinview $pending_select $curview]} {
4934 update
4935 selectline [rowofcommit $pending_select] 1
4937 drawvisible
4940 # With path limiting, we mightn't get the actual HEAD commit,
4941 # so ask git rev-list what is the first ancestor of HEAD that
4942 # touches a file in the path limit.
4943 proc get_viewmainhead {view} {
4944 global viewmainheadid vfilelimit viewinstances mainheadid
4946 catch {
4947 set rfd [open [concat | git rev-list -1 $mainheadid \
4948 -- $vfilelimit($view)] r]
4949 set j [reg_instance $rfd]
4950 lappend viewinstances($view) $j
4951 fconfigure $rfd -blocking 0
4952 filerun $rfd [list getviewhead $rfd $j $view]
4953 set viewmainheadid($curview) {}
4957 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4958 proc getviewhead {fd inst view} {
4959 global viewmainheadid commfd curview viewinstances showlocalchanges
4961 set id {}
4962 if {[gets $fd line] < 0} {
4963 if {![eof $fd]} {
4964 return 1
4966 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4967 set id $line
4969 set viewmainheadid($view) $id
4970 close $fd
4971 unset commfd($inst)
4972 set i [lsearch -exact $viewinstances($view) $inst]
4973 if {$i >= 0} {
4974 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4976 if {$showlocalchanges && $id ne {} && $view == $curview} {
4977 doshowlocalchanges
4979 return 0
4982 proc doshowlocalchanges {} {
4983 global curview viewmainheadid
4985 if {$viewmainheadid($curview) eq {}} return
4986 if {[commitinview $viewmainheadid($curview) $curview]} {
4987 dodiffindex
4988 } else {
4989 interestedin $viewmainheadid($curview) dodiffindex
4993 proc dohidelocalchanges {} {
4994 global nullid nullid2 lserial curview
4996 if {[commitinview $nullid $curview]} {
4997 removefakerow $nullid
4999 if {[commitinview $nullid2 $curview]} {
5000 removefakerow $nullid2
5002 incr lserial
5005 # spawn off a process to do git diff-index --cached HEAD
5006 proc dodiffindex {} {
5007 global lserial showlocalchanges vfilelimit curview
5008 global isworktree
5010 if {!$showlocalchanges || !$isworktree} return
5011 incr lserial
5012 set cmd "|git diff-index --cached HEAD"
5013 if {$vfilelimit($curview) ne {}} {
5014 set cmd [concat $cmd -- $vfilelimit($curview)]
5016 set fd [open $cmd r]
5017 fconfigure $fd -blocking 0
5018 set i [reg_instance $fd]
5019 filerun $fd [list readdiffindex $fd $lserial $i]
5022 proc readdiffindex {fd serial inst} {
5023 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5024 global vfilelimit
5026 set isdiff 1
5027 if {[gets $fd line] < 0} {
5028 if {![eof $fd]} {
5029 return 1
5031 set isdiff 0
5033 # we only need to see one line and we don't really care what it says...
5034 stop_instance $inst
5036 if {$serial != $lserial} {
5037 return 0
5040 # now see if there are any local changes not checked in to the index
5041 set cmd "|git diff-files"
5042 if {$vfilelimit($curview) ne {}} {
5043 set cmd [concat $cmd -- $vfilelimit($curview)]
5045 set fd [open $cmd r]
5046 fconfigure $fd -blocking 0
5047 set i [reg_instance $fd]
5048 filerun $fd [list readdifffiles $fd $serial $i]
5050 if {$isdiff && ![commitinview $nullid2 $curview]} {
5051 # add the line for the changes in the index to the graph
5052 set hl [mc "Local changes checked in to index but not committed"]
5053 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5054 set commitdata($nullid2) "\n $hl\n"
5055 if {[commitinview $nullid $curview]} {
5056 removefakerow $nullid
5058 insertfakerow $nullid2 $viewmainheadid($curview)
5059 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5060 if {[commitinview $nullid $curview]} {
5061 removefakerow $nullid
5063 removefakerow $nullid2
5065 return 0
5068 proc readdifffiles {fd serial inst} {
5069 global viewmainheadid nullid nullid2 curview
5070 global commitinfo commitdata lserial
5072 set isdiff 1
5073 if {[gets $fd line] < 0} {
5074 if {![eof $fd]} {
5075 return 1
5077 set isdiff 0
5079 # we only need to see one line and we don't really care what it says...
5080 stop_instance $inst
5082 if {$serial != $lserial} {
5083 return 0
5086 if {$isdiff && ![commitinview $nullid $curview]} {
5087 # add the line for the local diff to the graph
5088 set hl [mc "Local uncommitted changes, not checked in to index"]
5089 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5090 set commitdata($nullid) "\n $hl\n"
5091 if {[commitinview $nullid2 $curview]} {
5092 set p $nullid2
5093 } else {
5094 set p $viewmainheadid($curview)
5096 insertfakerow $nullid $p
5097 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5098 removefakerow $nullid
5100 return 0
5103 proc nextuse {id row} {
5104 global curview children
5106 if {[info exists children($curview,$id)]} {
5107 foreach kid $children($curview,$id) {
5108 if {![commitinview $kid $curview]} {
5109 return -1
5111 if {[rowofcommit $kid] > $row} {
5112 return [rowofcommit $kid]
5116 if {[commitinview $id $curview]} {
5117 return [rowofcommit $id]
5119 return -1
5122 proc prevuse {id row} {
5123 global curview children
5125 set ret -1
5126 if {[info exists children($curview,$id)]} {
5127 foreach kid $children($curview,$id) {
5128 if {![commitinview $kid $curview]} break
5129 if {[rowofcommit $kid] < $row} {
5130 set ret [rowofcommit $kid]
5134 return $ret
5137 proc make_idlist {row} {
5138 global displayorder parentlist uparrowlen downarrowlen mingaplen
5139 global commitidx curview children
5141 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5142 if {$r < 0} {
5143 set r 0
5145 set ra [expr {$row - $downarrowlen}]
5146 if {$ra < 0} {
5147 set ra 0
5149 set rb [expr {$row + $uparrowlen}]
5150 if {$rb > $commitidx($curview)} {
5151 set rb $commitidx($curview)
5153 make_disporder $r [expr {$rb + 1}]
5154 set ids {}
5155 for {} {$r < $ra} {incr r} {
5156 set nextid [lindex $displayorder [expr {$r + 1}]]
5157 foreach p [lindex $parentlist $r] {
5158 if {$p eq $nextid} continue
5159 set rn [nextuse $p $r]
5160 if {$rn >= $row &&
5161 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5162 lappend ids [list [ordertoken $p] $p]
5166 for {} {$r < $row} {incr r} {
5167 set nextid [lindex $displayorder [expr {$r + 1}]]
5168 foreach p [lindex $parentlist $r] {
5169 if {$p eq $nextid} continue
5170 set rn [nextuse $p $r]
5171 if {$rn < 0 || $rn >= $row} {
5172 lappend ids [list [ordertoken $p] $p]
5176 set id [lindex $displayorder $row]
5177 lappend ids [list [ordertoken $id] $id]
5178 while {$r < $rb} {
5179 foreach p [lindex $parentlist $r] {
5180 set firstkid [lindex $children($curview,$p) 0]
5181 if {[rowofcommit $firstkid] < $row} {
5182 lappend ids [list [ordertoken $p] $p]
5185 incr r
5186 set id [lindex $displayorder $r]
5187 if {$id ne {}} {
5188 set firstkid [lindex $children($curview,$id) 0]
5189 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5190 lappend ids [list [ordertoken $id] $id]
5194 set idlist {}
5195 foreach idx [lsort -unique $ids] {
5196 lappend idlist [lindex $idx 1]
5198 return $idlist
5201 proc rowsequal {a b} {
5202 while {[set i [lsearch -exact $a {}]] >= 0} {
5203 set a [lreplace $a $i $i]
5205 while {[set i [lsearch -exact $b {}]] >= 0} {
5206 set b [lreplace $b $i $i]
5208 return [expr {$a eq $b}]
5211 proc makeupline {id row rend col} {
5212 global rowidlist uparrowlen downarrowlen mingaplen
5214 for {set r $rend} {1} {set r $rstart} {
5215 set rstart [prevuse $id $r]
5216 if {$rstart < 0} return
5217 if {$rstart < $row} break
5219 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5220 set rstart [expr {$rend - $uparrowlen - 1}]
5222 for {set r $rstart} {[incr r] <= $row} {} {
5223 set idlist [lindex $rowidlist $r]
5224 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5225 set col [idcol $idlist $id $col]
5226 lset rowidlist $r [linsert $idlist $col $id]
5227 changedrow $r
5232 proc layoutrows {row endrow} {
5233 global rowidlist rowisopt rowfinal displayorder
5234 global uparrowlen downarrowlen maxwidth mingaplen
5235 global children parentlist
5236 global commitidx viewcomplete curview
5238 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5239 set idlist {}
5240 if {$row > 0} {
5241 set rm1 [expr {$row - 1}]
5242 foreach id [lindex $rowidlist $rm1] {
5243 if {$id ne {}} {
5244 lappend idlist $id
5247 set final [lindex $rowfinal $rm1]
5249 for {} {$row < $endrow} {incr row} {
5250 set rm1 [expr {$row - 1}]
5251 if {$rm1 < 0 || $idlist eq {}} {
5252 set idlist [make_idlist $row]
5253 set final 1
5254 } else {
5255 set id [lindex $displayorder $rm1]
5256 set col [lsearch -exact $idlist $id]
5257 set idlist [lreplace $idlist $col $col]
5258 foreach p [lindex $parentlist $rm1] {
5259 if {[lsearch -exact $idlist $p] < 0} {
5260 set col [idcol $idlist $p $col]
5261 set idlist [linsert $idlist $col $p]
5262 # if not the first child, we have to insert a line going up
5263 if {$id ne [lindex $children($curview,$p) 0]} {
5264 makeupline $p $rm1 $row $col
5268 set id [lindex $displayorder $row]
5269 if {$row > $downarrowlen} {
5270 set termrow [expr {$row - $downarrowlen - 1}]
5271 foreach p [lindex $parentlist $termrow] {
5272 set i [lsearch -exact $idlist $p]
5273 if {$i < 0} continue
5274 set nr [nextuse $p $termrow]
5275 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5276 set idlist [lreplace $idlist $i $i]
5280 set col [lsearch -exact $idlist $id]
5281 if {$col < 0} {
5282 set col [idcol $idlist $id]
5283 set idlist [linsert $idlist $col $id]
5284 if {$children($curview,$id) ne {}} {
5285 makeupline $id $rm1 $row $col
5288 set r [expr {$row + $uparrowlen - 1}]
5289 if {$r < $commitidx($curview)} {
5290 set x $col
5291 foreach p [lindex $parentlist $r] {
5292 if {[lsearch -exact $idlist $p] >= 0} continue
5293 set fk [lindex $children($curview,$p) 0]
5294 if {[rowofcommit $fk] < $row} {
5295 set x [idcol $idlist $p $x]
5296 set idlist [linsert $idlist $x $p]
5299 if {[incr r] < $commitidx($curview)} {
5300 set p [lindex $displayorder $r]
5301 if {[lsearch -exact $idlist $p] < 0} {
5302 set fk [lindex $children($curview,$p) 0]
5303 if {$fk ne {} && [rowofcommit $fk] < $row} {
5304 set x [idcol $idlist $p $x]
5305 set idlist [linsert $idlist $x $p]
5311 if {$final && !$viewcomplete($curview) &&
5312 $row + $uparrowlen + $mingaplen + $downarrowlen
5313 >= $commitidx($curview)} {
5314 set final 0
5316 set l [llength $rowidlist]
5317 if {$row == $l} {
5318 lappend rowidlist $idlist
5319 lappend rowisopt 0
5320 lappend rowfinal $final
5321 } elseif {$row < $l} {
5322 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5323 lset rowidlist $row $idlist
5324 changedrow $row
5326 lset rowfinal $row $final
5327 } else {
5328 set pad [ntimes [expr {$row - $l}] {}]
5329 set rowidlist [concat $rowidlist $pad]
5330 lappend rowidlist $idlist
5331 set rowfinal [concat $rowfinal $pad]
5332 lappend rowfinal $final
5333 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5336 return $row
5339 proc changedrow {row} {
5340 global displayorder iddrawn rowisopt need_redisplay
5342 set l [llength $rowisopt]
5343 if {$row < $l} {
5344 lset rowisopt $row 0
5345 if {$row + 1 < $l} {
5346 lset rowisopt [expr {$row + 1}] 0
5347 if {$row + 2 < $l} {
5348 lset rowisopt [expr {$row + 2}] 0
5352 set id [lindex $displayorder $row]
5353 if {[info exists iddrawn($id)]} {
5354 set need_redisplay 1
5358 proc insert_pad {row col npad} {
5359 global rowidlist
5361 set pad [ntimes $npad {}]
5362 set idlist [lindex $rowidlist $row]
5363 set bef [lrange $idlist 0 [expr {$col - 1}]]
5364 set aft [lrange $idlist $col end]
5365 set i [lsearch -exact $aft {}]
5366 if {$i > 0} {
5367 set aft [lreplace $aft $i $i]
5369 lset rowidlist $row [concat $bef $pad $aft]
5370 changedrow $row
5373 proc optimize_rows {row col endrow} {
5374 global rowidlist rowisopt displayorder curview children
5376 if {$row < 1} {
5377 set row 1
5379 for {} {$row < $endrow} {incr row; set col 0} {
5380 if {[lindex $rowisopt $row]} continue
5381 set haspad 0
5382 set y0 [expr {$row - 1}]
5383 set ym [expr {$row - 2}]
5384 set idlist [lindex $rowidlist $row]
5385 set previdlist [lindex $rowidlist $y0]
5386 if {$idlist eq {} || $previdlist eq {}} continue
5387 if {$ym >= 0} {
5388 set pprevidlist [lindex $rowidlist $ym]
5389 if {$pprevidlist eq {}} continue
5390 } else {
5391 set pprevidlist {}
5393 set x0 -1
5394 set xm -1
5395 for {} {$col < [llength $idlist]} {incr col} {
5396 set id [lindex $idlist $col]
5397 if {[lindex $previdlist $col] eq $id} continue
5398 if {$id eq {}} {
5399 set haspad 1
5400 continue
5402 set x0 [lsearch -exact $previdlist $id]
5403 if {$x0 < 0} continue
5404 set z [expr {$x0 - $col}]
5405 set isarrow 0
5406 set z0 {}
5407 if {$ym >= 0} {
5408 set xm [lsearch -exact $pprevidlist $id]
5409 if {$xm >= 0} {
5410 set z0 [expr {$xm - $x0}]
5413 if {$z0 eq {}} {
5414 # if row y0 is the first child of $id then it's not an arrow
5415 if {[lindex $children($curview,$id) 0] ne
5416 [lindex $displayorder $y0]} {
5417 set isarrow 1
5420 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5421 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5422 set isarrow 1
5424 # Looking at lines from this row to the previous row,
5425 # make them go straight up if they end in an arrow on
5426 # the previous row; otherwise make them go straight up
5427 # or at 45 degrees.
5428 if {$z < -1 || ($z < 0 && $isarrow)} {
5429 # Line currently goes left too much;
5430 # insert pads in the previous row, then optimize it
5431 set npad [expr {-1 - $z + $isarrow}]
5432 insert_pad $y0 $x0 $npad
5433 if {$y0 > 0} {
5434 optimize_rows $y0 $x0 $row
5436 set previdlist [lindex $rowidlist $y0]
5437 set x0 [lsearch -exact $previdlist $id]
5438 set z [expr {$x0 - $col}]
5439 if {$z0 ne {}} {
5440 set pprevidlist [lindex $rowidlist $ym]
5441 set xm [lsearch -exact $pprevidlist $id]
5442 set z0 [expr {$xm - $x0}]
5444 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5445 # Line currently goes right too much;
5446 # insert pads in this line
5447 set npad [expr {$z - 1 + $isarrow}]
5448 insert_pad $row $col $npad
5449 set idlist [lindex $rowidlist $row]
5450 incr col $npad
5451 set z [expr {$x0 - $col}]
5452 set haspad 1
5454 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5455 # this line links to its first child on row $row-2
5456 set id [lindex $displayorder $ym]
5457 set xc [lsearch -exact $pprevidlist $id]
5458 if {$xc >= 0} {
5459 set z0 [expr {$xc - $x0}]
5462 # avoid lines jigging left then immediately right
5463 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5464 insert_pad $y0 $x0 1
5465 incr x0
5466 optimize_rows $y0 $x0 $row
5467 set previdlist [lindex $rowidlist $y0]
5470 if {!$haspad} {
5471 # Find the first column that doesn't have a line going right
5472 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5473 set id [lindex $idlist $col]
5474 if {$id eq {}} break
5475 set x0 [lsearch -exact $previdlist $id]
5476 if {$x0 < 0} {
5477 # check if this is the link to the first child
5478 set kid [lindex $displayorder $y0]
5479 if {[lindex $children($curview,$id) 0] eq $kid} {
5480 # it is, work out offset to child
5481 set x0 [lsearch -exact $previdlist $kid]
5484 if {$x0 <= $col} break
5486 # Insert a pad at that column as long as it has a line and
5487 # isn't the last column
5488 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5489 set idlist [linsert $idlist $col {}]
5490 lset rowidlist $row $idlist
5491 changedrow $row
5497 proc xc {row col} {
5498 global canvx0 linespc
5499 return [expr {$canvx0 + $col * $linespc}]
5502 proc yc {row} {
5503 global canvy0 linespc
5504 return [expr {$canvy0 + $row * $linespc}]
5507 proc linewidth {id} {
5508 global thickerline lthickness
5510 set wid $lthickness
5511 if {[info exists thickerline] && $id eq $thickerline} {
5512 set wid [expr {2 * $lthickness}]
5514 return $wid
5517 proc rowranges {id} {
5518 global curview children uparrowlen downarrowlen
5519 global rowidlist
5521 set kids $children($curview,$id)
5522 if {$kids eq {}} {
5523 return {}
5525 set ret {}
5526 lappend kids $id
5527 foreach child $kids {
5528 if {![commitinview $child $curview]} break
5529 set row [rowofcommit $child]
5530 if {![info exists prev]} {
5531 lappend ret [expr {$row + 1}]
5532 } else {
5533 if {$row <= $prevrow} {
5534 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5536 # see if the line extends the whole way from prevrow to row
5537 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5538 [lsearch -exact [lindex $rowidlist \
5539 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5540 # it doesn't, see where it ends
5541 set r [expr {$prevrow + $downarrowlen}]
5542 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5543 while {[incr r -1] > $prevrow &&
5544 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5545 } else {
5546 while {[incr r] <= $row &&
5547 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5548 incr r -1
5550 lappend ret $r
5551 # see where it starts up again
5552 set r [expr {$row - $uparrowlen}]
5553 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5554 while {[incr r] < $row &&
5555 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5556 } else {
5557 while {[incr r -1] >= $prevrow &&
5558 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5559 incr r
5561 lappend ret $r
5564 if {$child eq $id} {
5565 lappend ret $row
5567 set prev $child
5568 set prevrow $row
5570 return $ret
5573 proc drawlineseg {id row endrow arrowlow} {
5574 global rowidlist displayorder iddrawn linesegs
5575 global canv colormap linespc curview maxlinelen parentlist
5577 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5578 set le [expr {$row + 1}]
5579 set arrowhigh 1
5580 while {1} {
5581 set c [lsearch -exact [lindex $rowidlist $le] $id]
5582 if {$c < 0} {
5583 incr le -1
5584 break
5586 lappend cols $c
5587 set x [lindex $displayorder $le]
5588 if {$x eq $id} {
5589 set arrowhigh 0
5590 break
5592 if {[info exists iddrawn($x)] || $le == $endrow} {
5593 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5594 if {$c >= 0} {
5595 lappend cols $c
5596 set arrowhigh 0
5598 break
5600 incr le
5602 if {$le <= $row} {
5603 return $row
5606 set lines {}
5607 set i 0
5608 set joinhigh 0
5609 if {[info exists linesegs($id)]} {
5610 set lines $linesegs($id)
5611 foreach li $lines {
5612 set r0 [lindex $li 0]
5613 if {$r0 > $row} {
5614 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5615 set joinhigh 1
5617 break
5619 incr i
5622 set joinlow 0
5623 if {$i > 0} {
5624 set li [lindex $lines [expr {$i-1}]]
5625 set r1 [lindex $li 1]
5626 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5627 set joinlow 1
5631 set x [lindex $cols [expr {$le - $row}]]
5632 set xp [lindex $cols [expr {$le - 1 - $row}]]
5633 set dir [expr {$xp - $x}]
5634 if {$joinhigh} {
5635 set ith [lindex $lines $i 2]
5636 set coords [$canv coords $ith]
5637 set ah [$canv itemcget $ith -arrow]
5638 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5639 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5640 if {$x2 ne {} && $x - $x2 == $dir} {
5641 set coords [lrange $coords 0 end-2]
5643 } else {
5644 set coords [list [xc $le $x] [yc $le]]
5646 if {$joinlow} {
5647 set itl [lindex $lines [expr {$i-1}] 2]
5648 set al [$canv itemcget $itl -arrow]
5649 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5650 } elseif {$arrowlow} {
5651 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5652 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5653 set arrowlow 0
5656 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5657 for {set y $le} {[incr y -1] > $row} {} {
5658 set x $xp
5659 set xp [lindex $cols [expr {$y - 1 - $row}]]
5660 set ndir [expr {$xp - $x}]
5661 if {$dir != $ndir || $xp < 0} {
5662 lappend coords [xc $y $x] [yc $y]
5664 set dir $ndir
5666 if {!$joinlow} {
5667 if {$xp < 0} {
5668 # join parent line to first child
5669 set ch [lindex $displayorder $row]
5670 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5671 if {$xc < 0} {
5672 puts "oops: drawlineseg: child $ch not on row $row"
5673 } elseif {$xc != $x} {
5674 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5675 set d [expr {int(0.5 * $linespc)}]
5676 set x1 [xc $row $x]
5677 if {$xc < $x} {
5678 set x2 [expr {$x1 - $d}]
5679 } else {
5680 set x2 [expr {$x1 + $d}]
5682 set y2 [yc $row]
5683 set y1 [expr {$y2 + $d}]
5684 lappend coords $x1 $y1 $x2 $y2
5685 } elseif {$xc < $x - 1} {
5686 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5687 } elseif {$xc > $x + 1} {
5688 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5690 set x $xc
5692 lappend coords [xc $row $x] [yc $row]
5693 } else {
5694 set xn [xc $row $xp]
5695 set yn [yc $row]
5696 lappend coords $xn $yn
5698 if {!$joinhigh} {
5699 assigncolor $id
5700 set t [$canv create line $coords -width [linewidth $id] \
5701 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5702 $canv lower $t
5703 bindline $t $id
5704 set lines [linsert $lines $i [list $row $le $t]]
5705 } else {
5706 $canv coords $ith $coords
5707 if {$arrow ne $ah} {
5708 $canv itemconf $ith -arrow $arrow
5710 lset lines $i 0 $row
5712 } else {
5713 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5714 set ndir [expr {$xo - $xp}]
5715 set clow [$canv coords $itl]
5716 if {$dir == $ndir} {
5717 set clow [lrange $clow 2 end]
5719 set coords [concat $coords $clow]
5720 if {!$joinhigh} {
5721 lset lines [expr {$i-1}] 1 $le
5722 } else {
5723 # coalesce two pieces
5724 $canv delete $ith
5725 set b [lindex $lines [expr {$i-1}] 0]
5726 set e [lindex $lines $i 1]
5727 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5729 $canv coords $itl $coords
5730 if {$arrow ne $al} {
5731 $canv itemconf $itl -arrow $arrow
5735 set linesegs($id) $lines
5736 return $le
5739 proc drawparentlinks {id row} {
5740 global rowidlist canv colormap curview parentlist
5741 global idpos linespc
5743 set rowids [lindex $rowidlist $row]
5744 set col [lsearch -exact $rowids $id]
5745 if {$col < 0} return
5746 set olds [lindex $parentlist $row]
5747 set row2 [expr {$row + 1}]
5748 set x [xc $row $col]
5749 set y [yc $row]
5750 set y2 [yc $row2]
5751 set d [expr {int(0.5 * $linespc)}]
5752 set ymid [expr {$y + $d}]
5753 set ids [lindex $rowidlist $row2]
5754 # rmx = right-most X coord used
5755 set rmx 0
5756 foreach p $olds {
5757 set i [lsearch -exact $ids $p]
5758 if {$i < 0} {
5759 puts "oops, parent $p of $id not in list"
5760 continue
5762 set x2 [xc $row2 $i]
5763 if {$x2 > $rmx} {
5764 set rmx $x2
5766 set j [lsearch -exact $rowids $p]
5767 if {$j < 0} {
5768 # drawlineseg will do this one for us
5769 continue
5771 assigncolor $p
5772 # should handle duplicated parents here...
5773 set coords [list $x $y]
5774 if {$i != $col} {
5775 # if attaching to a vertical segment, draw a smaller
5776 # slant for visual distinctness
5777 if {$i == $j} {
5778 if {$i < $col} {
5779 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5780 } else {
5781 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5783 } elseif {$i < $col && $i < $j} {
5784 # segment slants towards us already
5785 lappend coords [xc $row $j] $y
5786 } else {
5787 if {$i < $col - 1} {
5788 lappend coords [expr {$x2 + $linespc}] $y
5789 } elseif {$i > $col + 1} {
5790 lappend coords [expr {$x2 - $linespc}] $y
5792 lappend coords $x2 $y2
5794 } else {
5795 lappend coords $x2 $y2
5797 set t [$canv create line $coords -width [linewidth $p] \
5798 -fill $colormap($p) -tags lines.$p]
5799 $canv lower $t
5800 bindline $t $p
5802 if {$rmx > [lindex $idpos($id) 1]} {
5803 lset idpos($id) 1 $rmx
5804 redrawtags $id
5808 proc drawlines {id} {
5809 global canv
5811 $canv itemconf lines.$id -width [linewidth $id]
5814 proc drawcmittext {id row col} {
5815 global linespc canv canv2 canv3 fgcolor curview
5816 global cmitlisted commitinfo rowidlist parentlist
5817 global rowtextx idpos idtags idheads idotherrefs
5818 global linehtag linentag linedtag selectedline
5819 global canvxmax boldids boldnameids fgcolor markedid
5820 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5822 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5823 set listed $cmitlisted($curview,$id)
5824 if {$id eq $nullid} {
5825 set ofill red
5826 } elseif {$id eq $nullid2} {
5827 set ofill green
5828 } elseif {$id eq $mainheadid} {
5829 set ofill yellow
5830 } else {
5831 set ofill [lindex $circlecolors $listed]
5833 set x [xc $row $col]
5834 set y [yc $row]
5835 set orad [expr {$linespc / 3}]
5836 if {$listed <= 2} {
5837 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5838 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5839 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5840 } elseif {$listed == 3} {
5841 # triangle pointing left for left-side commits
5842 set t [$canv create polygon \
5843 [expr {$x - $orad}] $y \
5844 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5845 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5846 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5847 } else {
5848 # triangle pointing right for right-side commits
5849 set t [$canv create polygon \
5850 [expr {$x + $orad - 1}] $y \
5851 [expr {$x - $orad}] [expr {$y - $orad}] \
5852 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5853 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5855 set circleitem($row) $t
5856 $canv raise $t
5857 $canv bind $t <1> {selcanvline {} %x %y}
5858 set rmx [llength [lindex $rowidlist $row]]
5859 set olds [lindex $parentlist $row]
5860 if {$olds ne {}} {
5861 set nextids [lindex $rowidlist [expr {$row + 1}]]
5862 foreach p $olds {
5863 set i [lsearch -exact $nextids $p]
5864 if {$i > $rmx} {
5865 set rmx $i
5869 set xt [xc $row $rmx]
5870 set rowtextx($row) $xt
5871 set idpos($id) [list $x $xt $y]
5872 if {[info exists idtags($id)] || [info exists idheads($id)]
5873 || [info exists idotherrefs($id)]} {
5874 set xt [drawtags $id $x $xt $y]
5876 set headline [lindex $commitinfo($id) 0]
5877 set name [lindex $commitinfo($id) 1]
5878 set date [lindex $commitinfo($id) 2]
5879 set date [formatdate $date]
5880 set font mainfont
5881 set nfont mainfont
5882 set isbold [ishighlighted $id]
5883 if {$isbold > 0} {
5884 lappend boldids $id
5885 set font mainfontbold
5886 if {$isbold > 1} {
5887 lappend boldnameids $id
5888 set nfont mainfontbold
5891 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5892 -text $headline -font $font -tags text]
5893 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5894 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5895 -text $name -font $nfont -tags text]
5896 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5897 -text $date -font mainfont -tags text]
5898 if {$selectedline == $row} {
5899 make_secsel $id
5901 if {[info exists markedid] && $markedid eq $id} {
5902 make_idmark $id
5904 set xr [expr {$xt + [font measure $font $headline]}]
5905 if {$xr > $canvxmax} {
5906 set canvxmax $xr
5907 setcanvscroll
5911 proc drawcmitrow {row} {
5912 global displayorder rowidlist nrows_drawn
5913 global iddrawn markingmatches
5914 global commitinfo numcommits
5915 global filehighlight fhighlights findpattern nhighlights
5916 global hlview vhighlights
5917 global highlight_related rhighlights
5919 if {$row >= $numcommits} return
5921 set id [lindex $displayorder $row]
5922 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5923 askvhighlight $row $id
5925 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5926 askfilehighlight $row $id
5928 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5929 askfindhighlight $row $id
5931 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5932 askrelhighlight $row $id
5934 if {![info exists iddrawn($id)]} {
5935 set col [lsearch -exact [lindex $rowidlist $row] $id]
5936 if {$col < 0} {
5937 puts "oops, row $row id $id not in list"
5938 return
5940 if {![info exists commitinfo($id)]} {
5941 getcommit $id
5943 assigncolor $id
5944 drawcmittext $id $row $col
5945 set iddrawn($id) 1
5946 incr nrows_drawn
5948 if {$markingmatches} {
5949 markrowmatches $row $id
5953 proc drawcommits {row {endrow {}}} {
5954 global numcommits iddrawn displayorder curview need_redisplay
5955 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5957 if {$row < 0} {
5958 set row 0
5960 if {$endrow eq {}} {
5961 set endrow $row
5963 if {$endrow >= $numcommits} {
5964 set endrow [expr {$numcommits - 1}]
5967 set rl1 [expr {$row - $downarrowlen - 3}]
5968 if {$rl1 < 0} {
5969 set rl1 0
5971 set ro1 [expr {$row - 3}]
5972 if {$ro1 < 0} {
5973 set ro1 0
5975 set r2 [expr {$endrow + $uparrowlen + 3}]
5976 if {$r2 > $numcommits} {
5977 set r2 $numcommits
5979 for {set r $rl1} {$r < $r2} {incr r} {
5980 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5981 if {$rl1 < $r} {
5982 layoutrows $rl1 $r
5984 set rl1 [expr {$r + 1}]
5987 if {$rl1 < $r} {
5988 layoutrows $rl1 $r
5990 optimize_rows $ro1 0 $r2
5991 if {$need_redisplay || $nrows_drawn > 2000} {
5992 clear_display
5995 # make the lines join to already-drawn rows either side
5996 set r [expr {$row - 1}]
5997 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5998 set r $row
6000 set er [expr {$endrow + 1}]
6001 if {$er >= $numcommits ||
6002 ![info exists iddrawn([lindex $displayorder $er])]} {
6003 set er $endrow
6005 for {} {$r <= $er} {incr r} {
6006 set id [lindex $displayorder $r]
6007 set wasdrawn [info exists iddrawn($id)]
6008 drawcmitrow $r
6009 if {$r == $er} break
6010 set nextid [lindex $displayorder [expr {$r + 1}]]
6011 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6012 drawparentlinks $id $r
6014 set rowids [lindex $rowidlist $r]
6015 foreach lid $rowids {
6016 if {$lid eq {}} continue
6017 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6018 if {$lid eq $id} {
6019 # see if this is the first child of any of its parents
6020 foreach p [lindex $parentlist $r] {
6021 if {[lsearch -exact $rowids $p] < 0} {
6022 # make this line extend up to the child
6023 set lineend($p) [drawlineseg $p $r $er 0]
6026 } else {
6027 set lineend($lid) [drawlineseg $lid $r $er 1]
6033 proc undolayout {row} {
6034 global uparrowlen mingaplen downarrowlen
6035 global rowidlist rowisopt rowfinal need_redisplay
6037 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6038 if {$r < 0} {
6039 set r 0
6041 if {[llength $rowidlist] > $r} {
6042 incr r -1
6043 set rowidlist [lrange $rowidlist 0 $r]
6044 set rowfinal [lrange $rowfinal 0 $r]
6045 set rowisopt [lrange $rowisopt 0 $r]
6046 set need_redisplay 1
6047 run drawvisible
6051 proc drawvisible {} {
6052 global canv linespc curview vrowmod selectedline targetrow targetid
6053 global need_redisplay cscroll numcommits
6055 set fs [$canv yview]
6056 set ymax [lindex [$canv cget -scrollregion] 3]
6057 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6058 set f0 [lindex $fs 0]
6059 set f1 [lindex $fs 1]
6060 set y0 [expr {int($f0 * $ymax)}]
6061 set y1 [expr {int($f1 * $ymax)}]
6063 if {[info exists targetid]} {
6064 if {[commitinview $targetid $curview]} {
6065 set r [rowofcommit $targetid]
6066 if {$r != $targetrow} {
6067 # Fix up the scrollregion and change the scrolling position
6068 # now that our target row has moved.
6069 set diff [expr {($r - $targetrow) * $linespc}]
6070 set targetrow $r
6071 setcanvscroll
6072 set ymax [lindex [$canv cget -scrollregion] 3]
6073 incr y0 $diff
6074 incr y1 $diff
6075 set f0 [expr {$y0 / $ymax}]
6076 set f1 [expr {$y1 / $ymax}]
6077 allcanvs yview moveto $f0
6078 $cscroll set $f0 $f1
6079 set need_redisplay 1
6081 } else {
6082 unset targetid
6086 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6087 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6088 if {$endrow >= $vrowmod($curview)} {
6089 update_arcrows $curview
6091 if {$selectedline ne {} &&
6092 $row <= $selectedline && $selectedline <= $endrow} {
6093 set targetrow $selectedline
6094 } elseif {[info exists targetid]} {
6095 set targetrow [expr {int(($row + $endrow) / 2)}]
6097 if {[info exists targetrow]} {
6098 if {$targetrow >= $numcommits} {
6099 set targetrow [expr {$numcommits - 1}]
6101 set targetid [commitonrow $targetrow]
6103 drawcommits $row $endrow
6106 proc clear_display {} {
6107 global iddrawn linesegs need_redisplay nrows_drawn
6108 global vhighlights fhighlights nhighlights rhighlights
6109 global linehtag linentag linedtag boldids boldnameids
6111 allcanvs delete all
6112 catch {unset iddrawn}
6113 catch {unset linesegs}
6114 catch {unset linehtag}
6115 catch {unset linentag}
6116 catch {unset linedtag}
6117 set boldids {}
6118 set boldnameids {}
6119 catch {unset vhighlights}
6120 catch {unset fhighlights}
6121 catch {unset nhighlights}
6122 catch {unset rhighlights}
6123 set need_redisplay 0
6124 set nrows_drawn 0
6127 proc findcrossings {id} {
6128 global rowidlist parentlist numcommits displayorder
6130 set cross {}
6131 set ccross {}
6132 foreach {s e} [rowranges $id] {
6133 if {$e >= $numcommits} {
6134 set e [expr {$numcommits - 1}]
6136 if {$e <= $s} continue
6137 for {set row $e} {[incr row -1] >= $s} {} {
6138 set x [lsearch -exact [lindex $rowidlist $row] $id]
6139 if {$x < 0} break
6140 set olds [lindex $parentlist $row]
6141 set kid [lindex $displayorder $row]
6142 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6143 if {$kidx < 0} continue
6144 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6145 foreach p $olds {
6146 set px [lsearch -exact $nextrow $p]
6147 if {$px < 0} continue
6148 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6149 if {[lsearch -exact $ccross $p] >= 0} continue
6150 if {$x == $px + ($kidx < $px? -1: 1)} {
6151 lappend ccross $p
6152 } elseif {[lsearch -exact $cross $p] < 0} {
6153 lappend cross $p
6159 return [concat $ccross {{}} $cross]
6162 proc assigncolor {id} {
6163 global colormap colors nextcolor
6164 global parents children children curview
6166 if {[info exists colormap($id)]} return
6167 set ncolors [llength $colors]
6168 if {[info exists children($curview,$id)]} {
6169 set kids $children($curview,$id)
6170 } else {
6171 set kids {}
6173 if {[llength $kids] == 1} {
6174 set child [lindex $kids 0]
6175 if {[info exists colormap($child)]
6176 && [llength $parents($curview,$child)] == 1} {
6177 set colormap($id) $colormap($child)
6178 return
6181 set badcolors {}
6182 set origbad {}
6183 foreach x [findcrossings $id] {
6184 if {$x eq {}} {
6185 # delimiter between corner crossings and other crossings
6186 if {[llength $badcolors] >= $ncolors - 1} break
6187 set origbad $badcolors
6189 if {[info exists colormap($x)]
6190 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6191 lappend badcolors $colormap($x)
6194 if {[llength $badcolors] >= $ncolors} {
6195 set badcolors $origbad
6197 set origbad $badcolors
6198 if {[llength $badcolors] < $ncolors - 1} {
6199 foreach child $kids {
6200 if {[info exists colormap($child)]
6201 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6202 lappend badcolors $colormap($child)
6204 foreach p $parents($curview,$child) {
6205 if {[info exists colormap($p)]
6206 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6207 lappend badcolors $colormap($p)
6211 if {[llength $badcolors] >= $ncolors} {
6212 set badcolors $origbad
6215 for {set i 0} {$i <= $ncolors} {incr i} {
6216 set c [lindex $colors $nextcolor]
6217 if {[incr nextcolor] >= $ncolors} {
6218 set nextcolor 0
6220 if {[lsearch -exact $badcolors $c]} break
6222 set colormap($id) $c
6225 proc bindline {t id} {
6226 global canv
6228 $canv bind $t <Enter> "lineenter %x %y $id"
6229 $canv bind $t <Motion> "linemotion %x %y $id"
6230 $canv bind $t <Leave> "lineleave $id"
6231 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6234 proc drawtags {id x xt y1} {
6235 global idtags idheads idotherrefs mainhead
6236 global linespc lthickness
6237 global canv rowtextx curview fgcolor bgcolor ctxbut
6239 set marks {}
6240 set ntags 0
6241 set nheads 0
6242 if {[info exists idtags($id)]} {
6243 set marks $idtags($id)
6244 set ntags [llength $marks]
6246 if {[info exists idheads($id)]} {
6247 set marks [concat $marks $idheads($id)]
6248 set nheads [llength $idheads($id)]
6250 if {[info exists idotherrefs($id)]} {
6251 set marks [concat $marks $idotherrefs($id)]
6253 if {$marks eq {}} {
6254 return $xt
6257 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6258 set yt [expr {$y1 - 0.5 * $linespc}]
6259 set yb [expr {$yt + $linespc - 1}]
6260 set xvals {}
6261 set wvals {}
6262 set i -1
6263 foreach tag $marks {
6264 incr i
6265 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6266 set wid [font measure mainfontbold $tag]
6267 } else {
6268 set wid [font measure mainfont $tag]
6270 lappend xvals $xt
6271 lappend wvals $wid
6272 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6274 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6275 -width $lthickness -fill black -tags tag.$id]
6276 $canv lower $t
6277 foreach tag $marks x $xvals wid $wvals {
6278 set xl [expr {$x + $delta}]
6279 set xr [expr {$x + $delta + $wid + $lthickness}]
6280 set font mainfont
6281 if {[incr ntags -1] >= 0} {
6282 # draw a tag
6283 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6284 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6285 -width 1 -outline black -fill yellow -tags tag.$id]
6286 $canv bind $t <1> [list showtag $tag 1]
6287 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6288 } else {
6289 # draw a head or other ref
6290 if {[incr nheads -1] >= 0} {
6291 set col green
6292 if {$tag eq $mainhead} {
6293 set font mainfontbold
6295 } else {
6296 set col "#ddddff"
6298 set xl [expr {$xl - $delta/2}]
6299 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6300 -width 1 -outline black -fill $col -tags tag.$id
6301 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6302 set rwid [font measure mainfont $remoteprefix]
6303 set xi [expr {$x + 1}]
6304 set yti [expr {$yt + 1}]
6305 set xri [expr {$x + $rwid}]
6306 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6307 -width 0 -fill "#ffddaa" -tags tag.$id
6310 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6311 -font $font -tags [list tag.$id text]]
6312 if {$ntags >= 0} {
6313 $canv bind $t <1> [list showtag $tag 1]
6314 } elseif {$nheads >= 0} {
6315 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6318 return $xt
6321 proc xcoord {i level ln} {
6322 global canvx0 xspc1 xspc2
6324 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6325 if {$i > 0 && $i == $level} {
6326 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6327 } elseif {$i > $level} {
6328 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6330 return $x
6333 proc show_status {msg} {
6334 global canv fgcolor
6336 clear_display
6337 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6338 -tags text -fill $fgcolor
6341 # Don't change the text pane cursor if it is currently the hand cursor,
6342 # showing that we are over a sha1 ID link.
6343 proc settextcursor {c} {
6344 global ctext curtextcursor
6346 if {[$ctext cget -cursor] == $curtextcursor} {
6347 $ctext config -cursor $c
6349 set curtextcursor $c
6352 proc nowbusy {what {name {}}} {
6353 global isbusy busyname statusw
6355 if {[array names isbusy] eq {}} {
6356 . config -cursor watch
6357 settextcursor watch
6359 set isbusy($what) 1
6360 set busyname($what) $name
6361 if {$name ne {}} {
6362 $statusw conf -text $name
6366 proc notbusy {what} {
6367 global isbusy maincursor textcursor busyname statusw
6369 catch {
6370 unset isbusy($what)
6371 if {$busyname($what) ne {} &&
6372 [$statusw cget -text] eq $busyname($what)} {
6373 $statusw conf -text {}
6376 if {[array names isbusy] eq {}} {
6377 . config -cursor $maincursor
6378 settextcursor $textcursor
6382 proc findmatches {f} {
6383 global findtype findstring
6384 if {$findtype == [mc "Regexp"]} {
6385 set matches [regexp -indices -all -inline $findstring $f]
6386 } else {
6387 set fs $findstring
6388 if {$findtype == [mc "IgnCase"]} {
6389 set f [string tolower $f]
6390 set fs [string tolower $fs]
6392 set matches {}
6393 set i 0
6394 set l [string length $fs]
6395 while {[set j [string first $fs $f $i]] >= 0} {
6396 lappend matches [list $j [expr {$j+$l-1}]]
6397 set i [expr {$j + $l}]
6400 return $matches
6403 proc dofind {{dirn 1} {wrap 1}} {
6404 global findstring findstartline findcurline selectedline numcommits
6405 global gdttype filehighlight fh_serial find_dirn findallowwrap
6407 if {[info exists find_dirn]} {
6408 if {$find_dirn == $dirn} return
6409 stopfinding
6411 focus .
6412 if {$findstring eq {} || $numcommits == 0} return
6413 if {$selectedline eq {}} {
6414 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6415 } else {
6416 set findstartline $selectedline
6418 set findcurline $findstartline
6419 nowbusy finding [mc "Searching"]
6420 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6421 after cancel do_file_hl $fh_serial
6422 do_file_hl $fh_serial
6424 set find_dirn $dirn
6425 set findallowwrap $wrap
6426 run findmore
6429 proc stopfinding {} {
6430 global find_dirn findcurline fprogcoord
6432 if {[info exists find_dirn]} {
6433 unset find_dirn
6434 unset findcurline
6435 notbusy finding
6436 set fprogcoord 0
6437 adjustprogress
6439 stopblaming
6442 proc findmore {} {
6443 global commitdata commitinfo numcommits findpattern findloc
6444 global findstartline findcurline findallowwrap
6445 global find_dirn gdttype fhighlights fprogcoord
6446 global curview varcorder vrownum varccommits vrowmod
6448 if {![info exists find_dirn]} {
6449 return 0
6451 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6452 set l $findcurline
6453 set moretodo 0
6454 if {$find_dirn > 0} {
6455 incr l
6456 if {$l >= $numcommits} {
6457 set l 0
6459 if {$l <= $findstartline} {
6460 set lim [expr {$findstartline + 1}]
6461 } else {
6462 set lim $numcommits
6463 set moretodo $findallowwrap
6465 } else {
6466 if {$l == 0} {
6467 set l $numcommits
6469 incr l -1
6470 if {$l >= $findstartline} {
6471 set lim [expr {$findstartline - 1}]
6472 } else {
6473 set lim -1
6474 set moretodo $findallowwrap
6477 set n [expr {($lim - $l) * $find_dirn}]
6478 if {$n > 500} {
6479 set n 500
6480 set moretodo 1
6482 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6483 update_arcrows $curview
6485 set found 0
6486 set domore 1
6487 set ai [bsearch $vrownum($curview) $l]
6488 set a [lindex $varcorder($curview) $ai]
6489 set arow [lindex $vrownum($curview) $ai]
6490 set ids [lindex $varccommits($curview,$a)]
6491 set arowend [expr {$arow + [llength $ids]}]
6492 if {$gdttype eq [mc "containing:"]} {
6493 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6494 if {$l < $arow || $l >= $arowend} {
6495 incr ai $find_dirn
6496 set a [lindex $varcorder($curview) $ai]
6497 set arow [lindex $vrownum($curview) $ai]
6498 set ids [lindex $varccommits($curview,$a)]
6499 set arowend [expr {$arow + [llength $ids]}]
6501 set id [lindex $ids [expr {$l - $arow}]]
6502 # shouldn't happen unless git log doesn't give all the commits...
6503 if {![info exists commitdata($id)] ||
6504 ![doesmatch $commitdata($id)]} {
6505 continue
6507 if {![info exists commitinfo($id)]} {
6508 getcommit $id
6510 set info $commitinfo($id)
6511 foreach f $info ty $fldtypes {
6512 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6513 [doesmatch $f]} {
6514 set found 1
6515 break
6518 if {$found} break
6520 } else {
6521 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6522 if {$l < $arow || $l >= $arowend} {
6523 incr ai $find_dirn
6524 set a [lindex $varcorder($curview) $ai]
6525 set arow [lindex $vrownum($curview) $ai]
6526 set ids [lindex $varccommits($curview,$a)]
6527 set arowend [expr {$arow + [llength $ids]}]
6529 set id [lindex $ids [expr {$l - $arow}]]
6530 if {![info exists fhighlights($id)]} {
6531 # this sets fhighlights($id) to -1
6532 askfilehighlight $l $id
6534 if {$fhighlights($id) > 0} {
6535 set found $domore
6536 break
6538 if {$fhighlights($id) < 0} {
6539 if {$domore} {
6540 set domore 0
6541 set findcurline [expr {$l - $find_dirn}]
6546 if {$found || ($domore && !$moretodo)} {
6547 unset findcurline
6548 unset find_dirn
6549 notbusy finding
6550 set fprogcoord 0
6551 adjustprogress
6552 if {$found} {
6553 findselectline $l
6554 } else {
6555 bell
6557 return 0
6559 if {!$domore} {
6560 flushhighlights
6561 } else {
6562 set findcurline [expr {$l - $find_dirn}]
6564 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6565 if {$n < 0} {
6566 incr n $numcommits
6568 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6569 adjustprogress
6570 return $domore
6573 proc findselectline {l} {
6574 global findloc commentend ctext findcurline markingmatches gdttype
6576 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6577 set findcurline $l
6578 selectline $l 1
6579 if {$markingmatches &&
6580 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6581 # highlight the matches in the comments
6582 set f [$ctext get 1.0 $commentend]
6583 set matches [findmatches $f]
6584 foreach match $matches {
6585 set start [lindex $match 0]
6586 set end [expr {[lindex $match 1] + 1}]
6587 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6590 drawvisible
6593 # mark the bits of a headline or author that match a find string
6594 proc markmatches {canv l str tag matches font row} {
6595 global selectedline
6597 set bbox [$canv bbox $tag]
6598 set x0 [lindex $bbox 0]
6599 set y0 [lindex $bbox 1]
6600 set y1 [lindex $bbox 3]
6601 foreach match $matches {
6602 set start [lindex $match 0]
6603 set end [lindex $match 1]
6604 if {$start > $end} continue
6605 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6606 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6607 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6608 [expr {$x0+$xlen+2}] $y1 \
6609 -outline {} -tags [list match$l matches] -fill yellow]
6610 $canv lower $t
6611 if {$row == $selectedline} {
6612 $canv raise $t secsel
6617 proc unmarkmatches {} {
6618 global markingmatches
6620 allcanvs delete matches
6621 set markingmatches 0
6622 stopfinding
6625 proc selcanvline {w x y} {
6626 global canv canvy0 ctext linespc
6627 global rowtextx
6628 set ymax [lindex [$canv cget -scrollregion] 3]
6629 if {$ymax == {}} return
6630 set yfrac [lindex [$canv yview] 0]
6631 set y [expr {$y + $yfrac * $ymax}]
6632 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6633 if {$l < 0} {
6634 set l 0
6636 if {$w eq $canv} {
6637 set xmax [lindex [$canv cget -scrollregion] 2]
6638 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6639 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6641 unmarkmatches
6642 selectline $l 1
6645 proc commit_descriptor {p} {
6646 global commitinfo
6647 if {![info exists commitinfo($p)]} {
6648 getcommit $p
6650 set l "..."
6651 if {[llength $commitinfo($p)] > 1} {
6652 set l [lindex $commitinfo($p) 0]
6654 return "$p ($l)\n"
6657 # append some text to the ctext widget, and make any SHA1 ID
6658 # that we know about be a clickable link.
6659 proc appendwithlinks {text tags} {
6660 global ctext linknum curview
6662 set start [$ctext index "end - 1c"]
6663 $ctext insert end $text $tags
6664 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6665 foreach l $links {
6666 set s [lindex $l 0]
6667 set e [lindex $l 1]
6668 set linkid [string range $text $s $e]
6669 incr e
6670 $ctext tag delete link$linknum
6671 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6672 setlink $linkid link$linknum
6673 incr linknum
6677 proc setlink {id lk} {
6678 global curview ctext pendinglinks
6680 set known 0
6681 if {[string length $id] < 40} {
6682 set matches [longid $id]
6683 if {[llength $matches] > 0} {
6684 if {[llength $matches] > 1} return
6685 set known 1
6686 set id [lindex $matches 0]
6688 } else {
6689 set known [commitinview $id $curview]
6691 if {$known} {
6692 $ctext tag conf $lk -foreground blue -underline 1
6693 $ctext tag bind $lk <1> [list selbyid $id]
6694 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6695 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6696 } else {
6697 lappend pendinglinks($id) $lk
6698 interestedin $id {makelink %P}
6702 proc appendshortlink {id {pre {}} {post {}}} {
6703 global ctext linknum
6705 $ctext insert end $pre
6706 $ctext tag delete link$linknum
6707 $ctext insert end [string range $id 0 7] link$linknum
6708 $ctext insert end $post
6709 setlink $id link$linknum
6710 incr linknum
6713 proc makelink {id} {
6714 global pendinglinks
6716 if {![info exists pendinglinks($id)]} return
6717 foreach lk $pendinglinks($id) {
6718 setlink $id $lk
6720 unset pendinglinks($id)
6723 proc linkcursor {w inc} {
6724 global linkentercount curtextcursor
6726 if {[incr linkentercount $inc] > 0} {
6727 $w configure -cursor hand2
6728 } else {
6729 $w configure -cursor $curtextcursor
6730 if {$linkentercount < 0} {
6731 set linkentercount 0
6736 proc viewnextline {dir} {
6737 global canv linespc
6739 $canv delete hover
6740 set ymax [lindex [$canv cget -scrollregion] 3]
6741 set wnow [$canv yview]
6742 set wtop [expr {[lindex $wnow 0] * $ymax}]
6743 set newtop [expr {$wtop + $dir * $linespc}]
6744 if {$newtop < 0} {
6745 set newtop 0
6746 } elseif {$newtop > $ymax} {
6747 set newtop $ymax
6749 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6752 # add a list of tag or branch names at position pos
6753 # returns the number of names inserted
6754 proc appendrefs {pos ids var} {
6755 global ctext linknum curview $var maxrefs
6757 if {[catch {$ctext index $pos}]} {
6758 return 0
6760 $ctext conf -state normal
6761 $ctext delete $pos "$pos lineend"
6762 set tags {}
6763 foreach id $ids {
6764 foreach tag [set $var\($id\)] {
6765 lappend tags [list $tag $id]
6768 if {[llength $tags] > $maxrefs} {
6769 $ctext insert $pos "[mc "many"] ([llength $tags])"
6770 } else {
6771 set tags [lsort -index 0 -decreasing $tags]
6772 set sep {}
6773 foreach ti $tags {
6774 set id [lindex $ti 1]
6775 set lk link$linknum
6776 incr linknum
6777 $ctext tag delete $lk
6778 $ctext insert $pos $sep
6779 $ctext insert $pos [lindex $ti 0] $lk
6780 setlink $id $lk
6781 set sep ", "
6784 $ctext conf -state disabled
6785 return [llength $tags]
6788 # called when we have finished computing the nearby tags
6789 proc dispneartags {delay} {
6790 global selectedline currentid showneartags tagphase
6792 if {$selectedline eq {} || !$showneartags} return
6793 after cancel dispnexttag
6794 if {$delay} {
6795 after 200 dispnexttag
6796 set tagphase -1
6797 } else {
6798 after idle dispnexttag
6799 set tagphase 0
6803 proc dispnexttag {} {
6804 global selectedline currentid showneartags tagphase ctext
6806 if {$selectedline eq {} || !$showneartags} return
6807 switch -- $tagphase {
6809 set dtags [desctags $currentid]
6810 if {$dtags ne {}} {
6811 appendrefs precedes $dtags idtags
6815 set atags [anctags $currentid]
6816 if {$atags ne {}} {
6817 appendrefs follows $atags idtags
6821 set dheads [descheads $currentid]
6822 if {$dheads ne {}} {
6823 if {[appendrefs branch $dheads idheads] > 1
6824 && [$ctext get "branch -3c"] eq "h"} {
6825 # turn "Branch" into "Branches"
6826 $ctext conf -state normal
6827 $ctext insert "branch -2c" "es"
6828 $ctext conf -state disabled
6833 if {[incr tagphase] <= 2} {
6834 after idle dispnexttag
6838 proc make_secsel {id} {
6839 global linehtag linentag linedtag canv canv2 canv3
6841 if {![info exists linehtag($id)]} return
6842 $canv delete secsel
6843 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6844 -tags secsel -fill [$canv cget -selectbackground]]
6845 $canv lower $t
6846 $canv2 delete secsel
6847 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6848 -tags secsel -fill [$canv2 cget -selectbackground]]
6849 $canv2 lower $t
6850 $canv3 delete secsel
6851 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6852 -tags secsel -fill [$canv3 cget -selectbackground]]
6853 $canv3 lower $t
6856 proc make_idmark {id} {
6857 global linehtag canv fgcolor
6859 if {![info exists linehtag($id)]} return
6860 $canv delete markid
6861 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6862 -tags markid -outline $fgcolor]
6863 $canv raise $t
6866 proc selectline {l isnew {desired_loc {}}} {
6867 global canv ctext commitinfo selectedline
6868 global canvy0 linespc parents children curview
6869 global currentid sha1entry
6870 global commentend idtags linknum
6871 global mergemax numcommits pending_select
6872 global cmitmode showneartags allcommits
6873 global targetrow targetid lastscrollrows
6874 global autoselect jump_to_here
6876 catch {unset pending_select}
6877 $canv delete hover
6878 normalline
6879 unsel_reflist
6880 stopfinding
6881 if {$l < 0 || $l >= $numcommits} return
6882 set id [commitonrow $l]
6883 set targetid $id
6884 set targetrow $l
6885 set selectedline $l
6886 set currentid $id
6887 if {$lastscrollrows < $numcommits} {
6888 setcanvscroll
6891 set y [expr {$canvy0 + $l * $linespc}]
6892 set ymax [lindex [$canv cget -scrollregion] 3]
6893 set ytop [expr {$y - $linespc - 1}]
6894 set ybot [expr {$y + $linespc + 1}]
6895 set wnow [$canv yview]
6896 set wtop [expr {[lindex $wnow 0] * $ymax}]
6897 set wbot [expr {[lindex $wnow 1] * $ymax}]
6898 set wh [expr {$wbot - $wtop}]
6899 set newtop $wtop
6900 if {$ytop < $wtop} {
6901 if {$ybot < $wtop} {
6902 set newtop [expr {$y - $wh / 2.0}]
6903 } else {
6904 set newtop $ytop
6905 if {$newtop > $wtop - $linespc} {
6906 set newtop [expr {$wtop - $linespc}]
6909 } elseif {$ybot > $wbot} {
6910 if {$ytop > $wbot} {
6911 set newtop [expr {$y - $wh / 2.0}]
6912 } else {
6913 set newtop [expr {$ybot - $wh}]
6914 if {$newtop < $wtop + $linespc} {
6915 set newtop [expr {$wtop + $linespc}]
6919 if {$newtop != $wtop} {
6920 if {$newtop < 0} {
6921 set newtop 0
6923 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6924 drawvisible
6927 make_secsel $id
6929 if {$isnew} {
6930 addtohistory [list selbyid $id 0] savecmitpos
6933 $sha1entry delete 0 end
6934 $sha1entry insert 0 $id
6935 if {$autoselect} {
6936 $sha1entry selection range 0 end
6938 rhighlight_sel $id
6940 $ctext conf -state normal
6941 clear_ctext
6942 set linknum 0
6943 if {![info exists commitinfo($id)]} {
6944 getcommit $id
6946 set info $commitinfo($id)
6947 set date [formatdate [lindex $info 2]]
6948 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6949 set date [formatdate [lindex $info 4]]
6950 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6951 if {[info exists idtags($id)]} {
6952 $ctext insert end [mc "Tags:"]
6953 foreach tag $idtags($id) {
6954 $ctext insert end " $tag"
6956 $ctext insert end "\n"
6959 set headers {}
6960 set olds $parents($curview,$id)
6961 if {[llength $olds] > 1} {
6962 set np 0
6963 foreach p $olds {
6964 if {$np >= $mergemax} {
6965 set tag mmax
6966 } else {
6967 set tag m$np
6969 $ctext insert end "[mc "Parent"]: " $tag
6970 appendwithlinks [commit_descriptor $p] {}
6971 incr np
6973 } else {
6974 foreach p $olds {
6975 append headers "[mc "Parent"]: [commit_descriptor $p]"
6979 foreach c $children($curview,$id) {
6980 append headers "[mc "Child"]: [commit_descriptor $c]"
6983 # make anything that looks like a SHA1 ID be a clickable link
6984 appendwithlinks $headers {}
6985 if {$showneartags} {
6986 if {![info exists allcommits]} {
6987 getallcommits
6989 $ctext insert end "[mc "Branch"]: "
6990 $ctext mark set branch "end -1c"
6991 $ctext mark gravity branch left
6992 $ctext insert end "\n[mc "Follows"]: "
6993 $ctext mark set follows "end -1c"
6994 $ctext mark gravity follows left
6995 $ctext insert end "\n[mc "Precedes"]: "
6996 $ctext mark set precedes "end -1c"
6997 $ctext mark gravity precedes left
6998 $ctext insert end "\n"
6999 dispneartags 1
7001 $ctext insert end "\n"
7002 set comment [lindex $info 5]
7003 if {[string first "\r" $comment] >= 0} {
7004 set comment [string map {"\r" "\n "} $comment]
7006 appendwithlinks $comment {comment}
7008 $ctext tag remove found 1.0 end
7009 $ctext conf -state disabled
7010 set commentend [$ctext index "end - 1c"]
7012 set jump_to_here $desired_loc
7013 init_flist [mc "Comments"]
7014 if {$cmitmode eq "tree"} {
7015 gettree $id
7016 } elseif {[llength $olds] <= 1} {
7017 startdiff $id
7018 } else {
7019 mergediff $id
7023 proc selfirstline {} {
7024 unmarkmatches
7025 selectline 0 1
7028 proc sellastline {} {
7029 global numcommits
7030 unmarkmatches
7031 set l [expr {$numcommits - 1}]
7032 selectline $l 1
7035 proc selnextline {dir} {
7036 global selectedline
7037 focus .
7038 if {$selectedline eq {}} return
7039 set l [expr {$selectedline + $dir}]
7040 unmarkmatches
7041 selectline $l 1
7044 proc selnextpage {dir} {
7045 global canv linespc selectedline numcommits
7047 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7048 if {$lpp < 1} {
7049 set lpp 1
7051 allcanvs yview scroll [expr {$dir * $lpp}] units
7052 drawvisible
7053 if {$selectedline eq {}} return
7054 set l [expr {$selectedline + $dir * $lpp}]
7055 if {$l < 0} {
7056 set l 0
7057 } elseif {$l >= $numcommits} {
7058 set l [expr $numcommits - 1]
7060 unmarkmatches
7061 selectline $l 1
7064 proc unselectline {} {
7065 global selectedline currentid
7067 set selectedline {}
7068 catch {unset currentid}
7069 allcanvs delete secsel
7070 rhighlight_none
7073 proc reselectline {} {
7074 global selectedline
7076 if {$selectedline ne {}} {
7077 selectline $selectedline 0
7081 proc addtohistory {cmd {saveproc {}}} {
7082 global history historyindex curview
7084 unset_posvars
7085 save_position
7086 set elt [list $curview $cmd $saveproc {}]
7087 if {$historyindex > 0
7088 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7089 return
7092 if {$historyindex < [llength $history]} {
7093 set history [lreplace $history $historyindex end $elt]
7094 } else {
7095 lappend history $elt
7097 incr historyindex
7098 if {$historyindex > 1} {
7099 .tf.bar.leftbut conf -state normal
7100 } else {
7101 .tf.bar.leftbut conf -state disabled
7103 .tf.bar.rightbut conf -state disabled
7106 # save the scrolling position of the diff display pane
7107 proc save_position {} {
7108 global historyindex history
7110 if {$historyindex < 1} return
7111 set hi [expr {$historyindex - 1}]
7112 set fn [lindex $history $hi 2]
7113 if {$fn ne {}} {
7114 lset history $hi 3 [eval $fn]
7118 proc unset_posvars {} {
7119 global last_posvars
7121 if {[info exists last_posvars]} {
7122 foreach {var val} $last_posvars {
7123 global $var
7124 catch {unset $var}
7126 unset last_posvars
7130 proc godo {elt} {
7131 global curview last_posvars
7133 set view [lindex $elt 0]
7134 set cmd [lindex $elt 1]
7135 set pv [lindex $elt 3]
7136 if {$curview != $view} {
7137 showview $view
7139 unset_posvars
7140 foreach {var val} $pv {
7141 global $var
7142 set $var $val
7144 set last_posvars $pv
7145 eval $cmd
7148 proc goback {} {
7149 global history historyindex
7150 focus .
7152 if {$historyindex > 1} {
7153 save_position
7154 incr historyindex -1
7155 godo [lindex $history [expr {$historyindex - 1}]]
7156 .tf.bar.rightbut conf -state normal
7158 if {$historyindex <= 1} {
7159 .tf.bar.leftbut conf -state disabled
7163 proc goforw {} {
7164 global history historyindex
7165 focus .
7167 if {$historyindex < [llength $history]} {
7168 save_position
7169 set cmd [lindex $history $historyindex]
7170 incr historyindex
7171 godo $cmd
7172 .tf.bar.leftbut conf -state normal
7174 if {$historyindex >= [llength $history]} {
7175 .tf.bar.rightbut conf -state disabled
7179 proc gettree {id} {
7180 global treefilelist treeidlist diffids diffmergeid treepending
7181 global nullid nullid2
7183 set diffids $id
7184 catch {unset diffmergeid}
7185 if {![info exists treefilelist($id)]} {
7186 if {![info exists treepending]} {
7187 if {$id eq $nullid} {
7188 set cmd [list | git ls-files]
7189 } elseif {$id eq $nullid2} {
7190 set cmd [list | git ls-files --stage -t]
7191 } else {
7192 set cmd [list | git ls-tree -r $id]
7194 if {[catch {set gtf [open $cmd r]}]} {
7195 return
7197 set treepending $id
7198 set treefilelist($id) {}
7199 set treeidlist($id) {}
7200 fconfigure $gtf -blocking 0 -encoding binary
7201 filerun $gtf [list gettreeline $gtf $id]
7203 } else {
7204 setfilelist $id
7208 proc gettreeline {gtf id} {
7209 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7211 set nl 0
7212 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7213 if {$diffids eq $nullid} {
7214 set fname $line
7215 } else {
7216 set i [string first "\t" $line]
7217 if {$i < 0} continue
7218 set fname [string range $line [expr {$i+1}] end]
7219 set line [string range $line 0 [expr {$i-1}]]
7220 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7221 set sha1 [lindex $line 2]
7222 lappend treeidlist($id) $sha1
7224 if {[string index $fname 0] eq "\""} {
7225 set fname [lindex $fname 0]
7227 set fname [encoding convertfrom $fname]
7228 lappend treefilelist($id) $fname
7230 if {![eof $gtf]} {
7231 return [expr {$nl >= 1000? 2: 1}]
7233 close $gtf
7234 unset treepending
7235 if {$cmitmode ne "tree"} {
7236 if {![info exists diffmergeid]} {
7237 gettreediffs $diffids
7239 } elseif {$id ne $diffids} {
7240 gettree $diffids
7241 } else {
7242 setfilelist $id
7244 return 0
7247 proc showfile {f} {
7248 global treefilelist treeidlist diffids nullid nullid2
7249 global ctext_file_names ctext_file_lines
7250 global ctext commentend
7252 set i [lsearch -exact $treefilelist($diffids) $f]
7253 if {$i < 0} {
7254 puts "oops, $f not in list for id $diffids"
7255 return
7257 if {$diffids eq $nullid} {
7258 if {[catch {set bf [open $f r]} err]} {
7259 puts "oops, can't read $f: $err"
7260 return
7262 } else {
7263 set blob [lindex $treeidlist($diffids) $i]
7264 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7265 puts "oops, error reading blob $blob: $err"
7266 return
7269 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7270 filerun $bf [list getblobline $bf $diffids]
7271 $ctext config -state normal
7272 clear_ctext $commentend
7273 lappend ctext_file_names $f
7274 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7275 $ctext insert end "\n"
7276 $ctext insert end "$f\n" filesep
7277 $ctext config -state disabled
7278 $ctext yview $commentend
7279 settabs 0
7282 proc getblobline {bf id} {
7283 global diffids cmitmode ctext
7285 if {$id ne $diffids || $cmitmode ne "tree"} {
7286 catch {close $bf}
7287 return 0
7289 $ctext config -state normal
7290 set nl 0
7291 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7292 $ctext insert end "$line\n"
7294 if {[eof $bf]} {
7295 global jump_to_here ctext_file_names commentend
7297 # delete last newline
7298 $ctext delete "end - 2c" "end - 1c"
7299 close $bf
7300 if {$jump_to_here ne {} &&
7301 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7302 set lnum [expr {[lindex $jump_to_here 1] +
7303 [lindex [split $commentend .] 0]}]
7304 mark_ctext_line $lnum
7306 return 0
7308 $ctext config -state disabled
7309 return [expr {$nl >= 1000? 2: 1}]
7312 proc mark_ctext_line {lnum} {
7313 global ctext markbgcolor
7315 $ctext tag delete omark
7316 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7317 $ctext tag conf omark -background $markbgcolor
7318 $ctext see $lnum.0
7321 proc mergediff {id} {
7322 global diffmergeid
7323 global diffids treediffs
7324 global parents curview
7326 set diffmergeid $id
7327 set diffids $id
7328 set treediffs($id) {}
7329 set np [llength $parents($curview,$id)]
7330 settabs $np
7331 getblobdiffs $id
7334 proc startdiff {ids} {
7335 global treediffs diffids treepending diffmergeid nullid nullid2
7337 settabs 1
7338 set diffids $ids
7339 catch {unset diffmergeid}
7340 if {![info exists treediffs($ids)] ||
7341 [lsearch -exact $ids $nullid] >= 0 ||
7342 [lsearch -exact $ids $nullid2] >= 0} {
7343 if {![info exists treepending]} {
7344 gettreediffs $ids
7346 } else {
7347 addtocflist $ids
7351 proc path_filter {filter name} {
7352 foreach p $filter {
7353 set l [string length $p]
7354 if {[string index $p end] eq "/"} {
7355 if {[string compare -length $l $p $name] == 0} {
7356 return 1
7358 } else {
7359 if {[string compare -length $l $p $name] == 0 &&
7360 ([string length $name] == $l ||
7361 [string index $name $l] eq "/")} {
7362 return 1
7366 return 0
7369 proc addtocflist {ids} {
7370 global treediffs
7372 add_flist $treediffs($ids)
7373 getblobdiffs $ids
7376 proc diffcmd {ids flags} {
7377 global nullid nullid2
7379 set i [lsearch -exact $ids $nullid]
7380 set j [lsearch -exact $ids $nullid2]
7381 if {$i >= 0} {
7382 if {[llength $ids] > 1 && $j < 0} {
7383 # comparing working directory with some specific revision
7384 set cmd [concat | git diff-index $flags]
7385 if {$i == 0} {
7386 lappend cmd -R [lindex $ids 1]
7387 } else {
7388 lappend cmd [lindex $ids 0]
7390 } else {
7391 # comparing working directory with index
7392 set cmd [concat | git diff-files $flags]
7393 if {$j == 1} {
7394 lappend cmd -R
7397 } elseif {$j >= 0} {
7398 set cmd [concat | git diff-index --cached $flags]
7399 if {[llength $ids] > 1} {
7400 # comparing index with specific revision
7401 if {$j == 0} {
7402 lappend cmd -R [lindex $ids 1]
7403 } else {
7404 lappend cmd [lindex $ids 0]
7406 } else {
7407 # comparing index with HEAD
7408 lappend cmd HEAD
7410 } else {
7411 set cmd [concat | git diff-tree -r $flags $ids]
7413 return $cmd
7416 proc gettreediffs {ids} {
7417 global treediff treepending
7419 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7421 set treepending $ids
7422 set treediff {}
7423 fconfigure $gdtf -blocking 0 -encoding binary
7424 filerun $gdtf [list gettreediffline $gdtf $ids]
7427 proc gettreediffline {gdtf ids} {
7428 global treediff treediffs treepending diffids diffmergeid
7429 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7431 set nr 0
7432 set sublist {}
7433 set max 1000
7434 if {$perfile_attrs} {
7435 # cache_gitattr is slow, and even slower on win32 where we
7436 # have to invoke it for only about 30 paths at a time
7437 set max 500
7438 if {[tk windowingsystem] == "win32"} {
7439 set max 120
7442 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7443 set i [string first "\t" $line]
7444 if {$i >= 0} {
7445 set file [string range $line [expr {$i+1}] end]
7446 if {[string index $file 0] eq "\""} {
7447 set file [lindex $file 0]
7449 set file [encoding convertfrom $file]
7450 if {$file ne [lindex $treediff end]} {
7451 lappend treediff $file
7452 lappend sublist $file
7456 if {$perfile_attrs} {
7457 cache_gitattr encoding $sublist
7459 if {![eof $gdtf]} {
7460 return [expr {$nr >= $max? 2: 1}]
7462 close $gdtf
7463 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7464 set flist {}
7465 foreach f $treediff {
7466 if {[path_filter $vfilelimit($curview) $f]} {
7467 lappend flist $f
7470 set treediffs($ids) $flist
7471 } else {
7472 set treediffs($ids) $treediff
7474 unset treepending
7475 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7476 gettree $diffids
7477 } elseif {$ids != $diffids} {
7478 if {![info exists diffmergeid]} {
7479 gettreediffs $diffids
7481 } else {
7482 addtocflist $ids
7484 return 0
7487 # empty string or positive integer
7488 proc diffcontextvalidate {v} {
7489 return [regexp {^(|[1-9][0-9]*)$} $v]
7492 proc diffcontextchange {n1 n2 op} {
7493 global diffcontextstring diffcontext
7495 if {[string is integer -strict $diffcontextstring]} {
7496 if {$diffcontextstring >= 0} {
7497 set diffcontext $diffcontextstring
7498 reselectline
7503 proc changeignorespace {} {
7504 reselectline
7507 proc getblobdiffs {ids} {
7508 global blobdifffd diffids env
7509 global diffinhdr treediffs
7510 global diffcontext
7511 global ignorespace
7512 global limitdiffs vfilelimit curview
7513 global diffencoding targetline diffnparents
7514 global git_version currdiffsubmod
7516 set textconv {}
7517 if {[package vcompare $git_version "1.6.1"] >= 0} {
7518 set textconv "--textconv"
7520 set submodule {}
7521 if {[package vcompare $git_version "1.6.6"] >= 0} {
7522 set submodule "--submodule"
7524 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7525 if {$ignorespace} {
7526 append cmd " -w"
7528 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7529 set cmd [concat $cmd -- $vfilelimit($curview)]
7531 if {[catch {set bdf [open $cmd r]} err]} {
7532 error_popup [mc "Error getting diffs: %s" $err]
7533 return
7535 set targetline {}
7536 set diffnparents 0
7537 set diffinhdr 0
7538 set diffencoding [get_path_encoding {}]
7539 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7540 set blobdifffd($ids) $bdf
7541 set currdiffsubmod ""
7542 filerun $bdf [list getblobdiffline $bdf $diffids]
7545 proc savecmitpos {} {
7546 global ctext cmitmode
7548 if {$cmitmode eq "tree"} {
7549 return {}
7551 return [list target_scrollpos [$ctext index @0,0]]
7554 proc savectextpos {} {
7555 global ctext
7557 return [list target_scrollpos [$ctext index @0,0]]
7560 proc maybe_scroll_ctext {ateof} {
7561 global ctext target_scrollpos
7563 if {![info exists target_scrollpos]} return
7564 if {!$ateof} {
7565 set nlines [expr {[winfo height $ctext]
7566 / [font metrics textfont -linespace]}]
7567 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7569 $ctext yview $target_scrollpos
7570 unset target_scrollpos
7573 proc setinlist {var i val} {
7574 global $var
7576 while {[llength [set $var]] < $i} {
7577 lappend $var {}
7579 if {[llength [set $var]] == $i} {
7580 lappend $var $val
7581 } else {
7582 lset $var $i $val
7586 proc makediffhdr {fname ids} {
7587 global ctext curdiffstart treediffs diffencoding
7588 global ctext_file_names jump_to_here targetline diffline
7590 set fname [encoding convertfrom $fname]
7591 set diffencoding [get_path_encoding $fname]
7592 set i [lsearch -exact $treediffs($ids) $fname]
7593 if {$i >= 0} {
7594 setinlist difffilestart $i $curdiffstart
7596 lset ctext_file_names end $fname
7597 set l [expr {(78 - [string length $fname]) / 2}]
7598 set pad [string range "----------------------------------------" 1 $l]
7599 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7600 set targetline {}
7601 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7602 set targetline [lindex $jump_to_here 1]
7604 set diffline 0
7607 proc getblobdiffline {bdf ids} {
7608 global diffids blobdifffd ctext curdiffstart
7609 global diffnexthead diffnextnote difffilestart
7610 global ctext_file_names ctext_file_lines
7611 global diffinhdr treediffs mergemax diffnparents
7612 global diffencoding jump_to_here targetline diffline currdiffsubmod
7614 set nr 0
7615 $ctext conf -state normal
7616 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7617 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7618 catch {close $bdf}
7619 return 0
7621 if {![string compare -length 5 "diff " $line]} {
7622 if {![regexp {^diff (--cc|--git) } $line m type]} {
7623 set line [encoding convertfrom $line]
7624 $ctext insert end "$line\n" hunksep
7625 continue
7627 # start of a new file
7628 set diffinhdr 1
7629 $ctext insert end "\n"
7630 set curdiffstart [$ctext index "end - 1c"]
7631 lappend ctext_file_names ""
7632 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7633 $ctext insert end "\n" filesep
7635 if {$type eq "--cc"} {
7636 # start of a new file in a merge diff
7637 set fname [string range $line 10 end]
7638 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7639 lappend treediffs($ids) $fname
7640 add_flist [list $fname]
7643 } else {
7644 set line [string range $line 11 end]
7645 # If the name hasn't changed the length will be odd,
7646 # the middle char will be a space, and the two bits either
7647 # side will be a/name and b/name, or "a/name" and "b/name".
7648 # If the name has changed we'll get "rename from" and
7649 # "rename to" or "copy from" and "copy to" lines following
7650 # this, and we'll use them to get the filenames.
7651 # This complexity is necessary because spaces in the
7652 # filename(s) don't get escaped.
7653 set l [string length $line]
7654 set i [expr {$l / 2}]
7655 if {!(($l & 1) && [string index $line $i] eq " " &&
7656 [string range $line 2 [expr {$i - 1}]] eq \
7657 [string range $line [expr {$i + 3}] end])} {
7658 continue
7660 # unescape if quoted and chop off the a/ from the front
7661 if {[string index $line 0] eq "\""} {
7662 set fname [string range [lindex $line 0] 2 end]
7663 } else {
7664 set fname [string range $line 2 [expr {$i - 1}]]
7667 makediffhdr $fname $ids
7669 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7670 set fname [encoding convertfrom [string range $line 16 end]]
7671 $ctext insert end "\n"
7672 set curdiffstart [$ctext index "end - 1c"]
7673 lappend ctext_file_names $fname
7674 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7675 $ctext insert end "$line\n" filesep
7676 set i [lsearch -exact $treediffs($ids) $fname]
7677 if {$i >= 0} {
7678 setinlist difffilestart $i $curdiffstart
7681 } elseif {![string compare -length 2 "@@" $line]} {
7682 regexp {^@@+} $line ats
7683 set line [encoding convertfrom $diffencoding $line]
7684 $ctext insert end "$line\n" hunksep
7685 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7686 set diffline $nl
7688 set diffnparents [expr {[string length $ats] - 1}]
7689 set diffinhdr 0
7691 } elseif {![string compare -length 10 "Submodule " $line]} {
7692 # start of a new submodule
7693 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
7694 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
7695 } else {
7696 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
7698 if {$currdiffsubmod != $fname} {
7699 $ctext insert end "\n"; # Add newline after commit message
7701 set curdiffstart [$ctext index "end - 1c"]
7702 lappend ctext_file_names ""
7703 if {$currdiffsubmod != $fname} {
7704 lappend ctext_file_lines $fname
7705 makediffhdr $fname $ids
7706 set currdiffsubmod $fname
7707 $ctext insert end "\n$line\n" filesep
7708 } else {
7709 $ctext insert end "$line\n" filesep
7711 } elseif {![string compare -length 3 " >" $line]} {
7712 set $currdiffsubmod ""
7713 set line [encoding convertfrom $diffencoding $line]
7714 $ctext insert end "$line\n" dresult
7715 } elseif {![string compare -length 3 " <" $line]} {
7716 set $currdiffsubmod ""
7717 set line [encoding convertfrom $diffencoding $line]
7718 $ctext insert end "$line\n" d0
7719 } elseif {$diffinhdr} {
7720 if {![string compare -length 12 "rename from " $line]} {
7721 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7722 if {[string index $fname 0] eq "\""} {
7723 set fname [lindex $fname 0]
7725 set fname [encoding convertfrom $fname]
7726 set i [lsearch -exact $treediffs($ids) $fname]
7727 if {$i >= 0} {
7728 setinlist difffilestart $i $curdiffstart
7730 } elseif {![string compare -length 10 $line "rename to "] ||
7731 ![string compare -length 8 $line "copy to "]} {
7732 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7733 if {[string index $fname 0] eq "\""} {
7734 set fname [lindex $fname 0]
7736 makediffhdr $fname $ids
7737 } elseif {[string compare -length 3 $line "---"] == 0} {
7738 # do nothing
7739 continue
7740 } elseif {[string compare -length 3 $line "+++"] == 0} {
7741 set diffinhdr 0
7742 continue
7744 $ctext insert end "$line\n" filesep
7746 } else {
7747 set line [string map {\x1A ^Z} \
7748 [encoding convertfrom $diffencoding $line]]
7749 # parse the prefix - one ' ', '-' or '+' for each parent
7750 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7751 set tag [expr {$diffnparents > 1? "m": "d"}]
7752 if {[string trim $prefix " -+"] eq {}} {
7753 # prefix only has " ", "-" and "+" in it: normal diff line
7754 set num [string first "-" $prefix]
7755 if {$num >= 0} {
7756 # removed line, first parent with line is $num
7757 if {$num >= $mergemax} {
7758 set num "max"
7760 $ctext insert end "$line\n" $tag$num
7761 } else {
7762 set tags {}
7763 if {[string first "+" $prefix] >= 0} {
7764 # added line
7765 lappend tags ${tag}result
7766 if {$diffnparents > 1} {
7767 set num [string first " " $prefix]
7768 if {$num >= 0} {
7769 if {$num >= $mergemax} {
7770 set num "max"
7772 lappend tags m$num
7776 if {$targetline ne {}} {
7777 if {$diffline == $targetline} {
7778 set seehere [$ctext index "end - 1 chars"]
7779 set targetline {}
7780 } else {
7781 incr diffline
7784 $ctext insert end "$line\n" $tags
7786 } else {
7787 # "\ No newline at end of file",
7788 # or something else we don't recognize
7789 $ctext insert end "$line\n" hunksep
7793 if {[info exists seehere]} {
7794 mark_ctext_line [lindex [split $seehere .] 0]
7796 maybe_scroll_ctext [eof $bdf]
7797 $ctext conf -state disabled
7798 if {[eof $bdf]} {
7799 catch {close $bdf}
7800 return 0
7802 return [expr {$nr >= 1000? 2: 1}]
7805 proc changediffdisp {} {
7806 global ctext diffelide
7808 $ctext tag conf d0 -elide [lindex $diffelide 0]
7809 $ctext tag conf dresult -elide [lindex $diffelide 1]
7812 proc highlightfile {loc cline} {
7813 global ctext cflist cflist_top
7815 $ctext yview $loc
7816 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7817 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7818 $cflist see $cline.0
7819 set cflist_top $cline
7822 proc prevfile {} {
7823 global difffilestart ctext cmitmode
7825 if {$cmitmode eq "tree"} return
7826 set prev 0.0
7827 set prevline 1
7828 set here [$ctext index @0,0]
7829 foreach loc $difffilestart {
7830 if {[$ctext compare $loc >= $here]} {
7831 highlightfile $prev $prevline
7832 return
7834 set prev $loc
7835 incr prevline
7837 highlightfile $prev $prevline
7840 proc nextfile {} {
7841 global difffilestart ctext cmitmode
7843 if {$cmitmode eq "tree"} return
7844 set here [$ctext index @0,0]
7845 set line 1
7846 foreach loc $difffilestart {
7847 incr line
7848 if {[$ctext compare $loc > $here]} {
7849 highlightfile $loc $line
7850 return
7855 proc clear_ctext {{first 1.0}} {
7856 global ctext smarktop smarkbot
7857 global ctext_file_names ctext_file_lines
7858 global pendinglinks
7860 set l [lindex [split $first .] 0]
7861 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7862 set smarktop $l
7864 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7865 set smarkbot $l
7867 $ctext delete $first end
7868 if {$first eq "1.0"} {
7869 catch {unset pendinglinks}
7871 set ctext_file_names {}
7872 set ctext_file_lines {}
7875 proc settabs {{firstab {}}} {
7876 global firsttabstop tabstop ctext have_tk85
7878 if {$firstab ne {} && $have_tk85} {
7879 set firsttabstop $firstab
7881 set w [font measure textfont "0"]
7882 if {$firsttabstop != 0} {
7883 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7884 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7885 } elseif {$have_tk85 || $tabstop != 8} {
7886 $ctext conf -tabs [expr {$tabstop * $w}]
7887 } else {
7888 $ctext conf -tabs {}
7892 proc incrsearch {name ix op} {
7893 global ctext searchstring searchdirn
7895 $ctext tag remove found 1.0 end
7896 if {[catch {$ctext index anchor}]} {
7897 # no anchor set, use start of selection, or of visible area
7898 set sel [$ctext tag ranges sel]
7899 if {$sel ne {}} {
7900 $ctext mark set anchor [lindex $sel 0]
7901 } elseif {$searchdirn eq "-forwards"} {
7902 $ctext mark set anchor @0,0
7903 } else {
7904 $ctext mark set anchor @0,[winfo height $ctext]
7907 if {$searchstring ne {}} {
7908 set here [$ctext search $searchdirn -- $searchstring anchor]
7909 if {$here ne {}} {
7910 $ctext see $here
7912 searchmarkvisible 1
7916 proc dosearch {} {
7917 global sstring ctext searchstring searchdirn
7919 focus $sstring
7920 $sstring icursor end
7921 set searchdirn -forwards
7922 if {$searchstring ne {}} {
7923 set sel [$ctext tag ranges sel]
7924 if {$sel ne {}} {
7925 set start "[lindex $sel 0] + 1c"
7926 } elseif {[catch {set start [$ctext index anchor]}]} {
7927 set start "@0,0"
7929 set match [$ctext search -count mlen -- $searchstring $start]
7930 $ctext tag remove sel 1.0 end
7931 if {$match eq {}} {
7932 bell
7933 return
7935 $ctext see $match
7936 set mend "$match + $mlen c"
7937 $ctext tag add sel $match $mend
7938 $ctext mark unset anchor
7942 proc dosearchback {} {
7943 global sstring ctext searchstring searchdirn
7945 focus $sstring
7946 $sstring icursor end
7947 set searchdirn -backwards
7948 if {$searchstring ne {}} {
7949 set sel [$ctext tag ranges sel]
7950 if {$sel ne {}} {
7951 set start [lindex $sel 0]
7952 } elseif {[catch {set start [$ctext index anchor]}]} {
7953 set start @0,[winfo height $ctext]
7955 set match [$ctext search -backwards -count ml -- $searchstring $start]
7956 $ctext tag remove sel 1.0 end
7957 if {$match eq {}} {
7958 bell
7959 return
7961 $ctext see $match
7962 set mend "$match + $ml c"
7963 $ctext tag add sel $match $mend
7964 $ctext mark unset anchor
7968 proc searchmark {first last} {
7969 global ctext searchstring
7971 set mend $first.0
7972 while {1} {
7973 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7974 if {$match eq {}} break
7975 set mend "$match + $mlen c"
7976 $ctext tag add found $match $mend
7980 proc searchmarkvisible {doall} {
7981 global ctext smarktop smarkbot
7983 set topline [lindex [split [$ctext index @0,0] .] 0]
7984 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7985 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7986 # no overlap with previous
7987 searchmark $topline $botline
7988 set smarktop $topline
7989 set smarkbot $botline
7990 } else {
7991 if {$topline < $smarktop} {
7992 searchmark $topline [expr {$smarktop-1}]
7993 set smarktop $topline
7995 if {$botline > $smarkbot} {
7996 searchmark [expr {$smarkbot+1}] $botline
7997 set smarkbot $botline
8002 proc scrolltext {f0 f1} {
8003 global searchstring
8005 .bleft.bottom.sb set $f0 $f1
8006 if {$searchstring ne {}} {
8007 searchmarkvisible 0
8011 proc setcoords {} {
8012 global linespc charspc canvx0 canvy0
8013 global xspc1 xspc2 lthickness
8015 set linespc [font metrics mainfont -linespace]
8016 set charspc [font measure mainfont "m"]
8017 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8018 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8019 set lthickness [expr {int($linespc / 9) + 1}]
8020 set xspc1(0) $linespc
8021 set xspc2 $linespc
8024 proc redisplay {} {
8025 global canv
8026 global selectedline
8028 set ymax [lindex [$canv cget -scrollregion] 3]
8029 if {$ymax eq {} || $ymax == 0} return
8030 set span [$canv yview]
8031 clear_display
8032 setcanvscroll
8033 allcanvs yview moveto [lindex $span 0]
8034 drawvisible
8035 if {$selectedline ne {}} {
8036 selectline $selectedline 0
8037 allcanvs yview moveto [lindex $span 0]
8041 proc parsefont {f n} {
8042 global fontattr
8044 set fontattr($f,family) [lindex $n 0]
8045 set s [lindex $n 1]
8046 if {$s eq {} || $s == 0} {
8047 set s 10
8048 } elseif {$s < 0} {
8049 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8051 set fontattr($f,size) $s
8052 set fontattr($f,weight) normal
8053 set fontattr($f,slant) roman
8054 foreach style [lrange $n 2 end] {
8055 switch -- $style {
8056 "normal" -
8057 "bold" {set fontattr($f,weight) $style}
8058 "roman" -
8059 "italic" {set fontattr($f,slant) $style}
8064 proc fontflags {f {isbold 0}} {
8065 global fontattr
8067 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8068 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8069 -slant $fontattr($f,slant)]
8072 proc fontname {f} {
8073 global fontattr
8075 set n [list $fontattr($f,family) $fontattr($f,size)]
8076 if {$fontattr($f,weight) eq "bold"} {
8077 lappend n "bold"
8079 if {$fontattr($f,slant) eq "italic"} {
8080 lappend n "italic"
8082 return $n
8085 proc incrfont {inc} {
8086 global mainfont textfont ctext canv cflist showrefstop
8087 global stopped entries fontattr
8089 unmarkmatches
8090 set s $fontattr(mainfont,size)
8091 incr s $inc
8092 if {$s < 1} {
8093 set s 1
8095 set fontattr(mainfont,size) $s
8096 font config mainfont -size $s
8097 font config mainfontbold -size $s
8098 set mainfont [fontname mainfont]
8099 set s $fontattr(textfont,size)
8100 incr s $inc
8101 if {$s < 1} {
8102 set s 1
8104 set fontattr(textfont,size) $s
8105 font config textfont -size $s
8106 font config textfontbold -size $s
8107 set textfont [fontname textfont]
8108 setcoords
8109 settabs
8110 redisplay
8113 proc clearsha1 {} {
8114 global sha1entry sha1string
8115 if {[string length $sha1string] == 40} {
8116 $sha1entry delete 0 end
8120 proc sha1change {n1 n2 op} {
8121 global sha1string currentid sha1but
8122 if {$sha1string == {}
8123 || ([info exists currentid] && $sha1string == $currentid)} {
8124 set state disabled
8125 } else {
8126 set state normal
8128 if {[$sha1but cget -state] == $state} return
8129 if {$state == "normal"} {
8130 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8131 } else {
8132 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8136 proc gotocommit {} {
8137 global sha1string tagids headids curview varcid
8139 if {$sha1string == {}
8140 || ([info exists currentid] && $sha1string == $currentid)} return
8141 if {[info exists tagids($sha1string)]} {
8142 set id $tagids($sha1string)
8143 } elseif {[info exists headids($sha1string)]} {
8144 set id $headids($sha1string)
8145 } else {
8146 set id [string tolower $sha1string]
8147 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8148 set matches [longid $id]
8149 if {$matches ne {}} {
8150 if {[llength $matches] > 1} {
8151 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8152 return
8154 set id [lindex $matches 0]
8156 } else {
8157 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8158 error_popup [mc "Revision %s is not known" $sha1string]
8159 return
8163 if {[commitinview $id $curview]} {
8164 selectline [rowofcommit $id] 1
8165 return
8167 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8168 set msg [mc "SHA1 id %s is not known" $sha1string]
8169 } else {
8170 set msg [mc "Revision %s is not in the current view" $sha1string]
8172 error_popup $msg
8175 proc lineenter {x y id} {
8176 global hoverx hovery hoverid hovertimer
8177 global commitinfo canv
8179 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8180 set hoverx $x
8181 set hovery $y
8182 set hoverid $id
8183 if {[info exists hovertimer]} {
8184 after cancel $hovertimer
8186 set hovertimer [after 500 linehover]
8187 $canv delete hover
8190 proc linemotion {x y id} {
8191 global hoverx hovery hoverid hovertimer
8193 if {[info exists hoverid] && $id == $hoverid} {
8194 set hoverx $x
8195 set hovery $y
8196 if {[info exists hovertimer]} {
8197 after cancel $hovertimer
8199 set hovertimer [after 500 linehover]
8203 proc lineleave {id} {
8204 global hoverid hovertimer canv
8206 if {[info exists hoverid] && $id == $hoverid} {
8207 $canv delete hover
8208 if {[info exists hovertimer]} {
8209 after cancel $hovertimer
8210 unset hovertimer
8212 unset hoverid
8216 proc linehover {} {
8217 global hoverx hovery hoverid hovertimer
8218 global canv linespc lthickness
8219 global commitinfo
8221 set text [lindex $commitinfo($hoverid) 0]
8222 set ymax [lindex [$canv cget -scrollregion] 3]
8223 if {$ymax == {}} return
8224 set yfrac [lindex [$canv yview] 0]
8225 set x [expr {$hoverx + 2 * $linespc}]
8226 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8227 set x0 [expr {$x - 2 * $lthickness}]
8228 set y0 [expr {$y - 2 * $lthickness}]
8229 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8230 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8231 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8232 -fill \#ffff80 -outline black -width 1 -tags hover]
8233 $canv raise $t
8234 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8235 -font mainfont]
8236 $canv raise $t
8239 proc clickisonarrow {id y} {
8240 global lthickness
8242 set ranges [rowranges $id]
8243 set thresh [expr {2 * $lthickness + 6}]
8244 set n [expr {[llength $ranges] - 1}]
8245 for {set i 1} {$i < $n} {incr i} {
8246 set row [lindex $ranges $i]
8247 if {abs([yc $row] - $y) < $thresh} {
8248 return $i
8251 return {}
8254 proc arrowjump {id n y} {
8255 global canv
8257 # 1 <-> 2, 3 <-> 4, etc...
8258 set n [expr {(($n - 1) ^ 1) + 1}]
8259 set row [lindex [rowranges $id] $n]
8260 set yt [yc $row]
8261 set ymax [lindex [$canv cget -scrollregion] 3]
8262 if {$ymax eq {} || $ymax <= 0} return
8263 set view [$canv yview]
8264 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8265 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8266 if {$yfrac < 0} {
8267 set yfrac 0
8269 allcanvs yview moveto $yfrac
8272 proc lineclick {x y id isnew} {
8273 global ctext commitinfo children canv thickerline curview
8275 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8276 unmarkmatches
8277 unselectline
8278 normalline
8279 $canv delete hover
8280 # draw this line thicker than normal
8281 set thickerline $id
8282 drawlines $id
8283 if {$isnew} {
8284 set ymax [lindex [$canv cget -scrollregion] 3]
8285 if {$ymax eq {}} return
8286 set yfrac [lindex [$canv yview] 0]
8287 set y [expr {$y + $yfrac * $ymax}]
8289 set dirn [clickisonarrow $id $y]
8290 if {$dirn ne {}} {
8291 arrowjump $id $dirn $y
8292 return
8295 if {$isnew} {
8296 addtohistory [list lineclick $x $y $id 0] savectextpos
8298 # fill the details pane with info about this line
8299 $ctext conf -state normal
8300 clear_ctext
8301 settabs 0
8302 $ctext insert end "[mc "Parent"]:\t"
8303 $ctext insert end $id link0
8304 setlink $id link0
8305 set info $commitinfo($id)
8306 $ctext insert end "\n\t[lindex $info 0]\n"
8307 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8308 set date [formatdate [lindex $info 2]]
8309 $ctext insert end "\t[mc "Date"]:\t$date\n"
8310 set kids $children($curview,$id)
8311 if {$kids ne {}} {
8312 $ctext insert end "\n[mc "Children"]:"
8313 set i 0
8314 foreach child $kids {
8315 incr i
8316 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8317 set info $commitinfo($child)
8318 $ctext insert end "\n\t"
8319 $ctext insert end $child link$i
8320 setlink $child link$i
8321 $ctext insert end "\n\t[lindex $info 0]"
8322 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8323 set date [formatdate [lindex $info 2]]
8324 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8327 maybe_scroll_ctext 1
8328 $ctext conf -state disabled
8329 init_flist {}
8332 proc normalline {} {
8333 global thickerline
8334 if {[info exists thickerline]} {
8335 set id $thickerline
8336 unset thickerline
8337 drawlines $id
8341 proc selbyid {id {isnew 1}} {
8342 global curview
8343 if {[commitinview $id $curview]} {
8344 selectline [rowofcommit $id] $isnew
8348 proc mstime {} {
8349 global startmstime
8350 if {![info exists startmstime]} {
8351 set startmstime [clock clicks -milliseconds]
8353 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8356 proc rowmenu {x y id} {
8357 global rowctxmenu selectedline rowmenuid curview
8358 global nullid nullid2 fakerowmenu mainhead markedid
8360 stopfinding
8361 set rowmenuid $id
8362 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8363 set state disabled
8364 } else {
8365 set state normal
8367 if {$id ne $nullid && $id ne $nullid2} {
8368 set menu $rowctxmenu
8369 if {$mainhead ne {}} {
8370 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8371 } else {
8372 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8374 if {[info exists markedid] && $markedid ne $id} {
8375 $menu entryconfigure 9 -state normal
8376 $menu entryconfigure 10 -state normal
8377 $menu entryconfigure 11 -state normal
8378 } else {
8379 $menu entryconfigure 9 -state disabled
8380 $menu entryconfigure 10 -state disabled
8381 $menu entryconfigure 11 -state disabled
8383 } else {
8384 set menu $fakerowmenu
8386 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8387 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8388 $menu entryconfigure [mca "Make patch"] -state $state
8389 tk_popup $menu $x $y
8392 proc markhere {} {
8393 global rowmenuid markedid canv
8395 set markedid $rowmenuid
8396 make_idmark $markedid
8399 proc gotomark {} {
8400 global markedid
8402 if {[info exists markedid]} {
8403 selbyid $markedid
8407 proc replace_by_kids {l r} {
8408 global curview children
8410 set id [commitonrow $r]
8411 set l [lreplace $l 0 0]
8412 foreach kid $children($curview,$id) {
8413 lappend l [rowofcommit $kid]
8415 return [lsort -integer -decreasing -unique $l]
8418 proc find_common_desc {} {
8419 global markedid rowmenuid curview children
8421 if {![info exists markedid]} return
8422 if {![commitinview $markedid $curview] ||
8423 ![commitinview $rowmenuid $curview]} return
8424 #set t1 [clock clicks -milliseconds]
8425 set l1 [list [rowofcommit $markedid]]
8426 set l2 [list [rowofcommit $rowmenuid]]
8427 while 1 {
8428 set r1 [lindex $l1 0]
8429 set r2 [lindex $l2 0]
8430 if {$r1 eq {} || $r2 eq {}} break
8431 if {$r1 == $r2} {
8432 selectline $r1 1
8433 break
8435 if {$r1 > $r2} {
8436 set l1 [replace_by_kids $l1 $r1]
8437 } else {
8438 set l2 [replace_by_kids $l2 $r2]
8441 #set t2 [clock clicks -milliseconds]
8442 #puts "took [expr {$t2-$t1}]ms"
8445 proc compare_commits {} {
8446 global markedid rowmenuid curview children
8448 if {![info exists markedid]} return
8449 if {![commitinview $markedid $curview]} return
8450 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8451 do_cmp_commits $markedid $rowmenuid
8454 proc getpatchid {id} {
8455 global patchids
8457 if {![info exists patchids($id)]} {
8458 set cmd [diffcmd [list $id] {-p --root}]
8459 # trim off the initial "|"
8460 set cmd [lrange $cmd 1 end]
8461 if {[catch {
8462 set x [eval exec $cmd | git patch-id]
8463 set patchids($id) [lindex $x 0]
8464 }]} {
8465 set patchids($id) "error"
8468 return $patchids($id)
8471 proc do_cmp_commits {a b} {
8472 global ctext curview parents children patchids commitinfo
8474 $ctext conf -state normal
8475 clear_ctext
8476 init_flist {}
8477 for {set i 0} {$i < 100} {incr i} {
8478 set skipa 0
8479 set skipb 0
8480 if {[llength $parents($curview,$a)] > 1} {
8481 appendshortlink $a [mc "Skipping merge commit "] "\n"
8482 set skipa 1
8483 } else {
8484 set patcha [getpatchid $a]
8486 if {[llength $parents($curview,$b)] > 1} {
8487 appendshortlink $b [mc "Skipping merge commit "] "\n"
8488 set skipb 1
8489 } else {
8490 set patchb [getpatchid $b]
8492 if {!$skipa && !$skipb} {
8493 set heada [lindex $commitinfo($a) 0]
8494 set headb [lindex $commitinfo($b) 0]
8495 if {$patcha eq "error"} {
8496 appendshortlink $a [mc "Error getting patch ID for "] \
8497 [mc " - stopping\n"]
8498 break
8500 if {$patchb eq "error"} {
8501 appendshortlink $b [mc "Error getting patch ID for "] \
8502 [mc " - stopping\n"]
8503 break
8505 if {$patcha eq $patchb} {
8506 if {$heada eq $headb} {
8507 appendshortlink $a [mc "Commit "]
8508 appendshortlink $b " == " " $heada\n"
8509 } else {
8510 appendshortlink $a [mc "Commit "] " $heada\n"
8511 appendshortlink $b [mc " is the same patch as\n "] \
8512 " $headb\n"
8514 set skipa 1
8515 set skipb 1
8516 } else {
8517 $ctext insert end "\n"
8518 appendshortlink $a [mc "Commit "] " $heada\n"
8519 appendshortlink $b [mc " differs from\n "] \
8520 " $headb\n"
8521 $ctext insert end [mc "Diff of commits:\n\n"]
8522 $ctext conf -state disabled
8523 update
8524 diffcommits $a $b
8525 return
8528 if {$skipa} {
8529 set kids [real_children $curview,$a]
8530 if {[llength $kids] != 1} {
8531 $ctext insert end "\n"
8532 appendshortlink $a [mc "Commit "] \
8533 [mc " has %s children - stopping\n" [llength $kids]]
8534 break
8536 set a [lindex $kids 0]
8538 if {$skipb} {
8539 set kids [real_children $curview,$b]
8540 if {[llength $kids] != 1} {
8541 appendshortlink $b [mc "Commit "] \
8542 [mc " has %s children - stopping\n" [llength $kids]]
8543 break
8545 set b [lindex $kids 0]
8548 $ctext conf -state disabled
8551 proc diffcommits {a b} {
8552 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
8554 set tmpdir [gitknewtmpdir]
8555 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8556 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8557 if {[catch {
8558 exec git diff-tree -p --pretty $a >$fna
8559 exec git diff-tree -p --pretty $b >$fnb
8560 } err]} {
8561 error_popup [mc "Error writing commit to file: %s" $err]
8562 return
8564 if {[catch {
8565 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8566 } err]} {
8567 error_popup [mc "Error diffing commits: %s" $err]
8568 return
8570 set diffids [list commits $a $b]
8571 set blobdifffd($diffids) $fd
8572 set diffinhdr 0
8573 set currdiffsubmod ""
8574 filerun $fd [list getblobdiffline $fd $diffids]
8577 proc diffvssel {dirn} {
8578 global rowmenuid selectedline
8580 if {$selectedline eq {}} return
8581 if {$dirn} {
8582 set oldid [commitonrow $selectedline]
8583 set newid $rowmenuid
8584 } else {
8585 set oldid $rowmenuid
8586 set newid [commitonrow $selectedline]
8588 addtohistory [list doseldiff $oldid $newid] savectextpos
8589 doseldiff $oldid $newid
8592 proc doseldiff {oldid newid} {
8593 global ctext
8594 global commitinfo
8596 $ctext conf -state normal
8597 clear_ctext
8598 init_flist [mc "Top"]
8599 $ctext insert end "[mc "From"] "
8600 $ctext insert end $oldid link0
8601 setlink $oldid link0
8602 $ctext insert end "\n "
8603 $ctext insert end [lindex $commitinfo($oldid) 0]
8604 $ctext insert end "\n\n[mc "To"] "
8605 $ctext insert end $newid link1
8606 setlink $newid link1
8607 $ctext insert end "\n "
8608 $ctext insert end [lindex $commitinfo($newid) 0]
8609 $ctext insert end "\n"
8610 $ctext conf -state disabled
8611 $ctext tag remove found 1.0 end
8612 startdiff [list $oldid $newid]
8615 proc mkpatch {} {
8616 global rowmenuid currentid commitinfo patchtop patchnum NS
8618 if {![info exists currentid]} return
8619 set oldid $currentid
8620 set oldhead [lindex $commitinfo($oldid) 0]
8621 set newid $rowmenuid
8622 set newhead [lindex $commitinfo($newid) 0]
8623 set top .patch
8624 set patchtop $top
8625 catch {destroy $top}
8626 ttk_toplevel $top
8627 make_transient $top .
8628 ${NS}::label $top.title -text [mc "Generate patch"]
8629 grid $top.title - -pady 10
8630 ${NS}::label $top.from -text [mc "From:"]
8631 ${NS}::entry $top.fromsha1 -width 40
8632 $top.fromsha1 insert 0 $oldid
8633 $top.fromsha1 conf -state readonly
8634 grid $top.from $top.fromsha1 -sticky w
8635 ${NS}::entry $top.fromhead -width 60
8636 $top.fromhead insert 0 $oldhead
8637 $top.fromhead conf -state readonly
8638 grid x $top.fromhead -sticky w
8639 ${NS}::label $top.to -text [mc "To:"]
8640 ${NS}::entry $top.tosha1 -width 40
8641 $top.tosha1 insert 0 $newid
8642 $top.tosha1 conf -state readonly
8643 grid $top.to $top.tosha1 -sticky w
8644 ${NS}::entry $top.tohead -width 60
8645 $top.tohead insert 0 $newhead
8646 $top.tohead conf -state readonly
8647 grid x $top.tohead -sticky w
8648 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8649 grid $top.rev x -pady 10 -padx 5
8650 ${NS}::label $top.flab -text [mc "Output file:"]
8651 ${NS}::entry $top.fname -width 60
8652 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8653 incr patchnum
8654 grid $top.flab $top.fname -sticky w
8655 ${NS}::frame $top.buts
8656 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8657 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8658 bind $top <Key-Return> mkpatchgo
8659 bind $top <Key-Escape> mkpatchcan
8660 grid $top.buts.gen $top.buts.can
8661 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8662 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8663 grid $top.buts - -pady 10 -sticky ew
8664 focus $top.fname
8667 proc mkpatchrev {} {
8668 global patchtop
8670 set oldid [$patchtop.fromsha1 get]
8671 set oldhead [$patchtop.fromhead get]
8672 set newid [$patchtop.tosha1 get]
8673 set newhead [$patchtop.tohead get]
8674 foreach e [list fromsha1 fromhead tosha1 tohead] \
8675 v [list $newid $newhead $oldid $oldhead] {
8676 $patchtop.$e conf -state normal
8677 $patchtop.$e delete 0 end
8678 $patchtop.$e insert 0 $v
8679 $patchtop.$e conf -state readonly
8683 proc mkpatchgo {} {
8684 global patchtop nullid nullid2
8686 set oldid [$patchtop.fromsha1 get]
8687 set newid [$patchtop.tosha1 get]
8688 set fname [$patchtop.fname get]
8689 set cmd [diffcmd [list $oldid $newid] -p]
8690 # trim off the initial "|"
8691 set cmd [lrange $cmd 1 end]
8692 lappend cmd >$fname &
8693 if {[catch {eval exec $cmd} err]} {
8694 error_popup "[mc "Error creating patch:"] $err" $patchtop
8696 catch {destroy $patchtop}
8697 unset patchtop
8700 proc mkpatchcan {} {
8701 global patchtop
8703 catch {destroy $patchtop}
8704 unset patchtop
8707 proc mktag {} {
8708 global rowmenuid mktagtop commitinfo NS
8710 set top .maketag
8711 set mktagtop $top
8712 catch {destroy $top}
8713 ttk_toplevel $top
8714 make_transient $top .
8715 ${NS}::label $top.title -text [mc "Create tag"]
8716 grid $top.title - -pady 10
8717 ${NS}::label $top.id -text [mc "ID:"]
8718 ${NS}::entry $top.sha1 -width 40
8719 $top.sha1 insert 0 $rowmenuid
8720 $top.sha1 conf -state readonly
8721 grid $top.id $top.sha1 -sticky w
8722 ${NS}::entry $top.head -width 60
8723 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8724 $top.head conf -state readonly
8725 grid x $top.head -sticky w
8726 ${NS}::label $top.tlab -text [mc "Tag name:"]
8727 ${NS}::entry $top.tag -width 60
8728 grid $top.tlab $top.tag -sticky w
8729 ${NS}::label $top.op -text [mc "Tag message is optional"]
8730 grid $top.op -columnspan 2 -sticky we
8731 ${NS}::label $top.mlab -text [mc "Tag message:"]
8732 ${NS}::entry $top.msg -width 60
8733 grid $top.mlab $top.msg -sticky w
8734 ${NS}::frame $top.buts
8735 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8736 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8737 bind $top <Key-Return> mktaggo
8738 bind $top <Key-Escape> mktagcan
8739 grid $top.buts.gen $top.buts.can
8740 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8741 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8742 grid $top.buts - -pady 10 -sticky ew
8743 focus $top.tag
8746 proc domktag {} {
8747 global mktagtop env tagids idtags
8749 set id [$mktagtop.sha1 get]
8750 set tag [$mktagtop.tag get]
8751 set msg [$mktagtop.msg get]
8752 if {$tag == {}} {
8753 error_popup [mc "No tag name specified"] $mktagtop
8754 return 0
8756 if {[info exists tagids($tag)]} {
8757 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8758 return 0
8760 if {[catch {
8761 if {$msg != {}} {
8762 exec git tag -a -m $msg $tag $id
8763 } else {
8764 exec git tag $tag $id
8766 } err]} {
8767 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8768 return 0
8771 set tagids($tag) $id
8772 lappend idtags($id) $tag
8773 redrawtags $id
8774 addedtag $id
8775 dispneartags 0
8776 run refill_reflist
8777 return 1
8780 proc redrawtags {id} {
8781 global canv linehtag idpos currentid curview cmitlisted markedid
8782 global canvxmax iddrawn circleitem mainheadid circlecolors
8784 if {![commitinview $id $curview]} return
8785 if {![info exists iddrawn($id)]} return
8786 set row [rowofcommit $id]
8787 if {$id eq $mainheadid} {
8788 set ofill yellow
8789 } else {
8790 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8792 $canv itemconf $circleitem($row) -fill $ofill
8793 $canv delete tag.$id
8794 set xt [eval drawtags $id $idpos($id)]
8795 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8796 set text [$canv itemcget $linehtag($id) -text]
8797 set font [$canv itemcget $linehtag($id) -font]
8798 set xr [expr {$xt + [font measure $font $text]}]
8799 if {$xr > $canvxmax} {
8800 set canvxmax $xr
8801 setcanvscroll
8803 if {[info exists currentid] && $currentid == $id} {
8804 make_secsel $id
8806 if {[info exists markedid] && $markedid eq $id} {
8807 make_idmark $id
8811 proc mktagcan {} {
8812 global mktagtop
8814 catch {destroy $mktagtop}
8815 unset mktagtop
8818 proc mktaggo {} {
8819 if {![domktag]} return
8820 mktagcan
8823 proc writecommit {} {
8824 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8826 set top .writecommit
8827 set wrcomtop $top
8828 catch {destroy $top}
8829 ttk_toplevel $top
8830 make_transient $top .
8831 ${NS}::label $top.title -text [mc "Write commit to file"]
8832 grid $top.title - -pady 10
8833 ${NS}::label $top.id -text [mc "ID:"]
8834 ${NS}::entry $top.sha1 -width 40
8835 $top.sha1 insert 0 $rowmenuid
8836 $top.sha1 conf -state readonly
8837 grid $top.id $top.sha1 -sticky w
8838 ${NS}::entry $top.head -width 60
8839 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8840 $top.head conf -state readonly
8841 grid x $top.head -sticky w
8842 ${NS}::label $top.clab -text [mc "Command:"]
8843 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8844 grid $top.clab $top.cmd -sticky w -pady 10
8845 ${NS}::label $top.flab -text [mc "Output file:"]
8846 ${NS}::entry $top.fname -width 60
8847 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8848 grid $top.flab $top.fname -sticky w
8849 ${NS}::frame $top.buts
8850 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8851 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8852 bind $top <Key-Return> wrcomgo
8853 bind $top <Key-Escape> wrcomcan
8854 grid $top.buts.gen $top.buts.can
8855 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8856 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8857 grid $top.buts - -pady 10 -sticky ew
8858 focus $top.fname
8861 proc wrcomgo {} {
8862 global wrcomtop
8864 set id [$wrcomtop.sha1 get]
8865 set cmd "echo $id | [$wrcomtop.cmd get]"
8866 set fname [$wrcomtop.fname get]
8867 if {[catch {exec sh -c $cmd >$fname &} err]} {
8868 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8870 catch {destroy $wrcomtop}
8871 unset wrcomtop
8874 proc wrcomcan {} {
8875 global wrcomtop
8877 catch {destroy $wrcomtop}
8878 unset wrcomtop
8881 proc mkbranch {} {
8882 global rowmenuid mkbrtop NS
8884 set top .makebranch
8885 catch {destroy $top}
8886 ttk_toplevel $top
8887 make_transient $top .
8888 ${NS}::label $top.title -text [mc "Create new branch"]
8889 grid $top.title - -pady 10
8890 ${NS}::label $top.id -text [mc "ID:"]
8891 ${NS}::entry $top.sha1 -width 40
8892 $top.sha1 insert 0 $rowmenuid
8893 $top.sha1 conf -state readonly
8894 grid $top.id $top.sha1 -sticky w
8895 ${NS}::label $top.nlab -text [mc "Name:"]
8896 ${NS}::entry $top.name -width 40
8897 grid $top.nlab $top.name -sticky w
8898 ${NS}::frame $top.buts
8899 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8900 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8901 bind $top <Key-Return> [list mkbrgo $top]
8902 bind $top <Key-Escape> "catch {destroy $top}"
8903 grid $top.buts.go $top.buts.can
8904 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8905 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8906 grid $top.buts - -pady 10 -sticky ew
8907 focus $top.name
8910 proc mkbrgo {top} {
8911 global headids idheads
8913 set name [$top.name get]
8914 set id [$top.sha1 get]
8915 set cmdargs {}
8916 set old_id {}
8917 if {$name eq {}} {
8918 error_popup [mc "Please specify a name for the new branch"] $top
8919 return
8921 if {[info exists headids($name)]} {
8922 if {![confirm_popup [mc \
8923 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8924 return
8926 set old_id $headids($name)
8927 lappend cmdargs -f
8929 catch {destroy $top}
8930 lappend cmdargs $name $id
8931 nowbusy newbranch
8932 update
8933 if {[catch {
8934 eval exec git branch $cmdargs
8935 } err]} {
8936 notbusy newbranch
8937 error_popup $err
8938 } else {
8939 notbusy newbranch
8940 if {$old_id ne {}} {
8941 movehead $id $name
8942 movedhead $id $name
8943 redrawtags $old_id
8944 redrawtags $id
8945 } else {
8946 set headids($name) $id
8947 lappend idheads($id) $name
8948 addedhead $id $name
8949 redrawtags $id
8951 dispneartags 0
8952 run refill_reflist
8956 proc exec_citool {tool_args {baseid {}}} {
8957 global commitinfo env
8959 set save_env [array get env GIT_AUTHOR_*]
8961 if {$baseid ne {}} {
8962 if {![info exists commitinfo($baseid)]} {
8963 getcommit $baseid
8965 set author [lindex $commitinfo($baseid) 1]
8966 set date [lindex $commitinfo($baseid) 2]
8967 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8968 $author author name email]
8969 && $date ne {}} {
8970 set env(GIT_AUTHOR_NAME) $name
8971 set env(GIT_AUTHOR_EMAIL) $email
8972 set env(GIT_AUTHOR_DATE) $date
8976 eval exec git citool $tool_args &
8978 array unset env GIT_AUTHOR_*
8979 array set env $save_env
8982 proc cherrypick {} {
8983 global rowmenuid curview
8984 global mainhead mainheadid
8986 set oldhead [exec git rev-parse HEAD]
8987 set dheads [descheads $rowmenuid]
8988 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8989 set ok [confirm_popup [mc "Commit %s is already\
8990 included in branch %s -- really re-apply it?" \
8991 [string range $rowmenuid 0 7] $mainhead]]
8992 if {!$ok} return
8994 nowbusy cherrypick [mc "Cherry-picking"]
8995 update
8996 # Unfortunately git-cherry-pick writes stuff to stderr even when
8997 # no error occurs, and exec takes that as an indication of error...
8998 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8999 notbusy cherrypick
9000 if {[regexp -line \
9001 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9002 $err msg fname]} {
9003 error_popup [mc "Cherry-pick failed because of local changes\
9004 to file '%s'.\nPlease commit, reset or stash\
9005 your changes and try again." $fname]
9006 } elseif {[regexp -line \
9007 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
9008 $err]} {
9009 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9010 conflict.\nDo you wish to run git citool to\
9011 resolve it?"]]} {
9012 # Force citool to read MERGE_MSG
9013 file delete [file join [gitdir] "GITGUI_MSG"]
9014 exec_citool {} $rowmenuid
9016 } else {
9017 error_popup $err
9019 run updatecommits
9020 return
9022 set newhead [exec git rev-parse HEAD]
9023 if {$newhead eq $oldhead} {
9024 notbusy cherrypick
9025 error_popup [mc "No changes committed"]
9026 return
9028 addnewchild $newhead $oldhead
9029 if {[commitinview $oldhead $curview]} {
9030 # XXX this isn't right if we have a path limit...
9031 insertrow $newhead $oldhead $curview
9032 if {$mainhead ne {}} {
9033 movehead $newhead $mainhead
9034 movedhead $newhead $mainhead
9036 set mainheadid $newhead
9037 redrawtags $oldhead
9038 redrawtags $newhead
9039 selbyid $newhead
9041 notbusy cherrypick
9044 proc resethead {} {
9045 global mainhead rowmenuid confirm_ok resettype NS
9047 set confirm_ok 0
9048 set w ".confirmreset"
9049 ttk_toplevel $w
9050 make_transient $w .
9051 wm title $w [mc "Confirm reset"]
9052 ${NS}::label $w.m -text \
9053 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9054 pack $w.m -side top -fill x -padx 20 -pady 20
9055 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9056 set resettype mixed
9057 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9058 -text [mc "Soft: Leave working tree and index untouched"]
9059 grid $w.f.soft -sticky w
9060 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9061 -text [mc "Mixed: Leave working tree untouched, reset index"]
9062 grid $w.f.mixed -sticky w
9063 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9064 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9065 grid $w.f.hard -sticky w
9066 pack $w.f -side top -fill x -padx 4
9067 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9068 pack $w.ok -side left -fill x -padx 20 -pady 20
9069 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9070 bind $w <Key-Escape> [list destroy $w]
9071 pack $w.cancel -side right -fill x -padx 20 -pady 20
9072 bind $w <Visibility> "grab $w; focus $w"
9073 tkwait window $w
9074 if {!$confirm_ok} return
9075 if {[catch {set fd [open \
9076 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9077 error_popup $err
9078 } else {
9079 dohidelocalchanges
9080 filerun $fd [list readresetstat $fd]
9081 nowbusy reset [mc "Resetting"]
9082 selbyid $rowmenuid
9086 proc readresetstat {fd} {
9087 global mainhead mainheadid showlocalchanges rprogcoord
9089 if {[gets $fd line] >= 0} {
9090 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9091 set rprogcoord [expr {1.0 * $m / $n}]
9092 adjustprogress
9094 return 1
9096 set rprogcoord 0
9097 adjustprogress
9098 notbusy reset
9099 if {[catch {close $fd} err]} {
9100 error_popup $err
9102 set oldhead $mainheadid
9103 set newhead [exec git rev-parse HEAD]
9104 if {$newhead ne $oldhead} {
9105 movehead $newhead $mainhead
9106 movedhead $newhead $mainhead
9107 set mainheadid $newhead
9108 redrawtags $oldhead
9109 redrawtags $newhead
9111 if {$showlocalchanges} {
9112 doshowlocalchanges
9114 return 0
9117 # context menu for a head
9118 proc headmenu {x y id head} {
9119 global headmenuid headmenuhead headctxmenu mainhead
9121 stopfinding
9122 set headmenuid $id
9123 set headmenuhead $head
9124 set state normal
9125 if {[string match "remotes/*" $head]} {
9126 set state disabled
9128 if {$head eq $mainhead} {
9129 set state disabled
9131 $headctxmenu entryconfigure 0 -state $state
9132 $headctxmenu entryconfigure 1 -state $state
9133 tk_popup $headctxmenu $x $y
9136 proc cobranch {} {
9137 global headmenuid headmenuhead headids
9138 global showlocalchanges
9140 # check the tree is clean first??
9141 nowbusy checkout [mc "Checking out"]
9142 update
9143 dohidelocalchanges
9144 if {[catch {
9145 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9146 } err]} {
9147 notbusy checkout
9148 error_popup $err
9149 if {$showlocalchanges} {
9150 dodiffindex
9152 } else {
9153 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9157 proc readcheckoutstat {fd newhead newheadid} {
9158 global mainhead mainheadid headids showlocalchanges progresscoords
9159 global viewmainheadid curview
9161 if {[gets $fd line] >= 0} {
9162 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9163 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9164 adjustprogress
9166 return 1
9168 set progresscoords {0 0}
9169 adjustprogress
9170 notbusy checkout
9171 if {[catch {close $fd} err]} {
9172 error_popup $err
9174 set oldmainid $mainheadid
9175 set mainhead $newhead
9176 set mainheadid $newheadid
9177 set viewmainheadid($curview) $newheadid
9178 redrawtags $oldmainid
9179 redrawtags $newheadid
9180 selbyid $newheadid
9181 if {$showlocalchanges} {
9182 dodiffindex
9186 proc rmbranch {} {
9187 global headmenuid headmenuhead mainhead
9188 global idheads
9190 set head $headmenuhead
9191 set id $headmenuid
9192 # this check shouldn't be needed any more...
9193 if {$head eq $mainhead} {
9194 error_popup [mc "Cannot delete the currently checked-out branch"]
9195 return
9197 set dheads [descheads $id]
9198 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9199 # the stuff on this branch isn't on any other branch
9200 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9201 branch.\nReally delete branch %s?" $head $head]]} return
9203 nowbusy rmbranch
9204 update
9205 if {[catch {exec git branch -D $head} err]} {
9206 notbusy rmbranch
9207 error_popup $err
9208 return
9210 removehead $id $head
9211 removedhead $id $head
9212 redrawtags $id
9213 notbusy rmbranch
9214 dispneartags 0
9215 run refill_reflist
9218 # Display a list of tags and heads
9219 proc showrefs {} {
9220 global showrefstop bgcolor fgcolor selectbgcolor NS
9221 global bglist fglist reflistfilter reflist maincursor
9223 set top .showrefs
9224 set showrefstop $top
9225 if {[winfo exists $top]} {
9226 raise $top
9227 refill_reflist
9228 return
9230 ttk_toplevel $top
9231 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9232 make_transient $top .
9233 text $top.list -background $bgcolor -foreground $fgcolor \
9234 -selectbackground $selectbgcolor -font mainfont \
9235 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9236 -width 30 -height 20 -cursor $maincursor \
9237 -spacing1 1 -spacing3 1 -state disabled
9238 $top.list tag configure highlight -background $selectbgcolor
9239 lappend bglist $top.list
9240 lappend fglist $top.list
9241 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9242 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9243 grid $top.list $top.ysb -sticky nsew
9244 grid $top.xsb x -sticky ew
9245 ${NS}::frame $top.f
9246 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9247 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9248 set reflistfilter "*"
9249 trace add variable reflistfilter write reflistfilter_change
9250 pack $top.f.e -side right -fill x -expand 1
9251 pack $top.f.l -side left
9252 grid $top.f - -sticky ew -pady 2
9253 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9254 bind $top <Key-Escape> [list destroy $top]
9255 grid $top.close -
9256 grid columnconfigure $top 0 -weight 1
9257 grid rowconfigure $top 0 -weight 1
9258 bind $top.list <1> {break}
9259 bind $top.list <B1-Motion> {break}
9260 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9261 set reflist {}
9262 refill_reflist
9265 proc sel_reflist {w x y} {
9266 global showrefstop reflist headids tagids otherrefids
9268 if {![winfo exists $showrefstop]} return
9269 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9270 set ref [lindex $reflist [expr {$l-1}]]
9271 set n [lindex $ref 0]
9272 switch -- [lindex $ref 1] {
9273 "H" {selbyid $headids($n)}
9274 "T" {selbyid $tagids($n)}
9275 "o" {selbyid $otherrefids($n)}
9277 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9280 proc unsel_reflist {} {
9281 global showrefstop
9283 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9284 $showrefstop.list tag remove highlight 0.0 end
9287 proc reflistfilter_change {n1 n2 op} {
9288 global reflistfilter
9290 after cancel refill_reflist
9291 after 200 refill_reflist
9294 proc refill_reflist {} {
9295 global reflist reflistfilter showrefstop headids tagids otherrefids
9296 global curview
9298 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9299 set refs {}
9300 foreach n [array names headids] {
9301 if {[string match $reflistfilter $n]} {
9302 if {[commitinview $headids($n) $curview]} {
9303 lappend refs [list $n H]
9304 } else {
9305 interestedin $headids($n) {run refill_reflist}
9309 foreach n [array names tagids] {
9310 if {[string match $reflistfilter $n]} {
9311 if {[commitinview $tagids($n) $curview]} {
9312 lappend refs [list $n T]
9313 } else {
9314 interestedin $tagids($n) {run refill_reflist}
9318 foreach n [array names otherrefids] {
9319 if {[string match $reflistfilter $n]} {
9320 if {[commitinview $otherrefids($n) $curview]} {
9321 lappend refs [list $n o]
9322 } else {
9323 interestedin $otherrefids($n) {run refill_reflist}
9327 set refs [lsort -index 0 $refs]
9328 if {$refs eq $reflist} return
9330 # Update the contents of $showrefstop.list according to the
9331 # differences between $reflist (old) and $refs (new)
9332 $showrefstop.list conf -state normal
9333 $showrefstop.list insert end "\n"
9334 set i 0
9335 set j 0
9336 while {$i < [llength $reflist] || $j < [llength $refs]} {
9337 if {$i < [llength $reflist]} {
9338 if {$j < [llength $refs]} {
9339 set cmp [string compare [lindex $reflist $i 0] \
9340 [lindex $refs $j 0]]
9341 if {$cmp == 0} {
9342 set cmp [string compare [lindex $reflist $i 1] \
9343 [lindex $refs $j 1]]
9345 } else {
9346 set cmp -1
9348 } else {
9349 set cmp 1
9351 switch -- $cmp {
9352 -1 {
9353 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9354 incr i
9357 incr i
9358 incr j
9361 set l [expr {$j + 1}]
9362 $showrefstop.list image create $l.0 -align baseline \
9363 -image reficon-[lindex $refs $j 1] -padx 2
9364 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9365 incr j
9369 set reflist $refs
9370 # delete last newline
9371 $showrefstop.list delete end-2c end-1c
9372 $showrefstop.list conf -state disabled
9375 # Stuff for finding nearby tags
9376 proc getallcommits {} {
9377 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9378 global idheads idtags idotherrefs allparents tagobjid
9380 if {![info exists allcommits]} {
9381 set nextarc 0
9382 set allcommits 0
9383 set seeds {}
9384 set allcwait 0
9385 set cachedarcs 0
9386 set allccache [file join [gitdir] "gitk.cache"]
9387 if {![catch {
9388 set f [open $allccache r]
9389 set allcwait 1
9390 getcache $f
9391 }]} return
9394 if {$allcwait} {
9395 return
9397 set cmd [list | git rev-list --parents]
9398 set allcupdate [expr {$seeds ne {}}]
9399 if {!$allcupdate} {
9400 set ids "--all"
9401 } else {
9402 set refs [concat [array names idheads] [array names idtags] \
9403 [array names idotherrefs]]
9404 set ids {}
9405 set tagobjs {}
9406 foreach name [array names tagobjid] {
9407 lappend tagobjs $tagobjid($name)
9409 foreach id [lsort -unique $refs] {
9410 if {![info exists allparents($id)] &&
9411 [lsearch -exact $tagobjs $id] < 0} {
9412 lappend ids $id
9415 if {$ids ne {}} {
9416 foreach id $seeds {
9417 lappend ids "^$id"
9421 if {$ids ne {}} {
9422 set fd [open [concat $cmd $ids] r]
9423 fconfigure $fd -blocking 0
9424 incr allcommits
9425 nowbusy allcommits
9426 filerun $fd [list getallclines $fd]
9427 } else {
9428 dispneartags 0
9432 # Since most commits have 1 parent and 1 child, we group strings of
9433 # such commits into "arcs" joining branch/merge points (BMPs), which
9434 # are commits that either don't have 1 parent or don't have 1 child.
9436 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9437 # arcout(id) - outgoing arcs for BMP
9438 # arcids(a) - list of IDs on arc including end but not start
9439 # arcstart(a) - BMP ID at start of arc
9440 # arcend(a) - BMP ID at end of arc
9441 # growing(a) - arc a is still growing
9442 # arctags(a) - IDs out of arcids (excluding end) that have tags
9443 # archeads(a) - IDs out of arcids (excluding end) that have heads
9444 # The start of an arc is at the descendent end, so "incoming" means
9445 # coming from descendents, and "outgoing" means going towards ancestors.
9447 proc getallclines {fd} {
9448 global allparents allchildren idtags idheads nextarc
9449 global arcnos arcids arctags arcout arcend arcstart archeads growing
9450 global seeds allcommits cachedarcs allcupdate
9452 set nid 0
9453 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9454 set id [lindex $line 0]
9455 if {[info exists allparents($id)]} {
9456 # seen it already
9457 continue
9459 set cachedarcs 0
9460 set olds [lrange $line 1 end]
9461 set allparents($id) $olds
9462 if {![info exists allchildren($id)]} {
9463 set allchildren($id) {}
9464 set arcnos($id) {}
9465 lappend seeds $id
9466 } else {
9467 set a $arcnos($id)
9468 if {[llength $olds] == 1 && [llength $a] == 1} {
9469 lappend arcids($a) $id
9470 if {[info exists idtags($id)]} {
9471 lappend arctags($a) $id
9473 if {[info exists idheads($id)]} {
9474 lappend archeads($a) $id
9476 if {[info exists allparents($olds)]} {
9477 # seen parent already
9478 if {![info exists arcout($olds)]} {
9479 splitarc $olds
9481 lappend arcids($a) $olds
9482 set arcend($a) $olds
9483 unset growing($a)
9485 lappend allchildren($olds) $id
9486 lappend arcnos($olds) $a
9487 continue
9490 foreach a $arcnos($id) {
9491 lappend arcids($a) $id
9492 set arcend($a) $id
9493 unset growing($a)
9496 set ao {}
9497 foreach p $olds {
9498 lappend allchildren($p) $id
9499 set a [incr nextarc]
9500 set arcstart($a) $id
9501 set archeads($a) {}
9502 set arctags($a) {}
9503 set archeads($a) {}
9504 set arcids($a) {}
9505 lappend ao $a
9506 set growing($a) 1
9507 if {[info exists allparents($p)]} {
9508 # seen it already, may need to make a new branch
9509 if {![info exists arcout($p)]} {
9510 splitarc $p
9512 lappend arcids($a) $p
9513 set arcend($a) $p
9514 unset growing($a)
9516 lappend arcnos($p) $a
9518 set arcout($id) $ao
9520 if {$nid > 0} {
9521 global cached_dheads cached_dtags cached_atags
9522 catch {unset cached_dheads}
9523 catch {unset cached_dtags}
9524 catch {unset cached_atags}
9526 if {![eof $fd]} {
9527 return [expr {$nid >= 1000? 2: 1}]
9529 set cacheok 1
9530 if {[catch {
9531 fconfigure $fd -blocking 1
9532 close $fd
9533 } err]} {
9534 # got an error reading the list of commits
9535 # if we were updating, try rereading the whole thing again
9536 if {$allcupdate} {
9537 incr allcommits -1
9538 dropcache $err
9539 return
9541 error_popup "[mc "Error reading commit topology information;\
9542 branch and preceding/following tag information\
9543 will be incomplete."]\n($err)"
9544 set cacheok 0
9546 if {[incr allcommits -1] == 0} {
9547 notbusy allcommits
9548 if {$cacheok} {
9549 run savecache
9552 dispneartags 0
9553 return 0
9556 proc recalcarc {a} {
9557 global arctags archeads arcids idtags idheads
9559 set at {}
9560 set ah {}
9561 foreach id [lrange $arcids($a) 0 end-1] {
9562 if {[info exists idtags($id)]} {
9563 lappend at $id
9565 if {[info exists idheads($id)]} {
9566 lappend ah $id
9569 set arctags($a) $at
9570 set archeads($a) $ah
9573 proc splitarc {p} {
9574 global arcnos arcids nextarc arctags archeads idtags idheads
9575 global arcstart arcend arcout allparents growing
9577 set a $arcnos($p)
9578 if {[llength $a] != 1} {
9579 puts "oops splitarc called but [llength $a] arcs already"
9580 return
9582 set a [lindex $a 0]
9583 set i [lsearch -exact $arcids($a) $p]
9584 if {$i < 0} {
9585 puts "oops splitarc $p not in arc $a"
9586 return
9588 set na [incr nextarc]
9589 if {[info exists arcend($a)]} {
9590 set arcend($na) $arcend($a)
9591 } else {
9592 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9593 set j [lsearch -exact $arcnos($l) $a]
9594 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9596 set tail [lrange $arcids($a) [expr {$i+1}] end]
9597 set arcids($a) [lrange $arcids($a) 0 $i]
9598 set arcend($a) $p
9599 set arcstart($na) $p
9600 set arcout($p) $na
9601 set arcids($na) $tail
9602 if {[info exists growing($a)]} {
9603 set growing($na) 1
9604 unset growing($a)
9607 foreach id $tail {
9608 if {[llength $arcnos($id)] == 1} {
9609 set arcnos($id) $na
9610 } else {
9611 set j [lsearch -exact $arcnos($id) $a]
9612 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9616 # reconstruct tags and heads lists
9617 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9618 recalcarc $a
9619 recalcarc $na
9620 } else {
9621 set arctags($na) {}
9622 set archeads($na) {}
9626 # Update things for a new commit added that is a child of one
9627 # existing commit. Used when cherry-picking.
9628 proc addnewchild {id p} {
9629 global allparents allchildren idtags nextarc
9630 global arcnos arcids arctags arcout arcend arcstart archeads growing
9631 global seeds allcommits
9633 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9634 set allparents($id) [list $p]
9635 set allchildren($id) {}
9636 set arcnos($id) {}
9637 lappend seeds $id
9638 lappend allchildren($p) $id
9639 set a [incr nextarc]
9640 set arcstart($a) $id
9641 set archeads($a) {}
9642 set arctags($a) {}
9643 set arcids($a) [list $p]
9644 set arcend($a) $p
9645 if {![info exists arcout($p)]} {
9646 splitarc $p
9648 lappend arcnos($p) $a
9649 set arcout($id) [list $a]
9652 # This implements a cache for the topology information.
9653 # The cache saves, for each arc, the start and end of the arc,
9654 # the ids on the arc, and the outgoing arcs from the end.
9655 proc readcache {f} {
9656 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9657 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9658 global allcwait
9660 set a $nextarc
9661 set lim $cachedarcs
9662 if {$lim - $a > 500} {
9663 set lim [expr {$a + 500}]
9665 if {[catch {
9666 if {$a == $lim} {
9667 # finish reading the cache and setting up arctags, etc.
9668 set line [gets $f]
9669 if {$line ne "1"} {error "bad final version"}
9670 close $f
9671 foreach id [array names idtags] {
9672 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9673 [llength $allparents($id)] == 1} {
9674 set a [lindex $arcnos($id) 0]
9675 if {$arctags($a) eq {}} {
9676 recalcarc $a
9680 foreach id [array names idheads] {
9681 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9682 [llength $allparents($id)] == 1} {
9683 set a [lindex $arcnos($id) 0]
9684 if {$archeads($a) eq {}} {
9685 recalcarc $a
9689 foreach id [lsort -unique $possible_seeds] {
9690 if {$arcnos($id) eq {}} {
9691 lappend seeds $id
9694 set allcwait 0
9695 } else {
9696 while {[incr a] <= $lim} {
9697 set line [gets $f]
9698 if {[llength $line] != 3} {error "bad line"}
9699 set s [lindex $line 0]
9700 set arcstart($a) $s
9701 lappend arcout($s) $a
9702 if {![info exists arcnos($s)]} {
9703 lappend possible_seeds $s
9704 set arcnos($s) {}
9706 set e [lindex $line 1]
9707 if {$e eq {}} {
9708 set growing($a) 1
9709 } else {
9710 set arcend($a) $e
9711 if {![info exists arcout($e)]} {
9712 set arcout($e) {}
9715 set arcids($a) [lindex $line 2]
9716 foreach id $arcids($a) {
9717 lappend allparents($s) $id
9718 set s $id
9719 lappend arcnos($id) $a
9721 if {![info exists allparents($s)]} {
9722 set allparents($s) {}
9724 set arctags($a) {}
9725 set archeads($a) {}
9727 set nextarc [expr {$a - 1}]
9729 } err]} {
9730 dropcache $err
9731 return 0
9733 if {!$allcwait} {
9734 getallcommits
9736 return $allcwait
9739 proc getcache {f} {
9740 global nextarc cachedarcs possible_seeds
9742 if {[catch {
9743 set line [gets $f]
9744 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9745 # make sure it's an integer
9746 set cachedarcs [expr {int([lindex $line 1])}]
9747 if {$cachedarcs < 0} {error "bad number of arcs"}
9748 set nextarc 0
9749 set possible_seeds {}
9750 run readcache $f
9751 } err]} {
9752 dropcache $err
9754 return 0
9757 proc dropcache {err} {
9758 global allcwait nextarc cachedarcs seeds
9760 #puts "dropping cache ($err)"
9761 foreach v {arcnos arcout arcids arcstart arcend growing \
9762 arctags archeads allparents allchildren} {
9763 global $v
9764 catch {unset $v}
9766 set allcwait 0
9767 set nextarc 0
9768 set cachedarcs 0
9769 set seeds {}
9770 getallcommits
9773 proc writecache {f} {
9774 global cachearc cachedarcs allccache
9775 global arcstart arcend arcnos arcids arcout
9777 set a $cachearc
9778 set lim $cachedarcs
9779 if {$lim - $a > 1000} {
9780 set lim [expr {$a + 1000}]
9782 if {[catch {
9783 while {[incr a] <= $lim} {
9784 if {[info exists arcend($a)]} {
9785 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9786 } else {
9787 puts $f [list $arcstart($a) {} $arcids($a)]
9790 } err]} {
9791 catch {close $f}
9792 catch {file delete $allccache}
9793 #puts "writing cache failed ($err)"
9794 return 0
9796 set cachearc [expr {$a - 1}]
9797 if {$a > $cachedarcs} {
9798 puts $f "1"
9799 close $f
9800 return 0
9802 return 1
9805 proc savecache {} {
9806 global nextarc cachedarcs cachearc allccache
9808 if {$nextarc == $cachedarcs} return
9809 set cachearc 0
9810 set cachedarcs $nextarc
9811 catch {
9812 set f [open $allccache w]
9813 puts $f [list 1 $cachedarcs]
9814 run writecache $f
9818 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9819 # or 0 if neither is true.
9820 proc anc_or_desc {a b} {
9821 global arcout arcstart arcend arcnos cached_isanc
9823 if {$arcnos($a) eq $arcnos($b)} {
9824 # Both are on the same arc(s); either both are the same BMP,
9825 # or if one is not a BMP, the other is also not a BMP or is
9826 # the BMP at end of the arc (and it only has 1 incoming arc).
9827 # Or both can be BMPs with no incoming arcs.
9828 if {$a eq $b || $arcnos($a) eq {}} {
9829 return 0
9831 # assert {[llength $arcnos($a)] == 1}
9832 set arc [lindex $arcnos($a) 0]
9833 set i [lsearch -exact $arcids($arc) $a]
9834 set j [lsearch -exact $arcids($arc) $b]
9835 if {$i < 0 || $i > $j} {
9836 return 1
9837 } else {
9838 return -1
9842 if {![info exists arcout($a)]} {
9843 set arc [lindex $arcnos($a) 0]
9844 if {[info exists arcend($arc)]} {
9845 set aend $arcend($arc)
9846 } else {
9847 set aend {}
9849 set a $arcstart($arc)
9850 } else {
9851 set aend $a
9853 if {![info exists arcout($b)]} {
9854 set arc [lindex $arcnos($b) 0]
9855 if {[info exists arcend($arc)]} {
9856 set bend $arcend($arc)
9857 } else {
9858 set bend {}
9860 set b $arcstart($arc)
9861 } else {
9862 set bend $b
9864 if {$a eq $bend} {
9865 return 1
9867 if {$b eq $aend} {
9868 return -1
9870 if {[info exists cached_isanc($a,$bend)]} {
9871 if {$cached_isanc($a,$bend)} {
9872 return 1
9875 if {[info exists cached_isanc($b,$aend)]} {
9876 if {$cached_isanc($b,$aend)} {
9877 return -1
9879 if {[info exists cached_isanc($a,$bend)]} {
9880 return 0
9884 set todo [list $a $b]
9885 set anc($a) a
9886 set anc($b) b
9887 for {set i 0} {$i < [llength $todo]} {incr i} {
9888 set x [lindex $todo $i]
9889 if {$anc($x) eq {}} {
9890 continue
9892 foreach arc $arcnos($x) {
9893 set xd $arcstart($arc)
9894 if {$xd eq $bend} {
9895 set cached_isanc($a,$bend) 1
9896 set cached_isanc($b,$aend) 0
9897 return 1
9898 } elseif {$xd eq $aend} {
9899 set cached_isanc($b,$aend) 1
9900 set cached_isanc($a,$bend) 0
9901 return -1
9903 if {![info exists anc($xd)]} {
9904 set anc($xd) $anc($x)
9905 lappend todo $xd
9906 } elseif {$anc($xd) ne $anc($x)} {
9907 set anc($xd) {}
9911 set cached_isanc($a,$bend) 0
9912 set cached_isanc($b,$aend) 0
9913 return 0
9916 # This identifies whether $desc has an ancestor that is
9917 # a growing tip of the graph and which is not an ancestor of $anc
9918 # and returns 0 if so and 1 if not.
9919 # If we subsequently discover a tag on such a growing tip, and that
9920 # turns out to be a descendent of $anc (which it could, since we
9921 # don't necessarily see children before parents), then $desc
9922 # isn't a good choice to display as a descendent tag of
9923 # $anc (since it is the descendent of another tag which is
9924 # a descendent of $anc). Similarly, $anc isn't a good choice to
9925 # display as a ancestor tag of $desc.
9927 proc is_certain {desc anc} {
9928 global arcnos arcout arcstart arcend growing problems
9930 set certain {}
9931 if {[llength $arcnos($anc)] == 1} {
9932 # tags on the same arc are certain
9933 if {$arcnos($desc) eq $arcnos($anc)} {
9934 return 1
9936 if {![info exists arcout($anc)]} {
9937 # if $anc is partway along an arc, use the start of the arc instead
9938 set a [lindex $arcnos($anc) 0]
9939 set anc $arcstart($a)
9942 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9943 set x $desc
9944 } else {
9945 set a [lindex $arcnos($desc) 0]
9946 set x $arcend($a)
9948 if {$x == $anc} {
9949 return 1
9951 set anclist [list $x]
9952 set dl($x) 1
9953 set nnh 1
9954 set ngrowanc 0
9955 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9956 set x [lindex $anclist $i]
9957 if {$dl($x)} {
9958 incr nnh -1
9960 set done($x) 1
9961 foreach a $arcout($x) {
9962 if {[info exists growing($a)]} {
9963 if {![info exists growanc($x)] && $dl($x)} {
9964 set growanc($x) 1
9965 incr ngrowanc
9967 } else {
9968 set y $arcend($a)
9969 if {[info exists dl($y)]} {
9970 if {$dl($y)} {
9971 if {!$dl($x)} {
9972 set dl($y) 0
9973 if {![info exists done($y)]} {
9974 incr nnh -1
9976 if {[info exists growanc($x)]} {
9977 incr ngrowanc -1
9979 set xl [list $y]
9980 for {set k 0} {$k < [llength $xl]} {incr k} {
9981 set z [lindex $xl $k]
9982 foreach c $arcout($z) {
9983 if {[info exists arcend($c)]} {
9984 set v $arcend($c)
9985 if {[info exists dl($v)] && $dl($v)} {
9986 set dl($v) 0
9987 if {![info exists done($v)]} {
9988 incr nnh -1
9990 if {[info exists growanc($v)]} {
9991 incr ngrowanc -1
9993 lappend xl $v
10000 } elseif {$y eq $anc || !$dl($x)} {
10001 set dl($y) 0
10002 lappend anclist $y
10003 } else {
10004 set dl($y) 1
10005 lappend anclist $y
10006 incr nnh
10011 foreach x [array names growanc] {
10012 if {$dl($x)} {
10013 return 0
10015 return 0
10017 return 1
10020 proc validate_arctags {a} {
10021 global arctags idtags
10023 set i -1
10024 set na $arctags($a)
10025 foreach id $arctags($a) {
10026 incr i
10027 if {![info exists idtags($id)]} {
10028 set na [lreplace $na $i $i]
10029 incr i -1
10032 set arctags($a) $na
10035 proc validate_archeads {a} {
10036 global archeads idheads
10038 set i -1
10039 set na $archeads($a)
10040 foreach id $archeads($a) {
10041 incr i
10042 if {![info exists idheads($id)]} {
10043 set na [lreplace $na $i $i]
10044 incr i -1
10047 set archeads($a) $na
10050 # Return the list of IDs that have tags that are descendents of id,
10051 # ignoring IDs that are descendents of IDs already reported.
10052 proc desctags {id} {
10053 global arcnos arcstart arcids arctags idtags allparents
10054 global growing cached_dtags
10056 if {![info exists allparents($id)]} {
10057 return {}
10059 set t1 [clock clicks -milliseconds]
10060 set argid $id
10061 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10062 # part-way along an arc; check that arc first
10063 set a [lindex $arcnos($id) 0]
10064 if {$arctags($a) ne {}} {
10065 validate_arctags $a
10066 set i [lsearch -exact $arcids($a) $id]
10067 set tid {}
10068 foreach t $arctags($a) {
10069 set j [lsearch -exact $arcids($a) $t]
10070 if {$j >= $i} break
10071 set tid $t
10073 if {$tid ne {}} {
10074 return $tid
10077 set id $arcstart($a)
10078 if {[info exists idtags($id)]} {
10079 return $id
10082 if {[info exists cached_dtags($id)]} {
10083 return $cached_dtags($id)
10086 set origid $id
10087 set todo [list $id]
10088 set queued($id) 1
10089 set nc 1
10090 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10091 set id [lindex $todo $i]
10092 set done($id) 1
10093 set ta [info exists hastaggedancestor($id)]
10094 if {!$ta} {
10095 incr nc -1
10097 # ignore tags on starting node
10098 if {!$ta && $i > 0} {
10099 if {[info exists idtags($id)]} {
10100 set tagloc($id) $id
10101 set ta 1
10102 } elseif {[info exists cached_dtags($id)]} {
10103 set tagloc($id) $cached_dtags($id)
10104 set ta 1
10107 foreach a $arcnos($id) {
10108 set d $arcstart($a)
10109 if {!$ta && $arctags($a) ne {}} {
10110 validate_arctags $a
10111 if {$arctags($a) ne {}} {
10112 lappend tagloc($id) [lindex $arctags($a) end]
10115 if {$ta || $arctags($a) ne {}} {
10116 set tomark [list $d]
10117 for {set j 0} {$j < [llength $tomark]} {incr j} {
10118 set dd [lindex $tomark $j]
10119 if {![info exists hastaggedancestor($dd)]} {
10120 if {[info exists done($dd)]} {
10121 foreach b $arcnos($dd) {
10122 lappend tomark $arcstart($b)
10124 if {[info exists tagloc($dd)]} {
10125 unset tagloc($dd)
10127 } elseif {[info exists queued($dd)]} {
10128 incr nc -1
10130 set hastaggedancestor($dd) 1
10134 if {![info exists queued($d)]} {
10135 lappend todo $d
10136 set queued($d) 1
10137 if {![info exists hastaggedancestor($d)]} {
10138 incr nc
10143 set tags {}
10144 foreach id [array names tagloc] {
10145 if {![info exists hastaggedancestor($id)]} {
10146 foreach t $tagloc($id) {
10147 if {[lsearch -exact $tags $t] < 0} {
10148 lappend tags $t
10153 set t2 [clock clicks -milliseconds]
10154 set loopix $i
10156 # remove tags that are descendents of other tags
10157 for {set i 0} {$i < [llength $tags]} {incr i} {
10158 set a [lindex $tags $i]
10159 for {set j 0} {$j < $i} {incr j} {
10160 set b [lindex $tags $j]
10161 set r [anc_or_desc $a $b]
10162 if {$r == 1} {
10163 set tags [lreplace $tags $j $j]
10164 incr j -1
10165 incr i -1
10166 } elseif {$r == -1} {
10167 set tags [lreplace $tags $i $i]
10168 incr i -1
10169 break
10174 if {[array names growing] ne {}} {
10175 # graph isn't finished, need to check if any tag could get
10176 # eclipsed by another tag coming later. Simply ignore any
10177 # tags that could later get eclipsed.
10178 set ctags {}
10179 foreach t $tags {
10180 if {[is_certain $t $origid]} {
10181 lappend ctags $t
10184 if {$tags eq $ctags} {
10185 set cached_dtags($origid) $tags
10186 } else {
10187 set tags $ctags
10189 } else {
10190 set cached_dtags($origid) $tags
10192 set t3 [clock clicks -milliseconds]
10193 if {0 && $t3 - $t1 >= 100} {
10194 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10195 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10197 return $tags
10200 proc anctags {id} {
10201 global arcnos arcids arcout arcend arctags idtags allparents
10202 global growing cached_atags
10204 if {![info exists allparents($id)]} {
10205 return {}
10207 set t1 [clock clicks -milliseconds]
10208 set argid $id
10209 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10210 # part-way along an arc; check that arc first
10211 set a [lindex $arcnos($id) 0]
10212 if {$arctags($a) ne {}} {
10213 validate_arctags $a
10214 set i [lsearch -exact $arcids($a) $id]
10215 foreach t $arctags($a) {
10216 set j [lsearch -exact $arcids($a) $t]
10217 if {$j > $i} {
10218 return $t
10222 if {![info exists arcend($a)]} {
10223 return {}
10225 set id $arcend($a)
10226 if {[info exists idtags($id)]} {
10227 return $id
10230 if {[info exists cached_atags($id)]} {
10231 return $cached_atags($id)
10234 set origid $id
10235 set todo [list $id]
10236 set queued($id) 1
10237 set taglist {}
10238 set nc 1
10239 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10240 set id [lindex $todo $i]
10241 set done($id) 1
10242 set td [info exists hastaggeddescendent($id)]
10243 if {!$td} {
10244 incr nc -1
10246 # ignore tags on starting node
10247 if {!$td && $i > 0} {
10248 if {[info exists idtags($id)]} {
10249 set tagloc($id) $id
10250 set td 1
10251 } elseif {[info exists cached_atags($id)]} {
10252 set tagloc($id) $cached_atags($id)
10253 set td 1
10256 foreach a $arcout($id) {
10257 if {!$td && $arctags($a) ne {}} {
10258 validate_arctags $a
10259 if {$arctags($a) ne {}} {
10260 lappend tagloc($id) [lindex $arctags($a) 0]
10263 if {![info exists arcend($a)]} continue
10264 set d $arcend($a)
10265 if {$td || $arctags($a) ne {}} {
10266 set tomark [list $d]
10267 for {set j 0} {$j < [llength $tomark]} {incr j} {
10268 set dd [lindex $tomark $j]
10269 if {![info exists hastaggeddescendent($dd)]} {
10270 if {[info exists done($dd)]} {
10271 foreach b $arcout($dd) {
10272 if {[info exists arcend($b)]} {
10273 lappend tomark $arcend($b)
10276 if {[info exists tagloc($dd)]} {
10277 unset tagloc($dd)
10279 } elseif {[info exists queued($dd)]} {
10280 incr nc -1
10282 set hastaggeddescendent($dd) 1
10286 if {![info exists queued($d)]} {
10287 lappend todo $d
10288 set queued($d) 1
10289 if {![info exists hastaggeddescendent($d)]} {
10290 incr nc
10295 set t2 [clock clicks -milliseconds]
10296 set loopix $i
10297 set tags {}
10298 foreach id [array names tagloc] {
10299 if {![info exists hastaggeddescendent($id)]} {
10300 foreach t $tagloc($id) {
10301 if {[lsearch -exact $tags $t] < 0} {
10302 lappend tags $t
10308 # remove tags that are ancestors of other tags
10309 for {set i 0} {$i < [llength $tags]} {incr i} {
10310 set a [lindex $tags $i]
10311 for {set j 0} {$j < $i} {incr j} {
10312 set b [lindex $tags $j]
10313 set r [anc_or_desc $a $b]
10314 if {$r == -1} {
10315 set tags [lreplace $tags $j $j]
10316 incr j -1
10317 incr i -1
10318 } elseif {$r == 1} {
10319 set tags [lreplace $tags $i $i]
10320 incr i -1
10321 break
10326 if {[array names growing] ne {}} {
10327 # graph isn't finished, need to check if any tag could get
10328 # eclipsed by another tag coming later. Simply ignore any
10329 # tags that could later get eclipsed.
10330 set ctags {}
10331 foreach t $tags {
10332 if {[is_certain $origid $t]} {
10333 lappend ctags $t
10336 if {$tags eq $ctags} {
10337 set cached_atags($origid) $tags
10338 } else {
10339 set tags $ctags
10341 } else {
10342 set cached_atags($origid) $tags
10344 set t3 [clock clicks -milliseconds]
10345 if {0 && $t3 - $t1 >= 100} {
10346 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10347 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10349 return $tags
10352 # Return the list of IDs that have heads that are descendents of id,
10353 # including id itself if it has a head.
10354 proc descheads {id} {
10355 global arcnos arcstart arcids archeads idheads cached_dheads
10356 global allparents
10358 if {![info exists allparents($id)]} {
10359 return {}
10361 set aret {}
10362 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10363 # part-way along an arc; check it first
10364 set a [lindex $arcnos($id) 0]
10365 if {$archeads($a) ne {}} {
10366 validate_archeads $a
10367 set i [lsearch -exact $arcids($a) $id]
10368 foreach t $archeads($a) {
10369 set j [lsearch -exact $arcids($a) $t]
10370 if {$j > $i} break
10371 lappend aret $t
10374 set id $arcstart($a)
10376 set origid $id
10377 set todo [list $id]
10378 set seen($id) 1
10379 set ret {}
10380 for {set i 0} {$i < [llength $todo]} {incr i} {
10381 set id [lindex $todo $i]
10382 if {[info exists cached_dheads($id)]} {
10383 set ret [concat $ret $cached_dheads($id)]
10384 } else {
10385 if {[info exists idheads($id)]} {
10386 lappend ret $id
10388 foreach a $arcnos($id) {
10389 if {$archeads($a) ne {}} {
10390 validate_archeads $a
10391 if {$archeads($a) ne {}} {
10392 set ret [concat $ret $archeads($a)]
10395 set d $arcstart($a)
10396 if {![info exists seen($d)]} {
10397 lappend todo $d
10398 set seen($d) 1
10403 set ret [lsort -unique $ret]
10404 set cached_dheads($origid) $ret
10405 return [concat $ret $aret]
10408 proc addedtag {id} {
10409 global arcnos arcout cached_dtags cached_atags
10411 if {![info exists arcnos($id)]} return
10412 if {![info exists arcout($id)]} {
10413 recalcarc [lindex $arcnos($id) 0]
10415 catch {unset cached_dtags}
10416 catch {unset cached_atags}
10419 proc addedhead {hid head} {
10420 global arcnos arcout cached_dheads
10422 if {![info exists arcnos($hid)]} return
10423 if {![info exists arcout($hid)]} {
10424 recalcarc [lindex $arcnos($hid) 0]
10426 catch {unset cached_dheads}
10429 proc removedhead {hid head} {
10430 global cached_dheads
10432 catch {unset cached_dheads}
10435 proc movedhead {hid head} {
10436 global arcnos arcout cached_dheads
10438 if {![info exists arcnos($hid)]} return
10439 if {![info exists arcout($hid)]} {
10440 recalcarc [lindex $arcnos($hid) 0]
10442 catch {unset cached_dheads}
10445 proc changedrefs {} {
10446 global cached_dheads cached_dtags cached_atags
10447 global arctags archeads arcnos arcout idheads idtags
10449 foreach id [concat [array names idheads] [array names idtags]] {
10450 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10451 set a [lindex $arcnos($id) 0]
10452 if {![info exists donearc($a)]} {
10453 recalcarc $a
10454 set donearc($a) 1
10458 catch {unset cached_dtags}
10459 catch {unset cached_atags}
10460 catch {unset cached_dheads}
10463 proc rereadrefs {} {
10464 global idtags idheads idotherrefs mainheadid
10466 set refids [concat [array names idtags] \
10467 [array names idheads] [array names idotherrefs]]
10468 foreach id $refids {
10469 if {![info exists ref($id)]} {
10470 set ref($id) [listrefs $id]
10473 set oldmainhead $mainheadid
10474 readrefs
10475 changedrefs
10476 set refids [lsort -unique [concat $refids [array names idtags] \
10477 [array names idheads] [array names idotherrefs]]]
10478 foreach id $refids {
10479 set v [listrefs $id]
10480 if {![info exists ref($id)] || $ref($id) != $v} {
10481 redrawtags $id
10484 if {$oldmainhead ne $mainheadid} {
10485 redrawtags $oldmainhead
10486 redrawtags $mainheadid
10488 run refill_reflist
10491 proc listrefs {id} {
10492 global idtags idheads idotherrefs
10494 set x {}
10495 if {[info exists idtags($id)]} {
10496 set x $idtags($id)
10498 set y {}
10499 if {[info exists idheads($id)]} {
10500 set y $idheads($id)
10502 set z {}
10503 if {[info exists idotherrefs($id)]} {
10504 set z $idotherrefs($id)
10506 return [list $x $y $z]
10509 proc showtag {tag isnew} {
10510 global ctext tagcontents tagids linknum tagobjid
10512 if {$isnew} {
10513 addtohistory [list showtag $tag 0] savectextpos
10515 $ctext conf -state normal
10516 clear_ctext
10517 settabs 0
10518 set linknum 0
10519 if {![info exists tagcontents($tag)]} {
10520 catch {
10521 set tagcontents($tag) [exec git cat-file tag $tag]
10524 if {[info exists tagcontents($tag)]} {
10525 set text $tagcontents($tag)
10526 } else {
10527 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10529 appendwithlinks $text {}
10530 maybe_scroll_ctext 1
10531 $ctext conf -state disabled
10532 init_flist {}
10535 proc doquit {} {
10536 global stopped
10537 global gitktmpdir
10539 set stopped 100
10540 savestuff .
10541 destroy .
10543 if {[info exists gitktmpdir]} {
10544 catch {file delete -force $gitktmpdir}
10548 proc mkfontdisp {font top which} {
10549 global fontattr fontpref $font NS use_ttk
10551 set fontpref($font) [set $font]
10552 ${NS}::button $top.${font}but -text $which \
10553 -command [list choosefont $font $which]
10554 ${NS}::label $top.$font -relief flat -font $font \
10555 -text $fontattr($font,family) -justify left
10556 grid x $top.${font}but $top.$font -sticky w
10559 proc choosefont {font which} {
10560 global fontparam fontlist fonttop fontattr
10561 global prefstop NS
10563 set fontparam(which) $which
10564 set fontparam(font) $font
10565 set fontparam(family) [font actual $font -family]
10566 set fontparam(size) $fontattr($font,size)
10567 set fontparam(weight) $fontattr($font,weight)
10568 set fontparam(slant) $fontattr($font,slant)
10569 set top .gitkfont
10570 set fonttop $top
10571 if {![winfo exists $top]} {
10572 font create sample
10573 eval font config sample [font actual $font]
10574 ttk_toplevel $top
10575 make_transient $top $prefstop
10576 wm title $top [mc "Gitk font chooser"]
10577 ${NS}::label $top.l -textvariable fontparam(which)
10578 pack $top.l -side top
10579 set fontlist [lsort [font families]]
10580 ${NS}::frame $top.f
10581 listbox $top.f.fam -listvariable fontlist \
10582 -yscrollcommand [list $top.f.sb set]
10583 bind $top.f.fam <<ListboxSelect>> selfontfam
10584 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10585 pack $top.f.sb -side right -fill y
10586 pack $top.f.fam -side left -fill both -expand 1
10587 pack $top.f -side top -fill both -expand 1
10588 ${NS}::frame $top.g
10589 spinbox $top.g.size -from 4 -to 40 -width 4 \
10590 -textvariable fontparam(size) \
10591 -validatecommand {string is integer -strict %s}
10592 checkbutton $top.g.bold -padx 5 \
10593 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10594 -variable fontparam(weight) -onvalue bold -offvalue normal
10595 checkbutton $top.g.ital -padx 5 \
10596 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10597 -variable fontparam(slant) -onvalue italic -offvalue roman
10598 pack $top.g.size $top.g.bold $top.g.ital -side left
10599 pack $top.g -side top
10600 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10601 -background white
10602 $top.c create text 100 25 -anchor center -text $which -font sample \
10603 -fill black -tags text
10604 bind $top.c <Configure> [list centertext $top.c]
10605 pack $top.c -side top -fill x
10606 ${NS}::frame $top.buts
10607 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10608 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10609 bind $top <Key-Return> fontok
10610 bind $top <Key-Escape> fontcan
10611 grid $top.buts.ok $top.buts.can
10612 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10613 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10614 pack $top.buts -side bottom -fill x
10615 trace add variable fontparam write chg_fontparam
10616 } else {
10617 raise $top
10618 $top.c itemconf text -text $which
10620 set i [lsearch -exact $fontlist $fontparam(family)]
10621 if {$i >= 0} {
10622 $top.f.fam selection set $i
10623 $top.f.fam see $i
10627 proc centertext {w} {
10628 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10631 proc fontok {} {
10632 global fontparam fontpref prefstop
10634 set f $fontparam(font)
10635 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10636 if {$fontparam(weight) eq "bold"} {
10637 lappend fontpref($f) "bold"
10639 if {$fontparam(slant) eq "italic"} {
10640 lappend fontpref($f) "italic"
10642 set w $prefstop.$f
10643 $w conf -text $fontparam(family) -font $fontpref($f)
10645 fontcan
10648 proc fontcan {} {
10649 global fonttop fontparam
10651 if {[info exists fonttop]} {
10652 catch {destroy $fonttop}
10653 catch {font delete sample}
10654 unset fonttop
10655 unset fontparam
10659 if {[package vsatisfies [package provide Tk] 8.6]} {
10660 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10661 # function to make use of it.
10662 proc choosefont {font which} {
10663 tk fontchooser configure -title $which -font $font \
10664 -command [list on_choosefont $font $which]
10665 tk fontchooser show
10667 proc on_choosefont {font which newfont} {
10668 global fontparam
10669 puts stderr "$font $newfont"
10670 array set f [font actual $newfont]
10671 set fontparam(which) $which
10672 set fontparam(font) $font
10673 set fontparam(family) $f(-family)
10674 set fontparam(size) $f(-size)
10675 set fontparam(weight) $f(-weight)
10676 set fontparam(slant) $f(-slant)
10677 fontok
10681 proc selfontfam {} {
10682 global fonttop fontparam
10684 set i [$fonttop.f.fam curselection]
10685 if {$i ne {}} {
10686 set fontparam(family) [$fonttop.f.fam get $i]
10690 proc chg_fontparam {v sub op} {
10691 global fontparam
10693 font config sample -$sub $fontparam($sub)
10696 proc doprefs {} {
10697 global maxwidth maxgraphpct use_ttk NS
10698 global oldprefs prefstop showneartags showlocalchanges
10699 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10700 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10701 global hideremotes want_ttk have_ttk
10703 set top .gitkprefs
10704 set prefstop $top
10705 if {[winfo exists $top]} {
10706 raise $top
10707 return
10709 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10710 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10711 set oldprefs($v) [set $v]
10713 ttk_toplevel $top
10714 wm title $top [mc "Gitk preferences"]
10715 make_transient $top .
10716 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10717 grid $top.ldisp - -sticky w -pady 10
10718 ${NS}::label $top.spacer -text " "
10719 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10720 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10721 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10722 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10723 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10724 grid x $top.maxpctl $top.maxpct -sticky w
10725 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10726 -variable showlocalchanges
10727 grid x $top.showlocal -sticky w
10728 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10729 -variable autoselect
10730 grid x $top.autoselect -sticky w
10731 ${NS}::checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10732 -variable hideremotes
10733 grid x $top.hideremotes -sticky w
10735 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10736 grid $top.ddisp - -sticky w -pady 10
10737 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10738 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10739 grid x $top.tabstopl $top.tabstop -sticky w
10740 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10741 -variable showneartags
10742 grid x $top.ntag -sticky w
10743 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10744 -variable limitdiffs
10745 grid x $top.ldiff -sticky w
10746 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10747 -variable perfile_attrs
10748 grid x $top.lattr -sticky w
10750 ${NS}::entry $top.extdifft -textvariable extdifftool
10751 ${NS}::frame $top.extdifff
10752 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10753 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10754 pack $top.extdifff.l $top.extdifff.b -side left
10755 pack configure $top.extdifff.l -padx 10
10756 grid x $top.extdifff $top.extdifft -sticky ew
10758 ${NS}::label $top.lgen -text [mc "General options"]
10759 grid $top.lgen - -sticky w -pady 10
10760 ${NS}::checkbutton $top.want_ttk -variable want_ttk \
10761 -text [mc "Use themed widgets"]
10762 if {$have_ttk} {
10763 ${NS}::label $top.ttk_note -text [mc "(change requires restart)"]
10764 } else {
10765 ${NS}::label $top.ttk_note -text [mc "(currently unavailable)"]
10767 grid x $top.want_ttk $top.ttk_note -sticky w
10769 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10770 grid $top.cdisp - -sticky w -pady 10
10771 label $top.ui -padx 40 -relief sunk -background $uicolor
10772 ${NS}::button $top.uibut -text [mc "Interface"] \
10773 -command [list choosecolor uicolor {} $top.ui [mc "interface"] setui]
10774 grid x $top.uibut $top.ui -sticky w
10775 label $top.bg -padx 40 -relief sunk -background $bgcolor
10776 ${NS}::button $top.bgbut -text [mc "Background"] \
10777 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10778 grid x $top.bgbut $top.bg -sticky w
10779 label $top.fg -padx 40 -relief sunk -background $fgcolor
10780 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10781 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10782 grid x $top.fgbut $top.fg -sticky w
10783 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10784 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10785 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10786 [list $ctext tag conf d0 -foreground]]
10787 grid x $top.diffoldbut $top.diffold -sticky w
10788 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10789 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10790 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10791 [list $ctext tag conf dresult -foreground]]
10792 grid x $top.diffnewbut $top.diffnew -sticky w
10793 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10794 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10795 -command [list choosecolor diffcolors 2 $top.hunksep \
10796 [mc "diff hunk header"] \
10797 [list $ctext tag conf hunksep -foreground]]
10798 grid x $top.hunksepbut $top.hunksep -sticky w
10799 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10800 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10801 -command [list choosecolor markbgcolor {} $top.markbgsep \
10802 [mc "marked line background"] \
10803 [list $ctext tag conf omark -background]]
10804 grid x $top.markbgbut $top.markbgsep -sticky w
10805 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10806 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10807 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10808 grid x $top.selbgbut $top.selbgsep -sticky w
10810 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10811 grid $top.cfont - -sticky w -pady 10
10812 mkfontdisp mainfont $top [mc "Main font"]
10813 mkfontdisp textfont $top [mc "Diff display font"]
10814 mkfontdisp uifont $top [mc "User interface font"]
10816 ${NS}::frame $top.buts
10817 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10818 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10819 bind $top <Key-Return> prefsok
10820 bind $top <Key-Escape> prefscan
10821 grid $top.buts.ok $top.buts.can
10822 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10823 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10824 grid $top.buts - - -pady 10 -sticky ew
10825 grid columnconfigure $top 2 -weight 1
10826 bind $top <Visibility> "focus $top.buts.ok"
10829 proc choose_extdiff {} {
10830 global extdifftool
10832 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10833 if {$prog ne {}} {
10834 set extdifftool $prog
10838 proc choosecolor {v vi w x cmd} {
10839 global $v
10841 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10842 -title [mc "Gitk: choose color for %s" $x]]
10843 if {$c eq {}} return
10844 $w conf -background $c
10845 lset $v $vi $c
10846 eval $cmd $c
10849 proc setselbg {c} {
10850 global bglist cflist
10851 foreach w $bglist {
10852 $w configure -selectbackground $c
10854 $cflist tag configure highlight \
10855 -background [$cflist cget -selectbackground]
10856 allcanvs itemconf secsel -fill $c
10859 # This sets the background color and the color scheme for the whole UI.
10860 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
10861 # if we don't specify one ourselves, which makes the checkbuttons and
10862 # radiobuttons look bad. This chooses white for selectColor if the
10863 # background color is light, or black if it is dark.
10864 proc setui {c} {
10865 if {[tk windowingsystem] eq "win32"} { return }
10866 set bg [winfo rgb . $c]
10867 set selc black
10868 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
10869 set selc white
10871 tk_setPalette background $c selectColor $selc
10874 proc setbg {c} {
10875 global bglist
10877 foreach w $bglist {
10878 $w conf -background $c
10882 proc setfg {c} {
10883 global fglist canv
10885 foreach w $fglist {
10886 $w conf -foreground $c
10888 allcanvs itemconf text -fill $c
10889 $canv itemconf circle -outline $c
10890 $canv itemconf markid -outline $c
10893 proc prefscan {} {
10894 global oldprefs prefstop
10896 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10897 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10898 global $v
10899 set $v $oldprefs($v)
10901 catch {destroy $prefstop}
10902 unset prefstop
10903 fontcan
10906 proc prefsok {} {
10907 global maxwidth maxgraphpct
10908 global oldprefs prefstop showneartags showlocalchanges
10909 global fontpref mainfont textfont uifont
10910 global limitdiffs treediffs perfile_attrs
10911 global hideremotes
10913 catch {destroy $prefstop}
10914 unset prefstop
10915 fontcan
10916 set fontchanged 0
10917 if {$mainfont ne $fontpref(mainfont)} {
10918 set mainfont $fontpref(mainfont)
10919 parsefont mainfont $mainfont
10920 eval font configure mainfont [fontflags mainfont]
10921 eval font configure mainfontbold [fontflags mainfont 1]
10922 setcoords
10923 set fontchanged 1
10925 if {$textfont ne $fontpref(textfont)} {
10926 set textfont $fontpref(textfont)
10927 parsefont textfont $textfont
10928 eval font configure textfont [fontflags textfont]
10929 eval font configure textfontbold [fontflags textfont 1]
10931 if {$uifont ne $fontpref(uifont)} {
10932 set uifont $fontpref(uifont)
10933 parsefont uifont $uifont
10934 eval font configure uifont [fontflags uifont]
10936 settabs
10937 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10938 if {$showlocalchanges} {
10939 doshowlocalchanges
10940 } else {
10941 dohidelocalchanges
10944 if {$limitdiffs != $oldprefs(limitdiffs) ||
10945 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10946 # treediffs elements are limited by path;
10947 # won't have encodings cached if perfile_attrs was just turned on
10948 catch {unset treediffs}
10950 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10951 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10952 redisplay
10953 } elseif {$showneartags != $oldprefs(showneartags) ||
10954 $limitdiffs != $oldprefs(limitdiffs)} {
10955 reselectline
10957 if {$hideremotes != $oldprefs(hideremotes)} {
10958 rereadrefs
10962 proc formatdate {d} {
10963 global datetimeformat
10964 if {$d ne {}} {
10965 set d [clock format $d -format $datetimeformat]
10967 return $d
10970 # This list of encoding names and aliases is distilled from
10971 # http://www.iana.org/assignments/character-sets.
10972 # Not all of them are supported by Tcl.
10973 set encoding_aliases {
10974 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10975 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10976 { ISO-10646-UTF-1 csISO10646UTF1 }
10977 { ISO_646.basic:1983 ref csISO646basic1983 }
10978 { INVARIANT csINVARIANT }
10979 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10980 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10981 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10982 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10983 { NATS-DANO iso-ir-9-1 csNATSDANO }
10984 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10985 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10986 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10987 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10988 { ISO-2022-KR csISO2022KR }
10989 { EUC-KR csEUCKR }
10990 { ISO-2022-JP csISO2022JP }
10991 { ISO-2022-JP-2 csISO2022JP2 }
10992 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10993 csISO13JISC6220jp }
10994 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10995 { IT iso-ir-15 ISO646-IT csISO15Italian }
10996 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10997 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10998 { greek7-old iso-ir-18 csISO18Greek7Old }
10999 { latin-greek iso-ir-19 csISO19LatinGreek }
11000 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11001 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11002 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11003 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11004 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11005 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11006 { INIS iso-ir-49 csISO49INIS }
11007 { INIS-8 iso-ir-50 csISO50INIS8 }
11008 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11009 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11010 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11011 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11012 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11013 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11014 csISO60Norwegian1 }
11015 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11016 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11017 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11018 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11019 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11020 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11021 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11022 { greek7 iso-ir-88 csISO88Greek7 }
11023 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11024 { iso-ir-90 csISO90 }
11025 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11026 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11027 csISO92JISC62991984b }
11028 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11029 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11030 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11031 csISO95JIS62291984handadd }
11032 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11033 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11034 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11035 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11036 CP819 csISOLatin1 }
11037 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11038 { T.61-7bit iso-ir-102 csISO102T617bit }
11039 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11040 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11041 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11042 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11043 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11044 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11045 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11046 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11047 arabic csISOLatinArabic }
11048 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11049 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11050 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11051 greek greek8 csISOLatinGreek }
11052 { T.101-G2 iso-ir-128 csISO128T101G2 }
11053 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11054 csISOLatinHebrew }
11055 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11056 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11057 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11058 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11059 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11060 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11061 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11062 csISOLatinCyrillic }
11063 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11064 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11065 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11066 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11067 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11068 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11069 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11070 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11071 { ISO_10367-box iso-ir-155 csISO10367Box }
11072 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11073 { latin-lap lap iso-ir-158 csISO158Lap }
11074 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11075 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11076 { us-dk csUSDK }
11077 { dk-us csDKUS }
11078 { JIS_X0201 X0201 csHalfWidthKatakana }
11079 { KSC5636 ISO646-KR csKSC5636 }
11080 { ISO-10646-UCS-2 csUnicode }
11081 { ISO-10646-UCS-4 csUCS4 }
11082 { DEC-MCS dec csDECMCS }
11083 { hp-roman8 roman8 r8 csHPRoman8 }
11084 { macintosh mac csMacintosh }
11085 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11086 csIBM037 }
11087 { IBM038 EBCDIC-INT cp038 csIBM038 }
11088 { IBM273 CP273 csIBM273 }
11089 { IBM274 EBCDIC-BE CP274 csIBM274 }
11090 { IBM275 EBCDIC-BR cp275 csIBM275 }
11091 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11092 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11093 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11094 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11095 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11096 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11097 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11098 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11099 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11100 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11101 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11102 { IBM437 cp437 437 csPC8CodePage437 }
11103 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11104 { IBM775 cp775 csPC775Baltic }
11105 { IBM850 cp850 850 csPC850Multilingual }
11106 { IBM851 cp851 851 csIBM851 }
11107 { IBM852 cp852 852 csPCp852 }
11108 { IBM855 cp855 855 csIBM855 }
11109 { IBM857 cp857 857 csIBM857 }
11110 { IBM860 cp860 860 csIBM860 }
11111 { IBM861 cp861 861 cp-is csIBM861 }
11112 { IBM862 cp862 862 csPC862LatinHebrew }
11113 { IBM863 cp863 863 csIBM863 }
11114 { IBM864 cp864 csIBM864 }
11115 { IBM865 cp865 865 csIBM865 }
11116 { IBM866 cp866 866 csIBM866 }
11117 { IBM868 CP868 cp-ar csIBM868 }
11118 { IBM869 cp869 869 cp-gr csIBM869 }
11119 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11120 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11121 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11122 { IBM891 cp891 csIBM891 }
11123 { IBM903 cp903 csIBM903 }
11124 { IBM904 cp904 904 csIBBM904 }
11125 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11126 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11127 { IBM1026 CP1026 csIBM1026 }
11128 { EBCDIC-AT-DE csIBMEBCDICATDE }
11129 { EBCDIC-AT-DE-A csEBCDICATDEA }
11130 { EBCDIC-CA-FR csEBCDICCAFR }
11131 { EBCDIC-DK-NO csEBCDICDKNO }
11132 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11133 { EBCDIC-FI-SE csEBCDICFISE }
11134 { EBCDIC-FI-SE-A csEBCDICFISEA }
11135 { EBCDIC-FR csEBCDICFR }
11136 { EBCDIC-IT csEBCDICIT }
11137 { EBCDIC-PT csEBCDICPT }
11138 { EBCDIC-ES csEBCDICES }
11139 { EBCDIC-ES-A csEBCDICESA }
11140 { EBCDIC-ES-S csEBCDICESS }
11141 { EBCDIC-UK csEBCDICUK }
11142 { EBCDIC-US csEBCDICUS }
11143 { UNKNOWN-8BIT csUnknown8BiT }
11144 { MNEMONIC csMnemonic }
11145 { MNEM csMnem }
11146 { VISCII csVISCII }
11147 { VIQR csVIQR }
11148 { KOI8-R csKOI8R }
11149 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11150 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11151 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11152 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11153 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11154 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11155 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11156 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11157 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11158 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11159 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11160 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11161 { IBM1047 IBM-1047 }
11162 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11163 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11164 { UNICODE-1-1 csUnicode11 }
11165 { CESU-8 csCESU-8 }
11166 { BOCU-1 csBOCU-1 }
11167 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11168 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11169 l8 }
11170 { ISO-8859-15 ISO_8859-15 Latin-9 }
11171 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11172 { GBK CP936 MS936 windows-936 }
11173 { JIS_Encoding csJISEncoding }
11174 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11175 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11176 EUC-JP }
11177 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11178 { ISO-10646-UCS-Basic csUnicodeASCII }
11179 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11180 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11181 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11182 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11183 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11184 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11185 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11186 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11187 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11188 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11189 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11190 { Ventura-US csVenturaUS }
11191 { Ventura-International csVenturaInternational }
11192 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11193 { PC8-Turkish csPC8Turkish }
11194 { IBM-Symbols csIBMSymbols }
11195 { IBM-Thai csIBMThai }
11196 { HP-Legal csHPLegal }
11197 { HP-Pi-font csHPPiFont }
11198 { HP-Math8 csHPMath8 }
11199 { Adobe-Symbol-Encoding csHPPSMath }
11200 { HP-DeskTop csHPDesktop }
11201 { Ventura-Math csVenturaMath }
11202 { Microsoft-Publishing csMicrosoftPublishing }
11203 { Windows-31J csWindows31J }
11204 { GB2312 csGB2312 }
11205 { Big5 csBig5 }
11208 proc tcl_encoding {enc} {
11209 global encoding_aliases tcl_encoding_cache
11210 if {[info exists tcl_encoding_cache($enc)]} {
11211 return $tcl_encoding_cache($enc)
11213 set names [encoding names]
11214 set lcnames [string tolower $names]
11215 set enc [string tolower $enc]
11216 set i [lsearch -exact $lcnames $enc]
11217 if {$i < 0} {
11218 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11219 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11220 set i [lsearch -exact $lcnames $encx]
11223 if {$i < 0} {
11224 foreach l $encoding_aliases {
11225 set ll [string tolower $l]
11226 if {[lsearch -exact $ll $enc] < 0} continue
11227 # look through the aliases for one that tcl knows about
11228 foreach e $ll {
11229 set i [lsearch -exact $lcnames $e]
11230 if {$i < 0} {
11231 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11232 set i [lsearch -exact $lcnames $ex]
11235 if {$i >= 0} break
11237 break
11240 set tclenc {}
11241 if {$i >= 0} {
11242 set tclenc [lindex $names $i]
11244 set tcl_encoding_cache($enc) $tclenc
11245 return $tclenc
11248 proc gitattr {path attr default} {
11249 global path_attr_cache
11250 if {[info exists path_attr_cache($attr,$path)]} {
11251 set r $path_attr_cache($attr,$path)
11252 } else {
11253 set r "unspecified"
11254 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11255 regexp "(.*): $attr: (.*)" $line m f r
11257 set path_attr_cache($attr,$path) $r
11259 if {$r eq "unspecified"} {
11260 return $default
11262 return $r
11265 proc cache_gitattr {attr pathlist} {
11266 global path_attr_cache
11267 set newlist {}
11268 foreach path $pathlist {
11269 if {![info exists path_attr_cache($attr,$path)]} {
11270 lappend newlist $path
11273 set lim 1000
11274 if {[tk windowingsystem] == "win32"} {
11275 # windows has a 32k limit on the arguments to a command...
11276 set lim 30
11278 while {$newlist ne {}} {
11279 set head [lrange $newlist 0 [expr {$lim - 1}]]
11280 set newlist [lrange $newlist $lim end]
11281 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11282 foreach row [split $rlist "\n"] {
11283 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11284 if {[string index $path 0] eq "\""} {
11285 set path [encoding convertfrom [lindex $path 0]]
11287 set path_attr_cache($attr,$path) $value
11294 proc get_path_encoding {path} {
11295 global gui_encoding perfile_attrs
11296 set tcl_enc $gui_encoding
11297 if {$path ne {} && $perfile_attrs} {
11298 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11299 if {$enc2 ne {}} {
11300 set tcl_enc $enc2
11303 return $tcl_enc
11306 # First check that Tcl/Tk is recent enough
11307 if {[catch {package require Tk 8.4} err]} {
11308 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11309 Gitk requires at least Tcl/Tk 8.4." list
11310 exit 1
11313 # defaults...
11314 set wrcomcmd "git diff-tree --stdin -p --pretty"
11316 set gitencoding {}
11317 catch {
11318 set gitencoding [exec git config --get i18n.commitencoding]
11320 catch {
11321 set gitencoding [exec git config --get i18n.logoutputencoding]
11323 if {$gitencoding == ""} {
11324 set gitencoding "utf-8"
11326 set tclencoding [tcl_encoding $gitencoding]
11327 if {$tclencoding == {}} {
11328 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11331 set gui_encoding [encoding system]
11332 catch {
11333 set enc [exec git config --get gui.encoding]
11334 if {$enc ne {}} {
11335 set tclenc [tcl_encoding $enc]
11336 if {$tclenc ne {}} {
11337 set gui_encoding $tclenc
11338 } else {
11339 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11344 if {[tk windowingsystem] eq "aqua"} {
11345 set mainfont {{Lucida Grande} 9}
11346 set textfont {Monaco 9}
11347 set uifont {{Lucida Grande} 9 bold}
11348 } else {
11349 set mainfont {Helvetica 9}
11350 set textfont {Courier 9}
11351 set uifont {Helvetica 9 bold}
11353 set tabstop 8
11354 set findmergefiles 0
11355 set maxgraphpct 50
11356 set maxwidth 16
11357 set revlistorder 0
11358 set fastdate 0
11359 set uparrowlen 5
11360 set downarrowlen 5
11361 set mingaplen 100
11362 set cmitmode "patch"
11363 set wrapcomment "none"
11364 set showneartags 1
11365 set hideremotes 0
11366 set maxrefs 20
11367 set maxlinelen 200
11368 set showlocalchanges 1
11369 set limitdiffs 1
11370 set datetimeformat "%Y-%m-%d %H:%M:%S"
11371 set autoselect 1
11372 set perfile_attrs 0
11373 set want_ttk 1
11375 if {[tk windowingsystem] eq "aqua"} {
11376 set extdifftool "opendiff"
11377 } else {
11378 set extdifftool "meld"
11381 set colors {green red blue magenta darkgrey brown orange}
11382 if {[tk windowingsystem] eq "win32"} {
11383 set uicolor SystemButtonFace
11384 set bgcolor SystemWindow
11385 set fgcolor SystemButtonText
11386 set selectbgcolor SystemHighlight
11387 } else {
11388 set uicolor grey85
11389 set bgcolor white
11390 set fgcolor black
11391 set selectbgcolor gray85
11393 set diffcolors {red "#00a000" blue}
11394 set diffcontext 3
11395 set ignorespace 0
11396 set markbgcolor "#e0e0ff"
11398 set circlecolors {white blue gray blue blue}
11400 # button for popping up context menus
11401 if {[tk windowingsystem] eq "aqua"} {
11402 set ctxbut <Button-2>
11403 } else {
11404 set ctxbut <Button-3>
11407 ## For msgcat loading, first locate the installation location.
11408 if { [info exists ::env(GITK_MSGSDIR)] } {
11409 ## Msgsdir was manually set in the environment.
11410 set gitk_msgsdir $::env(GITK_MSGSDIR)
11411 } else {
11412 ## Let's guess the prefix from argv0.
11413 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11414 set gitk_libdir [file join $gitk_prefix share gitk lib]
11415 set gitk_msgsdir [file join $gitk_libdir msgs]
11416 unset gitk_prefix
11419 ## Internationalization (i18n) through msgcat and gettext. See
11420 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11421 package require msgcat
11422 namespace import ::msgcat::mc
11423 ## And eventually load the actual message catalog
11424 ::msgcat::mcload $gitk_msgsdir
11426 catch {source ~/.gitk}
11428 parsefont mainfont $mainfont
11429 eval font create mainfont [fontflags mainfont]
11430 eval font create mainfontbold [fontflags mainfont 1]
11432 parsefont textfont $textfont
11433 eval font create textfont [fontflags textfont]
11434 eval font create textfontbold [fontflags textfont 1]
11436 parsefont uifont $uifont
11437 eval font create uifont [fontflags uifont]
11439 setui $uicolor
11441 setoptions
11443 # check that we can find a .git directory somewhere...
11444 if {[catch {set gitdir [gitdir]}]} {
11445 show_error {} . [mc "Cannot find a git repository here."]
11446 exit 1
11448 if {![file isdirectory $gitdir]} {
11449 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11450 exit 1
11453 set selecthead {}
11454 set selectheadid {}
11456 set revtreeargs {}
11457 set cmdline_files {}
11458 set i 0
11459 set revtreeargscmd {}
11460 foreach arg $argv {
11461 switch -glob -- $arg {
11462 "" { }
11463 "--" {
11464 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11465 break
11467 "--select-commit=*" {
11468 set selecthead [string range $arg 16 end]
11470 "--argscmd=*" {
11471 set revtreeargscmd [string range $arg 10 end]
11473 default {
11474 lappend revtreeargs $arg
11477 incr i
11480 if {$selecthead eq "HEAD"} {
11481 set selecthead {}
11484 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11485 # no -- on command line, but some arguments (other than --argscmd)
11486 if {[catch {
11487 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11488 set cmdline_files [split $f "\n"]
11489 set n [llength $cmdline_files]
11490 set revtreeargs [lrange $revtreeargs 0 end-$n]
11491 # Unfortunately git rev-parse doesn't produce an error when
11492 # something is both a revision and a filename. To be consistent
11493 # with git log and git rev-list, check revtreeargs for filenames.
11494 foreach arg $revtreeargs {
11495 if {[file exists $arg]} {
11496 show_error {} . [mc "Ambiguous argument '%s': both revision\
11497 and filename" $arg]
11498 exit 1
11501 } err]} {
11502 # unfortunately we get both stdout and stderr in $err,
11503 # so look for "fatal:".
11504 set i [string first "fatal:" $err]
11505 if {$i > 0} {
11506 set err [string range $err [expr {$i + 6}] end]
11508 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11509 exit 1
11513 set nullid "0000000000000000000000000000000000000000"
11514 set nullid2 "0000000000000000000000000000000000000001"
11515 set nullfile "/dev/null"
11517 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11518 if {![info exists have_ttk]} {
11519 set have_ttk [llength [info commands ::ttk::style]]
11521 set use_ttk [expr {$have_ttk && $want_ttk}]
11522 set NS [expr {$use_ttk ? "ttk" : ""}]
11524 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11526 set show_notes {}
11527 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
11528 set show_notes "--show-notes"
11531 set runq {}
11532 set history {}
11533 set historyindex 0
11534 set fh_serial 0
11535 set nhl_names {}
11536 set highlight_paths {}
11537 set findpattern {}
11538 set searchdirn -forwards
11539 set boldids {}
11540 set boldnameids {}
11541 set diffelide {0 0}
11542 set markingmatches 0
11543 set linkentercount 0
11544 set need_redisplay 0
11545 set nrows_drawn 0
11546 set firsttabstop 0
11548 set nextviewnum 1
11549 set curview 0
11550 set selectedview 0
11551 set selectedhlview [mc "None"]
11552 set highlight_related [mc "None"]
11553 set highlight_files {}
11554 set viewfiles(0) {}
11555 set viewperm(0) 0
11556 set viewargs(0) {}
11557 set viewargscmd(0) {}
11559 set selectedline {}
11560 set numcommits 0
11561 set loginstance 0
11562 set cmdlineok 0
11563 set stopped 0
11564 set stuffsaved 0
11565 set patchnum 0
11566 set lserial 0
11567 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11568 setcoords
11569 makewindow
11570 catch {
11571 image create photo gitlogo -width 16 -height 16
11573 image create photo gitlogominus -width 4 -height 2
11574 gitlogominus put #C00000 -to 0 0 4 2
11575 gitlogo copy gitlogominus -to 1 5
11576 gitlogo copy gitlogominus -to 6 5
11577 gitlogo copy gitlogominus -to 11 5
11578 image delete gitlogominus
11580 image create photo gitlogoplus -width 4 -height 4
11581 gitlogoplus put #008000 -to 1 0 3 4
11582 gitlogoplus put #008000 -to 0 1 4 3
11583 gitlogo copy gitlogoplus -to 1 9
11584 gitlogo copy gitlogoplus -to 6 9
11585 gitlogo copy gitlogoplus -to 11 9
11586 image delete gitlogoplus
11588 image create photo gitlogo32 -width 32 -height 32
11589 gitlogo32 copy gitlogo -zoom 2 2
11591 wm iconphoto . -default gitlogo gitlogo32
11593 # wait for the window to become visible
11594 tkwait visibility .
11595 wm title . "[file tail $argv0]: [file tail [pwd]]"
11596 update
11597 readrefs
11599 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11600 # create a view for the files/dirs specified on the command line
11601 set curview 1
11602 set selectedview 1
11603 set nextviewnum 2
11604 set viewname(1) [mc "Command line"]
11605 set viewfiles(1) $cmdline_files
11606 set viewargs(1) $revtreeargs
11607 set viewargscmd(1) $revtreeargscmd
11608 set viewperm(1) 0
11609 set vdatemode(1) 0
11610 addviewmenu 1
11611 .bar.view entryconf [mca "Edit view..."] -state normal
11612 .bar.view entryconf [mca "Delete view"] -state normal
11615 if {[info exists permviews]} {
11616 foreach v $permviews {
11617 set n $nextviewnum
11618 incr nextviewnum
11619 set viewname($n) [lindex $v 0]
11620 set viewfiles($n) [lindex $v 1]
11621 set viewargs($n) [lindex $v 2]
11622 set viewargscmd($n) [lindex $v 3]
11623 set viewperm($n) 1
11624 addviewmenu $n
11628 if {[tk windowingsystem] eq "win32"} {
11629 focus -force .
11632 getcommits {}
11634 # Local variables:
11635 # mode: tcl
11636 # indent-tabs-mode: t
11637 # tab-width: 8
11638 # End: