gitk: Set the font for all listbox widgets
[git/debian.git] / gitk
blobccfc8dd89d01030d9c3c3fade37deb5860a80439
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
317 set startmsecs [clock clicks -milliseconds]
318 set commitidx($view) 0
319 # these are set this way for the error exits
320 set viewcomplete($view) 1
321 set viewactive($view) 0
322 varcinit $view
324 set args $viewargs($view)
325 if {$viewargscmd($view) ne {}} {
326 if {[catch {
327 set str [exec sh -c $viewargscmd($view)]
328 } err]} {
329 error_popup "[mc "Error executing --argscmd command:"] $err"
330 return 0
332 set args [concat $args [split $str "\n"]]
334 set vcanopt($view) [parseviewargs $view $args]
336 set files $viewfiles($view)
337 if {$vmergeonly($view)} {
338 set files [unmerged_files $files]
339 if {$files eq {}} {
340 global nr_unmerged
341 if {$nr_unmerged == 0} {
342 error_popup [mc "No files selected: --merge specified but\
343 no files are unmerged."]
344 } else {
345 error_popup [mc "No files selected: --merge specified but\
346 no unmerged files are within file limit."]
348 return 0
351 set vfilelimit($view) $files
353 if {$vcanopt($view)} {
354 set revs [parseviewrevs $view $vrevs($view)]
355 if {$revs eq {}} {
356 return 0
358 set args [concat $vflags($view) $revs]
359 } else {
360 set args $vorigargs($view)
363 if {[catch {
364 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
365 --boundary $args "--" $files] r]
366 } err]} {
367 error_popup "[mc "Error executing git log:"] $err"
368 return 0
370 set i [reg_instance $fd]
371 set viewinstances($view) [list $i]
372 set viewmainheadid($view) $mainheadid
373 set viewmainheadid_orig($view) $mainheadid
374 if {$files ne {} && $mainheadid ne {}} {
375 get_viewmainhead $view
377 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
378 interestedin $viewmainheadid($view) dodiffindex
380 fconfigure $fd -blocking 0 -translation lf -eofchar {}
381 if {$tclencoding != {}} {
382 fconfigure $fd -encoding $tclencoding
384 filerun $fd [list getcommitlines $fd $i $view 0]
385 nowbusy $view [mc "Reading"]
386 set viewcomplete($view) 0
387 set viewactive($view) 1
388 return 1
391 proc stop_instance {inst} {
392 global commfd leftover
394 set fd $commfd($inst)
395 catch {
396 set pid [pid $fd]
398 if {$::tcl_platform(platform) eq {windows}} {
399 exec kill -f $pid
400 } else {
401 exec kill $pid
404 catch {close $fd}
405 nukefile $fd
406 unset commfd($inst)
407 unset leftover($inst)
410 proc stop_backends {} {
411 global commfd
413 foreach inst [array names commfd] {
414 stop_instance $inst
418 proc stop_rev_list {view} {
419 global viewinstances
421 foreach inst $viewinstances($view) {
422 stop_instance $inst
424 set viewinstances($view) {}
427 proc reset_pending_select {selid} {
428 global pending_select mainheadid selectheadid
430 if {$selid ne {}} {
431 set pending_select $selid
432 } elseif {$selectheadid ne {}} {
433 set pending_select $selectheadid
434 } else {
435 set pending_select $mainheadid
439 proc getcommits {selid} {
440 global canv curview need_redisplay viewactive
442 initlayout
443 if {[start_rev_list $curview]} {
444 reset_pending_select $selid
445 show_status [mc "Reading commits..."]
446 set need_redisplay 1
447 } else {
448 show_status [mc "No commits selected"]
452 proc updatecommits {} {
453 global curview vcanopt vorigargs vfilelimit viewinstances
454 global viewactive viewcomplete tclencoding
455 global startmsecs showneartags showlocalchanges
456 global mainheadid viewmainheadid viewmainheadid_orig pending_select
457 global isworktree
458 global varcid vposids vnegids vflags vrevs
460 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
461 rereadrefs
462 set view $curview
463 if {$mainheadid ne $viewmainheadid_orig($view)} {
464 if {$showlocalchanges} {
465 dohidelocalchanges
467 set viewmainheadid($view) $mainheadid
468 set viewmainheadid_orig($view) $mainheadid
469 if {$vfilelimit($view) ne {}} {
470 get_viewmainhead $view
473 if {$showlocalchanges} {
474 doshowlocalchanges
476 if {$vcanopt($view)} {
477 set oldpos $vposids($view)
478 set oldneg $vnegids($view)
479 set revs [parseviewrevs $view $vrevs($view)]
480 if {$revs eq {}} {
481 return
483 # note: getting the delta when negative refs change is hard,
484 # and could require multiple git log invocations, so in that
485 # case we ask git log for all the commits (not just the delta)
486 if {$oldneg eq $vnegids($view)} {
487 set newrevs {}
488 set npos 0
489 # take out positive refs that we asked for before or
490 # that we have already seen
491 foreach rev $revs {
492 if {[string length $rev] == 40} {
493 if {[lsearch -exact $oldpos $rev] < 0
494 && ![info exists varcid($view,$rev)]} {
495 lappend newrevs $rev
496 incr npos
498 } else {
499 lappend $newrevs $rev
502 if {$npos == 0} return
503 set revs $newrevs
504 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
506 set args [concat $vflags($view) $revs --not $oldpos]
507 } else {
508 set args $vorigargs($view)
510 if {[catch {
511 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
512 --boundary $args "--" $vfilelimit($view)] r]
513 } err]} {
514 error_popup "[mc "Error executing git log:"] $err"
515 return
517 if {$viewactive($view) == 0} {
518 set startmsecs [clock clicks -milliseconds]
520 set i [reg_instance $fd]
521 lappend viewinstances($view) $i
522 fconfigure $fd -blocking 0 -translation lf -eofchar {}
523 if {$tclencoding != {}} {
524 fconfigure $fd -encoding $tclencoding
526 filerun $fd [list getcommitlines $fd $i $view 1]
527 incr viewactive($view)
528 set viewcomplete($view) 0
529 reset_pending_select {}
530 nowbusy $view [mc "Reading"]
531 if {$showneartags} {
532 getallcommits
536 proc reloadcommits {} {
537 global curview viewcomplete selectedline currentid thickerline
538 global showneartags treediffs commitinterest cached_commitrow
539 global targetid
541 set selid {}
542 if {$selectedline ne {}} {
543 set selid $currentid
546 if {!$viewcomplete($curview)} {
547 stop_rev_list $curview
549 resetvarcs $curview
550 set selectedline {}
551 catch {unset currentid}
552 catch {unset thickerline}
553 catch {unset treediffs}
554 readrefs
555 changedrefs
556 if {$showneartags} {
557 getallcommits
559 clear_display
560 catch {unset commitinterest}
561 catch {unset cached_commitrow}
562 catch {unset targetid}
563 setcanvscroll
564 getcommits $selid
565 return 0
568 # This makes a string representation of a positive integer which
569 # sorts as a string in numerical order
570 proc strrep {n} {
571 if {$n < 16} {
572 return [format "%x" $n]
573 } elseif {$n < 256} {
574 return [format "x%.2x" $n]
575 } elseif {$n < 65536} {
576 return [format "y%.4x" $n]
578 return [format "z%.8x" $n]
581 # Procedures used in reordering commits from git log (without
582 # --topo-order) into the order for display.
584 proc varcinit {view} {
585 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
586 global vtokmod varcmod vrowmod varcix vlastins
588 set varcstart($view) {{}}
589 set vupptr($view) {0}
590 set vdownptr($view) {0}
591 set vleftptr($view) {0}
592 set vbackptr($view) {0}
593 set varctok($view) {{}}
594 set varcrow($view) {{}}
595 set vtokmod($view) {}
596 set varcmod($view) 0
597 set vrowmod($view) 0
598 set varcix($view) {{}}
599 set vlastins($view) {0}
602 proc resetvarcs {view} {
603 global varcid varccommits parents children vseedcount ordertok
605 foreach vid [array names varcid $view,*] {
606 unset varcid($vid)
607 unset children($vid)
608 unset parents($vid)
610 # some commits might have children but haven't been seen yet
611 foreach vid [array names children $view,*] {
612 unset children($vid)
614 foreach va [array names varccommits $view,*] {
615 unset varccommits($va)
617 foreach vd [array names vseedcount $view,*] {
618 unset vseedcount($vd)
620 catch {unset ordertok}
623 # returns a list of the commits with no children
624 proc seeds {v} {
625 global vdownptr vleftptr varcstart
627 set ret {}
628 set a [lindex $vdownptr($v) 0]
629 while {$a != 0} {
630 lappend ret [lindex $varcstart($v) $a]
631 set a [lindex $vleftptr($v) $a]
633 return $ret
636 proc newvarc {view id} {
637 global varcid varctok parents children vdatemode
638 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
639 global commitdata commitinfo vseedcount varccommits vlastins
641 set a [llength $varctok($view)]
642 set vid $view,$id
643 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
644 if {![info exists commitinfo($id)]} {
645 parsecommit $id $commitdata($id) 1
647 set cdate [lindex $commitinfo($id) 4]
648 if {![string is integer -strict $cdate]} {
649 set cdate 0
651 if {![info exists vseedcount($view,$cdate)]} {
652 set vseedcount($view,$cdate) -1
654 set c [incr vseedcount($view,$cdate)]
655 set cdate [expr {$cdate ^ 0xffffffff}]
656 set tok "s[strrep $cdate][strrep $c]"
657 } else {
658 set tok {}
660 set ka 0
661 if {[llength $children($vid)] > 0} {
662 set kid [lindex $children($vid) end]
663 set k $varcid($view,$kid)
664 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
665 set ki $kid
666 set ka $k
667 set tok [lindex $varctok($view) $k]
670 if {$ka != 0} {
671 set i [lsearch -exact $parents($view,$ki) $id]
672 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
673 append tok [strrep $j]
675 set c [lindex $vlastins($view) $ka]
676 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
677 set c $ka
678 set b [lindex $vdownptr($view) $ka]
679 } else {
680 set b [lindex $vleftptr($view) $c]
682 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
683 set c $b
684 set b [lindex $vleftptr($view) $c]
686 if {$c == $ka} {
687 lset vdownptr($view) $ka $a
688 lappend vbackptr($view) 0
689 } else {
690 lset vleftptr($view) $c $a
691 lappend vbackptr($view) $c
693 lset vlastins($view) $ka $a
694 lappend vupptr($view) $ka
695 lappend vleftptr($view) $b
696 if {$b != 0} {
697 lset vbackptr($view) $b $a
699 lappend varctok($view) $tok
700 lappend varcstart($view) $id
701 lappend vdownptr($view) 0
702 lappend varcrow($view) {}
703 lappend varcix($view) {}
704 set varccommits($view,$a) {}
705 lappend vlastins($view) 0
706 return $a
709 proc splitvarc {p v} {
710 global varcid varcstart varccommits varctok vtokmod
711 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
713 set oa $varcid($v,$p)
714 set otok [lindex $varctok($v) $oa]
715 set ac $varccommits($v,$oa)
716 set i [lsearch -exact $varccommits($v,$oa) $p]
717 if {$i <= 0} return
718 set na [llength $varctok($v)]
719 # "%" sorts before "0"...
720 set tok "$otok%[strrep $i]"
721 lappend varctok($v) $tok
722 lappend varcrow($v) {}
723 lappend varcix($v) {}
724 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
725 set varccommits($v,$na) [lrange $ac $i end]
726 lappend varcstart($v) $p
727 foreach id $varccommits($v,$na) {
728 set varcid($v,$id) $na
730 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
731 lappend vlastins($v) [lindex $vlastins($v) $oa]
732 lset vdownptr($v) $oa $na
733 lset vlastins($v) $oa 0
734 lappend vupptr($v) $oa
735 lappend vleftptr($v) 0
736 lappend vbackptr($v) 0
737 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
738 lset vupptr($v) $b $na
740 if {[string compare $otok $vtokmod($v)] <= 0} {
741 modify_arc $v $oa
745 proc renumbervarc {a v} {
746 global parents children varctok varcstart varccommits
747 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
749 set t1 [clock clicks -milliseconds]
750 set todo {}
751 set isrelated($a) 1
752 set kidchanged($a) 1
753 set ntot 0
754 while {$a != 0} {
755 if {[info exists isrelated($a)]} {
756 lappend todo $a
757 set id [lindex $varccommits($v,$a) end]
758 foreach p $parents($v,$id) {
759 if {[info exists varcid($v,$p)]} {
760 set isrelated($varcid($v,$p)) 1
764 incr ntot
765 set b [lindex $vdownptr($v) $a]
766 if {$b == 0} {
767 while {$a != 0} {
768 set b [lindex $vleftptr($v) $a]
769 if {$b != 0} break
770 set a [lindex $vupptr($v) $a]
773 set a $b
775 foreach a $todo {
776 if {![info exists kidchanged($a)]} continue
777 set id [lindex $varcstart($v) $a]
778 if {[llength $children($v,$id)] > 1} {
779 set children($v,$id) [lsort -command [list vtokcmp $v] \
780 $children($v,$id)]
782 set oldtok [lindex $varctok($v) $a]
783 if {!$vdatemode($v)} {
784 set tok {}
785 } else {
786 set tok $oldtok
788 set ka 0
789 set kid [last_real_child $v,$id]
790 if {$kid ne {}} {
791 set k $varcid($v,$kid)
792 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
793 set ki $kid
794 set ka $k
795 set tok [lindex $varctok($v) $k]
798 if {$ka != 0} {
799 set i [lsearch -exact $parents($v,$ki) $id]
800 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
801 append tok [strrep $j]
803 if {$tok eq $oldtok} {
804 continue
806 set id [lindex $varccommits($v,$a) end]
807 foreach p $parents($v,$id) {
808 if {[info exists varcid($v,$p)]} {
809 set kidchanged($varcid($v,$p)) 1
810 } else {
811 set sortkids($p) 1
814 lset varctok($v) $a $tok
815 set b [lindex $vupptr($v) $a]
816 if {$b != $ka} {
817 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
818 modify_arc $v $ka
820 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
821 modify_arc $v $b
823 set c [lindex $vbackptr($v) $a]
824 set d [lindex $vleftptr($v) $a]
825 if {$c == 0} {
826 lset vdownptr($v) $b $d
827 } else {
828 lset vleftptr($v) $c $d
830 if {$d != 0} {
831 lset vbackptr($v) $d $c
833 if {[lindex $vlastins($v) $b] == $a} {
834 lset vlastins($v) $b $c
836 lset vupptr($v) $a $ka
837 set c [lindex $vlastins($v) $ka]
838 if {$c == 0 || \
839 [string compare $tok [lindex $varctok($v) $c]] < 0} {
840 set c $ka
841 set b [lindex $vdownptr($v) $ka]
842 } else {
843 set b [lindex $vleftptr($v) $c]
845 while {$b != 0 && \
846 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
847 set c $b
848 set b [lindex $vleftptr($v) $c]
850 if {$c == $ka} {
851 lset vdownptr($v) $ka $a
852 lset vbackptr($v) $a 0
853 } else {
854 lset vleftptr($v) $c $a
855 lset vbackptr($v) $a $c
857 lset vleftptr($v) $a $b
858 if {$b != 0} {
859 lset vbackptr($v) $b $a
861 lset vlastins($v) $ka $a
864 foreach id [array names sortkids] {
865 if {[llength $children($v,$id)] > 1} {
866 set children($v,$id) [lsort -command [list vtokcmp $v] \
867 $children($v,$id)]
870 set t2 [clock clicks -milliseconds]
871 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
874 # Fix up the graph after we have found out that in view $v,
875 # $p (a commit that we have already seen) is actually the parent
876 # of the last commit in arc $a.
877 proc fix_reversal {p a v} {
878 global varcid varcstart varctok vupptr
880 set pa $varcid($v,$p)
881 if {$p ne [lindex $varcstart($v) $pa]} {
882 splitvarc $p $v
883 set pa $varcid($v,$p)
885 # seeds always need to be renumbered
886 if {[lindex $vupptr($v) $pa] == 0 ||
887 [string compare [lindex $varctok($v) $a] \
888 [lindex $varctok($v) $pa]] > 0} {
889 renumbervarc $pa $v
893 proc insertrow {id p v} {
894 global cmitlisted children parents varcid varctok vtokmod
895 global varccommits ordertok commitidx numcommits curview
896 global targetid targetrow
898 readcommit $id
899 set vid $v,$id
900 set cmitlisted($vid) 1
901 set children($vid) {}
902 set parents($vid) [list $p]
903 set a [newvarc $v $id]
904 set varcid($vid) $a
905 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
906 modify_arc $v $a
908 lappend varccommits($v,$a) $id
909 set vp $v,$p
910 if {[llength [lappend children($vp) $id]] > 1} {
911 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
912 catch {unset ordertok}
914 fix_reversal $p $a $v
915 incr commitidx($v)
916 if {$v == $curview} {
917 set numcommits $commitidx($v)
918 setcanvscroll
919 if {[info exists targetid]} {
920 if {![comes_before $targetid $p]} {
921 incr targetrow
927 proc insertfakerow {id p} {
928 global varcid varccommits parents children cmitlisted
929 global commitidx varctok vtokmod targetid targetrow curview numcommits
931 set v $curview
932 set a $varcid($v,$p)
933 set i [lsearch -exact $varccommits($v,$a) $p]
934 if {$i < 0} {
935 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
936 return
938 set children($v,$id) {}
939 set parents($v,$id) [list $p]
940 set varcid($v,$id) $a
941 lappend children($v,$p) $id
942 set cmitlisted($v,$id) 1
943 set numcommits [incr commitidx($v)]
944 # note we deliberately don't update varcstart($v) even if $i == 0
945 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
946 modify_arc $v $a $i
947 if {[info exists targetid]} {
948 if {![comes_before $targetid $p]} {
949 incr targetrow
952 setcanvscroll
953 drawvisible
956 proc removefakerow {id} {
957 global varcid varccommits parents children commitidx
958 global varctok vtokmod cmitlisted currentid selectedline
959 global targetid curview numcommits
961 set v $curview
962 if {[llength $parents($v,$id)] != 1} {
963 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
964 return
966 set p [lindex $parents($v,$id) 0]
967 set a $varcid($v,$id)
968 set i [lsearch -exact $varccommits($v,$a) $id]
969 if {$i < 0} {
970 puts "oops: removefakerow can't find [shortids $id] on arc $a"
971 return
973 unset varcid($v,$id)
974 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
975 unset parents($v,$id)
976 unset children($v,$id)
977 unset cmitlisted($v,$id)
978 set numcommits [incr commitidx($v) -1]
979 set j [lsearch -exact $children($v,$p) $id]
980 if {$j >= 0} {
981 set children($v,$p) [lreplace $children($v,$p) $j $j]
983 modify_arc $v $a $i
984 if {[info exist currentid] && $id eq $currentid} {
985 unset currentid
986 set selectedline {}
988 if {[info exists targetid] && $targetid eq $id} {
989 set targetid $p
991 setcanvscroll
992 drawvisible
995 proc real_children {vp} {
996 global children nullid nullid2
998 set kids {}
999 foreach id $children($vp) {
1000 if {$id ne $nullid && $id ne $nullid2} {
1001 lappend kids $id
1004 return $kids
1007 proc first_real_child {vp} {
1008 global children nullid nullid2
1010 foreach id $children($vp) {
1011 if {$id ne $nullid && $id ne $nullid2} {
1012 return $id
1015 return {}
1018 proc last_real_child {vp} {
1019 global children nullid nullid2
1021 set kids $children($vp)
1022 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1023 set id [lindex $kids $i]
1024 if {$id ne $nullid && $id ne $nullid2} {
1025 return $id
1028 return {}
1031 proc vtokcmp {v a b} {
1032 global varctok varcid
1034 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1035 [lindex $varctok($v) $varcid($v,$b)]]
1038 # This assumes that if lim is not given, the caller has checked that
1039 # arc a's token is less than $vtokmod($v)
1040 proc modify_arc {v a {lim {}}} {
1041 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1043 if {$lim ne {}} {
1044 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1045 if {$c > 0} return
1046 if {$c == 0} {
1047 set r [lindex $varcrow($v) $a]
1048 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1051 set vtokmod($v) [lindex $varctok($v) $a]
1052 set varcmod($v) $a
1053 if {$v == $curview} {
1054 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1055 set a [lindex $vupptr($v) $a]
1056 set lim {}
1058 set r 0
1059 if {$a != 0} {
1060 if {$lim eq {}} {
1061 set lim [llength $varccommits($v,$a)]
1063 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1065 set vrowmod($v) $r
1066 undolayout $r
1070 proc update_arcrows {v} {
1071 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1072 global varcid vrownum varcorder varcix varccommits
1073 global vupptr vdownptr vleftptr varctok
1074 global displayorder parentlist curview cached_commitrow
1076 if {$vrowmod($v) == $commitidx($v)} return
1077 if {$v == $curview} {
1078 if {[llength $displayorder] > $vrowmod($v)} {
1079 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1080 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1082 catch {unset cached_commitrow}
1084 set narctot [expr {[llength $varctok($v)] - 1}]
1085 set a $varcmod($v)
1086 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1087 # go up the tree until we find something that has a row number,
1088 # or we get to a seed
1089 set a [lindex $vupptr($v) $a]
1091 if {$a == 0} {
1092 set a [lindex $vdownptr($v) 0]
1093 if {$a == 0} return
1094 set vrownum($v) {0}
1095 set varcorder($v) [list $a]
1096 lset varcix($v) $a 0
1097 lset varcrow($v) $a 0
1098 set arcn 0
1099 set row 0
1100 } else {
1101 set arcn [lindex $varcix($v) $a]
1102 if {[llength $vrownum($v)] > $arcn + 1} {
1103 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1104 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1106 set row [lindex $varcrow($v) $a]
1108 while {1} {
1109 set p $a
1110 incr row [llength $varccommits($v,$a)]
1111 # go down if possible
1112 set b [lindex $vdownptr($v) $a]
1113 if {$b == 0} {
1114 # if not, go left, or go up until we can go left
1115 while {$a != 0} {
1116 set b [lindex $vleftptr($v) $a]
1117 if {$b != 0} break
1118 set a [lindex $vupptr($v) $a]
1120 if {$a == 0} break
1122 set a $b
1123 incr arcn
1124 lappend vrownum($v) $row
1125 lappend varcorder($v) $a
1126 lset varcix($v) $a $arcn
1127 lset varcrow($v) $a $row
1129 set vtokmod($v) [lindex $varctok($v) $p]
1130 set varcmod($v) $p
1131 set vrowmod($v) $row
1132 if {[info exists currentid]} {
1133 set selectedline [rowofcommit $currentid]
1137 # Test whether view $v contains commit $id
1138 proc commitinview {id v} {
1139 global varcid
1141 return [info exists varcid($v,$id)]
1144 # Return the row number for commit $id in the current view
1145 proc rowofcommit {id} {
1146 global varcid varccommits varcrow curview cached_commitrow
1147 global varctok vtokmod
1149 set v $curview
1150 if {![info exists varcid($v,$id)]} {
1151 puts "oops rowofcommit no arc for [shortids $id]"
1152 return {}
1154 set a $varcid($v,$id)
1155 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1156 update_arcrows $v
1158 if {[info exists cached_commitrow($id)]} {
1159 return $cached_commitrow($id)
1161 set i [lsearch -exact $varccommits($v,$a) $id]
1162 if {$i < 0} {
1163 puts "oops didn't find commit [shortids $id] in arc $a"
1164 return {}
1166 incr i [lindex $varcrow($v) $a]
1167 set cached_commitrow($id) $i
1168 return $i
1171 # Returns 1 if a is on an earlier row than b, otherwise 0
1172 proc comes_before {a b} {
1173 global varcid varctok curview
1175 set v $curview
1176 if {$a eq $b || ![info exists varcid($v,$a)] || \
1177 ![info exists varcid($v,$b)]} {
1178 return 0
1180 if {$varcid($v,$a) != $varcid($v,$b)} {
1181 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1182 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1184 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1187 proc bsearch {l elt} {
1188 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1189 return 0
1191 set lo 0
1192 set hi [llength $l]
1193 while {$hi - $lo > 1} {
1194 set mid [expr {int(($lo + $hi) / 2)}]
1195 set t [lindex $l $mid]
1196 if {$elt < $t} {
1197 set hi $mid
1198 } elseif {$elt > $t} {
1199 set lo $mid
1200 } else {
1201 return $mid
1204 return $lo
1207 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1208 proc make_disporder {start end} {
1209 global vrownum curview commitidx displayorder parentlist
1210 global varccommits varcorder parents vrowmod varcrow
1211 global d_valid_start d_valid_end
1213 if {$end > $vrowmod($curview)} {
1214 update_arcrows $curview
1216 set ai [bsearch $vrownum($curview) $start]
1217 set start [lindex $vrownum($curview) $ai]
1218 set narc [llength $vrownum($curview)]
1219 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1220 set a [lindex $varcorder($curview) $ai]
1221 set l [llength $displayorder]
1222 set al [llength $varccommits($curview,$a)]
1223 if {$l < $r + $al} {
1224 if {$l < $r} {
1225 set pad [ntimes [expr {$r - $l}] {}]
1226 set displayorder [concat $displayorder $pad]
1227 set parentlist [concat $parentlist $pad]
1228 } elseif {$l > $r} {
1229 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1230 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1232 foreach id $varccommits($curview,$a) {
1233 lappend displayorder $id
1234 lappend parentlist $parents($curview,$id)
1236 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1237 set i $r
1238 foreach id $varccommits($curview,$a) {
1239 lset displayorder $i $id
1240 lset parentlist $i $parents($curview,$id)
1241 incr i
1244 incr r $al
1248 proc commitonrow {row} {
1249 global displayorder
1251 set id [lindex $displayorder $row]
1252 if {$id eq {}} {
1253 make_disporder $row [expr {$row + 1}]
1254 set id [lindex $displayorder $row]
1256 return $id
1259 proc closevarcs {v} {
1260 global varctok varccommits varcid parents children
1261 global cmitlisted commitidx vtokmod
1263 set missing_parents 0
1264 set scripts {}
1265 set narcs [llength $varctok($v)]
1266 for {set a 1} {$a < $narcs} {incr a} {
1267 set id [lindex $varccommits($v,$a) end]
1268 foreach p $parents($v,$id) {
1269 if {[info exists varcid($v,$p)]} continue
1270 # add p as a new commit
1271 incr missing_parents
1272 set cmitlisted($v,$p) 0
1273 set parents($v,$p) {}
1274 if {[llength $children($v,$p)] == 1 &&
1275 [llength $parents($v,$id)] == 1} {
1276 set b $a
1277 } else {
1278 set b [newvarc $v $p]
1280 set varcid($v,$p) $b
1281 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1282 modify_arc $v $b
1284 lappend varccommits($v,$b) $p
1285 incr commitidx($v)
1286 set scripts [check_interest $p $scripts]
1289 if {$missing_parents > 0} {
1290 foreach s $scripts {
1291 eval $s
1296 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1297 # Assumes we already have an arc for $rwid.
1298 proc rewrite_commit {v id rwid} {
1299 global children parents varcid varctok vtokmod varccommits
1301 foreach ch $children($v,$id) {
1302 # make $rwid be $ch's parent in place of $id
1303 set i [lsearch -exact $parents($v,$ch) $id]
1304 if {$i < 0} {
1305 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1307 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1308 # add $ch to $rwid's children and sort the list if necessary
1309 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1310 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1311 $children($v,$rwid)]
1313 # fix the graph after joining $id to $rwid
1314 set a $varcid($v,$ch)
1315 fix_reversal $rwid $a $v
1316 # parentlist is wrong for the last element of arc $a
1317 # even if displayorder is right, hence the 3rd arg here
1318 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1322 # Mechanism for registering a command to be executed when we come
1323 # across a particular commit. To handle the case when only the
1324 # prefix of the commit is known, the commitinterest array is now
1325 # indexed by the first 4 characters of the ID. Each element is a
1326 # list of id, cmd pairs.
1327 proc interestedin {id cmd} {
1328 global commitinterest
1330 lappend commitinterest([string range $id 0 3]) $id $cmd
1333 proc check_interest {id scripts} {
1334 global commitinterest
1336 set prefix [string range $id 0 3]
1337 if {[info exists commitinterest($prefix)]} {
1338 set newlist {}
1339 foreach {i script} $commitinterest($prefix) {
1340 if {[string match "$i*" $id]} {
1341 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1342 } else {
1343 lappend newlist $i $script
1346 if {$newlist ne {}} {
1347 set commitinterest($prefix) $newlist
1348 } else {
1349 unset commitinterest($prefix)
1352 return $scripts
1355 proc getcommitlines {fd inst view updating} {
1356 global cmitlisted leftover
1357 global commitidx commitdata vdatemode
1358 global parents children curview hlview
1359 global idpending ordertok
1360 global varccommits varcid varctok vtokmod vfilelimit
1362 set stuff [read $fd 500000]
1363 # git log doesn't terminate the last commit with a null...
1364 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1365 set stuff "\0"
1367 if {$stuff == {}} {
1368 if {![eof $fd]} {
1369 return 1
1371 global commfd viewcomplete viewactive viewname
1372 global viewinstances
1373 unset commfd($inst)
1374 set i [lsearch -exact $viewinstances($view) $inst]
1375 if {$i >= 0} {
1376 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1378 # set it blocking so we wait for the process to terminate
1379 fconfigure $fd -blocking 1
1380 if {[catch {close $fd} err]} {
1381 set fv {}
1382 if {$view != $curview} {
1383 set fv " for the \"$viewname($view)\" view"
1385 if {[string range $err 0 4] == "usage"} {
1386 set err "Gitk: error reading commits$fv:\
1387 bad arguments to git log."
1388 if {$viewname($view) eq "Command line"} {
1389 append err \
1390 " (Note: arguments to gitk are passed to git log\
1391 to allow selection of commits to be displayed.)"
1393 } else {
1394 set err "Error reading commits$fv: $err"
1396 error_popup $err
1398 if {[incr viewactive($view) -1] <= 0} {
1399 set viewcomplete($view) 1
1400 # Check if we have seen any ids listed as parents that haven't
1401 # appeared in the list
1402 closevarcs $view
1403 notbusy $view
1405 if {$view == $curview} {
1406 run chewcommits
1408 return 0
1410 set start 0
1411 set gotsome 0
1412 set scripts {}
1413 while 1 {
1414 set i [string first "\0" $stuff $start]
1415 if {$i < 0} {
1416 append leftover($inst) [string range $stuff $start end]
1417 break
1419 if {$start == 0} {
1420 set cmit $leftover($inst)
1421 append cmit [string range $stuff 0 [expr {$i - 1}]]
1422 set leftover($inst) {}
1423 } else {
1424 set cmit [string range $stuff $start [expr {$i - 1}]]
1426 set start [expr {$i + 1}]
1427 set j [string first "\n" $cmit]
1428 set ok 0
1429 set listed 1
1430 if {$j >= 0 && [string match "commit *" $cmit]} {
1431 set ids [string range $cmit 7 [expr {$j - 1}]]
1432 if {[string match {[-^<>]*} $ids]} {
1433 switch -- [string index $ids 0] {
1434 "-" {set listed 0}
1435 "^" {set listed 2}
1436 "<" {set listed 3}
1437 ">" {set listed 4}
1439 set ids [string range $ids 1 end]
1441 set ok 1
1442 foreach id $ids {
1443 if {[string length $id] != 40} {
1444 set ok 0
1445 break
1449 if {!$ok} {
1450 set shortcmit $cmit
1451 if {[string length $shortcmit] > 80} {
1452 set shortcmit "[string range $shortcmit 0 80]..."
1454 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1455 exit 1
1457 set id [lindex $ids 0]
1458 set vid $view,$id
1460 if {!$listed && $updating && ![info exists varcid($vid)] &&
1461 $vfilelimit($view) ne {}} {
1462 # git log doesn't rewrite parents for unlisted commits
1463 # when doing path limiting, so work around that here
1464 # by working out the rewritten parent with git rev-list
1465 # and if we already know about it, using the rewritten
1466 # parent as a substitute parent for $id's children.
1467 if {![catch {
1468 set rwid [exec git rev-list --first-parent --max-count=1 \
1469 $id -- $vfilelimit($view)]
1470 }]} {
1471 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1472 # use $rwid in place of $id
1473 rewrite_commit $view $id $rwid
1474 continue
1479 set a 0
1480 if {[info exists varcid($vid)]} {
1481 if {$cmitlisted($vid) || !$listed} continue
1482 set a $varcid($vid)
1484 if {$listed} {
1485 set olds [lrange $ids 1 end]
1486 } else {
1487 set olds {}
1489 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1490 set cmitlisted($vid) $listed
1491 set parents($vid) $olds
1492 if {![info exists children($vid)]} {
1493 set children($vid) {}
1494 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1495 set k [lindex $children($vid) 0]
1496 if {[llength $parents($view,$k)] == 1 &&
1497 (!$vdatemode($view) ||
1498 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1499 set a $varcid($view,$k)
1502 if {$a == 0} {
1503 # new arc
1504 set a [newvarc $view $id]
1506 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1507 modify_arc $view $a
1509 if {![info exists varcid($vid)]} {
1510 set varcid($vid) $a
1511 lappend varccommits($view,$a) $id
1512 incr commitidx($view)
1515 set i 0
1516 foreach p $olds {
1517 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1518 set vp $view,$p
1519 if {[llength [lappend children($vp) $id]] > 1 &&
1520 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1521 set children($vp) [lsort -command [list vtokcmp $view] \
1522 $children($vp)]
1523 catch {unset ordertok}
1525 if {[info exists varcid($view,$p)]} {
1526 fix_reversal $p $a $view
1529 incr i
1532 set scripts [check_interest $id $scripts]
1533 set gotsome 1
1535 if {$gotsome} {
1536 global numcommits hlview
1538 if {$view == $curview} {
1539 set numcommits $commitidx($view)
1540 run chewcommits
1542 if {[info exists hlview] && $view == $hlview} {
1543 # we never actually get here...
1544 run vhighlightmore
1546 foreach s $scripts {
1547 eval $s
1550 return 2
1553 proc chewcommits {} {
1554 global curview hlview viewcomplete
1555 global pending_select
1557 layoutmore
1558 if {$viewcomplete($curview)} {
1559 global commitidx varctok
1560 global numcommits startmsecs
1562 if {[info exists pending_select]} {
1563 update
1564 reset_pending_select {}
1566 if {[commitinview $pending_select $curview]} {
1567 selectline [rowofcommit $pending_select] 1
1568 } else {
1569 set row [first_real_row]
1570 selectline $row 1
1573 if {$commitidx($curview) > 0} {
1574 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1575 #puts "overall $ms ms for $numcommits commits"
1576 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1577 } else {
1578 show_status [mc "No commits selected"]
1580 notbusy layout
1582 return 0
1585 proc do_readcommit {id} {
1586 global tclencoding
1588 # Invoke git-log to handle automatic encoding conversion
1589 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1590 # Read the results using i18n.logoutputencoding
1591 fconfigure $fd -translation lf -eofchar {}
1592 if {$tclencoding != {}} {
1593 fconfigure $fd -encoding $tclencoding
1595 set contents [read $fd]
1596 close $fd
1597 # Remove the heading line
1598 regsub {^commit [0-9a-f]+\n} $contents {} contents
1600 return $contents
1603 proc readcommit {id} {
1604 if {[catch {set contents [do_readcommit $id]}]} return
1605 parsecommit $id $contents 1
1608 proc parsecommit {id contents listed} {
1609 global commitinfo cdate
1611 set inhdr 1
1612 set comment {}
1613 set headline {}
1614 set auname {}
1615 set audate {}
1616 set comname {}
1617 set comdate {}
1618 set hdrend [string first "\n\n" $contents]
1619 if {$hdrend < 0} {
1620 # should never happen...
1621 set hdrend [string length $contents]
1623 set header [string range $contents 0 [expr {$hdrend - 1}]]
1624 set comment [string range $contents [expr {$hdrend + 2}] end]
1625 foreach line [split $header "\n"] {
1626 set line [split $line " "]
1627 set tag [lindex $line 0]
1628 if {$tag == "author"} {
1629 set audate [lindex $line end-1]
1630 set auname [join [lrange $line 1 end-2] " "]
1631 } elseif {$tag == "committer"} {
1632 set comdate [lindex $line end-1]
1633 set comname [join [lrange $line 1 end-2] " "]
1636 set headline {}
1637 # take the first non-blank line of the comment as the headline
1638 set headline [string trimleft $comment]
1639 set i [string first "\n" $headline]
1640 if {$i >= 0} {
1641 set headline [string range $headline 0 $i]
1643 set headline [string trimright $headline]
1644 set i [string first "\r" $headline]
1645 if {$i >= 0} {
1646 set headline [string trimright [string range $headline 0 $i]]
1648 if {!$listed} {
1649 # git log indents the comment by 4 spaces;
1650 # if we got this via git cat-file, add the indentation
1651 set newcomment {}
1652 foreach line [split $comment "\n"] {
1653 append newcomment " "
1654 append newcomment $line
1655 append newcomment "\n"
1657 set comment $newcomment
1659 if {$comdate != {}} {
1660 set cdate($id) $comdate
1662 set commitinfo($id) [list $headline $auname $audate \
1663 $comname $comdate $comment]
1666 proc getcommit {id} {
1667 global commitdata commitinfo
1669 if {[info exists commitdata($id)]} {
1670 parsecommit $id $commitdata($id) 1
1671 } else {
1672 readcommit $id
1673 if {![info exists commitinfo($id)]} {
1674 set commitinfo($id) [list [mc "No commit information available"]]
1677 return 1
1680 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1681 # and are present in the current view.
1682 # This is fairly slow...
1683 proc longid {prefix} {
1684 global varcid curview
1686 set ids {}
1687 foreach match [array names varcid "$curview,$prefix*"] {
1688 lappend ids [lindex [split $match ","] 1]
1690 return $ids
1693 proc readrefs {} {
1694 global tagids idtags headids idheads tagobjid
1695 global otherrefids idotherrefs mainhead mainheadid
1696 global selecthead selectheadid
1697 global hideremotes
1699 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1700 catch {unset $v}
1702 set refd [open [list | git show-ref -d] r]
1703 while {[gets $refd line] >= 0} {
1704 if {[string index $line 40] ne " "} continue
1705 set id [string range $line 0 39]
1706 set ref [string range $line 41 end]
1707 if {![string match "refs/*" $ref]} continue
1708 set name [string range $ref 5 end]
1709 if {[string match "remotes/*" $name]} {
1710 if {![string match "*/HEAD" $name] && !$hideremotes} {
1711 set headids($name) $id
1712 lappend idheads($id) $name
1714 } elseif {[string match "heads/*" $name]} {
1715 set name [string range $name 6 end]
1716 set headids($name) $id
1717 lappend idheads($id) $name
1718 } elseif {[string match "tags/*" $name]} {
1719 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1720 # which is what we want since the former is the commit ID
1721 set name [string range $name 5 end]
1722 if {[string match "*^{}" $name]} {
1723 set name [string range $name 0 end-3]
1724 } else {
1725 set tagobjid($name) $id
1727 set tagids($name) $id
1728 lappend idtags($id) $name
1729 } else {
1730 set otherrefids($name) $id
1731 lappend idotherrefs($id) $name
1734 catch {close $refd}
1735 set mainhead {}
1736 set mainheadid {}
1737 catch {
1738 set mainheadid [exec git rev-parse HEAD]
1739 set thehead [exec git symbolic-ref HEAD]
1740 if {[string match "refs/heads/*" $thehead]} {
1741 set mainhead [string range $thehead 11 end]
1744 set selectheadid {}
1745 if {$selecthead ne {}} {
1746 catch {
1747 set selectheadid [exec git rev-parse --verify $selecthead]
1752 # skip over fake commits
1753 proc first_real_row {} {
1754 global nullid nullid2 numcommits
1756 for {set row 0} {$row < $numcommits} {incr row} {
1757 set id [commitonrow $row]
1758 if {$id ne $nullid && $id ne $nullid2} {
1759 break
1762 return $row
1765 # update things for a head moved to a child of its previous location
1766 proc movehead {id name} {
1767 global headids idheads
1769 removehead $headids($name) $name
1770 set headids($name) $id
1771 lappend idheads($id) $name
1774 # update things when a head has been removed
1775 proc removehead {id name} {
1776 global headids idheads
1778 if {$idheads($id) eq $name} {
1779 unset idheads($id)
1780 } else {
1781 set i [lsearch -exact $idheads($id) $name]
1782 if {$i >= 0} {
1783 set idheads($id) [lreplace $idheads($id) $i $i]
1786 unset headids($name)
1789 proc ttk_toplevel {w args} {
1790 global use_ttk
1791 eval [linsert $args 0 ::toplevel $w]
1792 if {$use_ttk} {
1793 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1795 return $w
1798 proc make_transient {window origin} {
1799 global have_tk85
1801 # In MacOS Tk 8.4 transient appears to work by setting
1802 # overrideredirect, which is utterly useless, since the
1803 # windows get no border, and are not even kept above
1804 # the parent.
1805 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1807 wm transient $window $origin
1809 # Windows fails to place transient windows normally, so
1810 # schedule a callback to center them on the parent.
1811 if {[tk windowingsystem] eq {win32}} {
1812 after idle [list tk::PlaceWindow $window widget $origin]
1816 proc show_error {w top msg {mc mc}} {
1817 global NS
1818 if {![info exists NS]} {set NS ""}
1819 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1820 message $w.m -text $msg -justify center -aspect 400
1821 pack $w.m -side top -fill x -padx 20 -pady 20
1822 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1823 pack $w.ok -side bottom -fill x
1824 bind $top <Visibility> "grab $top; focus $top"
1825 bind $top <Key-Return> "destroy $top"
1826 bind $top <Key-space> "destroy $top"
1827 bind $top <Key-Escape> "destroy $top"
1828 tkwait window $top
1831 proc error_popup {msg {owner .}} {
1832 if {[tk windowingsystem] eq "win32"} {
1833 tk_messageBox -icon error -type ok -title [wm title .] \
1834 -parent $owner -message $msg
1835 } else {
1836 set w .error
1837 ttk_toplevel $w
1838 make_transient $w $owner
1839 show_error $w $w $msg
1843 proc confirm_popup {msg {owner .}} {
1844 global confirm_ok NS
1845 set confirm_ok 0
1846 set w .confirm
1847 ttk_toplevel $w
1848 make_transient $w $owner
1849 message $w.m -text $msg -justify center -aspect 400
1850 pack $w.m -side top -fill x -padx 20 -pady 20
1851 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1852 pack $w.ok -side left -fill x
1853 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1854 pack $w.cancel -side right -fill x
1855 bind $w <Visibility> "grab $w; focus $w"
1856 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1857 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1858 bind $w <Key-Escape> "destroy $w"
1859 tk::PlaceWindow $w widget $owner
1860 tkwait window $w
1861 return $confirm_ok
1864 proc setoptions {} {
1865 if {[tk windowingsystem] ne "win32"} {
1866 option add *Panedwindow.showHandle 1 startupFile
1867 option add *Panedwindow.sashRelief raised startupFile
1868 if {[tk windowingsystem] ne "aqua"} {
1869 option add *Menu.font uifont startupFile
1871 } else {
1872 option add *Menu.TearOff 0 startupFile
1874 option add *Button.font uifont startupFile
1875 option add *Checkbutton.font uifont startupFile
1876 option add *Radiobutton.font uifont startupFile
1877 option add *Menubutton.font uifont startupFile
1878 option add *Label.font uifont startupFile
1879 option add *Message.font uifont startupFile
1880 option add *Entry.font uifont startupFile
1881 option add *Labelframe.font uifont startupFile
1882 option add *Spinbox.font textfont startupFile
1883 option add *Listbox.font mainfont startupFile
1886 # Make a menu and submenus.
1887 # m is the window name for the menu, items is the list of menu items to add.
1888 # Each item is a list {mc label type description options...}
1889 # mc is ignored; it's so we can put mc there to alert xgettext
1890 # label is the string that appears in the menu
1891 # type is cascade, command or radiobutton (should add checkbutton)
1892 # description depends on type; it's the sublist for cascade, the
1893 # command to invoke for command, or {variable value} for radiobutton
1894 proc makemenu {m items} {
1895 menu $m
1896 if {[tk windowingsystem] eq {aqua}} {
1897 set Meta1 Cmd
1898 } else {
1899 set Meta1 Ctrl
1901 foreach i $items {
1902 set name [mc [lindex $i 1]]
1903 set type [lindex $i 2]
1904 set thing [lindex $i 3]
1905 set params [list $type]
1906 if {$name ne {}} {
1907 set u [string first "&" [string map {&& x} $name]]
1908 lappend params -label [string map {&& & & {}} $name]
1909 if {$u >= 0} {
1910 lappend params -underline $u
1913 switch -- $type {
1914 "cascade" {
1915 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1916 lappend params -menu $m.$submenu
1918 "command" {
1919 lappend params -command $thing
1921 "radiobutton" {
1922 lappend params -variable [lindex $thing 0] \
1923 -value [lindex $thing 1]
1926 set tail [lrange $i 4 end]
1927 regsub -all {\yMeta1\y} $tail $Meta1 tail
1928 eval $m add $params $tail
1929 if {$type eq "cascade"} {
1930 makemenu $m.$submenu $thing
1935 # translate string and remove ampersands
1936 proc mca {str} {
1937 return [string map {&& & & {}} [mc $str]]
1940 proc makedroplist {w varname args} {
1941 global use_ttk
1942 if {$use_ttk} {
1943 set width 0
1944 foreach label $args {
1945 set cx [string length $label]
1946 if {$cx > $width} {set width $cx}
1948 set gm [ttk::combobox $w -width $width -state readonly\
1949 -textvariable $varname -values $args]
1950 } else {
1951 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
1953 return $gm
1956 proc makewindow {} {
1957 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1958 global tabstop
1959 global findtype findtypemenu findloc findstring fstring geometry
1960 global entries sha1entry sha1string sha1but
1961 global diffcontextstring diffcontext
1962 global ignorespace
1963 global maincursor textcursor curtextcursor
1964 global rowctxmenu fakerowmenu mergemax wrapcomment
1965 global highlight_files gdttype
1966 global searchstring sstring
1967 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1968 global headctxmenu progresscanv progressitem progresscoords statusw
1969 global fprogitem fprogcoord lastprogupdate progupdatepending
1970 global rprogitem rprogcoord rownumsel numcommits
1971 global have_tk85 use_ttk NS
1973 # The "mc" arguments here are purely so that xgettext
1974 # sees the following string as needing to be translated
1975 set file {
1976 mc "File" cascade {
1977 {mc "Update" command updatecommits -accelerator F5}
1978 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1979 {mc "Reread references" command rereadrefs}
1980 {mc "List references" command showrefs -accelerator F2}
1981 {xx "" separator}
1982 {mc "Start git gui" command {exec git gui &}}
1983 {xx "" separator}
1984 {mc "Quit" command doquit -accelerator Meta1-Q}
1986 set edit {
1987 mc "Edit" cascade {
1988 {mc "Preferences" command doprefs}
1990 set view {
1991 mc "View" cascade {
1992 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1993 {mc "Edit view..." command editview -state disabled -accelerator F4}
1994 {mc "Delete view" command delview -state disabled}
1995 {xx "" separator}
1996 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1998 if {[tk windowingsystem] ne "aqua"} {
1999 set help {
2000 mc "Help" cascade {
2001 {mc "About gitk" command about}
2002 {mc "Key bindings" command keys}
2004 set bar [list $file $edit $view $help]
2005 } else {
2006 proc ::tk::mac::ShowPreferences {} {doprefs}
2007 proc ::tk::mac::Quit {} {doquit}
2008 lset file end [lreplace [lindex $file end] end-1 end]
2009 set apple {
2010 xx "Apple" cascade {
2011 {mc "About gitk" command about}
2012 {xx "" separator}
2014 set help {
2015 mc "Help" cascade {
2016 {mc "Key bindings" command keys}
2018 set bar [list $apple $file $view $help]
2020 makemenu .bar $bar
2021 . configure -menu .bar
2023 if {$use_ttk} {
2024 # cover the non-themed toplevel with a themed frame.
2025 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2028 # the gui has upper and lower half, parts of a paned window.
2029 ${NS}::panedwindow .ctop -orient vertical
2031 # possibly use assumed geometry
2032 if {![info exists geometry(pwsash0)]} {
2033 set geometry(topheight) [expr {15 * $linespc}]
2034 set geometry(topwidth) [expr {80 * $charspc}]
2035 set geometry(botheight) [expr {15 * $linespc}]
2036 set geometry(botwidth) [expr {50 * $charspc}]
2037 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2038 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2041 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2042 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2043 ${NS}::frame .tf.histframe
2044 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2045 if {!$use_ttk} {
2046 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2049 # create three canvases
2050 set cscroll .tf.histframe.csb
2051 set canv .tf.histframe.pwclist.canv
2052 canvas $canv \
2053 -selectbackground $selectbgcolor \
2054 -background $bgcolor -bd 0 \
2055 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2056 .tf.histframe.pwclist add $canv
2057 set canv2 .tf.histframe.pwclist.canv2
2058 canvas $canv2 \
2059 -selectbackground $selectbgcolor \
2060 -background $bgcolor -bd 0 -yscrollincr $linespc
2061 .tf.histframe.pwclist add $canv2
2062 set canv3 .tf.histframe.pwclist.canv3
2063 canvas $canv3 \
2064 -selectbackground $selectbgcolor \
2065 -background $bgcolor -bd 0 -yscrollincr $linespc
2066 .tf.histframe.pwclist add $canv3
2067 if {$use_ttk} {
2068 bind .tf.histframe.pwclist <Map> {
2069 bind %W <Map> {}
2070 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2071 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2073 } else {
2074 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2075 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2078 # a scroll bar to rule them
2079 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2080 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2081 pack $cscroll -side right -fill y
2082 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2083 lappend bglist $canv $canv2 $canv3
2084 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2086 # we have two button bars at bottom of top frame. Bar 1
2087 ${NS}::frame .tf.bar
2088 ${NS}::frame .tf.lbar -height 15
2090 set sha1entry .tf.bar.sha1
2091 set entries $sha1entry
2092 set sha1but .tf.bar.sha1label
2093 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2094 -command gotocommit -width 8
2095 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2096 pack .tf.bar.sha1label -side left
2097 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2098 trace add variable sha1string write sha1change
2099 pack $sha1entry -side left -pady 2
2101 image create bitmap bm-left -data {
2102 #define left_width 16
2103 #define left_height 16
2104 static unsigned char left_bits[] = {
2105 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2106 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2107 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2109 image create bitmap bm-right -data {
2110 #define right_width 16
2111 #define right_height 16
2112 static unsigned char right_bits[] = {
2113 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2114 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2115 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2117 ${NS}::button .tf.bar.leftbut -image bm-left -command goback \
2118 -state disabled -width 26
2119 pack .tf.bar.leftbut -side left -fill y
2120 ${NS}::button .tf.bar.rightbut -image bm-right -command goforw \
2121 -state disabled -width 26
2122 pack .tf.bar.rightbut -side left -fill y
2124 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2125 set rownumsel {}
2126 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2127 -relief sunken -anchor e
2128 ${NS}::label .tf.bar.rowlabel2 -text "/"
2129 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2130 -relief sunken -anchor e
2131 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2132 -side left
2133 if {!$use_ttk} {
2134 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2136 global selectedline
2137 trace add variable selectedline write selectedline_change
2139 # Status label and progress bar
2140 set statusw .tf.bar.status
2141 ${NS}::label $statusw -width 15 -relief sunken
2142 pack $statusw -side left -padx 5
2143 if {$use_ttk} {
2144 set progresscanv [ttk::progressbar .tf.bar.progress]
2145 } else {
2146 set h [expr {[font metrics uifont -linespace] + 2}]
2147 set progresscanv .tf.bar.progress
2148 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2149 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2150 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2151 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2153 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2154 set progresscoords {0 0}
2155 set fprogcoord 0
2156 set rprogcoord 0
2157 bind $progresscanv <Configure> adjustprogress
2158 set lastprogupdate [clock clicks -milliseconds]
2159 set progupdatepending 0
2161 # build up the bottom bar of upper window
2162 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2163 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2164 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2165 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2166 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2167 -side left -fill y
2168 set gdttype [mc "containing:"]
2169 set gm [makedroplist .tf.lbar.gdttype gdttype \
2170 [mc "containing:"] \
2171 [mc "touching paths:"] \
2172 [mc "adding/removing string:"]]
2173 trace add variable gdttype write gdttype_change
2174 pack .tf.lbar.gdttype -side left -fill y
2176 set findstring {}
2177 set fstring .tf.lbar.findstring
2178 lappend entries $fstring
2179 ${NS}::entry $fstring -width 30 -font textfont -textvariable findstring
2180 trace add variable findstring write find_change
2181 set findtype [mc "Exact"]
2182 set findtypemenu [makedroplist .tf.lbar.findtype \
2183 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2184 trace add variable findtype write findcom_change
2185 set findloc [mc "All fields"]
2186 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2187 [mc "Comments"] [mc "Author"] [mc "Committer"]
2188 trace add variable findloc write find_change
2189 pack .tf.lbar.findloc -side right
2190 pack .tf.lbar.findtype -side right
2191 pack $fstring -side left -expand 1 -fill x
2193 # Finish putting the upper half of the viewer together
2194 pack .tf.lbar -in .tf -side bottom -fill x
2195 pack .tf.bar -in .tf -side bottom -fill x
2196 pack .tf.histframe -fill both -side top -expand 1
2197 .ctop add .tf
2198 if {!$use_ttk} {
2199 .ctop paneconfigure .tf -height $geometry(topheight)
2200 .ctop paneconfigure .tf -width $geometry(topwidth)
2203 # now build up the bottom
2204 ${NS}::panedwindow .pwbottom -orient horizontal
2206 # lower left, a text box over search bar, scroll bar to the right
2207 # if we know window height, then that will set the lower text height, otherwise
2208 # we set lower text height which will drive window height
2209 if {[info exists geometry(main)]} {
2210 ${NS}::frame .bleft -width $geometry(botwidth)
2211 } else {
2212 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2214 ${NS}::frame .bleft.top
2215 ${NS}::frame .bleft.mid
2216 ${NS}::frame .bleft.bottom
2218 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2219 pack .bleft.top.search -side left -padx 5
2220 set sstring .bleft.top.sstring
2221 set searchstring ""
2222 ${NS}::entry $sstring -width 20 -font textfont -textvariable searchstring
2223 lappend entries $sstring
2224 trace add variable searchstring write incrsearch
2225 pack $sstring -side left -expand 1 -fill x
2226 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2227 -command changediffdisp -variable diffelide -value {0 0}
2228 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2229 -command changediffdisp -variable diffelide -value {0 1}
2230 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2231 -command changediffdisp -variable diffelide -value {1 0}
2232 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2233 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2234 spinbox .bleft.mid.diffcontext -width 5 \
2235 -from 0 -increment 1 -to 10000000 \
2236 -validate all -validatecommand "diffcontextvalidate %P" \
2237 -textvariable diffcontextstring
2238 .bleft.mid.diffcontext set $diffcontext
2239 trace add variable diffcontextstring write diffcontextchange
2240 lappend entries .bleft.mid.diffcontext
2241 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2242 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2243 -command changeignorespace -variable ignorespace
2244 pack .bleft.mid.ignspace -side left -padx 5
2245 set ctext .bleft.bottom.ctext
2246 text $ctext -background $bgcolor -foreground $fgcolor \
2247 -state disabled -font textfont \
2248 -yscrollcommand scrolltext -wrap none \
2249 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2250 if {$have_tk85} {
2251 $ctext conf -tabstyle wordprocessor
2253 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2254 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2255 pack .bleft.top -side top -fill x
2256 pack .bleft.mid -side top -fill x
2257 grid $ctext .bleft.bottom.sb -sticky nsew
2258 grid .bleft.bottom.sbhorizontal -sticky ew
2259 grid columnconfigure .bleft.bottom 0 -weight 1
2260 grid rowconfigure .bleft.bottom 0 -weight 1
2261 grid rowconfigure .bleft.bottom 1 -weight 0
2262 pack .bleft.bottom -side top -fill both -expand 1
2263 lappend bglist $ctext
2264 lappend fglist $ctext
2266 $ctext tag conf comment -wrap $wrapcomment
2267 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2268 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2269 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2270 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2271 $ctext tag conf m0 -fore red
2272 $ctext tag conf m1 -fore blue
2273 $ctext tag conf m2 -fore green
2274 $ctext tag conf m3 -fore purple
2275 $ctext tag conf m4 -fore brown
2276 $ctext tag conf m5 -fore "#009090"
2277 $ctext tag conf m6 -fore magenta
2278 $ctext tag conf m7 -fore "#808000"
2279 $ctext tag conf m8 -fore "#009000"
2280 $ctext tag conf m9 -fore "#ff0080"
2281 $ctext tag conf m10 -fore cyan
2282 $ctext tag conf m11 -fore "#b07070"
2283 $ctext tag conf m12 -fore "#70b0f0"
2284 $ctext tag conf m13 -fore "#70f0b0"
2285 $ctext tag conf m14 -fore "#f0b070"
2286 $ctext tag conf m15 -fore "#ff70b0"
2287 $ctext tag conf mmax -fore darkgrey
2288 set mergemax 16
2289 $ctext tag conf mresult -font textfontbold
2290 $ctext tag conf msep -font textfontbold
2291 $ctext tag conf found -back yellow
2293 .pwbottom add .bleft
2294 if {!$use_ttk} {
2295 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2298 # lower right
2299 ${NS}::frame .bright
2300 ${NS}::frame .bright.mode
2301 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2302 -command reselectline -variable cmitmode -value "patch"
2303 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2304 -command reselectline -variable cmitmode -value "tree"
2305 grid .bright.mode.patch .bright.mode.tree -sticky ew
2306 pack .bright.mode -side top -fill x
2307 set cflist .bright.cfiles
2308 set indent [font measure mainfont "nn"]
2309 text $cflist \
2310 -selectbackground $selectbgcolor \
2311 -background $bgcolor -foreground $fgcolor \
2312 -font mainfont \
2313 -tabs [list $indent [expr {2 * $indent}]] \
2314 -yscrollcommand ".bright.sb set" \
2315 -cursor [. cget -cursor] \
2316 -spacing1 1 -spacing3 1
2317 lappend bglist $cflist
2318 lappend fglist $cflist
2319 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2320 pack .bright.sb -side right -fill y
2321 pack $cflist -side left -fill both -expand 1
2322 $cflist tag configure highlight \
2323 -background [$cflist cget -selectbackground]
2324 $cflist tag configure bold -font mainfontbold
2326 .pwbottom add .bright
2327 .ctop add .pwbottom
2329 # restore window width & height if known
2330 if {[info exists geometry(main)]} {
2331 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2332 if {$w > [winfo screenwidth .]} {
2333 set w [winfo screenwidth .]
2335 if {$h > [winfo screenheight .]} {
2336 set h [winfo screenheight .]
2338 wm geometry . "${w}x$h"
2342 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2343 wm state . $geometry(state)
2346 if {[tk windowingsystem] eq {aqua}} {
2347 set M1B M1
2348 set ::BM "3"
2349 } else {
2350 set M1B Control
2351 set ::BM "2"
2354 if {$use_ttk} {
2355 bind .ctop <Map> {
2356 bind %W <Map> {}
2357 %W sashpos 0 $::geometry(topheight)
2359 bind .pwbottom <Map> {
2360 bind %W <Map> {}
2361 %W sashpos 0 $::geometry(botwidth)
2365 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2366 pack .ctop -fill both -expand 1
2367 bindall <1> {selcanvline %W %x %y}
2368 #bindall <B1-Motion> {selcanvline %W %x %y}
2369 if {[tk windowingsystem] == "win32"} {
2370 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2371 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2372 } else {
2373 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2374 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2375 if {[tk windowingsystem] eq "aqua"} {
2376 bindall <MouseWheel> {
2377 set delta [expr {- (%D)}]
2378 allcanvs yview scroll $delta units
2380 bindall <Shift-MouseWheel> {
2381 set delta [expr {- (%D)}]
2382 $canv xview scroll $delta units
2386 bindall <$::BM> "canvscan mark %W %x %y"
2387 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2388 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2389 bind . <$M1B-Key-w> doquit
2390 bindkey <Home> selfirstline
2391 bindkey <End> sellastline
2392 bind . <Key-Up> "selnextline -1"
2393 bind . <Key-Down> "selnextline 1"
2394 bind . <Shift-Key-Up> "dofind -1 0"
2395 bind . <Shift-Key-Down> "dofind 1 0"
2396 bindkey <Key-Right> "goforw"
2397 bindkey <Key-Left> "goback"
2398 bind . <Key-Prior> "selnextpage -1"
2399 bind . <Key-Next> "selnextpage 1"
2400 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2401 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2402 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2403 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2404 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2405 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2406 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2407 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2408 bindkey <Key-space> "$ctext yview scroll 1 pages"
2409 bindkey p "selnextline -1"
2410 bindkey n "selnextline 1"
2411 bindkey z "goback"
2412 bindkey x "goforw"
2413 bindkey i "selnextline -1"
2414 bindkey k "selnextline 1"
2415 bindkey j "goback"
2416 bindkey l "goforw"
2417 bindkey b prevfile
2418 bindkey d "$ctext yview scroll 18 units"
2419 bindkey u "$ctext yview scroll -18 units"
2420 bindkey / {focus $fstring}
2421 bindkey <Key-KP_Divide> {focus $fstring}
2422 bindkey <Key-Return> {dofind 1 1}
2423 bindkey ? {dofind -1 1}
2424 bindkey f nextfile
2425 bind . <F5> updatecommits
2426 bind . <$M1B-F5> reloadcommits
2427 bind . <F2> showrefs
2428 bind . <Shift-F4> {newview 0}
2429 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2430 bind . <F4> edit_or_newview
2431 bind . <$M1B-q> doquit
2432 bind . <$M1B-f> {dofind 1 1}
2433 bind . <$M1B-g> {dofind 1 0}
2434 bind . <$M1B-r> dosearchback
2435 bind . <$M1B-s> dosearch
2436 bind . <$M1B-equal> {incrfont 1}
2437 bind . <$M1B-plus> {incrfont 1}
2438 bind . <$M1B-KP_Add> {incrfont 1}
2439 bind . <$M1B-minus> {incrfont -1}
2440 bind . <$M1B-KP_Subtract> {incrfont -1}
2441 wm protocol . WM_DELETE_WINDOW doquit
2442 bind . <Destroy> {stop_backends}
2443 bind . <Button-1> "click %W"
2444 bind $fstring <Key-Return> {dofind 1 1}
2445 bind $sha1entry <Key-Return> {gotocommit; break}
2446 bind $sha1entry <<PasteSelection>> clearsha1
2447 bind $cflist <1> {sel_flist %W %x %y; break}
2448 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2449 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2450 global ctxbut
2451 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2452 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2454 set maincursor [. cget -cursor]
2455 set textcursor [$ctext cget -cursor]
2456 set curtextcursor $textcursor
2458 set rowctxmenu .rowctxmenu
2459 makemenu $rowctxmenu {
2460 {mc "Diff this -> selected" command {diffvssel 0}}
2461 {mc "Diff selected -> this" command {diffvssel 1}}
2462 {mc "Make patch" command mkpatch}
2463 {mc "Create tag" command mktag}
2464 {mc "Write commit to file" command writecommit}
2465 {mc "Create new branch" command mkbranch}
2466 {mc "Cherry-pick this commit" command cherrypick}
2467 {mc "Reset HEAD branch to here" command resethead}
2468 {mc "Mark this commit" command markhere}
2469 {mc "Return to mark" command gotomark}
2470 {mc "Find descendant of this and mark" command find_common_desc}
2471 {mc "Compare with marked commit" command compare_commits}
2473 $rowctxmenu configure -tearoff 0
2475 set fakerowmenu .fakerowmenu
2476 makemenu $fakerowmenu {
2477 {mc "Diff this -> selected" command {diffvssel 0}}
2478 {mc "Diff selected -> this" command {diffvssel 1}}
2479 {mc "Make patch" command mkpatch}
2481 $fakerowmenu configure -tearoff 0
2483 set headctxmenu .headctxmenu
2484 makemenu $headctxmenu {
2485 {mc "Check out this branch" command cobranch}
2486 {mc "Remove this branch" command rmbranch}
2488 $headctxmenu configure -tearoff 0
2490 global flist_menu
2491 set flist_menu .flistctxmenu
2492 makemenu $flist_menu {
2493 {mc "Highlight this too" command {flist_hl 0}}
2494 {mc "Highlight this only" command {flist_hl 1}}
2495 {mc "External diff" command {external_diff}}
2496 {mc "Blame parent commit" command {external_blame 1}}
2498 $flist_menu configure -tearoff 0
2500 global diff_menu
2501 set diff_menu .diffctxmenu
2502 makemenu $diff_menu {
2503 {mc "Show origin of this line" command show_line_source}
2504 {mc "Run git gui blame on this line" command {external_blame_diff}}
2506 $diff_menu configure -tearoff 0
2509 # Windows sends all mouse wheel events to the current focused window, not
2510 # the one where the mouse hovers, so bind those events here and redirect
2511 # to the correct window
2512 proc windows_mousewheel_redirector {W X Y D} {
2513 global canv canv2 canv3
2514 set w [winfo containing -displayof $W $X $Y]
2515 if {$w ne ""} {
2516 set u [expr {$D < 0 ? 5 : -5}]
2517 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2518 allcanvs yview scroll $u units
2519 } else {
2520 catch {
2521 $w yview scroll $u units
2527 # Update row number label when selectedline changes
2528 proc selectedline_change {n1 n2 op} {
2529 global selectedline rownumsel
2531 if {$selectedline eq {}} {
2532 set rownumsel {}
2533 } else {
2534 set rownumsel [expr {$selectedline + 1}]
2538 # mouse-2 makes all windows scan vertically, but only the one
2539 # the cursor is in scans horizontally
2540 proc canvscan {op w x y} {
2541 global canv canv2 canv3
2542 foreach c [list $canv $canv2 $canv3] {
2543 if {$c == $w} {
2544 $c scan $op $x $y
2545 } else {
2546 $c scan $op 0 $y
2551 proc scrollcanv {cscroll f0 f1} {
2552 $cscroll set $f0 $f1
2553 drawvisible
2554 flushhighlights
2557 # when we make a key binding for the toplevel, make sure
2558 # it doesn't get triggered when that key is pressed in the
2559 # find string entry widget.
2560 proc bindkey {ev script} {
2561 global entries
2562 bind . $ev $script
2563 set escript [bind Entry $ev]
2564 if {$escript == {}} {
2565 set escript [bind Entry <Key>]
2567 foreach e $entries {
2568 bind $e $ev "$escript; break"
2572 # set the focus back to the toplevel for any click outside
2573 # the entry widgets
2574 proc click {w} {
2575 global ctext entries
2576 foreach e [concat $entries $ctext] {
2577 if {$w == $e} return
2579 focus .
2582 # Adjust the progress bar for a change in requested extent or canvas size
2583 proc adjustprogress {} {
2584 global progresscanv progressitem progresscoords
2585 global fprogitem fprogcoord lastprogupdate progupdatepending
2586 global rprogitem rprogcoord use_ttk
2588 if {$use_ttk} {
2589 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2590 return
2593 set w [expr {[winfo width $progresscanv] - 4}]
2594 set x0 [expr {$w * [lindex $progresscoords 0]}]
2595 set x1 [expr {$w * [lindex $progresscoords 1]}]
2596 set h [winfo height $progresscanv]
2597 $progresscanv coords $progressitem $x0 0 $x1 $h
2598 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2599 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2600 set now [clock clicks -milliseconds]
2601 if {$now >= $lastprogupdate + 100} {
2602 set progupdatepending 0
2603 update
2604 } elseif {!$progupdatepending} {
2605 set progupdatepending 1
2606 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2610 proc doprogupdate {} {
2611 global lastprogupdate progupdatepending
2613 if {$progupdatepending} {
2614 set progupdatepending 0
2615 set lastprogupdate [clock clicks -milliseconds]
2616 update
2620 proc savestuff {w} {
2621 global canv canv2 canv3 mainfont textfont uifont tabstop
2622 global stuffsaved findmergefiles maxgraphpct
2623 global maxwidth showneartags showlocalchanges
2624 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2625 global cmitmode wrapcomment datetimeformat limitdiffs
2626 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2627 global autoselect extdifftool perfile_attrs markbgcolor use_ttk
2628 global hideremotes want_ttk
2630 if {$stuffsaved} return
2631 if {![winfo viewable .]} return
2632 catch {
2633 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2634 set f [open "~/.gitk-new" w]
2635 if {$::tcl_platform(platform) eq {windows}} {
2636 file attributes "~/.gitk-new" -hidden true
2638 puts $f [list set mainfont $mainfont]
2639 puts $f [list set textfont $textfont]
2640 puts $f [list set uifont $uifont]
2641 puts $f [list set tabstop $tabstop]
2642 puts $f [list set findmergefiles $findmergefiles]
2643 puts $f [list set maxgraphpct $maxgraphpct]
2644 puts $f [list set maxwidth $maxwidth]
2645 puts $f [list set cmitmode $cmitmode]
2646 puts $f [list set wrapcomment $wrapcomment]
2647 puts $f [list set autoselect $autoselect]
2648 puts $f [list set showneartags $showneartags]
2649 puts $f [list set hideremotes $hideremotes]
2650 puts $f [list set showlocalchanges $showlocalchanges]
2651 puts $f [list set datetimeformat $datetimeformat]
2652 puts $f [list set limitdiffs $limitdiffs]
2653 puts $f [list set uicolor $uicolor]
2654 puts $f [list set want_ttk $want_ttk]
2655 puts $f [list set bgcolor $bgcolor]
2656 puts $f [list set fgcolor $fgcolor]
2657 puts $f [list set colors $colors]
2658 puts $f [list set diffcolors $diffcolors]
2659 puts $f [list set markbgcolor $markbgcolor]
2660 puts $f [list set diffcontext $diffcontext]
2661 puts $f [list set selectbgcolor $selectbgcolor]
2662 puts $f [list set extdifftool $extdifftool]
2663 puts $f [list set perfile_attrs $perfile_attrs]
2665 puts $f "set geometry(main) [wm geometry .]"
2666 puts $f "set geometry(state) [wm state .]"
2667 puts $f "set geometry(topwidth) [winfo width .tf]"
2668 puts $f "set geometry(topheight) [winfo height .tf]"
2669 if {$use_ttk} {
2670 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2671 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2672 } else {
2673 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2674 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2676 puts $f "set geometry(botwidth) [winfo width .bleft]"
2677 puts $f "set geometry(botheight) [winfo height .bleft]"
2679 puts -nonewline $f "set permviews {"
2680 for {set v 0} {$v < $nextviewnum} {incr v} {
2681 if {$viewperm($v)} {
2682 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2685 puts $f "}"
2686 close $f
2687 file rename -force "~/.gitk-new" "~/.gitk"
2689 set stuffsaved 1
2692 proc resizeclistpanes {win w} {
2693 global oldwidth use_ttk
2694 if {[info exists oldwidth($win)]} {
2695 if {$use_ttk} {
2696 set s0 [$win sashpos 0]
2697 set s1 [$win sashpos 1]
2698 } else {
2699 set s0 [$win sash coord 0]
2700 set s1 [$win sash coord 1]
2702 if {$w < 60} {
2703 set sash0 [expr {int($w/2 - 2)}]
2704 set sash1 [expr {int($w*5/6 - 2)}]
2705 } else {
2706 set factor [expr {1.0 * $w / $oldwidth($win)}]
2707 set sash0 [expr {int($factor * [lindex $s0 0])}]
2708 set sash1 [expr {int($factor * [lindex $s1 0])}]
2709 if {$sash0 < 30} {
2710 set sash0 30
2712 if {$sash1 < $sash0 + 20} {
2713 set sash1 [expr {$sash0 + 20}]
2715 if {$sash1 > $w - 10} {
2716 set sash1 [expr {$w - 10}]
2717 if {$sash0 > $sash1 - 20} {
2718 set sash0 [expr {$sash1 - 20}]
2722 if {$use_ttk} {
2723 $win sashpos 0 $sash0
2724 $win sashpos 1 $sash1
2725 } else {
2726 $win sash place 0 $sash0 [lindex $s0 1]
2727 $win sash place 1 $sash1 [lindex $s1 1]
2730 set oldwidth($win) $w
2733 proc resizecdetpanes {win w} {
2734 global oldwidth use_ttk
2735 if {[info exists oldwidth($win)]} {
2736 if {$use_ttk} {
2737 set s0 [$win sashpos 0]
2738 } else {
2739 set s0 [$win sash coord 0]
2741 if {$w < 60} {
2742 set sash0 [expr {int($w*3/4 - 2)}]
2743 } else {
2744 set factor [expr {1.0 * $w / $oldwidth($win)}]
2745 set sash0 [expr {int($factor * [lindex $s0 0])}]
2746 if {$sash0 < 45} {
2747 set sash0 45
2749 if {$sash0 > $w - 15} {
2750 set sash0 [expr {$w - 15}]
2753 if {$use_ttk} {
2754 $win sashpos 0 $sash0
2755 } else {
2756 $win sash place 0 $sash0 [lindex $s0 1]
2759 set oldwidth($win) $w
2762 proc allcanvs args {
2763 global canv canv2 canv3
2764 eval $canv $args
2765 eval $canv2 $args
2766 eval $canv3 $args
2769 proc bindall {event action} {
2770 global canv canv2 canv3
2771 bind $canv $event $action
2772 bind $canv2 $event $action
2773 bind $canv3 $event $action
2776 proc about {} {
2777 global uifont NS
2778 set w .about
2779 if {[winfo exists $w]} {
2780 raise $w
2781 return
2783 ttk_toplevel $w
2784 wm title $w [mc "About gitk"]
2785 make_transient $w .
2786 message $w.m -text [mc "
2787 Gitk - a commit viewer for git
2789 Copyright © 2005-2009 Paul Mackerras
2791 Use and redistribute under the terms of the GNU General Public License"] \
2792 -justify center -aspect 400 -border 2 -bg white -relief groove
2793 pack $w.m -side top -fill x -padx 2 -pady 2
2794 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2795 pack $w.ok -side bottom
2796 bind $w <Visibility> "focus $w.ok"
2797 bind $w <Key-Escape> "destroy $w"
2798 bind $w <Key-Return> "destroy $w"
2799 tk::PlaceWindow $w widget .
2802 proc keys {} {
2803 global NS
2804 set w .keys
2805 if {[winfo exists $w]} {
2806 raise $w
2807 return
2809 if {[tk windowingsystem] eq {aqua}} {
2810 set M1T Cmd
2811 } else {
2812 set M1T Ctrl
2814 ttk_toplevel $w
2815 wm title $w [mc "Gitk key bindings"]
2816 make_transient $w .
2817 message $w.m -text "
2818 [mc "Gitk key bindings:"]
2820 [mc "<%s-Q> Quit" $M1T]
2821 [mc "<%s-W> Close window" $M1T]
2822 [mc "<Home> Move to first commit"]
2823 [mc "<End> Move to last commit"]
2824 [mc "<Up>, p, i Move up one commit"]
2825 [mc "<Down>, n, k Move down one commit"]
2826 [mc "<Left>, z, j Go back in history list"]
2827 [mc "<Right>, x, l Go forward in history list"]
2828 [mc "<PageUp> Move up one page in commit list"]
2829 [mc "<PageDown> Move down one page in commit list"]
2830 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2831 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2832 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2833 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2834 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2835 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2836 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2837 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2838 [mc "<Delete>, b Scroll diff view up one page"]
2839 [mc "<Backspace> Scroll diff view up one page"]
2840 [mc "<Space> Scroll diff view down one page"]
2841 [mc "u Scroll diff view up 18 lines"]
2842 [mc "d Scroll diff view down 18 lines"]
2843 [mc "<%s-F> Find" $M1T]
2844 [mc "<%s-G> Move to next find hit" $M1T]
2845 [mc "<Return> Move to next find hit"]
2846 [mc "/ Focus the search box"]
2847 [mc "? Move to previous find hit"]
2848 [mc "f Scroll diff view to next file"]
2849 [mc "<%s-S> Search for next hit in diff view" $M1T]
2850 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2851 [mc "<%s-KP+> Increase font size" $M1T]
2852 [mc "<%s-plus> Increase font size" $M1T]
2853 [mc "<%s-KP-> Decrease font size" $M1T]
2854 [mc "<%s-minus> Decrease font size" $M1T]
2855 [mc "<F5> Update"]
2857 -justify left -bg white -border 2 -relief groove
2858 pack $w.m -side top -fill both -padx 2 -pady 2
2859 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2860 bind $w <Key-Escape> [list destroy $w]
2861 pack $w.ok -side bottom
2862 bind $w <Visibility> "focus $w.ok"
2863 bind $w <Key-Escape> "destroy $w"
2864 bind $w <Key-Return> "destroy $w"
2867 # Procedures for manipulating the file list window at the
2868 # bottom right of the overall window.
2870 proc treeview {w l openlevs} {
2871 global treecontents treediropen treeheight treeparent treeindex
2873 set ix 0
2874 set treeindex() 0
2875 set lev 0
2876 set prefix {}
2877 set prefixend -1
2878 set prefendstack {}
2879 set htstack {}
2880 set ht 0
2881 set treecontents() {}
2882 $w conf -state normal
2883 foreach f $l {
2884 while {[string range $f 0 $prefixend] ne $prefix} {
2885 if {$lev <= $openlevs} {
2886 $w mark set e:$treeindex($prefix) "end -1c"
2887 $w mark gravity e:$treeindex($prefix) left
2889 set treeheight($prefix) $ht
2890 incr ht [lindex $htstack end]
2891 set htstack [lreplace $htstack end end]
2892 set prefixend [lindex $prefendstack end]
2893 set prefendstack [lreplace $prefendstack end end]
2894 set prefix [string range $prefix 0 $prefixend]
2895 incr lev -1
2897 set tail [string range $f [expr {$prefixend+1}] end]
2898 while {[set slash [string first "/" $tail]] >= 0} {
2899 lappend htstack $ht
2900 set ht 0
2901 lappend prefendstack $prefixend
2902 incr prefixend [expr {$slash + 1}]
2903 set d [string range $tail 0 $slash]
2904 lappend treecontents($prefix) $d
2905 set oldprefix $prefix
2906 append prefix $d
2907 set treecontents($prefix) {}
2908 set treeindex($prefix) [incr ix]
2909 set treeparent($prefix) $oldprefix
2910 set tail [string range $tail [expr {$slash+1}] end]
2911 if {$lev <= $openlevs} {
2912 set ht 1
2913 set treediropen($prefix) [expr {$lev < $openlevs}]
2914 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2915 $w mark set d:$ix "end -1c"
2916 $w mark gravity d:$ix left
2917 set str "\n"
2918 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2919 $w insert end $str
2920 $w image create end -align center -image $bm -padx 1 \
2921 -name a:$ix
2922 $w insert end $d [highlight_tag $prefix]
2923 $w mark set s:$ix "end -1c"
2924 $w mark gravity s:$ix left
2926 incr lev
2928 if {$tail ne {}} {
2929 if {$lev <= $openlevs} {
2930 incr ht
2931 set str "\n"
2932 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2933 $w insert end $str
2934 $w insert end $tail [highlight_tag $f]
2936 lappend treecontents($prefix) $tail
2939 while {$htstack ne {}} {
2940 set treeheight($prefix) $ht
2941 incr ht [lindex $htstack end]
2942 set htstack [lreplace $htstack end end]
2943 set prefixend [lindex $prefendstack end]
2944 set prefendstack [lreplace $prefendstack end end]
2945 set prefix [string range $prefix 0 $prefixend]
2947 $w conf -state disabled
2950 proc linetoelt {l} {
2951 global treeheight treecontents
2953 set y 2
2954 set prefix {}
2955 while {1} {
2956 foreach e $treecontents($prefix) {
2957 if {$y == $l} {
2958 return "$prefix$e"
2960 set n 1
2961 if {[string index $e end] eq "/"} {
2962 set n $treeheight($prefix$e)
2963 if {$y + $n > $l} {
2964 append prefix $e
2965 incr y
2966 break
2969 incr y $n
2974 proc highlight_tree {y prefix} {
2975 global treeheight treecontents cflist
2977 foreach e $treecontents($prefix) {
2978 set path $prefix$e
2979 if {[highlight_tag $path] ne {}} {
2980 $cflist tag add bold $y.0 "$y.0 lineend"
2982 incr y
2983 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2984 set y [highlight_tree $y $path]
2987 return $y
2990 proc treeclosedir {w dir} {
2991 global treediropen treeheight treeparent treeindex
2993 set ix $treeindex($dir)
2994 $w conf -state normal
2995 $w delete s:$ix e:$ix
2996 set treediropen($dir) 0
2997 $w image configure a:$ix -image tri-rt
2998 $w conf -state disabled
2999 set n [expr {1 - $treeheight($dir)}]
3000 while {$dir ne {}} {
3001 incr treeheight($dir) $n
3002 set dir $treeparent($dir)
3006 proc treeopendir {w dir} {
3007 global treediropen treeheight treeparent treecontents treeindex
3009 set ix $treeindex($dir)
3010 $w conf -state normal
3011 $w image configure a:$ix -image tri-dn
3012 $w mark set e:$ix s:$ix
3013 $w mark gravity e:$ix right
3014 set lev 0
3015 set str "\n"
3016 set n [llength $treecontents($dir)]
3017 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3018 incr lev
3019 append str "\t"
3020 incr treeheight($x) $n
3022 foreach e $treecontents($dir) {
3023 set de $dir$e
3024 if {[string index $e end] eq "/"} {
3025 set iy $treeindex($de)
3026 $w mark set d:$iy e:$ix
3027 $w mark gravity d:$iy left
3028 $w insert e:$ix $str
3029 set treediropen($de) 0
3030 $w image create e:$ix -align center -image tri-rt -padx 1 \
3031 -name a:$iy
3032 $w insert e:$ix $e [highlight_tag $de]
3033 $w mark set s:$iy e:$ix
3034 $w mark gravity s:$iy left
3035 set treeheight($de) 1
3036 } else {
3037 $w insert e:$ix $str
3038 $w insert e:$ix $e [highlight_tag $de]
3041 $w mark gravity e:$ix right
3042 $w conf -state disabled
3043 set treediropen($dir) 1
3044 set top [lindex [split [$w index @0,0] .] 0]
3045 set ht [$w cget -height]
3046 set l [lindex [split [$w index s:$ix] .] 0]
3047 if {$l < $top} {
3048 $w yview $l.0
3049 } elseif {$l + $n + 1 > $top + $ht} {
3050 set top [expr {$l + $n + 2 - $ht}]
3051 if {$l < $top} {
3052 set top $l
3054 $w yview $top.0
3058 proc treeclick {w x y} {
3059 global treediropen cmitmode ctext cflist cflist_top
3061 if {$cmitmode ne "tree"} return
3062 if {![info exists cflist_top]} return
3063 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3064 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3065 $cflist tag add highlight $l.0 "$l.0 lineend"
3066 set cflist_top $l
3067 if {$l == 1} {
3068 $ctext yview 1.0
3069 return
3071 set e [linetoelt $l]
3072 if {[string index $e end] ne "/"} {
3073 showfile $e
3074 } elseif {$treediropen($e)} {
3075 treeclosedir $w $e
3076 } else {
3077 treeopendir $w $e
3081 proc setfilelist {id} {
3082 global treefilelist cflist jump_to_here
3084 treeview $cflist $treefilelist($id) 0
3085 if {$jump_to_here ne {}} {
3086 set f [lindex $jump_to_here 0]
3087 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3088 showfile $f
3093 image create bitmap tri-rt -background black -foreground blue -data {
3094 #define tri-rt_width 13
3095 #define tri-rt_height 13
3096 static unsigned char tri-rt_bits[] = {
3097 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3098 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3099 0x00, 0x00};
3100 } -maskdata {
3101 #define tri-rt-mask_width 13
3102 #define tri-rt-mask_height 13
3103 static unsigned char tri-rt-mask_bits[] = {
3104 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3105 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3106 0x08, 0x00};
3108 image create bitmap tri-dn -background black -foreground blue -data {
3109 #define tri-dn_width 13
3110 #define tri-dn_height 13
3111 static unsigned char tri-dn_bits[] = {
3112 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3113 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3114 0x00, 0x00};
3115 } -maskdata {
3116 #define tri-dn-mask_width 13
3117 #define tri-dn-mask_height 13
3118 static unsigned char tri-dn-mask_bits[] = {
3119 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3120 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3121 0x00, 0x00};
3124 image create bitmap reficon-T -background black -foreground yellow -data {
3125 #define tagicon_width 13
3126 #define tagicon_height 9
3127 static unsigned char tagicon_bits[] = {
3128 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3129 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3130 } -maskdata {
3131 #define tagicon-mask_width 13
3132 #define tagicon-mask_height 9
3133 static unsigned char tagicon-mask_bits[] = {
3134 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3135 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3137 set rectdata {
3138 #define headicon_width 13
3139 #define headicon_height 9
3140 static unsigned char headicon_bits[] = {
3141 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3142 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3144 set rectmask {
3145 #define headicon-mask_width 13
3146 #define headicon-mask_height 9
3147 static unsigned char headicon-mask_bits[] = {
3148 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3149 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3151 image create bitmap reficon-H -background black -foreground green \
3152 -data $rectdata -maskdata $rectmask
3153 image create bitmap reficon-o -background black -foreground "#ddddff" \
3154 -data $rectdata -maskdata $rectmask
3156 proc init_flist {first} {
3157 global cflist cflist_top difffilestart
3159 $cflist conf -state normal
3160 $cflist delete 0.0 end
3161 if {$first ne {}} {
3162 $cflist insert end $first
3163 set cflist_top 1
3164 $cflist tag add highlight 1.0 "1.0 lineend"
3165 } else {
3166 catch {unset cflist_top}
3168 $cflist conf -state disabled
3169 set difffilestart {}
3172 proc highlight_tag {f} {
3173 global highlight_paths
3175 foreach p $highlight_paths {
3176 if {[string match $p $f]} {
3177 return "bold"
3180 return {}
3183 proc highlight_filelist {} {
3184 global cmitmode cflist
3186 $cflist conf -state normal
3187 if {$cmitmode ne "tree"} {
3188 set end [lindex [split [$cflist index end] .] 0]
3189 for {set l 2} {$l < $end} {incr l} {
3190 set line [$cflist get $l.0 "$l.0 lineend"]
3191 if {[highlight_tag $line] ne {}} {
3192 $cflist tag add bold $l.0 "$l.0 lineend"
3195 } else {
3196 highlight_tree 2 {}
3198 $cflist conf -state disabled
3201 proc unhighlight_filelist {} {
3202 global cflist
3204 $cflist conf -state normal
3205 $cflist tag remove bold 1.0 end
3206 $cflist conf -state disabled
3209 proc add_flist {fl} {
3210 global cflist
3212 $cflist conf -state normal
3213 foreach f $fl {
3214 $cflist insert end "\n"
3215 $cflist insert end $f [highlight_tag $f]
3217 $cflist conf -state disabled
3220 proc sel_flist {w x y} {
3221 global ctext difffilestart cflist cflist_top cmitmode
3223 if {$cmitmode eq "tree"} return
3224 if {![info exists cflist_top]} return
3225 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3226 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3227 $cflist tag add highlight $l.0 "$l.0 lineend"
3228 set cflist_top $l
3229 if {$l == 1} {
3230 $ctext yview 1.0
3231 } else {
3232 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3236 proc pop_flist_menu {w X Y x y} {
3237 global ctext cflist cmitmode flist_menu flist_menu_file
3238 global treediffs diffids
3240 stopfinding
3241 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3242 if {$l <= 1} return
3243 if {$cmitmode eq "tree"} {
3244 set e [linetoelt $l]
3245 if {[string index $e end] eq "/"} return
3246 } else {
3247 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3249 set flist_menu_file $e
3250 set xdiffstate "normal"
3251 if {$cmitmode eq "tree"} {
3252 set xdiffstate "disabled"
3254 # Disable "External diff" item in tree mode
3255 $flist_menu entryconf 2 -state $xdiffstate
3256 tk_popup $flist_menu $X $Y
3259 proc find_ctext_fileinfo {line} {
3260 global ctext_file_names ctext_file_lines
3262 set ok [bsearch $ctext_file_lines $line]
3263 set tline [lindex $ctext_file_lines $ok]
3265 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3266 return {}
3267 } else {
3268 return [list [lindex $ctext_file_names $ok] $tline]
3272 proc pop_diff_menu {w X Y x y} {
3273 global ctext diff_menu flist_menu_file
3274 global diff_menu_txtpos diff_menu_line
3275 global diff_menu_filebase
3277 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3278 set diff_menu_line [lindex $diff_menu_txtpos 0]
3279 # don't pop up the menu on hunk-separator or file-separator lines
3280 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3281 return
3283 stopfinding
3284 set f [find_ctext_fileinfo $diff_menu_line]
3285 if {$f eq {}} return
3286 set flist_menu_file [lindex $f 0]
3287 set diff_menu_filebase [lindex $f 1]
3288 tk_popup $diff_menu $X $Y
3291 proc flist_hl {only} {
3292 global flist_menu_file findstring gdttype
3294 set x [shellquote $flist_menu_file]
3295 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3296 set findstring $x
3297 } else {
3298 append findstring " " $x
3300 set gdttype [mc "touching paths:"]
3303 proc gitknewtmpdir {} {
3304 global diffnum gitktmpdir gitdir
3306 if {![info exists gitktmpdir]} {
3307 set gitktmpdir [file join [file dirname $gitdir] \
3308 [format ".gitk-tmp.%s" [pid]]]
3309 if {[catch {file mkdir $gitktmpdir} err]} {
3310 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3311 unset gitktmpdir
3312 return {}
3314 set diffnum 0
3316 incr diffnum
3317 set diffdir [file join $gitktmpdir $diffnum]
3318 if {[catch {file mkdir $diffdir} err]} {
3319 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3320 return {}
3322 return $diffdir
3325 proc save_file_from_commit {filename output what} {
3326 global nullfile
3328 if {[catch {exec git show $filename -- > $output} err]} {
3329 if {[string match "fatal: bad revision *" $err]} {
3330 return $nullfile
3332 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3333 return {}
3335 return $output
3338 proc external_diff_get_one_file {diffid filename diffdir} {
3339 global nullid nullid2 nullfile
3340 global gitdir
3342 if {$diffid == $nullid} {
3343 set difffile [file join [file dirname $gitdir] $filename]
3344 if {[file exists $difffile]} {
3345 return $difffile
3347 return $nullfile
3349 if {$diffid == $nullid2} {
3350 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3351 return [save_file_from_commit :$filename $difffile index]
3353 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3354 return [save_file_from_commit $diffid:$filename $difffile \
3355 "revision $diffid"]
3358 proc external_diff {} {
3359 global nullid nullid2
3360 global flist_menu_file
3361 global diffids
3362 global extdifftool
3364 if {[llength $diffids] == 1} {
3365 # no reference commit given
3366 set diffidto [lindex $diffids 0]
3367 if {$diffidto eq $nullid} {
3368 # diffing working copy with index
3369 set diffidfrom $nullid2
3370 } elseif {$diffidto eq $nullid2} {
3371 # diffing index with HEAD
3372 set diffidfrom "HEAD"
3373 } else {
3374 # use first parent commit
3375 global parentlist selectedline
3376 set diffidfrom [lindex $parentlist $selectedline 0]
3378 } else {
3379 set diffidfrom [lindex $diffids 0]
3380 set diffidto [lindex $diffids 1]
3383 # make sure that several diffs wont collide
3384 set diffdir [gitknewtmpdir]
3385 if {$diffdir eq {}} return
3387 # gather files to diff
3388 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3389 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3391 if {$difffromfile ne {} && $difftofile ne {}} {
3392 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3393 if {[catch {set fl [open |$cmd r]} err]} {
3394 file delete -force $diffdir
3395 error_popup "$extdifftool: [mc "command failed:"] $err"
3396 } else {
3397 fconfigure $fl -blocking 0
3398 filerun $fl [list delete_at_eof $fl $diffdir]
3403 proc find_hunk_blamespec {base line} {
3404 global ctext
3406 # Find and parse the hunk header
3407 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3408 if {$s_lix eq {}} return
3410 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3411 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3412 s_line old_specs osz osz1 new_line nsz]} {
3413 return
3416 # base lines for the parents
3417 set base_lines [list $new_line]
3418 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3419 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3420 old_spec old_line osz]} {
3421 return
3423 lappend base_lines $old_line
3426 # Now scan the lines to determine offset within the hunk
3427 set max_parent [expr {[llength $base_lines]-2}]
3428 set dline 0
3429 set s_lno [lindex [split $s_lix "."] 0]
3431 # Determine if the line is removed
3432 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3433 if {[string match {[-+ ]*} $chunk]} {
3434 set removed_idx [string first "-" $chunk]
3435 # Choose a parent index
3436 if {$removed_idx >= 0} {
3437 set parent $removed_idx
3438 } else {
3439 set unchanged_idx [string first " " $chunk]
3440 if {$unchanged_idx >= 0} {
3441 set parent $unchanged_idx
3442 } else {
3443 # blame the current commit
3444 set parent -1
3447 # then count other lines that belong to it
3448 for {set i $line} {[incr i -1] > $s_lno} {} {
3449 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3450 # Determine if the line is removed
3451 set removed_idx [string first "-" $chunk]
3452 if {$parent >= 0} {
3453 set code [string index $chunk $parent]
3454 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3455 incr dline
3457 } else {
3458 if {$removed_idx < 0} {
3459 incr dline
3463 incr parent
3464 } else {
3465 set parent 0
3468 incr dline [lindex $base_lines $parent]
3469 return [list $parent $dline]
3472 proc external_blame_diff {} {
3473 global currentid cmitmode
3474 global diff_menu_txtpos diff_menu_line
3475 global diff_menu_filebase flist_menu_file
3477 if {$cmitmode eq "tree"} {
3478 set parent_idx 0
3479 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3480 } else {
3481 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3482 if {$hinfo ne {}} {
3483 set parent_idx [lindex $hinfo 0]
3484 set line [lindex $hinfo 1]
3485 } else {
3486 set parent_idx 0
3487 set line 0
3491 external_blame $parent_idx $line
3494 # Find the SHA1 ID of the blob for file $fname in the index
3495 # at stage 0 or 2
3496 proc index_sha1 {fname} {
3497 set f [open [list | git ls-files -s $fname] r]
3498 while {[gets $f line] >= 0} {
3499 set info [lindex [split $line "\t"] 0]
3500 set stage [lindex $info 2]
3501 if {$stage eq "0" || $stage eq "2"} {
3502 close $f
3503 return [lindex $info 1]
3506 close $f
3507 return {}
3510 # Turn an absolute path into one relative to the current directory
3511 proc make_relative {f} {
3512 if {[file pathtype $f] eq "relative"} {
3513 return $f
3515 set elts [file split $f]
3516 set here [file split [pwd]]
3517 set ei 0
3518 set hi 0
3519 set res {}
3520 foreach d $here {
3521 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3522 lappend res ".."
3523 } else {
3524 incr ei
3526 incr hi
3528 set elts [concat $res [lrange $elts $ei end]]
3529 return [eval file join $elts]
3532 proc external_blame {parent_idx {line {}}} {
3533 global flist_menu_file gitdir
3534 global nullid nullid2
3535 global parentlist selectedline currentid
3537 if {$parent_idx > 0} {
3538 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3539 } else {
3540 set base_commit $currentid
3543 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3544 error_popup [mc "No such commit"]
3545 return
3548 set cmdline [list git gui blame]
3549 if {$line ne {} && $line > 1} {
3550 lappend cmdline "--line=$line"
3552 set f [file join [file dirname $gitdir] $flist_menu_file]
3553 # Unfortunately it seems git gui blame doesn't like
3554 # being given an absolute path...
3555 set f [make_relative $f]
3556 lappend cmdline $base_commit $f
3557 if {[catch {eval exec $cmdline &} err]} {
3558 error_popup "[mc "git gui blame: command failed:"] $err"
3562 proc show_line_source {} {
3563 global cmitmode currentid parents curview blamestuff blameinst
3564 global diff_menu_line diff_menu_filebase flist_menu_file
3565 global nullid nullid2 gitdir
3567 set from_index {}
3568 if {$cmitmode eq "tree"} {
3569 set id $currentid
3570 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3571 } else {
3572 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3573 if {$h eq {}} return
3574 set pi [lindex $h 0]
3575 if {$pi == 0} {
3576 mark_ctext_line $diff_menu_line
3577 return
3579 incr pi -1
3580 if {$currentid eq $nullid} {
3581 if {$pi > 0} {
3582 # must be a merge in progress...
3583 if {[catch {
3584 # get the last line from .git/MERGE_HEAD
3585 set f [open [file join $gitdir MERGE_HEAD] r]
3586 set id [lindex [split [read $f] "\n"] end-1]
3587 close $f
3588 } err]} {
3589 error_popup [mc "Couldn't read merge head: %s" $err]
3590 return
3592 } elseif {$parents($curview,$currentid) eq $nullid2} {
3593 # need to do the blame from the index
3594 if {[catch {
3595 set from_index [index_sha1 $flist_menu_file]
3596 } err]} {
3597 error_popup [mc "Error reading index: %s" $err]
3598 return
3600 } else {
3601 set id $parents($curview,$currentid)
3603 } else {
3604 set id [lindex $parents($curview,$currentid) $pi]
3606 set line [lindex $h 1]
3608 set blameargs {}
3609 if {$from_index ne {}} {
3610 lappend blameargs | git cat-file blob $from_index
3612 lappend blameargs | git blame -p -L$line,+1
3613 if {$from_index ne {}} {
3614 lappend blameargs --contents -
3615 } else {
3616 lappend blameargs $id
3618 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3619 if {[catch {
3620 set f [open $blameargs r]
3621 } err]} {
3622 error_popup [mc "Couldn't start git blame: %s" $err]
3623 return
3625 nowbusy blaming [mc "Searching"]
3626 fconfigure $f -blocking 0
3627 set i [reg_instance $f]
3628 set blamestuff($i) {}
3629 set blameinst $i
3630 filerun $f [list read_line_source $f $i]
3633 proc stopblaming {} {
3634 global blameinst
3636 if {[info exists blameinst]} {
3637 stop_instance $blameinst
3638 unset blameinst
3639 notbusy blaming
3643 proc read_line_source {fd inst} {
3644 global blamestuff curview commfd blameinst nullid nullid2
3646 while {[gets $fd line] >= 0} {
3647 lappend blamestuff($inst) $line
3649 if {![eof $fd]} {
3650 return 1
3652 unset commfd($inst)
3653 unset blameinst
3654 notbusy blaming
3655 fconfigure $fd -blocking 1
3656 if {[catch {close $fd} err]} {
3657 error_popup [mc "Error running git blame: %s" $err]
3658 return 0
3661 set fname {}
3662 set line [split [lindex $blamestuff($inst) 0] " "]
3663 set id [lindex $line 0]
3664 set lnum [lindex $line 1]
3665 if {[string length $id] == 40 && [string is xdigit $id] &&
3666 [string is digit -strict $lnum]} {
3667 # look for "filename" line
3668 foreach l $blamestuff($inst) {
3669 if {[string match "filename *" $l]} {
3670 set fname [string range $l 9 end]
3671 break
3675 if {$fname ne {}} {
3676 # all looks good, select it
3677 if {$id eq $nullid} {
3678 # blame uses all-zeroes to mean not committed,
3679 # which would mean a change in the index
3680 set id $nullid2
3682 if {[commitinview $id $curview]} {
3683 selectline [rowofcommit $id] 1 [list $fname $lnum]
3684 } else {
3685 error_popup [mc "That line comes from commit %s, \
3686 which is not in this view" [shortids $id]]
3688 } else {
3689 puts "oops couldn't parse git blame output"
3691 return 0
3694 # delete $dir when we see eof on $f (presumably because the child has exited)
3695 proc delete_at_eof {f dir} {
3696 while {[gets $f line] >= 0} {}
3697 if {[eof $f]} {
3698 if {[catch {close $f} err]} {
3699 error_popup "[mc "External diff viewer failed:"] $err"
3701 file delete -force $dir
3702 return 0
3704 return 1
3707 # Functions for adding and removing shell-type quoting
3709 proc shellquote {str} {
3710 if {![string match "*\['\"\\ \t]*" $str]} {
3711 return $str
3713 if {![string match "*\['\"\\]*" $str]} {
3714 return "\"$str\""
3716 if {![string match "*'*" $str]} {
3717 return "'$str'"
3719 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3722 proc shellarglist {l} {
3723 set str {}
3724 foreach a $l {
3725 if {$str ne {}} {
3726 append str " "
3728 append str [shellquote $a]
3730 return $str
3733 proc shelldequote {str} {
3734 set ret {}
3735 set used -1
3736 while {1} {
3737 incr used
3738 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3739 append ret [string range $str $used end]
3740 set used [string length $str]
3741 break
3743 set first [lindex $first 0]
3744 set ch [string index $str $first]
3745 if {$first > $used} {
3746 append ret [string range $str $used [expr {$first - 1}]]
3747 set used $first
3749 if {$ch eq " " || $ch eq "\t"} break
3750 incr used
3751 if {$ch eq "'"} {
3752 set first [string first "'" $str $used]
3753 if {$first < 0} {
3754 error "unmatched single-quote"
3756 append ret [string range $str $used [expr {$first - 1}]]
3757 set used $first
3758 continue
3760 if {$ch eq "\\"} {
3761 if {$used >= [string length $str]} {
3762 error "trailing backslash"
3764 append ret [string index $str $used]
3765 continue
3767 # here ch == "\""
3768 while {1} {
3769 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3770 error "unmatched double-quote"
3772 set first [lindex $first 0]
3773 set ch [string index $str $first]
3774 if {$first > $used} {
3775 append ret [string range $str $used [expr {$first - 1}]]
3776 set used $first
3778 if {$ch eq "\""} break
3779 incr used
3780 append ret [string index $str $used]
3781 incr used
3784 return [list $used $ret]
3787 proc shellsplit {str} {
3788 set l {}
3789 while {1} {
3790 set str [string trimleft $str]
3791 if {$str eq {}} break
3792 set dq [shelldequote $str]
3793 set n [lindex $dq 0]
3794 set word [lindex $dq 1]
3795 set str [string range $str $n end]
3796 lappend l $word
3798 return $l
3801 # Code to implement multiple views
3803 proc newview {ishighlight} {
3804 global nextviewnum newviewname newishighlight
3805 global revtreeargs viewargscmd newviewopts curview
3807 set newishighlight $ishighlight
3808 set top .gitkview
3809 if {[winfo exists $top]} {
3810 raise $top
3811 return
3813 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3814 set newviewopts($nextviewnum,perm) 0
3815 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3816 decode_view_opts $nextviewnum $revtreeargs
3817 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3820 set known_view_options {
3821 {perm b . {} {mc "Remember this view"}}
3822 {reflabel l + {} {mc "References (space separated list):"}}
3823 {refs t15 .. {} {mc "Branches & tags:"}}
3824 {allrefs b *. "--all" {mc "All refs"}}
3825 {branches b . "--branches" {mc "All (local) branches"}}
3826 {tags b . "--tags" {mc "All tags"}}
3827 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3828 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3829 {author t15 .. "--author=*" {mc "Author:"}}
3830 {committer t15 . "--committer=*" {mc "Committer:"}}
3831 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3832 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3833 {changes_l l + {} {mc "Changes to Files:"}}
3834 {pickaxe_s r0 . {} {mc "Fixed String"}}
3835 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3836 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3837 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3838 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3839 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3840 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3841 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3842 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3843 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3844 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3845 {lright b . "--left-right" {mc "Mark branch sides"}}
3846 {first b . "--first-parent" {mc "Limit to first parent"}}
3847 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3848 {args t50 *. {} {mc "Additional arguments to git log:"}}
3849 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3850 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3853 proc encode_view_opts {n} {
3854 global known_view_options newviewopts
3856 set rargs [list]
3857 foreach opt $known_view_options {
3858 set patterns [lindex $opt 3]
3859 if {$patterns eq {}} continue
3860 set pattern [lindex $patterns 0]
3862 if {[lindex $opt 1] eq "b"} {
3863 set val $newviewopts($n,[lindex $opt 0])
3864 if {$val} {
3865 lappend rargs $pattern
3867 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3868 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3869 set val $newviewopts($n,$button_id)
3870 if {$val eq $value} {
3871 lappend rargs $pattern
3873 } else {
3874 set val $newviewopts($n,[lindex $opt 0])
3875 set val [string trim $val]
3876 if {$val ne {}} {
3877 set pfix [string range $pattern 0 end-1]
3878 lappend rargs $pfix$val
3882 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3883 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3886 proc decode_view_opts {n view_args} {
3887 global known_view_options newviewopts
3889 foreach opt $known_view_options {
3890 set id [lindex $opt 0]
3891 if {[lindex $opt 1] eq "b"} {
3892 # Checkboxes
3893 set val 0
3894 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3895 # Radiobuttons
3896 regexp {^(.*_)} $id uselessvar id
3897 set val 0
3898 } else {
3899 # Text fields
3900 set val {}
3902 set newviewopts($n,$id) $val
3904 set oargs [list]
3905 set refargs [list]
3906 foreach arg $view_args {
3907 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3908 && ![info exists found(limit)]} {
3909 set newviewopts($n,limit) $cnt
3910 set found(limit) 1
3911 continue
3913 catch { unset val }
3914 foreach opt $known_view_options {
3915 set id [lindex $opt 0]
3916 if {[info exists found($id)]} continue
3917 foreach pattern [lindex $opt 3] {
3918 if {![string match $pattern $arg]} continue
3919 if {[lindex $opt 1] eq "b"} {
3920 # Check buttons
3921 set val 1
3922 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3923 # Radio buttons
3924 regexp {^(.*_)} $id uselessvar id
3925 set val $num
3926 } else {
3927 # Text input fields
3928 set size [string length $pattern]
3929 set val [string range $arg [expr {$size-1}] end]
3931 set newviewopts($n,$id) $val
3932 set found($id) 1
3933 break
3935 if {[info exists val]} break
3937 if {[info exists val]} continue
3938 if {[regexp {^-} $arg]} {
3939 lappend oargs $arg
3940 } else {
3941 lappend refargs $arg
3944 set newviewopts($n,refs) [shellarglist $refargs]
3945 set newviewopts($n,args) [shellarglist $oargs]
3948 proc edit_or_newview {} {
3949 global curview
3951 if {$curview > 0} {
3952 editview
3953 } else {
3954 newview 0
3958 proc editview {} {
3959 global curview
3960 global viewname viewperm newviewname newviewopts
3961 global viewargs viewargscmd
3963 set top .gitkvedit-$curview
3964 if {[winfo exists $top]} {
3965 raise $top
3966 return
3968 set newviewname($curview) $viewname($curview)
3969 set newviewopts($curview,perm) $viewperm($curview)
3970 set newviewopts($curview,cmd) $viewargscmd($curview)
3971 decode_view_opts $curview $viewargs($curview)
3972 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3975 proc vieweditor {top n title} {
3976 global newviewname newviewopts viewfiles bgcolor
3977 global known_view_options NS
3979 ttk_toplevel $top
3980 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3981 make_transient $top .
3983 # View name
3984 ${NS}::frame $top.nfr
3985 ${NS}::label $top.nl -text [mc "View Name"]
3986 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
3987 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3988 pack $top.nl -in $top.nfr -side left -padx {0 5}
3989 pack $top.name -in $top.nfr -side left -padx {0 25}
3991 # View options
3992 set cframe $top.nfr
3993 set cexpand 0
3994 set cnt 0
3995 foreach opt $known_view_options {
3996 set id [lindex $opt 0]
3997 set type [lindex $opt 1]
3998 set flags [lindex $opt 2]
3999 set title [eval [lindex $opt 4]]
4000 set lxpad 0
4002 if {$flags eq "+" || $flags eq "*"} {
4003 set cframe $top.fr$cnt
4004 incr cnt
4005 ${NS}::frame $cframe
4006 pack $cframe -in $top -fill x -pady 3 -padx 3
4007 set cexpand [expr {$flags eq "*"}]
4008 } elseif {$flags eq ".." || $flags eq "*."} {
4009 set cframe $top.fr$cnt
4010 incr cnt
4011 ${NS}::frame $cframe
4012 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4013 set cexpand [expr {$flags eq "*."}]
4014 } else {
4015 set lxpad 5
4018 if {$type eq "l"} {
4019 ${NS}::label $cframe.l_$id -text $title
4020 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4021 } elseif {$type eq "b"} {
4022 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4023 pack $cframe.c_$id -in $cframe -side left \
4024 -padx [list $lxpad 0] -expand $cexpand -anchor w
4025 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4026 regexp {^(.*_)} $id uselessvar button_id
4027 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4028 pack $cframe.c_$id -in $cframe -side left \
4029 -padx [list $lxpad 0] -expand $cexpand -anchor w
4030 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4031 ${NS}::label $cframe.l_$id -text $title
4032 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4033 -textvariable newviewopts($n,$id)
4034 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4035 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4036 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4037 ${NS}::label $cframe.l_$id -text $title
4038 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4039 -textvariable newviewopts($n,$id)
4040 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4041 pack $cframe.e_$id -in $cframe -side top -fill x
4042 } elseif {$type eq "path"} {
4043 ${NS}::label $top.l -text $title
4044 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4045 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
4046 if {[info exists viewfiles($n)]} {
4047 foreach f $viewfiles($n) {
4048 $top.t insert end $f
4049 $top.t insert end "\n"
4051 $top.t delete {end - 1c} end
4052 $top.t mark set insert 0.0
4054 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4058 ${NS}::frame $top.buts
4059 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4060 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4061 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4062 bind $top <Control-Return> [list newviewok $top $n]
4063 bind $top <F5> [list newviewok $top $n 1]
4064 bind $top <Escape> [list destroy $top]
4065 grid $top.buts.ok $top.buts.apply $top.buts.can
4066 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4067 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4068 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4069 pack $top.buts -in $top -side top -fill x
4070 focus $top.t
4073 proc doviewmenu {m first cmd op argv} {
4074 set nmenu [$m index end]
4075 for {set i $first} {$i <= $nmenu} {incr i} {
4076 if {[$m entrycget $i -command] eq $cmd} {
4077 eval $m $op $i $argv
4078 break
4083 proc allviewmenus {n op args} {
4084 # global viewhlmenu
4086 doviewmenu .bar.view 5 [list showview $n] $op $args
4087 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4090 proc newviewok {top n {apply 0}} {
4091 global nextviewnum newviewperm newviewname newishighlight
4092 global viewname viewfiles viewperm selectedview curview
4093 global viewargs viewargscmd newviewopts viewhlmenu
4095 if {[catch {
4096 set newargs [encode_view_opts $n]
4097 } err]} {
4098 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4099 return
4101 set files {}
4102 foreach f [split [$top.t get 0.0 end] "\n"] {
4103 set ft [string trim $f]
4104 if {$ft ne {}} {
4105 lappend files $ft
4108 if {![info exists viewfiles($n)]} {
4109 # creating a new view
4110 incr nextviewnum
4111 set viewname($n) $newviewname($n)
4112 set viewperm($n) $newviewopts($n,perm)
4113 set viewfiles($n) $files
4114 set viewargs($n) $newargs
4115 set viewargscmd($n) $newviewopts($n,cmd)
4116 addviewmenu $n
4117 if {!$newishighlight} {
4118 run showview $n
4119 } else {
4120 run addvhighlight $n
4122 } else {
4123 # editing an existing view
4124 set viewperm($n) $newviewopts($n,perm)
4125 if {$newviewname($n) ne $viewname($n)} {
4126 set viewname($n) $newviewname($n)
4127 doviewmenu .bar.view 5 [list showview $n] \
4128 entryconf [list -label $viewname($n)]
4129 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4130 # entryconf [list -label $viewname($n) -value $viewname($n)]
4132 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4133 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4134 set viewfiles($n) $files
4135 set viewargs($n) $newargs
4136 set viewargscmd($n) $newviewopts($n,cmd)
4137 if {$curview == $n} {
4138 run reloadcommits
4142 if {$apply} return
4143 catch {destroy $top}
4146 proc delview {} {
4147 global curview viewperm hlview selectedhlview
4149 if {$curview == 0} return
4150 if {[info exists hlview] && $hlview == $curview} {
4151 set selectedhlview [mc "None"]
4152 unset hlview
4154 allviewmenus $curview delete
4155 set viewperm($curview) 0
4156 showview 0
4159 proc addviewmenu {n} {
4160 global viewname viewhlmenu
4162 .bar.view add radiobutton -label $viewname($n) \
4163 -command [list showview $n] -variable selectedview -value $n
4164 #$viewhlmenu add radiobutton -label $viewname($n) \
4165 # -command [list addvhighlight $n] -variable selectedhlview
4168 proc showview {n} {
4169 global curview cached_commitrow ordertok
4170 global displayorder parentlist rowidlist rowisopt rowfinal
4171 global colormap rowtextx nextcolor canvxmax
4172 global numcommits viewcomplete
4173 global selectedline currentid canv canvy0
4174 global treediffs
4175 global pending_select mainheadid
4176 global commitidx
4177 global selectedview
4178 global hlview selectedhlview commitinterest
4180 if {$n == $curview} return
4181 set selid {}
4182 set ymax [lindex [$canv cget -scrollregion] 3]
4183 set span [$canv yview]
4184 set ytop [expr {[lindex $span 0] * $ymax}]
4185 set ybot [expr {[lindex $span 1] * $ymax}]
4186 set yscreen [expr {($ybot - $ytop) / 2}]
4187 if {$selectedline ne {}} {
4188 set selid $currentid
4189 set y [yc $selectedline]
4190 if {$ytop < $y && $y < $ybot} {
4191 set yscreen [expr {$y - $ytop}]
4193 } elseif {[info exists pending_select]} {
4194 set selid $pending_select
4195 unset pending_select
4197 unselectline
4198 normalline
4199 catch {unset treediffs}
4200 clear_display
4201 if {[info exists hlview] && $hlview == $n} {
4202 unset hlview
4203 set selectedhlview [mc "None"]
4205 catch {unset commitinterest}
4206 catch {unset cached_commitrow}
4207 catch {unset ordertok}
4209 set curview $n
4210 set selectedview $n
4211 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4212 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4214 run refill_reflist
4215 if {![info exists viewcomplete($n)]} {
4216 getcommits $selid
4217 return
4220 set displayorder {}
4221 set parentlist {}
4222 set rowidlist {}
4223 set rowisopt {}
4224 set rowfinal {}
4225 set numcommits $commitidx($n)
4227 catch {unset colormap}
4228 catch {unset rowtextx}
4229 set nextcolor 0
4230 set canvxmax [$canv cget -width]
4231 set curview $n
4232 set row 0
4233 setcanvscroll
4234 set yf 0
4235 set row {}
4236 if {$selid ne {} && [commitinview $selid $n]} {
4237 set row [rowofcommit $selid]
4238 # try to get the selected row in the same position on the screen
4239 set ymax [lindex [$canv cget -scrollregion] 3]
4240 set ytop [expr {[yc $row] - $yscreen}]
4241 if {$ytop < 0} {
4242 set ytop 0
4244 set yf [expr {$ytop * 1.0 / $ymax}]
4246 allcanvs yview moveto $yf
4247 drawvisible
4248 if {$row ne {}} {
4249 selectline $row 0
4250 } elseif {!$viewcomplete($n)} {
4251 reset_pending_select $selid
4252 } else {
4253 reset_pending_select {}
4255 if {[commitinview $pending_select $curview]} {
4256 selectline [rowofcommit $pending_select] 1
4257 } else {
4258 set row [first_real_row]
4259 if {$row < $numcommits} {
4260 selectline $row 0
4264 if {!$viewcomplete($n)} {
4265 if {$numcommits == 0} {
4266 show_status [mc "Reading commits..."]
4268 } elseif {$numcommits == 0} {
4269 show_status [mc "No commits selected"]
4273 # Stuff relating to the highlighting facility
4275 proc ishighlighted {id} {
4276 global vhighlights fhighlights nhighlights rhighlights
4278 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4279 return $nhighlights($id)
4281 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4282 return $vhighlights($id)
4284 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4285 return $fhighlights($id)
4287 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4288 return $rhighlights($id)
4290 return 0
4293 proc bolden {id font} {
4294 global canv linehtag currentid boldids need_redisplay markedid
4296 # need_redisplay = 1 means the display is stale and about to be redrawn
4297 if {$need_redisplay} return
4298 lappend boldids $id
4299 $canv itemconf $linehtag($id) -font $font
4300 if {[info exists currentid] && $id eq $currentid} {
4301 $canv delete secsel
4302 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4303 -outline {{}} -tags secsel \
4304 -fill [$canv cget -selectbackground]]
4305 $canv lower $t
4307 if {[info exists markedid] && $id eq $markedid} {
4308 make_idmark $id
4312 proc bolden_name {id font} {
4313 global canv2 linentag currentid boldnameids need_redisplay
4315 if {$need_redisplay} return
4316 lappend boldnameids $id
4317 $canv2 itemconf $linentag($id) -font $font
4318 if {[info exists currentid] && $id eq $currentid} {
4319 $canv2 delete secsel
4320 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4321 -outline {{}} -tags secsel \
4322 -fill [$canv2 cget -selectbackground]]
4323 $canv2 lower $t
4327 proc unbolden {} {
4328 global boldids
4330 set stillbold {}
4331 foreach id $boldids {
4332 if {![ishighlighted $id]} {
4333 bolden $id mainfont
4334 } else {
4335 lappend stillbold $id
4338 set boldids $stillbold
4341 proc addvhighlight {n} {
4342 global hlview viewcomplete curview vhl_done commitidx
4344 if {[info exists hlview]} {
4345 delvhighlight
4347 set hlview $n
4348 if {$n != $curview && ![info exists viewcomplete($n)]} {
4349 start_rev_list $n
4351 set vhl_done $commitidx($hlview)
4352 if {$vhl_done > 0} {
4353 drawvisible
4357 proc delvhighlight {} {
4358 global hlview vhighlights
4360 if {![info exists hlview]} return
4361 unset hlview
4362 catch {unset vhighlights}
4363 unbolden
4366 proc vhighlightmore {} {
4367 global hlview vhl_done commitidx vhighlights curview
4369 set max $commitidx($hlview)
4370 set vr [visiblerows]
4371 set r0 [lindex $vr 0]
4372 set r1 [lindex $vr 1]
4373 for {set i $vhl_done} {$i < $max} {incr i} {
4374 set id [commitonrow $i $hlview]
4375 if {[commitinview $id $curview]} {
4376 set row [rowofcommit $id]
4377 if {$r0 <= $row && $row <= $r1} {
4378 if {![highlighted $row]} {
4379 bolden $id mainfontbold
4381 set vhighlights($id) 1
4385 set vhl_done $max
4386 return 0
4389 proc askvhighlight {row id} {
4390 global hlview vhighlights iddrawn
4392 if {[commitinview $id $hlview]} {
4393 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4394 bolden $id mainfontbold
4396 set vhighlights($id) 1
4397 } else {
4398 set vhighlights($id) 0
4402 proc hfiles_change {} {
4403 global highlight_files filehighlight fhighlights fh_serial
4404 global highlight_paths
4406 if {[info exists filehighlight]} {
4407 # delete previous highlights
4408 catch {close $filehighlight}
4409 unset filehighlight
4410 catch {unset fhighlights}
4411 unbolden
4412 unhighlight_filelist
4414 set highlight_paths {}
4415 after cancel do_file_hl $fh_serial
4416 incr fh_serial
4417 if {$highlight_files ne {}} {
4418 after 300 do_file_hl $fh_serial
4422 proc gdttype_change {name ix op} {
4423 global gdttype highlight_files findstring findpattern
4425 stopfinding
4426 if {$findstring ne {}} {
4427 if {$gdttype eq [mc "containing:"]} {
4428 if {$highlight_files ne {}} {
4429 set highlight_files {}
4430 hfiles_change
4432 findcom_change
4433 } else {
4434 if {$findpattern ne {}} {
4435 set findpattern {}
4436 findcom_change
4438 set highlight_files $findstring
4439 hfiles_change
4441 drawvisible
4443 # enable/disable findtype/findloc menus too
4446 proc find_change {name ix op} {
4447 global gdttype findstring highlight_files
4449 stopfinding
4450 if {$gdttype eq [mc "containing:"]} {
4451 findcom_change
4452 } else {
4453 if {$highlight_files ne $findstring} {
4454 set highlight_files $findstring
4455 hfiles_change
4458 drawvisible
4461 proc findcom_change args {
4462 global nhighlights boldnameids
4463 global findpattern findtype findstring gdttype
4465 stopfinding
4466 # delete previous highlights, if any
4467 foreach id $boldnameids {
4468 bolden_name $id mainfont
4470 set boldnameids {}
4471 catch {unset nhighlights}
4472 unbolden
4473 unmarkmatches
4474 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4475 set findpattern {}
4476 } elseif {$findtype eq [mc "Regexp"]} {
4477 set findpattern $findstring
4478 } else {
4479 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4480 $findstring]
4481 set findpattern "*$e*"
4485 proc makepatterns {l} {
4486 set ret {}
4487 foreach e $l {
4488 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4489 if {[string index $ee end] eq "/"} {
4490 lappend ret "$ee*"
4491 } else {
4492 lappend ret $ee
4493 lappend ret "$ee/*"
4496 return $ret
4499 proc do_file_hl {serial} {
4500 global highlight_files filehighlight highlight_paths gdttype fhl_list
4502 if {$gdttype eq [mc "touching paths:"]} {
4503 if {[catch {set paths [shellsplit $highlight_files]}]} return
4504 set highlight_paths [makepatterns $paths]
4505 highlight_filelist
4506 set gdtargs [concat -- $paths]
4507 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4508 set gdtargs [list "-S$highlight_files"]
4509 } else {
4510 # must be "containing:", i.e. we're searching commit info
4511 return
4513 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4514 set filehighlight [open $cmd r+]
4515 fconfigure $filehighlight -blocking 0
4516 filerun $filehighlight readfhighlight
4517 set fhl_list {}
4518 drawvisible
4519 flushhighlights
4522 proc flushhighlights {} {
4523 global filehighlight fhl_list
4525 if {[info exists filehighlight]} {
4526 lappend fhl_list {}
4527 puts $filehighlight ""
4528 flush $filehighlight
4532 proc askfilehighlight {row id} {
4533 global filehighlight fhighlights fhl_list
4535 lappend fhl_list $id
4536 set fhighlights($id) -1
4537 puts $filehighlight $id
4540 proc readfhighlight {} {
4541 global filehighlight fhighlights curview iddrawn
4542 global fhl_list find_dirn
4544 if {![info exists filehighlight]} {
4545 return 0
4547 set nr 0
4548 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4549 set line [string trim $line]
4550 set i [lsearch -exact $fhl_list $line]
4551 if {$i < 0} continue
4552 for {set j 0} {$j < $i} {incr j} {
4553 set id [lindex $fhl_list $j]
4554 set fhighlights($id) 0
4556 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4557 if {$line eq {}} continue
4558 if {![commitinview $line $curview]} continue
4559 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4560 bolden $line mainfontbold
4562 set fhighlights($line) 1
4564 if {[eof $filehighlight]} {
4565 # strange...
4566 puts "oops, git diff-tree died"
4567 catch {close $filehighlight}
4568 unset filehighlight
4569 return 0
4571 if {[info exists find_dirn]} {
4572 run findmore
4574 return 1
4577 proc doesmatch {f} {
4578 global findtype findpattern
4580 if {$findtype eq [mc "Regexp"]} {
4581 return [regexp $findpattern $f]
4582 } elseif {$findtype eq [mc "IgnCase"]} {
4583 return [string match -nocase $findpattern $f]
4584 } else {
4585 return [string match $findpattern $f]
4589 proc askfindhighlight {row id} {
4590 global nhighlights commitinfo iddrawn
4591 global findloc
4592 global markingmatches
4594 if {![info exists commitinfo($id)]} {
4595 getcommit $id
4597 set info $commitinfo($id)
4598 set isbold 0
4599 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4600 foreach f $info ty $fldtypes {
4601 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4602 [doesmatch $f]} {
4603 if {$ty eq [mc "Author"]} {
4604 set isbold 2
4605 break
4607 set isbold 1
4610 if {$isbold && [info exists iddrawn($id)]} {
4611 if {![ishighlighted $id]} {
4612 bolden $id mainfontbold
4613 if {$isbold > 1} {
4614 bolden_name $id mainfontbold
4617 if {$markingmatches} {
4618 markrowmatches $row $id
4621 set nhighlights($id) $isbold
4624 proc markrowmatches {row id} {
4625 global canv canv2 linehtag linentag commitinfo findloc
4627 set headline [lindex $commitinfo($id) 0]
4628 set author [lindex $commitinfo($id) 1]
4629 $canv delete match$row
4630 $canv2 delete match$row
4631 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4632 set m [findmatches $headline]
4633 if {$m ne {}} {
4634 markmatches $canv $row $headline $linehtag($id) $m \
4635 [$canv itemcget $linehtag($id) -font] $row
4638 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4639 set m [findmatches $author]
4640 if {$m ne {}} {
4641 markmatches $canv2 $row $author $linentag($id) $m \
4642 [$canv2 itemcget $linentag($id) -font] $row
4647 proc vrel_change {name ix op} {
4648 global highlight_related
4650 rhighlight_none
4651 if {$highlight_related ne [mc "None"]} {
4652 run drawvisible
4656 # prepare for testing whether commits are descendents or ancestors of a
4657 proc rhighlight_sel {a} {
4658 global descendent desc_todo ancestor anc_todo
4659 global highlight_related
4661 catch {unset descendent}
4662 set desc_todo [list $a]
4663 catch {unset ancestor}
4664 set anc_todo [list $a]
4665 if {$highlight_related ne [mc "None"]} {
4666 rhighlight_none
4667 run drawvisible
4671 proc rhighlight_none {} {
4672 global rhighlights
4674 catch {unset rhighlights}
4675 unbolden
4678 proc is_descendent {a} {
4679 global curview children descendent desc_todo
4681 set v $curview
4682 set la [rowofcommit $a]
4683 set todo $desc_todo
4684 set leftover {}
4685 set done 0
4686 for {set i 0} {$i < [llength $todo]} {incr i} {
4687 set do [lindex $todo $i]
4688 if {[rowofcommit $do] < $la} {
4689 lappend leftover $do
4690 continue
4692 foreach nk $children($v,$do) {
4693 if {![info exists descendent($nk)]} {
4694 set descendent($nk) 1
4695 lappend todo $nk
4696 if {$nk eq $a} {
4697 set done 1
4701 if {$done} {
4702 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4703 return
4706 set descendent($a) 0
4707 set desc_todo $leftover
4710 proc is_ancestor {a} {
4711 global curview parents ancestor anc_todo
4713 set v $curview
4714 set la [rowofcommit $a]
4715 set todo $anc_todo
4716 set leftover {}
4717 set done 0
4718 for {set i 0} {$i < [llength $todo]} {incr i} {
4719 set do [lindex $todo $i]
4720 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4721 lappend leftover $do
4722 continue
4724 foreach np $parents($v,$do) {
4725 if {![info exists ancestor($np)]} {
4726 set ancestor($np) 1
4727 lappend todo $np
4728 if {$np eq $a} {
4729 set done 1
4733 if {$done} {
4734 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4735 return
4738 set ancestor($a) 0
4739 set anc_todo $leftover
4742 proc askrelhighlight {row id} {
4743 global descendent highlight_related iddrawn rhighlights
4744 global selectedline ancestor
4746 if {$selectedline eq {}} return
4747 set isbold 0
4748 if {$highlight_related eq [mc "Descendant"] ||
4749 $highlight_related eq [mc "Not descendant"]} {
4750 if {![info exists descendent($id)]} {
4751 is_descendent $id
4753 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4754 set isbold 1
4756 } elseif {$highlight_related eq [mc "Ancestor"] ||
4757 $highlight_related eq [mc "Not ancestor"]} {
4758 if {![info exists ancestor($id)]} {
4759 is_ancestor $id
4761 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4762 set isbold 1
4765 if {[info exists iddrawn($id)]} {
4766 if {$isbold && ![ishighlighted $id]} {
4767 bolden $id mainfontbold
4770 set rhighlights($id) $isbold
4773 # Graph layout functions
4775 proc shortids {ids} {
4776 set res {}
4777 foreach id $ids {
4778 if {[llength $id] > 1} {
4779 lappend res [shortids $id]
4780 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4781 lappend res [string range $id 0 7]
4782 } else {
4783 lappend res $id
4786 return $res
4789 proc ntimes {n o} {
4790 set ret {}
4791 set o [list $o]
4792 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4793 if {($n & $mask) != 0} {
4794 set ret [concat $ret $o]
4796 set o [concat $o $o]
4798 return $ret
4801 proc ordertoken {id} {
4802 global ordertok curview varcid varcstart varctok curview parents children
4803 global nullid nullid2
4805 if {[info exists ordertok($id)]} {
4806 return $ordertok($id)
4808 set origid $id
4809 set todo {}
4810 while {1} {
4811 if {[info exists varcid($curview,$id)]} {
4812 set a $varcid($curview,$id)
4813 set p [lindex $varcstart($curview) $a]
4814 } else {
4815 set p [lindex $children($curview,$id) 0]
4817 if {[info exists ordertok($p)]} {
4818 set tok $ordertok($p)
4819 break
4821 set id [first_real_child $curview,$p]
4822 if {$id eq {}} {
4823 # it's a root
4824 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4825 break
4827 if {[llength $parents($curview,$id)] == 1} {
4828 lappend todo [list $p {}]
4829 } else {
4830 set j [lsearch -exact $parents($curview,$id) $p]
4831 if {$j < 0} {
4832 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4834 lappend todo [list $p [strrep $j]]
4837 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4838 set p [lindex $todo $i 0]
4839 append tok [lindex $todo $i 1]
4840 set ordertok($p) $tok
4842 set ordertok($origid) $tok
4843 return $tok
4846 # Work out where id should go in idlist so that order-token
4847 # values increase from left to right
4848 proc idcol {idlist id {i 0}} {
4849 set t [ordertoken $id]
4850 if {$i < 0} {
4851 set i 0
4853 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4854 if {$i > [llength $idlist]} {
4855 set i [llength $idlist]
4857 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4858 incr i
4859 } else {
4860 if {$t > [ordertoken [lindex $idlist $i]]} {
4861 while {[incr i] < [llength $idlist] &&
4862 $t >= [ordertoken [lindex $idlist $i]]} {}
4865 return $i
4868 proc initlayout {} {
4869 global rowidlist rowisopt rowfinal displayorder parentlist
4870 global numcommits canvxmax canv
4871 global nextcolor
4872 global colormap rowtextx
4874 set numcommits 0
4875 set displayorder {}
4876 set parentlist {}
4877 set nextcolor 0
4878 set rowidlist {}
4879 set rowisopt {}
4880 set rowfinal {}
4881 set canvxmax [$canv cget -width]
4882 catch {unset colormap}
4883 catch {unset rowtextx}
4884 setcanvscroll
4887 proc setcanvscroll {} {
4888 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4889 global lastscrollset lastscrollrows
4891 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4892 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4893 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4894 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4895 set lastscrollset [clock clicks -milliseconds]
4896 set lastscrollrows $numcommits
4899 proc visiblerows {} {
4900 global canv numcommits linespc
4902 set ymax [lindex [$canv cget -scrollregion] 3]
4903 if {$ymax eq {} || $ymax == 0} return
4904 set f [$canv yview]
4905 set y0 [expr {int([lindex $f 0] * $ymax)}]
4906 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4907 if {$r0 < 0} {
4908 set r0 0
4910 set y1 [expr {int([lindex $f 1] * $ymax)}]
4911 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4912 if {$r1 >= $numcommits} {
4913 set r1 [expr {$numcommits - 1}]
4915 return [list $r0 $r1]
4918 proc layoutmore {} {
4919 global commitidx viewcomplete curview
4920 global numcommits pending_select curview
4921 global lastscrollset lastscrollrows
4923 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4924 [clock clicks -milliseconds] - $lastscrollset > 500} {
4925 setcanvscroll
4927 if {[info exists pending_select] &&
4928 [commitinview $pending_select $curview]} {
4929 update
4930 selectline [rowofcommit $pending_select] 1
4932 drawvisible
4935 # With path limiting, we mightn't get the actual HEAD commit,
4936 # so ask git rev-list what is the first ancestor of HEAD that
4937 # touches a file in the path limit.
4938 proc get_viewmainhead {view} {
4939 global viewmainheadid vfilelimit viewinstances mainheadid
4941 catch {
4942 set rfd [open [concat | git rev-list -1 $mainheadid \
4943 -- $vfilelimit($view)] r]
4944 set j [reg_instance $rfd]
4945 lappend viewinstances($view) $j
4946 fconfigure $rfd -blocking 0
4947 filerun $rfd [list getviewhead $rfd $j $view]
4948 set viewmainheadid($curview) {}
4952 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4953 proc getviewhead {fd inst view} {
4954 global viewmainheadid commfd curview viewinstances showlocalchanges
4956 set id {}
4957 if {[gets $fd line] < 0} {
4958 if {![eof $fd]} {
4959 return 1
4961 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4962 set id $line
4964 set viewmainheadid($view) $id
4965 close $fd
4966 unset commfd($inst)
4967 set i [lsearch -exact $viewinstances($view) $inst]
4968 if {$i >= 0} {
4969 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4971 if {$showlocalchanges && $id ne {} && $view == $curview} {
4972 doshowlocalchanges
4974 return 0
4977 proc doshowlocalchanges {} {
4978 global curview viewmainheadid
4980 if {$viewmainheadid($curview) eq {}} return
4981 if {[commitinview $viewmainheadid($curview) $curview]} {
4982 dodiffindex
4983 } else {
4984 interestedin $viewmainheadid($curview) dodiffindex
4988 proc dohidelocalchanges {} {
4989 global nullid nullid2 lserial curview
4991 if {[commitinview $nullid $curview]} {
4992 removefakerow $nullid
4994 if {[commitinview $nullid2 $curview]} {
4995 removefakerow $nullid2
4997 incr lserial
5000 # spawn off a process to do git diff-index --cached HEAD
5001 proc dodiffindex {} {
5002 global lserial showlocalchanges vfilelimit curview
5003 global isworktree
5005 if {!$showlocalchanges || !$isworktree} return
5006 incr lserial
5007 set cmd "|git diff-index --cached HEAD"
5008 if {$vfilelimit($curview) ne {}} {
5009 set cmd [concat $cmd -- $vfilelimit($curview)]
5011 set fd [open $cmd r]
5012 fconfigure $fd -blocking 0
5013 set i [reg_instance $fd]
5014 filerun $fd [list readdiffindex $fd $lserial $i]
5017 proc readdiffindex {fd serial inst} {
5018 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5019 global vfilelimit
5021 set isdiff 1
5022 if {[gets $fd line] < 0} {
5023 if {![eof $fd]} {
5024 return 1
5026 set isdiff 0
5028 # we only need to see one line and we don't really care what it says...
5029 stop_instance $inst
5031 if {$serial != $lserial} {
5032 return 0
5035 # now see if there are any local changes not checked in to the index
5036 set cmd "|git diff-files"
5037 if {$vfilelimit($curview) ne {}} {
5038 set cmd [concat $cmd -- $vfilelimit($curview)]
5040 set fd [open $cmd r]
5041 fconfigure $fd -blocking 0
5042 set i [reg_instance $fd]
5043 filerun $fd [list readdifffiles $fd $serial $i]
5045 if {$isdiff && ![commitinview $nullid2 $curview]} {
5046 # add the line for the changes in the index to the graph
5047 set hl [mc "Local changes checked in to index but not committed"]
5048 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5049 set commitdata($nullid2) "\n $hl\n"
5050 if {[commitinview $nullid $curview]} {
5051 removefakerow $nullid
5053 insertfakerow $nullid2 $viewmainheadid($curview)
5054 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5055 if {[commitinview $nullid $curview]} {
5056 removefakerow $nullid
5058 removefakerow $nullid2
5060 return 0
5063 proc readdifffiles {fd serial inst} {
5064 global viewmainheadid nullid nullid2 curview
5065 global commitinfo commitdata lserial
5067 set isdiff 1
5068 if {[gets $fd line] < 0} {
5069 if {![eof $fd]} {
5070 return 1
5072 set isdiff 0
5074 # we only need to see one line and we don't really care what it says...
5075 stop_instance $inst
5077 if {$serial != $lserial} {
5078 return 0
5081 if {$isdiff && ![commitinview $nullid $curview]} {
5082 # add the line for the local diff to the graph
5083 set hl [mc "Local uncommitted changes, not checked in to index"]
5084 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5085 set commitdata($nullid) "\n $hl\n"
5086 if {[commitinview $nullid2 $curview]} {
5087 set p $nullid2
5088 } else {
5089 set p $viewmainheadid($curview)
5091 insertfakerow $nullid $p
5092 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5093 removefakerow $nullid
5095 return 0
5098 proc nextuse {id row} {
5099 global curview children
5101 if {[info exists children($curview,$id)]} {
5102 foreach kid $children($curview,$id) {
5103 if {![commitinview $kid $curview]} {
5104 return -1
5106 if {[rowofcommit $kid] > $row} {
5107 return [rowofcommit $kid]
5111 if {[commitinview $id $curview]} {
5112 return [rowofcommit $id]
5114 return -1
5117 proc prevuse {id row} {
5118 global curview children
5120 set ret -1
5121 if {[info exists children($curview,$id)]} {
5122 foreach kid $children($curview,$id) {
5123 if {![commitinview $kid $curview]} break
5124 if {[rowofcommit $kid] < $row} {
5125 set ret [rowofcommit $kid]
5129 return $ret
5132 proc make_idlist {row} {
5133 global displayorder parentlist uparrowlen downarrowlen mingaplen
5134 global commitidx curview children
5136 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5137 if {$r < 0} {
5138 set r 0
5140 set ra [expr {$row - $downarrowlen}]
5141 if {$ra < 0} {
5142 set ra 0
5144 set rb [expr {$row + $uparrowlen}]
5145 if {$rb > $commitidx($curview)} {
5146 set rb $commitidx($curview)
5148 make_disporder $r [expr {$rb + 1}]
5149 set ids {}
5150 for {} {$r < $ra} {incr r} {
5151 set nextid [lindex $displayorder [expr {$r + 1}]]
5152 foreach p [lindex $parentlist $r] {
5153 if {$p eq $nextid} continue
5154 set rn [nextuse $p $r]
5155 if {$rn >= $row &&
5156 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5157 lappend ids [list [ordertoken $p] $p]
5161 for {} {$r < $row} {incr r} {
5162 set nextid [lindex $displayorder [expr {$r + 1}]]
5163 foreach p [lindex $parentlist $r] {
5164 if {$p eq $nextid} continue
5165 set rn [nextuse $p $r]
5166 if {$rn < 0 || $rn >= $row} {
5167 lappend ids [list [ordertoken $p] $p]
5171 set id [lindex $displayorder $row]
5172 lappend ids [list [ordertoken $id] $id]
5173 while {$r < $rb} {
5174 foreach p [lindex $parentlist $r] {
5175 set firstkid [lindex $children($curview,$p) 0]
5176 if {[rowofcommit $firstkid] < $row} {
5177 lappend ids [list [ordertoken $p] $p]
5180 incr r
5181 set id [lindex $displayorder $r]
5182 if {$id ne {}} {
5183 set firstkid [lindex $children($curview,$id) 0]
5184 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5185 lappend ids [list [ordertoken $id] $id]
5189 set idlist {}
5190 foreach idx [lsort -unique $ids] {
5191 lappend idlist [lindex $idx 1]
5193 return $idlist
5196 proc rowsequal {a b} {
5197 while {[set i [lsearch -exact $a {}]] >= 0} {
5198 set a [lreplace $a $i $i]
5200 while {[set i [lsearch -exact $b {}]] >= 0} {
5201 set b [lreplace $b $i $i]
5203 return [expr {$a eq $b}]
5206 proc makeupline {id row rend col} {
5207 global rowidlist uparrowlen downarrowlen mingaplen
5209 for {set r $rend} {1} {set r $rstart} {
5210 set rstart [prevuse $id $r]
5211 if {$rstart < 0} return
5212 if {$rstart < $row} break
5214 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5215 set rstart [expr {$rend - $uparrowlen - 1}]
5217 for {set r $rstart} {[incr r] <= $row} {} {
5218 set idlist [lindex $rowidlist $r]
5219 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5220 set col [idcol $idlist $id $col]
5221 lset rowidlist $r [linsert $idlist $col $id]
5222 changedrow $r
5227 proc layoutrows {row endrow} {
5228 global rowidlist rowisopt rowfinal displayorder
5229 global uparrowlen downarrowlen maxwidth mingaplen
5230 global children parentlist
5231 global commitidx viewcomplete curview
5233 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5234 set idlist {}
5235 if {$row > 0} {
5236 set rm1 [expr {$row - 1}]
5237 foreach id [lindex $rowidlist $rm1] {
5238 if {$id ne {}} {
5239 lappend idlist $id
5242 set final [lindex $rowfinal $rm1]
5244 for {} {$row < $endrow} {incr row} {
5245 set rm1 [expr {$row - 1}]
5246 if {$rm1 < 0 || $idlist eq {}} {
5247 set idlist [make_idlist $row]
5248 set final 1
5249 } else {
5250 set id [lindex $displayorder $rm1]
5251 set col [lsearch -exact $idlist $id]
5252 set idlist [lreplace $idlist $col $col]
5253 foreach p [lindex $parentlist $rm1] {
5254 if {[lsearch -exact $idlist $p] < 0} {
5255 set col [idcol $idlist $p $col]
5256 set idlist [linsert $idlist $col $p]
5257 # if not the first child, we have to insert a line going up
5258 if {$id ne [lindex $children($curview,$p) 0]} {
5259 makeupline $p $rm1 $row $col
5263 set id [lindex $displayorder $row]
5264 if {$row > $downarrowlen} {
5265 set termrow [expr {$row - $downarrowlen - 1}]
5266 foreach p [lindex $parentlist $termrow] {
5267 set i [lsearch -exact $idlist $p]
5268 if {$i < 0} continue
5269 set nr [nextuse $p $termrow]
5270 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5271 set idlist [lreplace $idlist $i $i]
5275 set col [lsearch -exact $idlist $id]
5276 if {$col < 0} {
5277 set col [idcol $idlist $id]
5278 set idlist [linsert $idlist $col $id]
5279 if {$children($curview,$id) ne {}} {
5280 makeupline $id $rm1 $row $col
5283 set r [expr {$row + $uparrowlen - 1}]
5284 if {$r < $commitidx($curview)} {
5285 set x $col
5286 foreach p [lindex $parentlist $r] {
5287 if {[lsearch -exact $idlist $p] >= 0} continue
5288 set fk [lindex $children($curview,$p) 0]
5289 if {[rowofcommit $fk] < $row} {
5290 set x [idcol $idlist $p $x]
5291 set idlist [linsert $idlist $x $p]
5294 if {[incr r] < $commitidx($curview)} {
5295 set p [lindex $displayorder $r]
5296 if {[lsearch -exact $idlist $p] < 0} {
5297 set fk [lindex $children($curview,$p) 0]
5298 if {$fk ne {} && [rowofcommit $fk] < $row} {
5299 set x [idcol $idlist $p $x]
5300 set idlist [linsert $idlist $x $p]
5306 if {$final && !$viewcomplete($curview) &&
5307 $row + $uparrowlen + $mingaplen + $downarrowlen
5308 >= $commitidx($curview)} {
5309 set final 0
5311 set l [llength $rowidlist]
5312 if {$row == $l} {
5313 lappend rowidlist $idlist
5314 lappend rowisopt 0
5315 lappend rowfinal $final
5316 } elseif {$row < $l} {
5317 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5318 lset rowidlist $row $idlist
5319 changedrow $row
5321 lset rowfinal $row $final
5322 } else {
5323 set pad [ntimes [expr {$row - $l}] {}]
5324 set rowidlist [concat $rowidlist $pad]
5325 lappend rowidlist $idlist
5326 set rowfinal [concat $rowfinal $pad]
5327 lappend rowfinal $final
5328 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5331 return $row
5334 proc changedrow {row} {
5335 global displayorder iddrawn rowisopt need_redisplay
5337 set l [llength $rowisopt]
5338 if {$row < $l} {
5339 lset rowisopt $row 0
5340 if {$row + 1 < $l} {
5341 lset rowisopt [expr {$row + 1}] 0
5342 if {$row + 2 < $l} {
5343 lset rowisopt [expr {$row + 2}] 0
5347 set id [lindex $displayorder $row]
5348 if {[info exists iddrawn($id)]} {
5349 set need_redisplay 1
5353 proc insert_pad {row col npad} {
5354 global rowidlist
5356 set pad [ntimes $npad {}]
5357 set idlist [lindex $rowidlist $row]
5358 set bef [lrange $idlist 0 [expr {$col - 1}]]
5359 set aft [lrange $idlist $col end]
5360 set i [lsearch -exact $aft {}]
5361 if {$i > 0} {
5362 set aft [lreplace $aft $i $i]
5364 lset rowidlist $row [concat $bef $pad $aft]
5365 changedrow $row
5368 proc optimize_rows {row col endrow} {
5369 global rowidlist rowisopt displayorder curview children
5371 if {$row < 1} {
5372 set row 1
5374 for {} {$row < $endrow} {incr row; set col 0} {
5375 if {[lindex $rowisopt $row]} continue
5376 set haspad 0
5377 set y0 [expr {$row - 1}]
5378 set ym [expr {$row - 2}]
5379 set idlist [lindex $rowidlist $row]
5380 set previdlist [lindex $rowidlist $y0]
5381 if {$idlist eq {} || $previdlist eq {}} continue
5382 if {$ym >= 0} {
5383 set pprevidlist [lindex $rowidlist $ym]
5384 if {$pprevidlist eq {}} continue
5385 } else {
5386 set pprevidlist {}
5388 set x0 -1
5389 set xm -1
5390 for {} {$col < [llength $idlist]} {incr col} {
5391 set id [lindex $idlist $col]
5392 if {[lindex $previdlist $col] eq $id} continue
5393 if {$id eq {}} {
5394 set haspad 1
5395 continue
5397 set x0 [lsearch -exact $previdlist $id]
5398 if {$x0 < 0} continue
5399 set z [expr {$x0 - $col}]
5400 set isarrow 0
5401 set z0 {}
5402 if {$ym >= 0} {
5403 set xm [lsearch -exact $pprevidlist $id]
5404 if {$xm >= 0} {
5405 set z0 [expr {$xm - $x0}]
5408 if {$z0 eq {}} {
5409 # if row y0 is the first child of $id then it's not an arrow
5410 if {[lindex $children($curview,$id) 0] ne
5411 [lindex $displayorder $y0]} {
5412 set isarrow 1
5415 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5416 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5417 set isarrow 1
5419 # Looking at lines from this row to the previous row,
5420 # make them go straight up if they end in an arrow on
5421 # the previous row; otherwise make them go straight up
5422 # or at 45 degrees.
5423 if {$z < -1 || ($z < 0 && $isarrow)} {
5424 # Line currently goes left too much;
5425 # insert pads in the previous row, then optimize it
5426 set npad [expr {-1 - $z + $isarrow}]
5427 insert_pad $y0 $x0 $npad
5428 if {$y0 > 0} {
5429 optimize_rows $y0 $x0 $row
5431 set previdlist [lindex $rowidlist $y0]
5432 set x0 [lsearch -exact $previdlist $id]
5433 set z [expr {$x0 - $col}]
5434 if {$z0 ne {}} {
5435 set pprevidlist [lindex $rowidlist $ym]
5436 set xm [lsearch -exact $pprevidlist $id]
5437 set z0 [expr {$xm - $x0}]
5439 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5440 # Line currently goes right too much;
5441 # insert pads in this line
5442 set npad [expr {$z - 1 + $isarrow}]
5443 insert_pad $row $col $npad
5444 set idlist [lindex $rowidlist $row]
5445 incr col $npad
5446 set z [expr {$x0 - $col}]
5447 set haspad 1
5449 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5450 # this line links to its first child on row $row-2
5451 set id [lindex $displayorder $ym]
5452 set xc [lsearch -exact $pprevidlist $id]
5453 if {$xc >= 0} {
5454 set z0 [expr {$xc - $x0}]
5457 # avoid lines jigging left then immediately right
5458 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5459 insert_pad $y0 $x0 1
5460 incr x0
5461 optimize_rows $y0 $x0 $row
5462 set previdlist [lindex $rowidlist $y0]
5465 if {!$haspad} {
5466 # Find the first column that doesn't have a line going right
5467 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5468 set id [lindex $idlist $col]
5469 if {$id eq {}} break
5470 set x0 [lsearch -exact $previdlist $id]
5471 if {$x0 < 0} {
5472 # check if this is the link to the first child
5473 set kid [lindex $displayorder $y0]
5474 if {[lindex $children($curview,$id) 0] eq $kid} {
5475 # it is, work out offset to child
5476 set x0 [lsearch -exact $previdlist $kid]
5479 if {$x0 <= $col} break
5481 # Insert a pad at that column as long as it has a line and
5482 # isn't the last column
5483 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5484 set idlist [linsert $idlist $col {}]
5485 lset rowidlist $row $idlist
5486 changedrow $row
5492 proc xc {row col} {
5493 global canvx0 linespc
5494 return [expr {$canvx0 + $col * $linespc}]
5497 proc yc {row} {
5498 global canvy0 linespc
5499 return [expr {$canvy0 + $row * $linespc}]
5502 proc linewidth {id} {
5503 global thickerline lthickness
5505 set wid $lthickness
5506 if {[info exists thickerline] && $id eq $thickerline} {
5507 set wid [expr {2 * $lthickness}]
5509 return $wid
5512 proc rowranges {id} {
5513 global curview children uparrowlen downarrowlen
5514 global rowidlist
5516 set kids $children($curview,$id)
5517 if {$kids eq {}} {
5518 return {}
5520 set ret {}
5521 lappend kids $id
5522 foreach child $kids {
5523 if {![commitinview $child $curview]} break
5524 set row [rowofcommit $child]
5525 if {![info exists prev]} {
5526 lappend ret [expr {$row + 1}]
5527 } else {
5528 if {$row <= $prevrow} {
5529 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5531 # see if the line extends the whole way from prevrow to row
5532 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5533 [lsearch -exact [lindex $rowidlist \
5534 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5535 # it doesn't, see where it ends
5536 set r [expr {$prevrow + $downarrowlen}]
5537 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5538 while {[incr r -1] > $prevrow &&
5539 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5540 } else {
5541 while {[incr r] <= $row &&
5542 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5543 incr r -1
5545 lappend ret $r
5546 # see where it starts up again
5547 set r [expr {$row - $uparrowlen}]
5548 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5549 while {[incr r] < $row &&
5550 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5551 } else {
5552 while {[incr r -1] >= $prevrow &&
5553 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5554 incr r
5556 lappend ret $r
5559 if {$child eq $id} {
5560 lappend ret $row
5562 set prev $child
5563 set prevrow $row
5565 return $ret
5568 proc drawlineseg {id row endrow arrowlow} {
5569 global rowidlist displayorder iddrawn linesegs
5570 global canv colormap linespc curview maxlinelen parentlist
5572 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5573 set le [expr {$row + 1}]
5574 set arrowhigh 1
5575 while {1} {
5576 set c [lsearch -exact [lindex $rowidlist $le] $id]
5577 if {$c < 0} {
5578 incr le -1
5579 break
5581 lappend cols $c
5582 set x [lindex $displayorder $le]
5583 if {$x eq $id} {
5584 set arrowhigh 0
5585 break
5587 if {[info exists iddrawn($x)] || $le == $endrow} {
5588 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5589 if {$c >= 0} {
5590 lappend cols $c
5591 set arrowhigh 0
5593 break
5595 incr le
5597 if {$le <= $row} {
5598 return $row
5601 set lines {}
5602 set i 0
5603 set joinhigh 0
5604 if {[info exists linesegs($id)]} {
5605 set lines $linesegs($id)
5606 foreach li $lines {
5607 set r0 [lindex $li 0]
5608 if {$r0 > $row} {
5609 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5610 set joinhigh 1
5612 break
5614 incr i
5617 set joinlow 0
5618 if {$i > 0} {
5619 set li [lindex $lines [expr {$i-1}]]
5620 set r1 [lindex $li 1]
5621 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5622 set joinlow 1
5626 set x [lindex $cols [expr {$le - $row}]]
5627 set xp [lindex $cols [expr {$le - 1 - $row}]]
5628 set dir [expr {$xp - $x}]
5629 if {$joinhigh} {
5630 set ith [lindex $lines $i 2]
5631 set coords [$canv coords $ith]
5632 set ah [$canv itemcget $ith -arrow]
5633 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5634 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5635 if {$x2 ne {} && $x - $x2 == $dir} {
5636 set coords [lrange $coords 0 end-2]
5638 } else {
5639 set coords [list [xc $le $x] [yc $le]]
5641 if {$joinlow} {
5642 set itl [lindex $lines [expr {$i-1}] 2]
5643 set al [$canv itemcget $itl -arrow]
5644 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5645 } elseif {$arrowlow} {
5646 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5647 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5648 set arrowlow 0
5651 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5652 for {set y $le} {[incr y -1] > $row} {} {
5653 set x $xp
5654 set xp [lindex $cols [expr {$y - 1 - $row}]]
5655 set ndir [expr {$xp - $x}]
5656 if {$dir != $ndir || $xp < 0} {
5657 lappend coords [xc $y $x] [yc $y]
5659 set dir $ndir
5661 if {!$joinlow} {
5662 if {$xp < 0} {
5663 # join parent line to first child
5664 set ch [lindex $displayorder $row]
5665 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5666 if {$xc < 0} {
5667 puts "oops: drawlineseg: child $ch not on row $row"
5668 } elseif {$xc != $x} {
5669 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5670 set d [expr {int(0.5 * $linespc)}]
5671 set x1 [xc $row $x]
5672 if {$xc < $x} {
5673 set x2 [expr {$x1 - $d}]
5674 } else {
5675 set x2 [expr {$x1 + $d}]
5677 set y2 [yc $row]
5678 set y1 [expr {$y2 + $d}]
5679 lappend coords $x1 $y1 $x2 $y2
5680 } elseif {$xc < $x - 1} {
5681 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5682 } elseif {$xc > $x + 1} {
5683 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5685 set x $xc
5687 lappend coords [xc $row $x] [yc $row]
5688 } else {
5689 set xn [xc $row $xp]
5690 set yn [yc $row]
5691 lappend coords $xn $yn
5693 if {!$joinhigh} {
5694 assigncolor $id
5695 set t [$canv create line $coords -width [linewidth $id] \
5696 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5697 $canv lower $t
5698 bindline $t $id
5699 set lines [linsert $lines $i [list $row $le $t]]
5700 } else {
5701 $canv coords $ith $coords
5702 if {$arrow ne $ah} {
5703 $canv itemconf $ith -arrow $arrow
5705 lset lines $i 0 $row
5707 } else {
5708 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5709 set ndir [expr {$xo - $xp}]
5710 set clow [$canv coords $itl]
5711 if {$dir == $ndir} {
5712 set clow [lrange $clow 2 end]
5714 set coords [concat $coords $clow]
5715 if {!$joinhigh} {
5716 lset lines [expr {$i-1}] 1 $le
5717 } else {
5718 # coalesce two pieces
5719 $canv delete $ith
5720 set b [lindex $lines [expr {$i-1}] 0]
5721 set e [lindex $lines $i 1]
5722 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5724 $canv coords $itl $coords
5725 if {$arrow ne $al} {
5726 $canv itemconf $itl -arrow $arrow
5730 set linesegs($id) $lines
5731 return $le
5734 proc drawparentlinks {id row} {
5735 global rowidlist canv colormap curview parentlist
5736 global idpos linespc
5738 set rowids [lindex $rowidlist $row]
5739 set col [lsearch -exact $rowids $id]
5740 if {$col < 0} return
5741 set olds [lindex $parentlist $row]
5742 set row2 [expr {$row + 1}]
5743 set x [xc $row $col]
5744 set y [yc $row]
5745 set y2 [yc $row2]
5746 set d [expr {int(0.5 * $linespc)}]
5747 set ymid [expr {$y + $d}]
5748 set ids [lindex $rowidlist $row2]
5749 # rmx = right-most X coord used
5750 set rmx 0
5751 foreach p $olds {
5752 set i [lsearch -exact $ids $p]
5753 if {$i < 0} {
5754 puts "oops, parent $p of $id not in list"
5755 continue
5757 set x2 [xc $row2 $i]
5758 if {$x2 > $rmx} {
5759 set rmx $x2
5761 set j [lsearch -exact $rowids $p]
5762 if {$j < 0} {
5763 # drawlineseg will do this one for us
5764 continue
5766 assigncolor $p
5767 # should handle duplicated parents here...
5768 set coords [list $x $y]
5769 if {$i != $col} {
5770 # if attaching to a vertical segment, draw a smaller
5771 # slant for visual distinctness
5772 if {$i == $j} {
5773 if {$i < $col} {
5774 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5775 } else {
5776 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5778 } elseif {$i < $col && $i < $j} {
5779 # segment slants towards us already
5780 lappend coords [xc $row $j] $y
5781 } else {
5782 if {$i < $col - 1} {
5783 lappend coords [expr {$x2 + $linespc}] $y
5784 } elseif {$i > $col + 1} {
5785 lappend coords [expr {$x2 - $linespc}] $y
5787 lappend coords $x2 $y2
5789 } else {
5790 lappend coords $x2 $y2
5792 set t [$canv create line $coords -width [linewidth $p] \
5793 -fill $colormap($p) -tags lines.$p]
5794 $canv lower $t
5795 bindline $t $p
5797 if {$rmx > [lindex $idpos($id) 1]} {
5798 lset idpos($id) 1 $rmx
5799 redrawtags $id
5803 proc drawlines {id} {
5804 global canv
5806 $canv itemconf lines.$id -width [linewidth $id]
5809 proc drawcmittext {id row col} {
5810 global linespc canv canv2 canv3 fgcolor curview
5811 global cmitlisted commitinfo rowidlist parentlist
5812 global rowtextx idpos idtags idheads idotherrefs
5813 global linehtag linentag linedtag selectedline
5814 global canvxmax boldids boldnameids fgcolor markedid
5815 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5817 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5818 set listed $cmitlisted($curview,$id)
5819 if {$id eq $nullid} {
5820 set ofill red
5821 } elseif {$id eq $nullid2} {
5822 set ofill green
5823 } elseif {$id eq $mainheadid} {
5824 set ofill yellow
5825 } else {
5826 set ofill [lindex $circlecolors $listed]
5828 set x [xc $row $col]
5829 set y [yc $row]
5830 set orad [expr {$linespc / 3}]
5831 if {$listed <= 2} {
5832 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5833 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5834 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5835 } elseif {$listed == 3} {
5836 # triangle pointing left for left-side commits
5837 set t [$canv create polygon \
5838 [expr {$x - $orad}] $y \
5839 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5840 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5841 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5842 } else {
5843 # triangle pointing right for right-side commits
5844 set t [$canv create polygon \
5845 [expr {$x + $orad - 1}] $y \
5846 [expr {$x - $orad}] [expr {$y - $orad}] \
5847 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5848 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5850 set circleitem($row) $t
5851 $canv raise $t
5852 $canv bind $t <1> {selcanvline {} %x %y}
5853 set rmx [llength [lindex $rowidlist $row]]
5854 set olds [lindex $parentlist $row]
5855 if {$olds ne {}} {
5856 set nextids [lindex $rowidlist [expr {$row + 1}]]
5857 foreach p $olds {
5858 set i [lsearch -exact $nextids $p]
5859 if {$i > $rmx} {
5860 set rmx $i
5864 set xt [xc $row $rmx]
5865 set rowtextx($row) $xt
5866 set idpos($id) [list $x $xt $y]
5867 if {[info exists idtags($id)] || [info exists idheads($id)]
5868 || [info exists idotherrefs($id)]} {
5869 set xt [drawtags $id $x $xt $y]
5871 set headline [lindex $commitinfo($id) 0]
5872 set name [lindex $commitinfo($id) 1]
5873 set date [lindex $commitinfo($id) 2]
5874 set date [formatdate $date]
5875 set font mainfont
5876 set nfont mainfont
5877 set isbold [ishighlighted $id]
5878 if {$isbold > 0} {
5879 lappend boldids $id
5880 set font mainfontbold
5881 if {$isbold > 1} {
5882 lappend boldnameids $id
5883 set nfont mainfontbold
5886 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5887 -text $headline -font $font -tags text]
5888 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5889 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5890 -text $name -font $nfont -tags text]
5891 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5892 -text $date -font mainfont -tags text]
5893 if {$selectedline == $row} {
5894 make_secsel $id
5896 if {[info exists markedid] && $markedid eq $id} {
5897 make_idmark $id
5899 set xr [expr {$xt + [font measure $font $headline]}]
5900 if {$xr > $canvxmax} {
5901 set canvxmax $xr
5902 setcanvscroll
5906 proc drawcmitrow {row} {
5907 global displayorder rowidlist nrows_drawn
5908 global iddrawn markingmatches
5909 global commitinfo numcommits
5910 global filehighlight fhighlights findpattern nhighlights
5911 global hlview vhighlights
5912 global highlight_related rhighlights
5914 if {$row >= $numcommits} return
5916 set id [lindex $displayorder $row]
5917 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5918 askvhighlight $row $id
5920 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5921 askfilehighlight $row $id
5923 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5924 askfindhighlight $row $id
5926 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5927 askrelhighlight $row $id
5929 if {![info exists iddrawn($id)]} {
5930 set col [lsearch -exact [lindex $rowidlist $row] $id]
5931 if {$col < 0} {
5932 puts "oops, row $row id $id not in list"
5933 return
5935 if {![info exists commitinfo($id)]} {
5936 getcommit $id
5938 assigncolor $id
5939 drawcmittext $id $row $col
5940 set iddrawn($id) 1
5941 incr nrows_drawn
5943 if {$markingmatches} {
5944 markrowmatches $row $id
5948 proc drawcommits {row {endrow {}}} {
5949 global numcommits iddrawn displayorder curview need_redisplay
5950 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5952 if {$row < 0} {
5953 set row 0
5955 if {$endrow eq {}} {
5956 set endrow $row
5958 if {$endrow >= $numcommits} {
5959 set endrow [expr {$numcommits - 1}]
5962 set rl1 [expr {$row - $downarrowlen - 3}]
5963 if {$rl1 < 0} {
5964 set rl1 0
5966 set ro1 [expr {$row - 3}]
5967 if {$ro1 < 0} {
5968 set ro1 0
5970 set r2 [expr {$endrow + $uparrowlen + 3}]
5971 if {$r2 > $numcommits} {
5972 set r2 $numcommits
5974 for {set r $rl1} {$r < $r2} {incr r} {
5975 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5976 if {$rl1 < $r} {
5977 layoutrows $rl1 $r
5979 set rl1 [expr {$r + 1}]
5982 if {$rl1 < $r} {
5983 layoutrows $rl1 $r
5985 optimize_rows $ro1 0 $r2
5986 if {$need_redisplay || $nrows_drawn > 2000} {
5987 clear_display
5990 # make the lines join to already-drawn rows either side
5991 set r [expr {$row - 1}]
5992 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5993 set r $row
5995 set er [expr {$endrow + 1}]
5996 if {$er >= $numcommits ||
5997 ![info exists iddrawn([lindex $displayorder $er])]} {
5998 set er $endrow
6000 for {} {$r <= $er} {incr r} {
6001 set id [lindex $displayorder $r]
6002 set wasdrawn [info exists iddrawn($id)]
6003 drawcmitrow $r
6004 if {$r == $er} break
6005 set nextid [lindex $displayorder [expr {$r + 1}]]
6006 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6007 drawparentlinks $id $r
6009 set rowids [lindex $rowidlist $r]
6010 foreach lid $rowids {
6011 if {$lid eq {}} continue
6012 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6013 if {$lid eq $id} {
6014 # see if this is the first child of any of its parents
6015 foreach p [lindex $parentlist $r] {
6016 if {[lsearch -exact $rowids $p] < 0} {
6017 # make this line extend up to the child
6018 set lineend($p) [drawlineseg $p $r $er 0]
6021 } else {
6022 set lineend($lid) [drawlineseg $lid $r $er 1]
6028 proc undolayout {row} {
6029 global uparrowlen mingaplen downarrowlen
6030 global rowidlist rowisopt rowfinal need_redisplay
6032 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6033 if {$r < 0} {
6034 set r 0
6036 if {[llength $rowidlist] > $r} {
6037 incr r -1
6038 set rowidlist [lrange $rowidlist 0 $r]
6039 set rowfinal [lrange $rowfinal 0 $r]
6040 set rowisopt [lrange $rowisopt 0 $r]
6041 set need_redisplay 1
6042 run drawvisible
6046 proc drawvisible {} {
6047 global canv linespc curview vrowmod selectedline targetrow targetid
6048 global need_redisplay cscroll numcommits
6050 set fs [$canv yview]
6051 set ymax [lindex [$canv cget -scrollregion] 3]
6052 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6053 set f0 [lindex $fs 0]
6054 set f1 [lindex $fs 1]
6055 set y0 [expr {int($f0 * $ymax)}]
6056 set y1 [expr {int($f1 * $ymax)}]
6058 if {[info exists targetid]} {
6059 if {[commitinview $targetid $curview]} {
6060 set r [rowofcommit $targetid]
6061 if {$r != $targetrow} {
6062 # Fix up the scrollregion and change the scrolling position
6063 # now that our target row has moved.
6064 set diff [expr {($r - $targetrow) * $linespc}]
6065 set targetrow $r
6066 setcanvscroll
6067 set ymax [lindex [$canv cget -scrollregion] 3]
6068 incr y0 $diff
6069 incr y1 $diff
6070 set f0 [expr {$y0 / $ymax}]
6071 set f1 [expr {$y1 / $ymax}]
6072 allcanvs yview moveto $f0
6073 $cscroll set $f0 $f1
6074 set need_redisplay 1
6076 } else {
6077 unset targetid
6081 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6082 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6083 if {$endrow >= $vrowmod($curview)} {
6084 update_arcrows $curview
6086 if {$selectedline ne {} &&
6087 $row <= $selectedline && $selectedline <= $endrow} {
6088 set targetrow $selectedline
6089 } elseif {[info exists targetid]} {
6090 set targetrow [expr {int(($row + $endrow) / 2)}]
6092 if {[info exists targetrow]} {
6093 if {$targetrow >= $numcommits} {
6094 set targetrow [expr {$numcommits - 1}]
6096 set targetid [commitonrow $targetrow]
6098 drawcommits $row $endrow
6101 proc clear_display {} {
6102 global iddrawn linesegs need_redisplay nrows_drawn
6103 global vhighlights fhighlights nhighlights rhighlights
6104 global linehtag linentag linedtag boldids boldnameids
6106 allcanvs delete all
6107 catch {unset iddrawn}
6108 catch {unset linesegs}
6109 catch {unset linehtag}
6110 catch {unset linentag}
6111 catch {unset linedtag}
6112 set boldids {}
6113 set boldnameids {}
6114 catch {unset vhighlights}
6115 catch {unset fhighlights}
6116 catch {unset nhighlights}
6117 catch {unset rhighlights}
6118 set need_redisplay 0
6119 set nrows_drawn 0
6122 proc findcrossings {id} {
6123 global rowidlist parentlist numcommits displayorder
6125 set cross {}
6126 set ccross {}
6127 foreach {s e} [rowranges $id] {
6128 if {$e >= $numcommits} {
6129 set e [expr {$numcommits - 1}]
6131 if {$e <= $s} continue
6132 for {set row $e} {[incr row -1] >= $s} {} {
6133 set x [lsearch -exact [lindex $rowidlist $row] $id]
6134 if {$x < 0} break
6135 set olds [lindex $parentlist $row]
6136 set kid [lindex $displayorder $row]
6137 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6138 if {$kidx < 0} continue
6139 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6140 foreach p $olds {
6141 set px [lsearch -exact $nextrow $p]
6142 if {$px < 0} continue
6143 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6144 if {[lsearch -exact $ccross $p] >= 0} continue
6145 if {$x == $px + ($kidx < $px? -1: 1)} {
6146 lappend ccross $p
6147 } elseif {[lsearch -exact $cross $p] < 0} {
6148 lappend cross $p
6154 return [concat $ccross {{}} $cross]
6157 proc assigncolor {id} {
6158 global colormap colors nextcolor
6159 global parents children children curview
6161 if {[info exists colormap($id)]} return
6162 set ncolors [llength $colors]
6163 if {[info exists children($curview,$id)]} {
6164 set kids $children($curview,$id)
6165 } else {
6166 set kids {}
6168 if {[llength $kids] == 1} {
6169 set child [lindex $kids 0]
6170 if {[info exists colormap($child)]
6171 && [llength $parents($curview,$child)] == 1} {
6172 set colormap($id) $colormap($child)
6173 return
6176 set badcolors {}
6177 set origbad {}
6178 foreach x [findcrossings $id] {
6179 if {$x eq {}} {
6180 # delimiter between corner crossings and other crossings
6181 if {[llength $badcolors] >= $ncolors - 1} break
6182 set origbad $badcolors
6184 if {[info exists colormap($x)]
6185 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6186 lappend badcolors $colormap($x)
6189 if {[llength $badcolors] >= $ncolors} {
6190 set badcolors $origbad
6192 set origbad $badcolors
6193 if {[llength $badcolors] < $ncolors - 1} {
6194 foreach child $kids {
6195 if {[info exists colormap($child)]
6196 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6197 lappend badcolors $colormap($child)
6199 foreach p $parents($curview,$child) {
6200 if {[info exists colormap($p)]
6201 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6202 lappend badcolors $colormap($p)
6206 if {[llength $badcolors] >= $ncolors} {
6207 set badcolors $origbad
6210 for {set i 0} {$i <= $ncolors} {incr i} {
6211 set c [lindex $colors $nextcolor]
6212 if {[incr nextcolor] >= $ncolors} {
6213 set nextcolor 0
6215 if {[lsearch -exact $badcolors $c]} break
6217 set colormap($id) $c
6220 proc bindline {t id} {
6221 global canv
6223 $canv bind $t <Enter> "lineenter %x %y $id"
6224 $canv bind $t <Motion> "linemotion %x %y $id"
6225 $canv bind $t <Leave> "lineleave $id"
6226 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6229 proc drawtags {id x xt y1} {
6230 global idtags idheads idotherrefs mainhead
6231 global linespc lthickness
6232 global canv rowtextx curview fgcolor bgcolor ctxbut
6234 set marks {}
6235 set ntags 0
6236 set nheads 0
6237 if {[info exists idtags($id)]} {
6238 set marks $idtags($id)
6239 set ntags [llength $marks]
6241 if {[info exists idheads($id)]} {
6242 set marks [concat $marks $idheads($id)]
6243 set nheads [llength $idheads($id)]
6245 if {[info exists idotherrefs($id)]} {
6246 set marks [concat $marks $idotherrefs($id)]
6248 if {$marks eq {}} {
6249 return $xt
6252 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6253 set yt [expr {$y1 - 0.5 * $linespc}]
6254 set yb [expr {$yt + $linespc - 1}]
6255 set xvals {}
6256 set wvals {}
6257 set i -1
6258 foreach tag $marks {
6259 incr i
6260 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6261 set wid [font measure mainfontbold $tag]
6262 } else {
6263 set wid [font measure mainfont $tag]
6265 lappend xvals $xt
6266 lappend wvals $wid
6267 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6269 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6270 -width $lthickness -fill black -tags tag.$id]
6271 $canv lower $t
6272 foreach tag $marks x $xvals wid $wvals {
6273 set xl [expr {$x + $delta}]
6274 set xr [expr {$x + $delta + $wid + $lthickness}]
6275 set font mainfont
6276 if {[incr ntags -1] >= 0} {
6277 # draw a tag
6278 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6279 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6280 -width 1 -outline black -fill yellow -tags tag.$id]
6281 $canv bind $t <1> [list showtag $tag 1]
6282 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6283 } else {
6284 # draw a head or other ref
6285 if {[incr nheads -1] >= 0} {
6286 set col green
6287 if {$tag eq $mainhead} {
6288 set font mainfontbold
6290 } else {
6291 set col "#ddddff"
6293 set xl [expr {$xl - $delta/2}]
6294 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6295 -width 1 -outline black -fill $col -tags tag.$id
6296 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6297 set rwid [font measure mainfont $remoteprefix]
6298 set xi [expr {$x + 1}]
6299 set yti [expr {$yt + 1}]
6300 set xri [expr {$x + $rwid}]
6301 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6302 -width 0 -fill "#ffddaa" -tags tag.$id
6305 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6306 -font $font -tags [list tag.$id text]]
6307 if {$ntags >= 0} {
6308 $canv bind $t <1> [list showtag $tag 1]
6309 } elseif {$nheads >= 0} {
6310 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6313 return $xt
6316 proc xcoord {i level ln} {
6317 global canvx0 xspc1 xspc2
6319 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6320 if {$i > 0 && $i == $level} {
6321 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6322 } elseif {$i > $level} {
6323 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6325 return $x
6328 proc show_status {msg} {
6329 global canv fgcolor
6331 clear_display
6332 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6333 -tags text -fill $fgcolor
6336 # Don't change the text pane cursor if it is currently the hand cursor,
6337 # showing that we are over a sha1 ID link.
6338 proc settextcursor {c} {
6339 global ctext curtextcursor
6341 if {[$ctext cget -cursor] == $curtextcursor} {
6342 $ctext config -cursor $c
6344 set curtextcursor $c
6347 proc nowbusy {what {name {}}} {
6348 global isbusy busyname statusw
6350 if {[array names isbusy] eq {}} {
6351 . config -cursor watch
6352 settextcursor watch
6354 set isbusy($what) 1
6355 set busyname($what) $name
6356 if {$name ne {}} {
6357 $statusw conf -text $name
6361 proc notbusy {what} {
6362 global isbusy maincursor textcursor busyname statusw
6364 catch {
6365 unset isbusy($what)
6366 if {$busyname($what) ne {} &&
6367 [$statusw cget -text] eq $busyname($what)} {
6368 $statusw conf -text {}
6371 if {[array names isbusy] eq {}} {
6372 . config -cursor $maincursor
6373 settextcursor $textcursor
6377 proc findmatches {f} {
6378 global findtype findstring
6379 if {$findtype == [mc "Regexp"]} {
6380 set matches [regexp -indices -all -inline $findstring $f]
6381 } else {
6382 set fs $findstring
6383 if {$findtype == [mc "IgnCase"]} {
6384 set f [string tolower $f]
6385 set fs [string tolower $fs]
6387 set matches {}
6388 set i 0
6389 set l [string length $fs]
6390 while {[set j [string first $fs $f $i]] >= 0} {
6391 lappend matches [list $j [expr {$j+$l-1}]]
6392 set i [expr {$j + $l}]
6395 return $matches
6398 proc dofind {{dirn 1} {wrap 1}} {
6399 global findstring findstartline findcurline selectedline numcommits
6400 global gdttype filehighlight fh_serial find_dirn findallowwrap
6402 if {[info exists find_dirn]} {
6403 if {$find_dirn == $dirn} return
6404 stopfinding
6406 focus .
6407 if {$findstring eq {} || $numcommits == 0} return
6408 if {$selectedline eq {}} {
6409 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6410 } else {
6411 set findstartline $selectedline
6413 set findcurline $findstartline
6414 nowbusy finding [mc "Searching"]
6415 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6416 after cancel do_file_hl $fh_serial
6417 do_file_hl $fh_serial
6419 set find_dirn $dirn
6420 set findallowwrap $wrap
6421 run findmore
6424 proc stopfinding {} {
6425 global find_dirn findcurline fprogcoord
6427 if {[info exists find_dirn]} {
6428 unset find_dirn
6429 unset findcurline
6430 notbusy finding
6431 set fprogcoord 0
6432 adjustprogress
6434 stopblaming
6437 proc findmore {} {
6438 global commitdata commitinfo numcommits findpattern findloc
6439 global findstartline findcurline findallowwrap
6440 global find_dirn gdttype fhighlights fprogcoord
6441 global curview varcorder vrownum varccommits vrowmod
6443 if {![info exists find_dirn]} {
6444 return 0
6446 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6447 set l $findcurline
6448 set moretodo 0
6449 if {$find_dirn > 0} {
6450 incr l
6451 if {$l >= $numcommits} {
6452 set l 0
6454 if {$l <= $findstartline} {
6455 set lim [expr {$findstartline + 1}]
6456 } else {
6457 set lim $numcommits
6458 set moretodo $findallowwrap
6460 } else {
6461 if {$l == 0} {
6462 set l $numcommits
6464 incr l -1
6465 if {$l >= $findstartline} {
6466 set lim [expr {$findstartline - 1}]
6467 } else {
6468 set lim -1
6469 set moretodo $findallowwrap
6472 set n [expr {($lim - $l) * $find_dirn}]
6473 if {$n > 500} {
6474 set n 500
6475 set moretodo 1
6477 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6478 update_arcrows $curview
6480 set found 0
6481 set domore 1
6482 set ai [bsearch $vrownum($curview) $l]
6483 set a [lindex $varcorder($curview) $ai]
6484 set arow [lindex $vrownum($curview) $ai]
6485 set ids [lindex $varccommits($curview,$a)]
6486 set arowend [expr {$arow + [llength $ids]}]
6487 if {$gdttype eq [mc "containing:"]} {
6488 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6489 if {$l < $arow || $l >= $arowend} {
6490 incr ai $find_dirn
6491 set a [lindex $varcorder($curview) $ai]
6492 set arow [lindex $vrownum($curview) $ai]
6493 set ids [lindex $varccommits($curview,$a)]
6494 set arowend [expr {$arow + [llength $ids]}]
6496 set id [lindex $ids [expr {$l - $arow}]]
6497 # shouldn't happen unless git log doesn't give all the commits...
6498 if {![info exists commitdata($id)] ||
6499 ![doesmatch $commitdata($id)]} {
6500 continue
6502 if {![info exists commitinfo($id)]} {
6503 getcommit $id
6505 set info $commitinfo($id)
6506 foreach f $info ty $fldtypes {
6507 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6508 [doesmatch $f]} {
6509 set found 1
6510 break
6513 if {$found} break
6515 } else {
6516 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6517 if {$l < $arow || $l >= $arowend} {
6518 incr ai $find_dirn
6519 set a [lindex $varcorder($curview) $ai]
6520 set arow [lindex $vrownum($curview) $ai]
6521 set ids [lindex $varccommits($curview,$a)]
6522 set arowend [expr {$arow + [llength $ids]}]
6524 set id [lindex $ids [expr {$l - $arow}]]
6525 if {![info exists fhighlights($id)]} {
6526 # this sets fhighlights($id) to -1
6527 askfilehighlight $l $id
6529 if {$fhighlights($id) > 0} {
6530 set found $domore
6531 break
6533 if {$fhighlights($id) < 0} {
6534 if {$domore} {
6535 set domore 0
6536 set findcurline [expr {$l - $find_dirn}]
6541 if {$found || ($domore && !$moretodo)} {
6542 unset findcurline
6543 unset find_dirn
6544 notbusy finding
6545 set fprogcoord 0
6546 adjustprogress
6547 if {$found} {
6548 findselectline $l
6549 } else {
6550 bell
6552 return 0
6554 if {!$domore} {
6555 flushhighlights
6556 } else {
6557 set findcurline [expr {$l - $find_dirn}]
6559 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6560 if {$n < 0} {
6561 incr n $numcommits
6563 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6564 adjustprogress
6565 return $domore
6568 proc findselectline {l} {
6569 global findloc commentend ctext findcurline markingmatches gdttype
6571 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6572 set findcurline $l
6573 selectline $l 1
6574 if {$markingmatches &&
6575 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6576 # highlight the matches in the comments
6577 set f [$ctext get 1.0 $commentend]
6578 set matches [findmatches $f]
6579 foreach match $matches {
6580 set start [lindex $match 0]
6581 set end [expr {[lindex $match 1] + 1}]
6582 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6585 drawvisible
6588 # mark the bits of a headline or author that match a find string
6589 proc markmatches {canv l str tag matches font row} {
6590 global selectedline
6592 set bbox [$canv bbox $tag]
6593 set x0 [lindex $bbox 0]
6594 set y0 [lindex $bbox 1]
6595 set y1 [lindex $bbox 3]
6596 foreach match $matches {
6597 set start [lindex $match 0]
6598 set end [lindex $match 1]
6599 if {$start > $end} continue
6600 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6601 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6602 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6603 [expr {$x0+$xlen+2}] $y1 \
6604 -outline {} -tags [list match$l matches] -fill yellow]
6605 $canv lower $t
6606 if {$row == $selectedline} {
6607 $canv raise $t secsel
6612 proc unmarkmatches {} {
6613 global markingmatches
6615 allcanvs delete matches
6616 set markingmatches 0
6617 stopfinding
6620 proc selcanvline {w x y} {
6621 global canv canvy0 ctext linespc
6622 global rowtextx
6623 set ymax [lindex [$canv cget -scrollregion] 3]
6624 if {$ymax == {}} return
6625 set yfrac [lindex [$canv yview] 0]
6626 set y [expr {$y + $yfrac * $ymax}]
6627 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6628 if {$l < 0} {
6629 set l 0
6631 if {$w eq $canv} {
6632 set xmax [lindex [$canv cget -scrollregion] 2]
6633 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6634 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6636 unmarkmatches
6637 selectline $l 1
6640 proc commit_descriptor {p} {
6641 global commitinfo
6642 if {![info exists commitinfo($p)]} {
6643 getcommit $p
6645 set l "..."
6646 if {[llength $commitinfo($p)] > 1} {
6647 set l [lindex $commitinfo($p) 0]
6649 return "$p ($l)\n"
6652 # append some text to the ctext widget, and make any SHA1 ID
6653 # that we know about be a clickable link.
6654 proc appendwithlinks {text tags} {
6655 global ctext linknum curview
6657 set start [$ctext index "end - 1c"]
6658 $ctext insert end $text $tags
6659 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6660 foreach l $links {
6661 set s [lindex $l 0]
6662 set e [lindex $l 1]
6663 set linkid [string range $text $s $e]
6664 incr e
6665 $ctext tag delete link$linknum
6666 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6667 setlink $linkid link$linknum
6668 incr linknum
6672 proc setlink {id lk} {
6673 global curview ctext pendinglinks
6675 set known 0
6676 if {[string length $id] < 40} {
6677 set matches [longid $id]
6678 if {[llength $matches] > 0} {
6679 if {[llength $matches] > 1} return
6680 set known 1
6681 set id [lindex $matches 0]
6683 } else {
6684 set known [commitinview $id $curview]
6686 if {$known} {
6687 $ctext tag conf $lk -foreground blue -underline 1
6688 $ctext tag bind $lk <1> [list selbyid $id]
6689 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6690 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6691 } else {
6692 lappend pendinglinks($id) $lk
6693 interestedin $id {makelink %P}
6697 proc appendshortlink {id {pre {}} {post {}}} {
6698 global ctext linknum
6700 $ctext insert end $pre
6701 $ctext tag delete link$linknum
6702 $ctext insert end [string range $id 0 7] link$linknum
6703 $ctext insert end $post
6704 setlink $id link$linknum
6705 incr linknum
6708 proc makelink {id} {
6709 global pendinglinks
6711 if {![info exists pendinglinks($id)]} return
6712 foreach lk $pendinglinks($id) {
6713 setlink $id $lk
6715 unset pendinglinks($id)
6718 proc linkcursor {w inc} {
6719 global linkentercount curtextcursor
6721 if {[incr linkentercount $inc] > 0} {
6722 $w configure -cursor hand2
6723 } else {
6724 $w configure -cursor $curtextcursor
6725 if {$linkentercount < 0} {
6726 set linkentercount 0
6731 proc viewnextline {dir} {
6732 global canv linespc
6734 $canv delete hover
6735 set ymax [lindex [$canv cget -scrollregion] 3]
6736 set wnow [$canv yview]
6737 set wtop [expr {[lindex $wnow 0] * $ymax}]
6738 set newtop [expr {$wtop + $dir * $linespc}]
6739 if {$newtop < 0} {
6740 set newtop 0
6741 } elseif {$newtop > $ymax} {
6742 set newtop $ymax
6744 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6747 # add a list of tag or branch names at position pos
6748 # returns the number of names inserted
6749 proc appendrefs {pos ids var} {
6750 global ctext linknum curview $var maxrefs
6752 if {[catch {$ctext index $pos}]} {
6753 return 0
6755 $ctext conf -state normal
6756 $ctext delete $pos "$pos lineend"
6757 set tags {}
6758 foreach id $ids {
6759 foreach tag [set $var\($id\)] {
6760 lappend tags [list $tag $id]
6763 if {[llength $tags] > $maxrefs} {
6764 $ctext insert $pos "[mc "many"] ([llength $tags])"
6765 } else {
6766 set tags [lsort -index 0 -decreasing $tags]
6767 set sep {}
6768 foreach ti $tags {
6769 set id [lindex $ti 1]
6770 set lk link$linknum
6771 incr linknum
6772 $ctext tag delete $lk
6773 $ctext insert $pos $sep
6774 $ctext insert $pos [lindex $ti 0] $lk
6775 setlink $id $lk
6776 set sep ", "
6779 $ctext conf -state disabled
6780 return [llength $tags]
6783 # called when we have finished computing the nearby tags
6784 proc dispneartags {delay} {
6785 global selectedline currentid showneartags tagphase
6787 if {$selectedline eq {} || !$showneartags} return
6788 after cancel dispnexttag
6789 if {$delay} {
6790 after 200 dispnexttag
6791 set tagphase -1
6792 } else {
6793 after idle dispnexttag
6794 set tagphase 0
6798 proc dispnexttag {} {
6799 global selectedline currentid showneartags tagphase ctext
6801 if {$selectedline eq {} || !$showneartags} return
6802 switch -- $tagphase {
6804 set dtags [desctags $currentid]
6805 if {$dtags ne {}} {
6806 appendrefs precedes $dtags idtags
6810 set atags [anctags $currentid]
6811 if {$atags ne {}} {
6812 appendrefs follows $atags idtags
6816 set dheads [descheads $currentid]
6817 if {$dheads ne {}} {
6818 if {[appendrefs branch $dheads idheads] > 1
6819 && [$ctext get "branch -3c"] eq "h"} {
6820 # turn "Branch" into "Branches"
6821 $ctext conf -state normal
6822 $ctext insert "branch -2c" "es"
6823 $ctext conf -state disabled
6828 if {[incr tagphase] <= 2} {
6829 after idle dispnexttag
6833 proc make_secsel {id} {
6834 global linehtag linentag linedtag canv canv2 canv3
6836 if {![info exists linehtag($id)]} return
6837 $canv delete secsel
6838 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6839 -tags secsel -fill [$canv cget -selectbackground]]
6840 $canv lower $t
6841 $canv2 delete secsel
6842 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6843 -tags secsel -fill [$canv2 cget -selectbackground]]
6844 $canv2 lower $t
6845 $canv3 delete secsel
6846 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6847 -tags secsel -fill [$canv3 cget -selectbackground]]
6848 $canv3 lower $t
6851 proc make_idmark {id} {
6852 global linehtag canv fgcolor
6854 if {![info exists linehtag($id)]} return
6855 $canv delete markid
6856 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6857 -tags markid -outline $fgcolor]
6858 $canv raise $t
6861 proc selectline {l isnew {desired_loc {}}} {
6862 global canv ctext commitinfo selectedline
6863 global canvy0 linespc parents children curview
6864 global currentid sha1entry
6865 global commentend idtags linknum
6866 global mergemax numcommits pending_select
6867 global cmitmode showneartags allcommits
6868 global targetrow targetid lastscrollrows
6869 global autoselect jump_to_here
6871 catch {unset pending_select}
6872 $canv delete hover
6873 normalline
6874 unsel_reflist
6875 stopfinding
6876 if {$l < 0 || $l >= $numcommits} return
6877 set id [commitonrow $l]
6878 set targetid $id
6879 set targetrow $l
6880 set selectedline $l
6881 set currentid $id
6882 if {$lastscrollrows < $numcommits} {
6883 setcanvscroll
6886 set y [expr {$canvy0 + $l * $linespc}]
6887 set ymax [lindex [$canv cget -scrollregion] 3]
6888 set ytop [expr {$y - $linespc - 1}]
6889 set ybot [expr {$y + $linespc + 1}]
6890 set wnow [$canv yview]
6891 set wtop [expr {[lindex $wnow 0] * $ymax}]
6892 set wbot [expr {[lindex $wnow 1] * $ymax}]
6893 set wh [expr {$wbot - $wtop}]
6894 set newtop $wtop
6895 if {$ytop < $wtop} {
6896 if {$ybot < $wtop} {
6897 set newtop [expr {$y - $wh / 2.0}]
6898 } else {
6899 set newtop $ytop
6900 if {$newtop > $wtop - $linespc} {
6901 set newtop [expr {$wtop - $linespc}]
6904 } elseif {$ybot > $wbot} {
6905 if {$ytop > $wbot} {
6906 set newtop [expr {$y - $wh / 2.0}]
6907 } else {
6908 set newtop [expr {$ybot - $wh}]
6909 if {$newtop < $wtop + $linespc} {
6910 set newtop [expr {$wtop + $linespc}]
6914 if {$newtop != $wtop} {
6915 if {$newtop < 0} {
6916 set newtop 0
6918 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6919 drawvisible
6922 make_secsel $id
6924 if {$isnew} {
6925 addtohistory [list selbyid $id 0] savecmitpos
6928 $sha1entry delete 0 end
6929 $sha1entry insert 0 $id
6930 if {$autoselect} {
6931 $sha1entry selection range 0 end
6933 rhighlight_sel $id
6935 $ctext conf -state normal
6936 clear_ctext
6937 set linknum 0
6938 if {![info exists commitinfo($id)]} {
6939 getcommit $id
6941 set info $commitinfo($id)
6942 set date [formatdate [lindex $info 2]]
6943 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6944 set date [formatdate [lindex $info 4]]
6945 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6946 if {[info exists idtags($id)]} {
6947 $ctext insert end [mc "Tags:"]
6948 foreach tag $idtags($id) {
6949 $ctext insert end " $tag"
6951 $ctext insert end "\n"
6954 set headers {}
6955 set olds $parents($curview,$id)
6956 if {[llength $olds] > 1} {
6957 set np 0
6958 foreach p $olds {
6959 if {$np >= $mergemax} {
6960 set tag mmax
6961 } else {
6962 set tag m$np
6964 $ctext insert end "[mc "Parent"]: " $tag
6965 appendwithlinks [commit_descriptor $p] {}
6966 incr np
6968 } else {
6969 foreach p $olds {
6970 append headers "[mc "Parent"]: [commit_descriptor $p]"
6974 foreach c $children($curview,$id) {
6975 append headers "[mc "Child"]: [commit_descriptor $c]"
6978 # make anything that looks like a SHA1 ID be a clickable link
6979 appendwithlinks $headers {}
6980 if {$showneartags} {
6981 if {![info exists allcommits]} {
6982 getallcommits
6984 $ctext insert end "[mc "Branch"]: "
6985 $ctext mark set branch "end -1c"
6986 $ctext mark gravity branch left
6987 $ctext insert end "\n[mc "Follows"]: "
6988 $ctext mark set follows "end -1c"
6989 $ctext mark gravity follows left
6990 $ctext insert end "\n[mc "Precedes"]: "
6991 $ctext mark set precedes "end -1c"
6992 $ctext mark gravity precedes left
6993 $ctext insert end "\n"
6994 dispneartags 1
6996 $ctext insert end "\n"
6997 set comment [lindex $info 5]
6998 if {[string first "\r" $comment] >= 0} {
6999 set comment [string map {"\r" "\n "} $comment]
7001 appendwithlinks $comment {comment}
7003 $ctext tag remove found 1.0 end
7004 $ctext conf -state disabled
7005 set commentend [$ctext index "end - 1c"]
7007 set jump_to_here $desired_loc
7008 init_flist [mc "Comments"]
7009 if {$cmitmode eq "tree"} {
7010 gettree $id
7011 } elseif {[llength $olds] <= 1} {
7012 startdiff $id
7013 } else {
7014 mergediff $id
7018 proc selfirstline {} {
7019 unmarkmatches
7020 selectline 0 1
7023 proc sellastline {} {
7024 global numcommits
7025 unmarkmatches
7026 set l [expr {$numcommits - 1}]
7027 selectline $l 1
7030 proc selnextline {dir} {
7031 global selectedline
7032 focus .
7033 if {$selectedline eq {}} return
7034 set l [expr {$selectedline + $dir}]
7035 unmarkmatches
7036 selectline $l 1
7039 proc selnextpage {dir} {
7040 global canv linespc selectedline numcommits
7042 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7043 if {$lpp < 1} {
7044 set lpp 1
7046 allcanvs yview scroll [expr {$dir * $lpp}] units
7047 drawvisible
7048 if {$selectedline eq {}} return
7049 set l [expr {$selectedline + $dir * $lpp}]
7050 if {$l < 0} {
7051 set l 0
7052 } elseif {$l >= $numcommits} {
7053 set l [expr $numcommits - 1]
7055 unmarkmatches
7056 selectline $l 1
7059 proc unselectline {} {
7060 global selectedline currentid
7062 set selectedline {}
7063 catch {unset currentid}
7064 allcanvs delete secsel
7065 rhighlight_none
7068 proc reselectline {} {
7069 global selectedline
7071 if {$selectedline ne {}} {
7072 selectline $selectedline 0
7076 proc addtohistory {cmd {saveproc {}}} {
7077 global history historyindex curview
7079 unset_posvars
7080 save_position
7081 set elt [list $curview $cmd $saveproc {}]
7082 if {$historyindex > 0
7083 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7084 return
7087 if {$historyindex < [llength $history]} {
7088 set history [lreplace $history $historyindex end $elt]
7089 } else {
7090 lappend history $elt
7092 incr historyindex
7093 if {$historyindex > 1} {
7094 .tf.bar.leftbut conf -state normal
7095 } else {
7096 .tf.bar.leftbut conf -state disabled
7098 .tf.bar.rightbut conf -state disabled
7101 # save the scrolling position of the diff display pane
7102 proc save_position {} {
7103 global historyindex history
7105 if {$historyindex < 1} return
7106 set hi [expr {$historyindex - 1}]
7107 set fn [lindex $history $hi 2]
7108 if {$fn ne {}} {
7109 lset history $hi 3 [eval $fn]
7113 proc unset_posvars {} {
7114 global last_posvars
7116 if {[info exists last_posvars]} {
7117 foreach {var val} $last_posvars {
7118 global $var
7119 catch {unset $var}
7121 unset last_posvars
7125 proc godo {elt} {
7126 global curview last_posvars
7128 set view [lindex $elt 0]
7129 set cmd [lindex $elt 1]
7130 set pv [lindex $elt 3]
7131 if {$curview != $view} {
7132 showview $view
7134 unset_posvars
7135 foreach {var val} $pv {
7136 global $var
7137 set $var $val
7139 set last_posvars $pv
7140 eval $cmd
7143 proc goback {} {
7144 global history historyindex
7145 focus .
7147 if {$historyindex > 1} {
7148 save_position
7149 incr historyindex -1
7150 godo [lindex $history [expr {$historyindex - 1}]]
7151 .tf.bar.rightbut conf -state normal
7153 if {$historyindex <= 1} {
7154 .tf.bar.leftbut conf -state disabled
7158 proc goforw {} {
7159 global history historyindex
7160 focus .
7162 if {$historyindex < [llength $history]} {
7163 save_position
7164 set cmd [lindex $history $historyindex]
7165 incr historyindex
7166 godo $cmd
7167 .tf.bar.leftbut conf -state normal
7169 if {$historyindex >= [llength $history]} {
7170 .tf.bar.rightbut conf -state disabled
7174 proc gettree {id} {
7175 global treefilelist treeidlist diffids diffmergeid treepending
7176 global nullid nullid2
7178 set diffids $id
7179 catch {unset diffmergeid}
7180 if {![info exists treefilelist($id)]} {
7181 if {![info exists treepending]} {
7182 if {$id eq $nullid} {
7183 set cmd [list | git ls-files]
7184 } elseif {$id eq $nullid2} {
7185 set cmd [list | git ls-files --stage -t]
7186 } else {
7187 set cmd [list | git ls-tree -r $id]
7189 if {[catch {set gtf [open $cmd r]}]} {
7190 return
7192 set treepending $id
7193 set treefilelist($id) {}
7194 set treeidlist($id) {}
7195 fconfigure $gtf -blocking 0 -encoding binary
7196 filerun $gtf [list gettreeline $gtf $id]
7198 } else {
7199 setfilelist $id
7203 proc gettreeline {gtf id} {
7204 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7206 set nl 0
7207 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7208 if {$diffids eq $nullid} {
7209 set fname $line
7210 } else {
7211 set i [string first "\t" $line]
7212 if {$i < 0} continue
7213 set fname [string range $line [expr {$i+1}] end]
7214 set line [string range $line 0 [expr {$i-1}]]
7215 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7216 set sha1 [lindex $line 2]
7217 lappend treeidlist($id) $sha1
7219 if {[string index $fname 0] eq "\""} {
7220 set fname [lindex $fname 0]
7222 set fname [encoding convertfrom $fname]
7223 lappend treefilelist($id) $fname
7225 if {![eof $gtf]} {
7226 return [expr {$nl >= 1000? 2: 1}]
7228 close $gtf
7229 unset treepending
7230 if {$cmitmode ne "tree"} {
7231 if {![info exists diffmergeid]} {
7232 gettreediffs $diffids
7234 } elseif {$id ne $diffids} {
7235 gettree $diffids
7236 } else {
7237 setfilelist $id
7239 return 0
7242 proc showfile {f} {
7243 global treefilelist treeidlist diffids nullid nullid2
7244 global ctext_file_names ctext_file_lines
7245 global ctext commentend
7247 set i [lsearch -exact $treefilelist($diffids) $f]
7248 if {$i < 0} {
7249 puts "oops, $f not in list for id $diffids"
7250 return
7252 if {$diffids eq $nullid} {
7253 if {[catch {set bf [open $f r]} err]} {
7254 puts "oops, can't read $f: $err"
7255 return
7257 } else {
7258 set blob [lindex $treeidlist($diffids) $i]
7259 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7260 puts "oops, error reading blob $blob: $err"
7261 return
7264 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7265 filerun $bf [list getblobline $bf $diffids]
7266 $ctext config -state normal
7267 clear_ctext $commentend
7268 lappend ctext_file_names $f
7269 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7270 $ctext insert end "\n"
7271 $ctext insert end "$f\n" filesep
7272 $ctext config -state disabled
7273 $ctext yview $commentend
7274 settabs 0
7277 proc getblobline {bf id} {
7278 global diffids cmitmode ctext
7280 if {$id ne $diffids || $cmitmode ne "tree"} {
7281 catch {close $bf}
7282 return 0
7284 $ctext config -state normal
7285 set nl 0
7286 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7287 $ctext insert end "$line\n"
7289 if {[eof $bf]} {
7290 global jump_to_here ctext_file_names commentend
7292 # delete last newline
7293 $ctext delete "end - 2c" "end - 1c"
7294 close $bf
7295 if {$jump_to_here ne {} &&
7296 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7297 set lnum [expr {[lindex $jump_to_here 1] +
7298 [lindex [split $commentend .] 0]}]
7299 mark_ctext_line $lnum
7301 return 0
7303 $ctext config -state disabled
7304 return [expr {$nl >= 1000? 2: 1}]
7307 proc mark_ctext_line {lnum} {
7308 global ctext markbgcolor
7310 $ctext tag delete omark
7311 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7312 $ctext tag conf omark -background $markbgcolor
7313 $ctext see $lnum.0
7316 proc mergediff {id} {
7317 global diffmergeid
7318 global diffids treediffs
7319 global parents curview
7321 set diffmergeid $id
7322 set diffids $id
7323 set treediffs($id) {}
7324 set np [llength $parents($curview,$id)]
7325 settabs $np
7326 getblobdiffs $id
7329 proc startdiff {ids} {
7330 global treediffs diffids treepending diffmergeid nullid nullid2
7332 settabs 1
7333 set diffids $ids
7334 catch {unset diffmergeid}
7335 if {![info exists treediffs($ids)] ||
7336 [lsearch -exact $ids $nullid] >= 0 ||
7337 [lsearch -exact $ids $nullid2] >= 0} {
7338 if {![info exists treepending]} {
7339 gettreediffs $ids
7341 } else {
7342 addtocflist $ids
7346 proc path_filter {filter name} {
7347 foreach p $filter {
7348 set l [string length $p]
7349 if {[string index $p end] eq "/"} {
7350 if {[string compare -length $l $p $name] == 0} {
7351 return 1
7353 } else {
7354 if {[string compare -length $l $p $name] == 0 &&
7355 ([string length $name] == $l ||
7356 [string index $name $l] eq "/")} {
7357 return 1
7361 return 0
7364 proc addtocflist {ids} {
7365 global treediffs
7367 add_flist $treediffs($ids)
7368 getblobdiffs $ids
7371 proc diffcmd {ids flags} {
7372 global nullid nullid2
7374 set i [lsearch -exact $ids $nullid]
7375 set j [lsearch -exact $ids $nullid2]
7376 if {$i >= 0} {
7377 if {[llength $ids] > 1 && $j < 0} {
7378 # comparing working directory with some specific revision
7379 set cmd [concat | git diff-index $flags]
7380 if {$i == 0} {
7381 lappend cmd -R [lindex $ids 1]
7382 } else {
7383 lappend cmd [lindex $ids 0]
7385 } else {
7386 # comparing working directory with index
7387 set cmd [concat | git diff-files $flags]
7388 if {$j == 1} {
7389 lappend cmd -R
7392 } elseif {$j >= 0} {
7393 set cmd [concat | git diff-index --cached $flags]
7394 if {[llength $ids] > 1} {
7395 # comparing index with specific revision
7396 if {$j == 0} {
7397 lappend cmd -R [lindex $ids 1]
7398 } else {
7399 lappend cmd [lindex $ids 0]
7401 } else {
7402 # comparing index with HEAD
7403 lappend cmd HEAD
7405 } else {
7406 set cmd [concat | git diff-tree -r $flags $ids]
7408 return $cmd
7411 proc gettreediffs {ids} {
7412 global treediff treepending
7414 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7416 set treepending $ids
7417 set treediff {}
7418 fconfigure $gdtf -blocking 0 -encoding binary
7419 filerun $gdtf [list gettreediffline $gdtf $ids]
7422 proc gettreediffline {gdtf ids} {
7423 global treediff treediffs treepending diffids diffmergeid
7424 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7426 set nr 0
7427 set sublist {}
7428 set max 1000
7429 if {$perfile_attrs} {
7430 # cache_gitattr is slow, and even slower on win32 where we
7431 # have to invoke it for only about 30 paths at a time
7432 set max 500
7433 if {[tk windowingsystem] == "win32"} {
7434 set max 120
7437 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7438 set i [string first "\t" $line]
7439 if {$i >= 0} {
7440 set file [string range $line [expr {$i+1}] end]
7441 if {[string index $file 0] eq "\""} {
7442 set file [lindex $file 0]
7444 set file [encoding convertfrom $file]
7445 if {$file ne [lindex $treediff end]} {
7446 lappend treediff $file
7447 lappend sublist $file
7451 if {$perfile_attrs} {
7452 cache_gitattr encoding $sublist
7454 if {![eof $gdtf]} {
7455 return [expr {$nr >= $max? 2: 1}]
7457 close $gdtf
7458 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7459 set flist {}
7460 foreach f $treediff {
7461 if {[path_filter $vfilelimit($curview) $f]} {
7462 lappend flist $f
7465 set treediffs($ids) $flist
7466 } else {
7467 set treediffs($ids) $treediff
7469 unset treepending
7470 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7471 gettree $diffids
7472 } elseif {$ids != $diffids} {
7473 if {![info exists diffmergeid]} {
7474 gettreediffs $diffids
7476 } else {
7477 addtocflist $ids
7479 return 0
7482 # empty string or positive integer
7483 proc diffcontextvalidate {v} {
7484 return [regexp {^(|[1-9][0-9]*)$} $v]
7487 proc diffcontextchange {n1 n2 op} {
7488 global diffcontextstring diffcontext
7490 if {[string is integer -strict $diffcontextstring]} {
7491 if {$diffcontextstring >= 0} {
7492 set diffcontext $diffcontextstring
7493 reselectline
7498 proc changeignorespace {} {
7499 reselectline
7502 proc getblobdiffs {ids} {
7503 global blobdifffd diffids env
7504 global diffinhdr treediffs
7505 global diffcontext
7506 global ignorespace
7507 global limitdiffs vfilelimit curview
7508 global diffencoding targetline diffnparents
7509 global git_version
7511 set textconv {}
7512 if {[package vcompare $git_version "1.6.1"] >= 0} {
7513 set textconv "--textconv"
7515 set submodule {}
7516 if {[package vcompare $git_version "1.6.6"] >= 0} {
7517 set submodule "--submodule"
7519 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7520 if {$ignorespace} {
7521 append cmd " -w"
7523 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7524 set cmd [concat $cmd -- $vfilelimit($curview)]
7526 if {[catch {set bdf [open $cmd r]} err]} {
7527 error_popup [mc "Error getting diffs: %s" $err]
7528 return
7530 set targetline {}
7531 set diffnparents 0
7532 set diffinhdr 0
7533 set diffencoding [get_path_encoding {}]
7534 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7535 set blobdifffd($ids) $bdf
7536 filerun $bdf [list getblobdiffline $bdf $diffids]
7539 proc savecmitpos {} {
7540 global ctext cmitmode
7542 if {$cmitmode eq "tree"} {
7543 return {}
7545 return [list target_scrollpos [$ctext index @0,0]]
7548 proc savectextpos {} {
7549 global ctext
7551 return [list target_scrollpos [$ctext index @0,0]]
7554 proc maybe_scroll_ctext {ateof} {
7555 global ctext target_scrollpos
7557 if {![info exists target_scrollpos]} return
7558 if {!$ateof} {
7559 set nlines [expr {[winfo height $ctext]
7560 / [font metrics textfont -linespace]}]
7561 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7563 $ctext yview $target_scrollpos
7564 unset target_scrollpos
7567 proc setinlist {var i val} {
7568 global $var
7570 while {[llength [set $var]] < $i} {
7571 lappend $var {}
7573 if {[llength [set $var]] == $i} {
7574 lappend $var $val
7575 } else {
7576 lset $var $i $val
7580 proc makediffhdr {fname ids} {
7581 global ctext curdiffstart treediffs diffencoding
7582 global ctext_file_names jump_to_here targetline diffline
7584 set fname [encoding convertfrom $fname]
7585 set diffencoding [get_path_encoding $fname]
7586 set i [lsearch -exact $treediffs($ids) $fname]
7587 if {$i >= 0} {
7588 setinlist difffilestart $i $curdiffstart
7590 lset ctext_file_names end $fname
7591 set l [expr {(78 - [string length $fname]) / 2}]
7592 set pad [string range "----------------------------------------" 1 $l]
7593 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7594 set targetline {}
7595 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7596 set targetline [lindex $jump_to_here 1]
7598 set diffline 0
7601 proc getblobdiffline {bdf ids} {
7602 global diffids blobdifffd ctext curdiffstart
7603 global diffnexthead diffnextnote difffilestart
7604 global ctext_file_names ctext_file_lines
7605 global diffinhdr treediffs mergemax diffnparents
7606 global diffencoding jump_to_here targetline diffline
7608 set nr 0
7609 $ctext conf -state normal
7610 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7611 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7612 catch {close $bdf}
7613 return 0
7615 if {![string compare -length 5 "diff " $line]} {
7616 if {![regexp {^diff (--cc|--git) } $line m type]} {
7617 set line [encoding convertfrom $line]
7618 $ctext insert end "$line\n" hunksep
7619 continue
7621 # start of a new file
7622 set diffinhdr 1
7623 $ctext insert end "\n"
7624 set curdiffstart [$ctext index "end - 1c"]
7625 lappend ctext_file_names ""
7626 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7627 $ctext insert end "\n" filesep
7629 if {$type eq "--cc"} {
7630 # start of a new file in a merge diff
7631 set fname [string range $line 10 end]
7632 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7633 lappend treediffs($ids) $fname
7634 add_flist [list $fname]
7637 } else {
7638 set line [string range $line 11 end]
7639 # If the name hasn't changed the length will be odd,
7640 # the middle char will be a space, and the two bits either
7641 # side will be a/name and b/name, or "a/name" and "b/name".
7642 # If the name has changed we'll get "rename from" and
7643 # "rename to" or "copy from" and "copy to" lines following
7644 # this, and we'll use them to get the filenames.
7645 # This complexity is necessary because spaces in the
7646 # filename(s) don't get escaped.
7647 set l [string length $line]
7648 set i [expr {$l / 2}]
7649 if {!(($l & 1) && [string index $line $i] eq " " &&
7650 [string range $line 2 [expr {$i - 1}]] eq \
7651 [string range $line [expr {$i + 3}] end])} {
7652 continue
7654 # unescape if quoted and chop off the a/ from the front
7655 if {[string index $line 0] eq "\""} {
7656 set fname [string range [lindex $line 0] 2 end]
7657 } else {
7658 set fname [string range $line 2 [expr {$i - 1}]]
7661 makediffhdr $fname $ids
7663 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7664 set fname [encoding convertfrom [string range $line 16 end]]
7665 $ctext insert end "\n"
7666 set curdiffstart [$ctext index "end - 1c"]
7667 lappend ctext_file_names $fname
7668 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7669 $ctext insert end "$line\n" filesep
7670 set i [lsearch -exact $treediffs($ids) $fname]
7671 if {$i >= 0} {
7672 setinlist difffilestart $i $curdiffstart
7675 } elseif {![string compare -length 2 "@@" $line]} {
7676 regexp {^@@+} $line ats
7677 set line [encoding convertfrom $diffencoding $line]
7678 $ctext insert end "$line\n" hunksep
7679 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7680 set diffline $nl
7682 set diffnparents [expr {[string length $ats] - 1}]
7683 set diffinhdr 0
7685 } elseif {![string compare -length 10 "Submodule " $line]} {
7686 # start of a new submodule
7687 if {[string compare [$ctext get "end - 4c" end] "\n \n\n"]} {
7688 $ctext insert end "\n"; # Add newline after commit message
7690 set curdiffstart [$ctext index "end - 1c"]
7691 lappend ctext_file_names ""
7692 set fname [string range $line 10 [expr [string last " " $line] - 1]]
7693 lappend ctext_file_lines $fname
7694 makediffhdr $fname $ids
7695 $ctext insert end "\n$line\n" filesep
7696 } elseif {![string compare -length 3 " >" $line]} {
7697 set line [encoding convertfrom $diffencoding $line]
7698 $ctext insert end "$line\n" dresult
7699 } elseif {![string compare -length 3 " <" $line]} {
7700 set line [encoding convertfrom $diffencoding $line]
7701 $ctext insert end "$line\n" d0
7702 } elseif {$diffinhdr} {
7703 if {![string compare -length 12 "rename from " $line]} {
7704 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7705 if {[string index $fname 0] eq "\""} {
7706 set fname [lindex $fname 0]
7708 set fname [encoding convertfrom $fname]
7709 set i [lsearch -exact $treediffs($ids) $fname]
7710 if {$i >= 0} {
7711 setinlist difffilestart $i $curdiffstart
7713 } elseif {![string compare -length 10 $line "rename to "] ||
7714 ![string compare -length 8 $line "copy to "]} {
7715 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7716 if {[string index $fname 0] eq "\""} {
7717 set fname [lindex $fname 0]
7719 makediffhdr $fname $ids
7720 } elseif {[string compare -length 3 $line "---"] == 0} {
7721 # do nothing
7722 continue
7723 } elseif {[string compare -length 3 $line "+++"] == 0} {
7724 set diffinhdr 0
7725 continue
7727 $ctext insert end "$line\n" filesep
7729 } else {
7730 set line [string map {\x1A ^Z} \
7731 [encoding convertfrom $diffencoding $line]]
7732 # parse the prefix - one ' ', '-' or '+' for each parent
7733 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7734 set tag [expr {$diffnparents > 1? "m": "d"}]
7735 if {[string trim $prefix " -+"] eq {}} {
7736 # prefix only has " ", "-" and "+" in it: normal diff line
7737 set num [string first "-" $prefix]
7738 if {$num >= 0} {
7739 # removed line, first parent with line is $num
7740 if {$num >= $mergemax} {
7741 set num "max"
7743 $ctext insert end "$line\n" $tag$num
7744 } else {
7745 set tags {}
7746 if {[string first "+" $prefix] >= 0} {
7747 # added line
7748 lappend tags ${tag}result
7749 if {$diffnparents > 1} {
7750 set num [string first " " $prefix]
7751 if {$num >= 0} {
7752 if {$num >= $mergemax} {
7753 set num "max"
7755 lappend tags m$num
7759 if {$targetline ne {}} {
7760 if {$diffline == $targetline} {
7761 set seehere [$ctext index "end - 1 chars"]
7762 set targetline {}
7763 } else {
7764 incr diffline
7767 $ctext insert end "$line\n" $tags
7769 } else {
7770 # "\ No newline at end of file",
7771 # or something else we don't recognize
7772 $ctext insert end "$line\n" hunksep
7776 if {[info exists seehere]} {
7777 mark_ctext_line [lindex [split $seehere .] 0]
7779 maybe_scroll_ctext [eof $bdf]
7780 $ctext conf -state disabled
7781 if {[eof $bdf]} {
7782 catch {close $bdf}
7783 return 0
7785 return [expr {$nr >= 1000? 2: 1}]
7788 proc changediffdisp {} {
7789 global ctext diffelide
7791 $ctext tag conf d0 -elide [lindex $diffelide 0]
7792 $ctext tag conf dresult -elide [lindex $diffelide 1]
7795 proc highlightfile {loc cline} {
7796 global ctext cflist cflist_top
7798 $ctext yview $loc
7799 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7800 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7801 $cflist see $cline.0
7802 set cflist_top $cline
7805 proc prevfile {} {
7806 global difffilestart ctext cmitmode
7808 if {$cmitmode eq "tree"} return
7809 set prev 0.0
7810 set prevline 1
7811 set here [$ctext index @0,0]
7812 foreach loc $difffilestart {
7813 if {[$ctext compare $loc >= $here]} {
7814 highlightfile $prev $prevline
7815 return
7817 set prev $loc
7818 incr prevline
7820 highlightfile $prev $prevline
7823 proc nextfile {} {
7824 global difffilestart ctext cmitmode
7826 if {$cmitmode eq "tree"} return
7827 set here [$ctext index @0,0]
7828 set line 1
7829 foreach loc $difffilestart {
7830 incr line
7831 if {[$ctext compare $loc > $here]} {
7832 highlightfile $loc $line
7833 return
7838 proc clear_ctext {{first 1.0}} {
7839 global ctext smarktop smarkbot
7840 global ctext_file_names ctext_file_lines
7841 global pendinglinks
7843 set l [lindex [split $first .] 0]
7844 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7845 set smarktop $l
7847 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7848 set smarkbot $l
7850 $ctext delete $first end
7851 if {$first eq "1.0"} {
7852 catch {unset pendinglinks}
7854 set ctext_file_names {}
7855 set ctext_file_lines {}
7858 proc settabs {{firstab {}}} {
7859 global firsttabstop tabstop ctext have_tk85
7861 if {$firstab ne {} && $have_tk85} {
7862 set firsttabstop $firstab
7864 set w [font measure textfont "0"]
7865 if {$firsttabstop != 0} {
7866 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7867 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7868 } elseif {$have_tk85 || $tabstop != 8} {
7869 $ctext conf -tabs [expr {$tabstop * $w}]
7870 } else {
7871 $ctext conf -tabs {}
7875 proc incrsearch {name ix op} {
7876 global ctext searchstring searchdirn
7878 $ctext tag remove found 1.0 end
7879 if {[catch {$ctext index anchor}]} {
7880 # no anchor set, use start of selection, or of visible area
7881 set sel [$ctext tag ranges sel]
7882 if {$sel ne {}} {
7883 $ctext mark set anchor [lindex $sel 0]
7884 } elseif {$searchdirn eq "-forwards"} {
7885 $ctext mark set anchor @0,0
7886 } else {
7887 $ctext mark set anchor @0,[winfo height $ctext]
7890 if {$searchstring ne {}} {
7891 set here [$ctext search $searchdirn -- $searchstring anchor]
7892 if {$here ne {}} {
7893 $ctext see $here
7895 searchmarkvisible 1
7899 proc dosearch {} {
7900 global sstring ctext searchstring searchdirn
7902 focus $sstring
7903 $sstring icursor end
7904 set searchdirn -forwards
7905 if {$searchstring ne {}} {
7906 set sel [$ctext tag ranges sel]
7907 if {$sel ne {}} {
7908 set start "[lindex $sel 0] + 1c"
7909 } elseif {[catch {set start [$ctext index anchor]}]} {
7910 set start "@0,0"
7912 set match [$ctext search -count mlen -- $searchstring $start]
7913 $ctext tag remove sel 1.0 end
7914 if {$match eq {}} {
7915 bell
7916 return
7918 $ctext see $match
7919 set mend "$match + $mlen c"
7920 $ctext tag add sel $match $mend
7921 $ctext mark unset anchor
7925 proc dosearchback {} {
7926 global sstring ctext searchstring searchdirn
7928 focus $sstring
7929 $sstring icursor end
7930 set searchdirn -backwards
7931 if {$searchstring ne {}} {
7932 set sel [$ctext tag ranges sel]
7933 if {$sel ne {}} {
7934 set start [lindex $sel 0]
7935 } elseif {[catch {set start [$ctext index anchor]}]} {
7936 set start @0,[winfo height $ctext]
7938 set match [$ctext search -backwards -count ml -- $searchstring $start]
7939 $ctext tag remove sel 1.0 end
7940 if {$match eq {}} {
7941 bell
7942 return
7944 $ctext see $match
7945 set mend "$match + $ml c"
7946 $ctext tag add sel $match $mend
7947 $ctext mark unset anchor
7951 proc searchmark {first last} {
7952 global ctext searchstring
7954 set mend $first.0
7955 while {1} {
7956 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7957 if {$match eq {}} break
7958 set mend "$match + $mlen c"
7959 $ctext tag add found $match $mend
7963 proc searchmarkvisible {doall} {
7964 global ctext smarktop smarkbot
7966 set topline [lindex [split [$ctext index @0,0] .] 0]
7967 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7968 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7969 # no overlap with previous
7970 searchmark $topline $botline
7971 set smarktop $topline
7972 set smarkbot $botline
7973 } else {
7974 if {$topline < $smarktop} {
7975 searchmark $topline [expr {$smarktop-1}]
7976 set smarktop $topline
7978 if {$botline > $smarkbot} {
7979 searchmark [expr {$smarkbot+1}] $botline
7980 set smarkbot $botline
7985 proc scrolltext {f0 f1} {
7986 global searchstring
7988 .bleft.bottom.sb set $f0 $f1
7989 if {$searchstring ne {}} {
7990 searchmarkvisible 0
7994 proc setcoords {} {
7995 global linespc charspc canvx0 canvy0
7996 global xspc1 xspc2 lthickness
7998 set linespc [font metrics mainfont -linespace]
7999 set charspc [font measure mainfont "m"]
8000 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8001 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8002 set lthickness [expr {int($linespc / 9) + 1}]
8003 set xspc1(0) $linespc
8004 set xspc2 $linespc
8007 proc redisplay {} {
8008 global canv
8009 global selectedline
8011 set ymax [lindex [$canv cget -scrollregion] 3]
8012 if {$ymax eq {} || $ymax == 0} return
8013 set span [$canv yview]
8014 clear_display
8015 setcanvscroll
8016 allcanvs yview moveto [lindex $span 0]
8017 drawvisible
8018 if {$selectedline ne {}} {
8019 selectline $selectedline 0
8020 allcanvs yview moveto [lindex $span 0]
8024 proc parsefont {f n} {
8025 global fontattr
8027 set fontattr($f,family) [lindex $n 0]
8028 set s [lindex $n 1]
8029 if {$s eq {} || $s == 0} {
8030 set s 10
8031 } elseif {$s < 0} {
8032 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8034 set fontattr($f,size) $s
8035 set fontattr($f,weight) normal
8036 set fontattr($f,slant) roman
8037 foreach style [lrange $n 2 end] {
8038 switch -- $style {
8039 "normal" -
8040 "bold" {set fontattr($f,weight) $style}
8041 "roman" -
8042 "italic" {set fontattr($f,slant) $style}
8047 proc fontflags {f {isbold 0}} {
8048 global fontattr
8050 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8051 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8052 -slant $fontattr($f,slant)]
8055 proc fontname {f} {
8056 global fontattr
8058 set n [list $fontattr($f,family) $fontattr($f,size)]
8059 if {$fontattr($f,weight) eq "bold"} {
8060 lappend n "bold"
8062 if {$fontattr($f,slant) eq "italic"} {
8063 lappend n "italic"
8065 return $n
8068 proc incrfont {inc} {
8069 global mainfont textfont ctext canv cflist showrefstop
8070 global stopped entries fontattr
8072 unmarkmatches
8073 set s $fontattr(mainfont,size)
8074 incr s $inc
8075 if {$s < 1} {
8076 set s 1
8078 set fontattr(mainfont,size) $s
8079 font config mainfont -size $s
8080 font config mainfontbold -size $s
8081 set mainfont [fontname mainfont]
8082 set s $fontattr(textfont,size)
8083 incr s $inc
8084 if {$s < 1} {
8085 set s 1
8087 set fontattr(textfont,size) $s
8088 font config textfont -size $s
8089 font config textfontbold -size $s
8090 set textfont [fontname textfont]
8091 setcoords
8092 settabs
8093 redisplay
8096 proc clearsha1 {} {
8097 global sha1entry sha1string
8098 if {[string length $sha1string] == 40} {
8099 $sha1entry delete 0 end
8103 proc sha1change {n1 n2 op} {
8104 global sha1string currentid sha1but
8105 if {$sha1string == {}
8106 || ([info exists currentid] && $sha1string == $currentid)} {
8107 set state disabled
8108 } else {
8109 set state normal
8111 if {[$sha1but cget -state] == $state} return
8112 if {$state == "normal"} {
8113 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8114 } else {
8115 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8119 proc gotocommit {} {
8120 global sha1string tagids headids curview varcid
8122 if {$sha1string == {}
8123 || ([info exists currentid] && $sha1string == $currentid)} return
8124 if {[info exists tagids($sha1string)]} {
8125 set id $tagids($sha1string)
8126 } elseif {[info exists headids($sha1string)]} {
8127 set id $headids($sha1string)
8128 } else {
8129 set id [string tolower $sha1string]
8130 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8131 set matches [longid $id]
8132 if {$matches ne {}} {
8133 if {[llength $matches] > 1} {
8134 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8135 return
8137 set id [lindex $matches 0]
8139 } else {
8140 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8141 error_popup [mc "Revision %s is not known" $sha1string]
8142 return
8146 if {[commitinview $id $curview]} {
8147 selectline [rowofcommit $id] 1
8148 return
8150 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8151 set msg [mc "SHA1 id %s is not known" $sha1string]
8152 } else {
8153 set msg [mc "Revision %s is not in the current view" $sha1string]
8155 error_popup $msg
8158 proc lineenter {x y id} {
8159 global hoverx hovery hoverid hovertimer
8160 global commitinfo canv
8162 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8163 set hoverx $x
8164 set hovery $y
8165 set hoverid $id
8166 if {[info exists hovertimer]} {
8167 after cancel $hovertimer
8169 set hovertimer [after 500 linehover]
8170 $canv delete hover
8173 proc linemotion {x y id} {
8174 global hoverx hovery hoverid hovertimer
8176 if {[info exists hoverid] && $id == $hoverid} {
8177 set hoverx $x
8178 set hovery $y
8179 if {[info exists hovertimer]} {
8180 after cancel $hovertimer
8182 set hovertimer [after 500 linehover]
8186 proc lineleave {id} {
8187 global hoverid hovertimer canv
8189 if {[info exists hoverid] && $id == $hoverid} {
8190 $canv delete hover
8191 if {[info exists hovertimer]} {
8192 after cancel $hovertimer
8193 unset hovertimer
8195 unset hoverid
8199 proc linehover {} {
8200 global hoverx hovery hoverid hovertimer
8201 global canv linespc lthickness
8202 global commitinfo
8204 set text [lindex $commitinfo($hoverid) 0]
8205 set ymax [lindex [$canv cget -scrollregion] 3]
8206 if {$ymax == {}} return
8207 set yfrac [lindex [$canv yview] 0]
8208 set x [expr {$hoverx + 2 * $linespc}]
8209 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8210 set x0 [expr {$x - 2 * $lthickness}]
8211 set y0 [expr {$y - 2 * $lthickness}]
8212 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8213 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8214 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8215 -fill \#ffff80 -outline black -width 1 -tags hover]
8216 $canv raise $t
8217 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8218 -font mainfont]
8219 $canv raise $t
8222 proc clickisonarrow {id y} {
8223 global lthickness
8225 set ranges [rowranges $id]
8226 set thresh [expr {2 * $lthickness + 6}]
8227 set n [expr {[llength $ranges] - 1}]
8228 for {set i 1} {$i < $n} {incr i} {
8229 set row [lindex $ranges $i]
8230 if {abs([yc $row] - $y) < $thresh} {
8231 return $i
8234 return {}
8237 proc arrowjump {id n y} {
8238 global canv
8240 # 1 <-> 2, 3 <-> 4, etc...
8241 set n [expr {(($n - 1) ^ 1) + 1}]
8242 set row [lindex [rowranges $id] $n]
8243 set yt [yc $row]
8244 set ymax [lindex [$canv cget -scrollregion] 3]
8245 if {$ymax eq {} || $ymax <= 0} return
8246 set view [$canv yview]
8247 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8248 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8249 if {$yfrac < 0} {
8250 set yfrac 0
8252 allcanvs yview moveto $yfrac
8255 proc lineclick {x y id isnew} {
8256 global ctext commitinfo children canv thickerline curview
8258 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8259 unmarkmatches
8260 unselectline
8261 normalline
8262 $canv delete hover
8263 # draw this line thicker than normal
8264 set thickerline $id
8265 drawlines $id
8266 if {$isnew} {
8267 set ymax [lindex [$canv cget -scrollregion] 3]
8268 if {$ymax eq {}} return
8269 set yfrac [lindex [$canv yview] 0]
8270 set y [expr {$y + $yfrac * $ymax}]
8272 set dirn [clickisonarrow $id $y]
8273 if {$dirn ne {}} {
8274 arrowjump $id $dirn $y
8275 return
8278 if {$isnew} {
8279 addtohistory [list lineclick $x $y $id 0] savectextpos
8281 # fill the details pane with info about this line
8282 $ctext conf -state normal
8283 clear_ctext
8284 settabs 0
8285 $ctext insert end "[mc "Parent"]:\t"
8286 $ctext insert end $id link0
8287 setlink $id link0
8288 set info $commitinfo($id)
8289 $ctext insert end "\n\t[lindex $info 0]\n"
8290 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8291 set date [formatdate [lindex $info 2]]
8292 $ctext insert end "\t[mc "Date"]:\t$date\n"
8293 set kids $children($curview,$id)
8294 if {$kids ne {}} {
8295 $ctext insert end "\n[mc "Children"]:"
8296 set i 0
8297 foreach child $kids {
8298 incr i
8299 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8300 set info $commitinfo($child)
8301 $ctext insert end "\n\t"
8302 $ctext insert end $child link$i
8303 setlink $child link$i
8304 $ctext insert end "\n\t[lindex $info 0]"
8305 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8306 set date [formatdate [lindex $info 2]]
8307 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8310 maybe_scroll_ctext 1
8311 $ctext conf -state disabled
8312 init_flist {}
8315 proc normalline {} {
8316 global thickerline
8317 if {[info exists thickerline]} {
8318 set id $thickerline
8319 unset thickerline
8320 drawlines $id
8324 proc selbyid {id {isnew 1}} {
8325 global curview
8326 if {[commitinview $id $curview]} {
8327 selectline [rowofcommit $id] $isnew
8331 proc mstime {} {
8332 global startmstime
8333 if {![info exists startmstime]} {
8334 set startmstime [clock clicks -milliseconds]
8336 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8339 proc rowmenu {x y id} {
8340 global rowctxmenu selectedline rowmenuid curview
8341 global nullid nullid2 fakerowmenu mainhead markedid
8343 stopfinding
8344 set rowmenuid $id
8345 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8346 set state disabled
8347 } else {
8348 set state normal
8350 if {$id ne $nullid && $id ne $nullid2} {
8351 set menu $rowctxmenu
8352 if {$mainhead ne {}} {
8353 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8354 } else {
8355 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8357 if {[info exists markedid] && $markedid ne $id} {
8358 $menu entryconfigure 9 -state normal
8359 $menu entryconfigure 10 -state normal
8360 $menu entryconfigure 11 -state normal
8361 } else {
8362 $menu entryconfigure 9 -state disabled
8363 $menu entryconfigure 10 -state disabled
8364 $menu entryconfigure 11 -state disabled
8366 } else {
8367 set menu $fakerowmenu
8369 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8370 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8371 $menu entryconfigure [mca "Make patch"] -state $state
8372 tk_popup $menu $x $y
8375 proc markhere {} {
8376 global rowmenuid markedid canv
8378 set markedid $rowmenuid
8379 make_idmark $markedid
8382 proc gotomark {} {
8383 global markedid
8385 if {[info exists markedid]} {
8386 selbyid $markedid
8390 proc replace_by_kids {l r} {
8391 global curview children
8393 set id [commitonrow $r]
8394 set l [lreplace $l 0 0]
8395 foreach kid $children($curview,$id) {
8396 lappend l [rowofcommit $kid]
8398 return [lsort -integer -decreasing -unique $l]
8401 proc find_common_desc {} {
8402 global markedid rowmenuid curview children
8404 if {![info exists markedid]} return
8405 if {![commitinview $markedid $curview] ||
8406 ![commitinview $rowmenuid $curview]} return
8407 #set t1 [clock clicks -milliseconds]
8408 set l1 [list [rowofcommit $markedid]]
8409 set l2 [list [rowofcommit $rowmenuid]]
8410 while 1 {
8411 set r1 [lindex $l1 0]
8412 set r2 [lindex $l2 0]
8413 if {$r1 eq {} || $r2 eq {}} break
8414 if {$r1 == $r2} {
8415 selectline $r1 1
8416 break
8418 if {$r1 > $r2} {
8419 set l1 [replace_by_kids $l1 $r1]
8420 } else {
8421 set l2 [replace_by_kids $l2 $r2]
8424 #set t2 [clock clicks -milliseconds]
8425 #puts "took [expr {$t2-$t1}]ms"
8428 proc compare_commits {} {
8429 global markedid rowmenuid curview children
8431 if {![info exists markedid]} return
8432 if {![commitinview $markedid $curview]} return
8433 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8434 do_cmp_commits $markedid $rowmenuid
8437 proc getpatchid {id} {
8438 global patchids
8440 if {![info exists patchids($id)]} {
8441 set cmd [diffcmd [list $id] {-p --root}]
8442 # trim off the initial "|"
8443 set cmd [lrange $cmd 1 end]
8444 if {[catch {
8445 set x [eval exec $cmd | git patch-id]
8446 set patchids($id) [lindex $x 0]
8447 }]} {
8448 set patchids($id) "error"
8451 return $patchids($id)
8454 proc do_cmp_commits {a b} {
8455 global ctext curview parents children patchids commitinfo
8457 $ctext conf -state normal
8458 clear_ctext
8459 init_flist {}
8460 for {set i 0} {$i < 100} {incr i} {
8461 set skipa 0
8462 set skipb 0
8463 if {[llength $parents($curview,$a)] > 1} {
8464 appendshortlink $a [mc "Skipping merge commit "] "\n"
8465 set skipa 1
8466 } else {
8467 set patcha [getpatchid $a]
8469 if {[llength $parents($curview,$b)] > 1} {
8470 appendshortlink $b [mc "Skipping merge commit "] "\n"
8471 set skipb 1
8472 } else {
8473 set patchb [getpatchid $b]
8475 if {!$skipa && !$skipb} {
8476 set heada [lindex $commitinfo($a) 0]
8477 set headb [lindex $commitinfo($b) 0]
8478 if {$patcha eq "error"} {
8479 appendshortlink $a [mc "Error getting patch ID for "] \
8480 [mc " - stopping\n"]
8481 break
8483 if {$patchb eq "error"} {
8484 appendshortlink $b [mc "Error getting patch ID for "] \
8485 [mc " - stopping\n"]
8486 break
8488 if {$patcha eq $patchb} {
8489 if {$heada eq $headb} {
8490 appendshortlink $a [mc "Commit "]
8491 appendshortlink $b " == " " $heada\n"
8492 } else {
8493 appendshortlink $a [mc "Commit "] " $heada\n"
8494 appendshortlink $b [mc " is the same patch as\n "] \
8495 " $headb\n"
8497 set skipa 1
8498 set skipb 1
8499 } else {
8500 $ctext insert end "\n"
8501 appendshortlink $a [mc "Commit "] " $heada\n"
8502 appendshortlink $b [mc " differs from\n "] \
8503 " $headb\n"
8504 $ctext insert end [mc "Diff of commits:\n\n"]
8505 $ctext conf -state disabled
8506 update
8507 diffcommits $a $b
8508 return
8511 if {$skipa} {
8512 set kids [real_children $curview,$a]
8513 if {[llength $kids] != 1} {
8514 $ctext insert end "\n"
8515 appendshortlink $a [mc "Commit "] \
8516 [mc " has %s children - stopping\n" [llength $kids]]
8517 break
8519 set a [lindex $kids 0]
8521 if {$skipb} {
8522 set kids [real_children $curview,$b]
8523 if {[llength $kids] != 1} {
8524 appendshortlink $b [mc "Commit "] \
8525 [mc " has %s children - stopping\n" [llength $kids]]
8526 break
8528 set b [lindex $kids 0]
8531 $ctext conf -state disabled
8534 proc diffcommits {a b} {
8535 global diffcontext diffids blobdifffd diffinhdr
8537 set tmpdir [gitknewtmpdir]
8538 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8539 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8540 if {[catch {
8541 exec git diff-tree -p --pretty $a >$fna
8542 exec git diff-tree -p --pretty $b >$fnb
8543 } err]} {
8544 error_popup [mc "Error writing commit to file: %s" $err]
8545 return
8547 if {[catch {
8548 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8549 } err]} {
8550 error_popup [mc "Error diffing commits: %s" $err]
8551 return
8553 set diffids [list commits $a $b]
8554 set blobdifffd($diffids) $fd
8555 set diffinhdr 0
8556 filerun $fd [list getblobdiffline $fd $diffids]
8559 proc diffvssel {dirn} {
8560 global rowmenuid selectedline
8562 if {$selectedline eq {}} return
8563 if {$dirn} {
8564 set oldid [commitonrow $selectedline]
8565 set newid $rowmenuid
8566 } else {
8567 set oldid $rowmenuid
8568 set newid [commitonrow $selectedline]
8570 addtohistory [list doseldiff $oldid $newid] savectextpos
8571 doseldiff $oldid $newid
8574 proc doseldiff {oldid newid} {
8575 global ctext
8576 global commitinfo
8578 $ctext conf -state normal
8579 clear_ctext
8580 init_flist [mc "Top"]
8581 $ctext insert end "[mc "From"] "
8582 $ctext insert end $oldid link0
8583 setlink $oldid link0
8584 $ctext insert end "\n "
8585 $ctext insert end [lindex $commitinfo($oldid) 0]
8586 $ctext insert end "\n\n[mc "To"] "
8587 $ctext insert end $newid link1
8588 setlink $newid link1
8589 $ctext insert end "\n "
8590 $ctext insert end [lindex $commitinfo($newid) 0]
8591 $ctext insert end "\n"
8592 $ctext conf -state disabled
8593 $ctext tag remove found 1.0 end
8594 startdiff [list $oldid $newid]
8597 proc mkpatch {} {
8598 global rowmenuid currentid commitinfo patchtop patchnum NS
8600 if {![info exists currentid]} return
8601 set oldid $currentid
8602 set oldhead [lindex $commitinfo($oldid) 0]
8603 set newid $rowmenuid
8604 set newhead [lindex $commitinfo($newid) 0]
8605 set top .patch
8606 set patchtop $top
8607 catch {destroy $top}
8608 ttk_toplevel $top
8609 make_transient $top .
8610 ${NS}::label $top.title -text [mc "Generate patch"]
8611 grid $top.title - -pady 10
8612 ${NS}::label $top.from -text [mc "From:"]
8613 ${NS}::entry $top.fromsha1 -width 40
8614 $top.fromsha1 insert 0 $oldid
8615 $top.fromsha1 conf -state readonly
8616 grid $top.from $top.fromsha1 -sticky w
8617 ${NS}::entry $top.fromhead -width 60
8618 $top.fromhead insert 0 $oldhead
8619 $top.fromhead conf -state readonly
8620 grid x $top.fromhead -sticky w
8621 ${NS}::label $top.to -text [mc "To:"]
8622 ${NS}::entry $top.tosha1 -width 40
8623 $top.tosha1 insert 0 $newid
8624 $top.tosha1 conf -state readonly
8625 grid $top.to $top.tosha1 -sticky w
8626 ${NS}::entry $top.tohead -width 60
8627 $top.tohead insert 0 $newhead
8628 $top.tohead conf -state readonly
8629 grid x $top.tohead -sticky w
8630 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8631 grid $top.rev x -pady 10 -padx 5
8632 ${NS}::label $top.flab -text [mc "Output file:"]
8633 ${NS}::entry $top.fname -width 60
8634 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8635 incr patchnum
8636 grid $top.flab $top.fname -sticky w
8637 ${NS}::frame $top.buts
8638 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8639 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8640 bind $top <Key-Return> mkpatchgo
8641 bind $top <Key-Escape> mkpatchcan
8642 grid $top.buts.gen $top.buts.can
8643 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8644 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8645 grid $top.buts - -pady 10 -sticky ew
8646 focus $top.fname
8649 proc mkpatchrev {} {
8650 global patchtop
8652 set oldid [$patchtop.fromsha1 get]
8653 set oldhead [$patchtop.fromhead get]
8654 set newid [$patchtop.tosha1 get]
8655 set newhead [$patchtop.tohead get]
8656 foreach e [list fromsha1 fromhead tosha1 tohead] \
8657 v [list $newid $newhead $oldid $oldhead] {
8658 $patchtop.$e conf -state normal
8659 $patchtop.$e delete 0 end
8660 $patchtop.$e insert 0 $v
8661 $patchtop.$e conf -state readonly
8665 proc mkpatchgo {} {
8666 global patchtop nullid nullid2
8668 set oldid [$patchtop.fromsha1 get]
8669 set newid [$patchtop.tosha1 get]
8670 set fname [$patchtop.fname get]
8671 set cmd [diffcmd [list $oldid $newid] -p]
8672 # trim off the initial "|"
8673 set cmd [lrange $cmd 1 end]
8674 lappend cmd >$fname &
8675 if {[catch {eval exec $cmd} err]} {
8676 error_popup "[mc "Error creating patch:"] $err" $patchtop
8678 catch {destroy $patchtop}
8679 unset patchtop
8682 proc mkpatchcan {} {
8683 global patchtop
8685 catch {destroy $patchtop}
8686 unset patchtop
8689 proc mktag {} {
8690 global rowmenuid mktagtop commitinfo NS
8692 set top .maketag
8693 set mktagtop $top
8694 catch {destroy $top}
8695 ttk_toplevel $top
8696 make_transient $top .
8697 ${NS}::label $top.title -text [mc "Create tag"]
8698 grid $top.title - -pady 10
8699 ${NS}::label $top.id -text [mc "ID:"]
8700 ${NS}::entry $top.sha1 -width 40
8701 $top.sha1 insert 0 $rowmenuid
8702 $top.sha1 conf -state readonly
8703 grid $top.id $top.sha1 -sticky w
8704 ${NS}::entry $top.head -width 60
8705 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8706 $top.head conf -state readonly
8707 grid x $top.head -sticky w
8708 ${NS}::label $top.tlab -text [mc "Tag name:"]
8709 ${NS}::entry $top.tag -width 60
8710 grid $top.tlab $top.tag -sticky w
8711 ${NS}::label $top.op -text [mc "Tag message is optional"]
8712 grid $top.op -columnspan 2 -sticky we
8713 ${NS}::label $top.mlab -text [mc "Tag message:"]
8714 ${NS}::entry $top.msg -width 60
8715 grid $top.mlab $top.msg -sticky w
8716 ${NS}::frame $top.buts
8717 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8718 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8719 bind $top <Key-Return> mktaggo
8720 bind $top <Key-Escape> mktagcan
8721 grid $top.buts.gen $top.buts.can
8722 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8723 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8724 grid $top.buts - -pady 10 -sticky ew
8725 focus $top.tag
8728 proc domktag {} {
8729 global mktagtop env tagids idtags
8731 set id [$mktagtop.sha1 get]
8732 set tag [$mktagtop.tag get]
8733 set msg [$mktagtop.msg get]
8734 if {$tag == {}} {
8735 error_popup [mc "No tag name specified"] $mktagtop
8736 return 0
8738 if {[info exists tagids($tag)]} {
8739 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8740 return 0
8742 if {[catch {
8743 if {$msg != {}} {
8744 exec git tag -a -m $msg $tag $id
8745 } else {
8746 exec git tag $tag $id
8748 } err]} {
8749 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8750 return 0
8753 set tagids($tag) $id
8754 lappend idtags($id) $tag
8755 redrawtags $id
8756 addedtag $id
8757 dispneartags 0
8758 run refill_reflist
8759 return 1
8762 proc redrawtags {id} {
8763 global canv linehtag idpos currentid curview cmitlisted markedid
8764 global canvxmax iddrawn circleitem mainheadid circlecolors
8766 if {![commitinview $id $curview]} return
8767 if {![info exists iddrawn($id)]} return
8768 set row [rowofcommit $id]
8769 if {$id eq $mainheadid} {
8770 set ofill yellow
8771 } else {
8772 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8774 $canv itemconf $circleitem($row) -fill $ofill
8775 $canv delete tag.$id
8776 set xt [eval drawtags $id $idpos($id)]
8777 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8778 set text [$canv itemcget $linehtag($id) -text]
8779 set font [$canv itemcget $linehtag($id) -font]
8780 set xr [expr {$xt + [font measure $font $text]}]
8781 if {$xr > $canvxmax} {
8782 set canvxmax $xr
8783 setcanvscroll
8785 if {[info exists currentid] && $currentid == $id} {
8786 make_secsel $id
8788 if {[info exists markedid] && $markedid eq $id} {
8789 make_idmark $id
8793 proc mktagcan {} {
8794 global mktagtop
8796 catch {destroy $mktagtop}
8797 unset mktagtop
8800 proc mktaggo {} {
8801 if {![domktag]} return
8802 mktagcan
8805 proc writecommit {} {
8806 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8808 set top .writecommit
8809 set wrcomtop $top
8810 catch {destroy $top}
8811 ttk_toplevel $top
8812 make_transient $top .
8813 ${NS}::label $top.title -text [mc "Write commit to file"]
8814 grid $top.title - -pady 10
8815 ${NS}::label $top.id -text [mc "ID:"]
8816 ${NS}::entry $top.sha1 -width 40
8817 $top.sha1 insert 0 $rowmenuid
8818 $top.sha1 conf -state readonly
8819 grid $top.id $top.sha1 -sticky w
8820 ${NS}::entry $top.head -width 60
8821 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8822 $top.head conf -state readonly
8823 grid x $top.head -sticky w
8824 ${NS}::label $top.clab -text [mc "Command:"]
8825 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8826 grid $top.clab $top.cmd -sticky w -pady 10
8827 ${NS}::label $top.flab -text [mc "Output file:"]
8828 ${NS}::entry $top.fname -width 60
8829 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8830 grid $top.flab $top.fname -sticky w
8831 ${NS}::frame $top.buts
8832 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8833 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8834 bind $top <Key-Return> wrcomgo
8835 bind $top <Key-Escape> wrcomcan
8836 grid $top.buts.gen $top.buts.can
8837 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8838 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8839 grid $top.buts - -pady 10 -sticky ew
8840 focus $top.fname
8843 proc wrcomgo {} {
8844 global wrcomtop
8846 set id [$wrcomtop.sha1 get]
8847 set cmd "echo $id | [$wrcomtop.cmd get]"
8848 set fname [$wrcomtop.fname get]
8849 if {[catch {exec sh -c $cmd >$fname &} err]} {
8850 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8852 catch {destroy $wrcomtop}
8853 unset wrcomtop
8856 proc wrcomcan {} {
8857 global wrcomtop
8859 catch {destroy $wrcomtop}
8860 unset wrcomtop
8863 proc mkbranch {} {
8864 global rowmenuid mkbrtop NS
8866 set top .makebranch
8867 catch {destroy $top}
8868 ttk_toplevel $top
8869 make_transient $top .
8870 ${NS}::label $top.title -text [mc "Create new branch"]
8871 grid $top.title - -pady 10
8872 ${NS}::label $top.id -text [mc "ID:"]
8873 ${NS}::entry $top.sha1 -width 40
8874 $top.sha1 insert 0 $rowmenuid
8875 $top.sha1 conf -state readonly
8876 grid $top.id $top.sha1 -sticky w
8877 ${NS}::label $top.nlab -text [mc "Name:"]
8878 ${NS}::entry $top.name -width 40
8879 grid $top.nlab $top.name -sticky w
8880 ${NS}::frame $top.buts
8881 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8882 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8883 bind $top <Key-Return> [list mkbrgo $top]
8884 bind $top <Key-Escape> "catch {destroy $top}"
8885 grid $top.buts.go $top.buts.can
8886 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8887 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8888 grid $top.buts - -pady 10 -sticky ew
8889 focus $top.name
8892 proc mkbrgo {top} {
8893 global headids idheads
8895 set name [$top.name get]
8896 set id [$top.sha1 get]
8897 set cmdargs {}
8898 set old_id {}
8899 if {$name eq {}} {
8900 error_popup [mc "Please specify a name for the new branch"] $top
8901 return
8903 if {[info exists headids($name)]} {
8904 if {![confirm_popup [mc \
8905 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8906 return
8908 set old_id $headids($name)
8909 lappend cmdargs -f
8911 catch {destroy $top}
8912 lappend cmdargs $name $id
8913 nowbusy newbranch
8914 update
8915 if {[catch {
8916 eval exec git branch $cmdargs
8917 } err]} {
8918 notbusy newbranch
8919 error_popup $err
8920 } else {
8921 notbusy newbranch
8922 if {$old_id ne {}} {
8923 movehead $id $name
8924 movedhead $id $name
8925 redrawtags $old_id
8926 redrawtags $id
8927 } else {
8928 set headids($name) $id
8929 lappend idheads($id) $name
8930 addedhead $id $name
8931 redrawtags $id
8933 dispneartags 0
8934 run refill_reflist
8938 proc exec_citool {tool_args {baseid {}}} {
8939 global commitinfo env
8941 set save_env [array get env GIT_AUTHOR_*]
8943 if {$baseid ne {}} {
8944 if {![info exists commitinfo($baseid)]} {
8945 getcommit $baseid
8947 set author [lindex $commitinfo($baseid) 1]
8948 set date [lindex $commitinfo($baseid) 2]
8949 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8950 $author author name email]
8951 && $date ne {}} {
8952 set env(GIT_AUTHOR_NAME) $name
8953 set env(GIT_AUTHOR_EMAIL) $email
8954 set env(GIT_AUTHOR_DATE) $date
8958 eval exec git citool $tool_args &
8960 array unset env GIT_AUTHOR_*
8961 array set env $save_env
8964 proc cherrypick {} {
8965 global rowmenuid curview
8966 global mainhead mainheadid
8968 set oldhead [exec git rev-parse HEAD]
8969 set dheads [descheads $rowmenuid]
8970 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8971 set ok [confirm_popup [mc "Commit %s is already\
8972 included in branch %s -- really re-apply it?" \
8973 [string range $rowmenuid 0 7] $mainhead]]
8974 if {!$ok} return
8976 nowbusy cherrypick [mc "Cherry-picking"]
8977 update
8978 # Unfortunately git-cherry-pick writes stuff to stderr even when
8979 # no error occurs, and exec takes that as an indication of error...
8980 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8981 notbusy cherrypick
8982 if {[regexp -line \
8983 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8984 $err msg fname]} {
8985 error_popup [mc "Cherry-pick failed because of local changes\
8986 to file '%s'.\nPlease commit, reset or stash\
8987 your changes and try again." $fname]
8988 } elseif {[regexp -line \
8989 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8990 $err]} {
8991 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8992 conflict.\nDo you wish to run git citool to\
8993 resolve it?"]]} {
8994 # Force citool to read MERGE_MSG
8995 file delete [file join [gitdir] "GITGUI_MSG"]
8996 exec_citool {} $rowmenuid
8998 } else {
8999 error_popup $err
9001 run updatecommits
9002 return
9004 set newhead [exec git rev-parse HEAD]
9005 if {$newhead eq $oldhead} {
9006 notbusy cherrypick
9007 error_popup [mc "No changes committed"]
9008 return
9010 addnewchild $newhead $oldhead
9011 if {[commitinview $oldhead $curview]} {
9012 # XXX this isn't right if we have a path limit...
9013 insertrow $newhead $oldhead $curview
9014 if {$mainhead ne {}} {
9015 movehead $newhead $mainhead
9016 movedhead $newhead $mainhead
9018 set mainheadid $newhead
9019 redrawtags $oldhead
9020 redrawtags $newhead
9021 selbyid $newhead
9023 notbusy cherrypick
9026 proc resethead {} {
9027 global mainhead rowmenuid confirm_ok resettype NS
9029 set confirm_ok 0
9030 set w ".confirmreset"
9031 ttk_toplevel $w
9032 make_transient $w .
9033 wm title $w [mc "Confirm reset"]
9034 ${NS}::label $w.m -text \
9035 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9036 pack $w.m -side top -fill x -padx 20 -pady 20
9037 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9038 set resettype mixed
9039 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9040 -text [mc "Soft: Leave working tree and index untouched"]
9041 grid $w.f.soft -sticky w
9042 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9043 -text [mc "Mixed: Leave working tree untouched, reset index"]
9044 grid $w.f.mixed -sticky w
9045 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9046 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9047 grid $w.f.hard -sticky w
9048 pack $w.f -side top -fill x -padx 4
9049 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9050 pack $w.ok -side left -fill x -padx 20 -pady 20
9051 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9052 bind $w <Key-Escape> [list destroy $w]
9053 pack $w.cancel -side right -fill x -padx 20 -pady 20
9054 bind $w <Visibility> "grab $w; focus $w"
9055 tkwait window $w
9056 if {!$confirm_ok} return
9057 if {[catch {set fd [open \
9058 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9059 error_popup $err
9060 } else {
9061 dohidelocalchanges
9062 filerun $fd [list readresetstat $fd]
9063 nowbusy reset [mc "Resetting"]
9064 selbyid $rowmenuid
9068 proc readresetstat {fd} {
9069 global mainhead mainheadid showlocalchanges rprogcoord
9071 if {[gets $fd line] >= 0} {
9072 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9073 set rprogcoord [expr {1.0 * $m / $n}]
9074 adjustprogress
9076 return 1
9078 set rprogcoord 0
9079 adjustprogress
9080 notbusy reset
9081 if {[catch {close $fd} err]} {
9082 error_popup $err
9084 set oldhead $mainheadid
9085 set newhead [exec git rev-parse HEAD]
9086 if {$newhead ne $oldhead} {
9087 movehead $newhead $mainhead
9088 movedhead $newhead $mainhead
9089 set mainheadid $newhead
9090 redrawtags $oldhead
9091 redrawtags $newhead
9093 if {$showlocalchanges} {
9094 doshowlocalchanges
9096 return 0
9099 # context menu for a head
9100 proc headmenu {x y id head} {
9101 global headmenuid headmenuhead headctxmenu mainhead
9103 stopfinding
9104 set headmenuid $id
9105 set headmenuhead $head
9106 set state normal
9107 if {[string match "remotes/*" $head]} {
9108 set state disabled
9110 if {$head eq $mainhead} {
9111 set state disabled
9113 $headctxmenu entryconfigure 0 -state $state
9114 $headctxmenu entryconfigure 1 -state $state
9115 tk_popup $headctxmenu $x $y
9118 proc cobranch {} {
9119 global headmenuid headmenuhead headids
9120 global showlocalchanges
9122 # check the tree is clean first??
9123 nowbusy checkout [mc "Checking out"]
9124 update
9125 dohidelocalchanges
9126 if {[catch {
9127 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9128 } err]} {
9129 notbusy checkout
9130 error_popup $err
9131 if {$showlocalchanges} {
9132 dodiffindex
9134 } else {
9135 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9139 proc readcheckoutstat {fd newhead newheadid} {
9140 global mainhead mainheadid headids showlocalchanges progresscoords
9141 global viewmainheadid curview
9143 if {[gets $fd line] >= 0} {
9144 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9145 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9146 adjustprogress
9148 return 1
9150 set progresscoords {0 0}
9151 adjustprogress
9152 notbusy checkout
9153 if {[catch {close $fd} err]} {
9154 error_popup $err
9156 set oldmainid $mainheadid
9157 set mainhead $newhead
9158 set mainheadid $newheadid
9159 set viewmainheadid($curview) $newheadid
9160 redrawtags $oldmainid
9161 redrawtags $newheadid
9162 selbyid $newheadid
9163 if {$showlocalchanges} {
9164 dodiffindex
9168 proc rmbranch {} {
9169 global headmenuid headmenuhead mainhead
9170 global idheads
9172 set head $headmenuhead
9173 set id $headmenuid
9174 # this check shouldn't be needed any more...
9175 if {$head eq $mainhead} {
9176 error_popup [mc "Cannot delete the currently checked-out branch"]
9177 return
9179 set dheads [descheads $id]
9180 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9181 # the stuff on this branch isn't on any other branch
9182 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9183 branch.\nReally delete branch %s?" $head $head]]} return
9185 nowbusy rmbranch
9186 update
9187 if {[catch {exec git branch -D $head} err]} {
9188 notbusy rmbranch
9189 error_popup $err
9190 return
9192 removehead $id $head
9193 removedhead $id $head
9194 redrawtags $id
9195 notbusy rmbranch
9196 dispneartags 0
9197 run refill_reflist
9200 # Display a list of tags and heads
9201 proc showrefs {} {
9202 global showrefstop bgcolor fgcolor selectbgcolor NS
9203 global bglist fglist reflistfilter reflist maincursor
9205 set top .showrefs
9206 set showrefstop $top
9207 if {[winfo exists $top]} {
9208 raise $top
9209 refill_reflist
9210 return
9212 ttk_toplevel $top
9213 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9214 make_transient $top .
9215 text $top.list -background $bgcolor -foreground $fgcolor \
9216 -selectbackground $selectbgcolor -font mainfont \
9217 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9218 -width 30 -height 20 -cursor $maincursor \
9219 -spacing1 1 -spacing3 1 -state disabled
9220 $top.list tag configure highlight -background $selectbgcolor
9221 lappend bglist $top.list
9222 lappend fglist $top.list
9223 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9224 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9225 grid $top.list $top.ysb -sticky nsew
9226 grid $top.xsb x -sticky ew
9227 ${NS}::frame $top.f
9228 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9229 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9230 set reflistfilter "*"
9231 trace add variable reflistfilter write reflistfilter_change
9232 pack $top.f.e -side right -fill x -expand 1
9233 pack $top.f.l -side left
9234 grid $top.f - -sticky ew -pady 2
9235 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9236 bind $top <Key-Escape> [list destroy $top]
9237 grid $top.close -
9238 grid columnconfigure $top 0 -weight 1
9239 grid rowconfigure $top 0 -weight 1
9240 bind $top.list <1> {break}
9241 bind $top.list <B1-Motion> {break}
9242 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9243 set reflist {}
9244 refill_reflist
9247 proc sel_reflist {w x y} {
9248 global showrefstop reflist headids tagids otherrefids
9250 if {![winfo exists $showrefstop]} return
9251 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9252 set ref [lindex $reflist [expr {$l-1}]]
9253 set n [lindex $ref 0]
9254 switch -- [lindex $ref 1] {
9255 "H" {selbyid $headids($n)}
9256 "T" {selbyid $tagids($n)}
9257 "o" {selbyid $otherrefids($n)}
9259 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9262 proc unsel_reflist {} {
9263 global showrefstop
9265 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9266 $showrefstop.list tag remove highlight 0.0 end
9269 proc reflistfilter_change {n1 n2 op} {
9270 global reflistfilter
9272 after cancel refill_reflist
9273 after 200 refill_reflist
9276 proc refill_reflist {} {
9277 global reflist reflistfilter showrefstop headids tagids otherrefids
9278 global curview
9280 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9281 set refs {}
9282 foreach n [array names headids] {
9283 if {[string match $reflistfilter $n]} {
9284 if {[commitinview $headids($n) $curview]} {
9285 lappend refs [list $n H]
9286 } else {
9287 interestedin $headids($n) {run refill_reflist}
9291 foreach n [array names tagids] {
9292 if {[string match $reflistfilter $n]} {
9293 if {[commitinview $tagids($n) $curview]} {
9294 lappend refs [list $n T]
9295 } else {
9296 interestedin $tagids($n) {run refill_reflist}
9300 foreach n [array names otherrefids] {
9301 if {[string match $reflistfilter $n]} {
9302 if {[commitinview $otherrefids($n) $curview]} {
9303 lappend refs [list $n o]
9304 } else {
9305 interestedin $otherrefids($n) {run refill_reflist}
9309 set refs [lsort -index 0 $refs]
9310 if {$refs eq $reflist} return
9312 # Update the contents of $showrefstop.list according to the
9313 # differences between $reflist (old) and $refs (new)
9314 $showrefstop.list conf -state normal
9315 $showrefstop.list insert end "\n"
9316 set i 0
9317 set j 0
9318 while {$i < [llength $reflist] || $j < [llength $refs]} {
9319 if {$i < [llength $reflist]} {
9320 if {$j < [llength $refs]} {
9321 set cmp [string compare [lindex $reflist $i 0] \
9322 [lindex $refs $j 0]]
9323 if {$cmp == 0} {
9324 set cmp [string compare [lindex $reflist $i 1] \
9325 [lindex $refs $j 1]]
9327 } else {
9328 set cmp -1
9330 } else {
9331 set cmp 1
9333 switch -- $cmp {
9334 -1 {
9335 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9336 incr i
9339 incr i
9340 incr j
9343 set l [expr {$j + 1}]
9344 $showrefstop.list image create $l.0 -align baseline \
9345 -image reficon-[lindex $refs $j 1] -padx 2
9346 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9347 incr j
9351 set reflist $refs
9352 # delete last newline
9353 $showrefstop.list delete end-2c end-1c
9354 $showrefstop.list conf -state disabled
9357 # Stuff for finding nearby tags
9358 proc getallcommits {} {
9359 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9360 global idheads idtags idotherrefs allparents tagobjid
9362 if {![info exists allcommits]} {
9363 set nextarc 0
9364 set allcommits 0
9365 set seeds {}
9366 set allcwait 0
9367 set cachedarcs 0
9368 set allccache [file join [gitdir] "gitk.cache"]
9369 if {![catch {
9370 set f [open $allccache r]
9371 set allcwait 1
9372 getcache $f
9373 }]} return
9376 if {$allcwait} {
9377 return
9379 set cmd [list | git rev-list --parents]
9380 set allcupdate [expr {$seeds ne {}}]
9381 if {!$allcupdate} {
9382 set ids "--all"
9383 } else {
9384 set refs [concat [array names idheads] [array names idtags] \
9385 [array names idotherrefs]]
9386 set ids {}
9387 set tagobjs {}
9388 foreach name [array names tagobjid] {
9389 lappend tagobjs $tagobjid($name)
9391 foreach id [lsort -unique $refs] {
9392 if {![info exists allparents($id)] &&
9393 [lsearch -exact $tagobjs $id] < 0} {
9394 lappend ids $id
9397 if {$ids ne {}} {
9398 foreach id $seeds {
9399 lappend ids "^$id"
9403 if {$ids ne {}} {
9404 set fd [open [concat $cmd $ids] r]
9405 fconfigure $fd -blocking 0
9406 incr allcommits
9407 nowbusy allcommits
9408 filerun $fd [list getallclines $fd]
9409 } else {
9410 dispneartags 0
9414 # Since most commits have 1 parent and 1 child, we group strings of
9415 # such commits into "arcs" joining branch/merge points (BMPs), which
9416 # are commits that either don't have 1 parent or don't have 1 child.
9418 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9419 # arcout(id) - outgoing arcs for BMP
9420 # arcids(a) - list of IDs on arc including end but not start
9421 # arcstart(a) - BMP ID at start of arc
9422 # arcend(a) - BMP ID at end of arc
9423 # growing(a) - arc a is still growing
9424 # arctags(a) - IDs out of arcids (excluding end) that have tags
9425 # archeads(a) - IDs out of arcids (excluding end) that have heads
9426 # The start of an arc is at the descendent end, so "incoming" means
9427 # coming from descendents, and "outgoing" means going towards ancestors.
9429 proc getallclines {fd} {
9430 global allparents allchildren idtags idheads nextarc
9431 global arcnos arcids arctags arcout arcend arcstart archeads growing
9432 global seeds allcommits cachedarcs allcupdate
9434 set nid 0
9435 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9436 set id [lindex $line 0]
9437 if {[info exists allparents($id)]} {
9438 # seen it already
9439 continue
9441 set cachedarcs 0
9442 set olds [lrange $line 1 end]
9443 set allparents($id) $olds
9444 if {![info exists allchildren($id)]} {
9445 set allchildren($id) {}
9446 set arcnos($id) {}
9447 lappend seeds $id
9448 } else {
9449 set a $arcnos($id)
9450 if {[llength $olds] == 1 && [llength $a] == 1} {
9451 lappend arcids($a) $id
9452 if {[info exists idtags($id)]} {
9453 lappend arctags($a) $id
9455 if {[info exists idheads($id)]} {
9456 lappend archeads($a) $id
9458 if {[info exists allparents($olds)]} {
9459 # seen parent already
9460 if {![info exists arcout($olds)]} {
9461 splitarc $olds
9463 lappend arcids($a) $olds
9464 set arcend($a) $olds
9465 unset growing($a)
9467 lappend allchildren($olds) $id
9468 lappend arcnos($olds) $a
9469 continue
9472 foreach a $arcnos($id) {
9473 lappend arcids($a) $id
9474 set arcend($a) $id
9475 unset growing($a)
9478 set ao {}
9479 foreach p $olds {
9480 lappend allchildren($p) $id
9481 set a [incr nextarc]
9482 set arcstart($a) $id
9483 set archeads($a) {}
9484 set arctags($a) {}
9485 set archeads($a) {}
9486 set arcids($a) {}
9487 lappend ao $a
9488 set growing($a) 1
9489 if {[info exists allparents($p)]} {
9490 # seen it already, may need to make a new branch
9491 if {![info exists arcout($p)]} {
9492 splitarc $p
9494 lappend arcids($a) $p
9495 set arcend($a) $p
9496 unset growing($a)
9498 lappend arcnos($p) $a
9500 set arcout($id) $ao
9502 if {$nid > 0} {
9503 global cached_dheads cached_dtags cached_atags
9504 catch {unset cached_dheads}
9505 catch {unset cached_dtags}
9506 catch {unset cached_atags}
9508 if {![eof $fd]} {
9509 return [expr {$nid >= 1000? 2: 1}]
9511 set cacheok 1
9512 if {[catch {
9513 fconfigure $fd -blocking 1
9514 close $fd
9515 } err]} {
9516 # got an error reading the list of commits
9517 # if we were updating, try rereading the whole thing again
9518 if {$allcupdate} {
9519 incr allcommits -1
9520 dropcache $err
9521 return
9523 error_popup "[mc "Error reading commit topology information;\
9524 branch and preceding/following tag information\
9525 will be incomplete."]\n($err)"
9526 set cacheok 0
9528 if {[incr allcommits -1] == 0} {
9529 notbusy allcommits
9530 if {$cacheok} {
9531 run savecache
9534 dispneartags 0
9535 return 0
9538 proc recalcarc {a} {
9539 global arctags archeads arcids idtags idheads
9541 set at {}
9542 set ah {}
9543 foreach id [lrange $arcids($a) 0 end-1] {
9544 if {[info exists idtags($id)]} {
9545 lappend at $id
9547 if {[info exists idheads($id)]} {
9548 lappend ah $id
9551 set arctags($a) $at
9552 set archeads($a) $ah
9555 proc splitarc {p} {
9556 global arcnos arcids nextarc arctags archeads idtags idheads
9557 global arcstart arcend arcout allparents growing
9559 set a $arcnos($p)
9560 if {[llength $a] != 1} {
9561 puts "oops splitarc called but [llength $a] arcs already"
9562 return
9564 set a [lindex $a 0]
9565 set i [lsearch -exact $arcids($a) $p]
9566 if {$i < 0} {
9567 puts "oops splitarc $p not in arc $a"
9568 return
9570 set na [incr nextarc]
9571 if {[info exists arcend($a)]} {
9572 set arcend($na) $arcend($a)
9573 } else {
9574 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9575 set j [lsearch -exact $arcnos($l) $a]
9576 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9578 set tail [lrange $arcids($a) [expr {$i+1}] end]
9579 set arcids($a) [lrange $arcids($a) 0 $i]
9580 set arcend($a) $p
9581 set arcstart($na) $p
9582 set arcout($p) $na
9583 set arcids($na) $tail
9584 if {[info exists growing($a)]} {
9585 set growing($na) 1
9586 unset growing($a)
9589 foreach id $tail {
9590 if {[llength $arcnos($id)] == 1} {
9591 set arcnos($id) $na
9592 } else {
9593 set j [lsearch -exact $arcnos($id) $a]
9594 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9598 # reconstruct tags and heads lists
9599 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9600 recalcarc $a
9601 recalcarc $na
9602 } else {
9603 set arctags($na) {}
9604 set archeads($na) {}
9608 # Update things for a new commit added that is a child of one
9609 # existing commit. Used when cherry-picking.
9610 proc addnewchild {id p} {
9611 global allparents allchildren idtags nextarc
9612 global arcnos arcids arctags arcout arcend arcstart archeads growing
9613 global seeds allcommits
9615 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9616 set allparents($id) [list $p]
9617 set allchildren($id) {}
9618 set arcnos($id) {}
9619 lappend seeds $id
9620 lappend allchildren($p) $id
9621 set a [incr nextarc]
9622 set arcstart($a) $id
9623 set archeads($a) {}
9624 set arctags($a) {}
9625 set arcids($a) [list $p]
9626 set arcend($a) $p
9627 if {![info exists arcout($p)]} {
9628 splitarc $p
9630 lappend arcnos($p) $a
9631 set arcout($id) [list $a]
9634 # This implements a cache for the topology information.
9635 # The cache saves, for each arc, the start and end of the arc,
9636 # the ids on the arc, and the outgoing arcs from the end.
9637 proc readcache {f} {
9638 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9639 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9640 global allcwait
9642 set a $nextarc
9643 set lim $cachedarcs
9644 if {$lim - $a > 500} {
9645 set lim [expr {$a + 500}]
9647 if {[catch {
9648 if {$a == $lim} {
9649 # finish reading the cache and setting up arctags, etc.
9650 set line [gets $f]
9651 if {$line ne "1"} {error "bad final version"}
9652 close $f
9653 foreach id [array names idtags] {
9654 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9655 [llength $allparents($id)] == 1} {
9656 set a [lindex $arcnos($id) 0]
9657 if {$arctags($a) eq {}} {
9658 recalcarc $a
9662 foreach id [array names idheads] {
9663 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9664 [llength $allparents($id)] == 1} {
9665 set a [lindex $arcnos($id) 0]
9666 if {$archeads($a) eq {}} {
9667 recalcarc $a
9671 foreach id [lsort -unique $possible_seeds] {
9672 if {$arcnos($id) eq {}} {
9673 lappend seeds $id
9676 set allcwait 0
9677 } else {
9678 while {[incr a] <= $lim} {
9679 set line [gets $f]
9680 if {[llength $line] != 3} {error "bad line"}
9681 set s [lindex $line 0]
9682 set arcstart($a) $s
9683 lappend arcout($s) $a
9684 if {![info exists arcnos($s)]} {
9685 lappend possible_seeds $s
9686 set arcnos($s) {}
9688 set e [lindex $line 1]
9689 if {$e eq {}} {
9690 set growing($a) 1
9691 } else {
9692 set arcend($a) $e
9693 if {![info exists arcout($e)]} {
9694 set arcout($e) {}
9697 set arcids($a) [lindex $line 2]
9698 foreach id $arcids($a) {
9699 lappend allparents($s) $id
9700 set s $id
9701 lappend arcnos($id) $a
9703 if {![info exists allparents($s)]} {
9704 set allparents($s) {}
9706 set arctags($a) {}
9707 set archeads($a) {}
9709 set nextarc [expr {$a - 1}]
9711 } err]} {
9712 dropcache $err
9713 return 0
9715 if {!$allcwait} {
9716 getallcommits
9718 return $allcwait
9721 proc getcache {f} {
9722 global nextarc cachedarcs possible_seeds
9724 if {[catch {
9725 set line [gets $f]
9726 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9727 # make sure it's an integer
9728 set cachedarcs [expr {int([lindex $line 1])}]
9729 if {$cachedarcs < 0} {error "bad number of arcs"}
9730 set nextarc 0
9731 set possible_seeds {}
9732 run readcache $f
9733 } err]} {
9734 dropcache $err
9736 return 0
9739 proc dropcache {err} {
9740 global allcwait nextarc cachedarcs seeds
9742 #puts "dropping cache ($err)"
9743 foreach v {arcnos arcout arcids arcstart arcend growing \
9744 arctags archeads allparents allchildren} {
9745 global $v
9746 catch {unset $v}
9748 set allcwait 0
9749 set nextarc 0
9750 set cachedarcs 0
9751 set seeds {}
9752 getallcommits
9755 proc writecache {f} {
9756 global cachearc cachedarcs allccache
9757 global arcstart arcend arcnos arcids arcout
9759 set a $cachearc
9760 set lim $cachedarcs
9761 if {$lim - $a > 1000} {
9762 set lim [expr {$a + 1000}]
9764 if {[catch {
9765 while {[incr a] <= $lim} {
9766 if {[info exists arcend($a)]} {
9767 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9768 } else {
9769 puts $f [list $arcstart($a) {} $arcids($a)]
9772 } err]} {
9773 catch {close $f}
9774 catch {file delete $allccache}
9775 #puts "writing cache failed ($err)"
9776 return 0
9778 set cachearc [expr {$a - 1}]
9779 if {$a > $cachedarcs} {
9780 puts $f "1"
9781 close $f
9782 return 0
9784 return 1
9787 proc savecache {} {
9788 global nextarc cachedarcs cachearc allccache
9790 if {$nextarc == $cachedarcs} return
9791 set cachearc 0
9792 set cachedarcs $nextarc
9793 catch {
9794 set f [open $allccache w]
9795 puts $f [list 1 $cachedarcs]
9796 run writecache $f
9800 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9801 # or 0 if neither is true.
9802 proc anc_or_desc {a b} {
9803 global arcout arcstart arcend arcnos cached_isanc
9805 if {$arcnos($a) eq $arcnos($b)} {
9806 # Both are on the same arc(s); either both are the same BMP,
9807 # or if one is not a BMP, the other is also not a BMP or is
9808 # the BMP at end of the arc (and it only has 1 incoming arc).
9809 # Or both can be BMPs with no incoming arcs.
9810 if {$a eq $b || $arcnos($a) eq {}} {
9811 return 0
9813 # assert {[llength $arcnos($a)] == 1}
9814 set arc [lindex $arcnos($a) 0]
9815 set i [lsearch -exact $arcids($arc) $a]
9816 set j [lsearch -exact $arcids($arc) $b]
9817 if {$i < 0 || $i > $j} {
9818 return 1
9819 } else {
9820 return -1
9824 if {![info exists arcout($a)]} {
9825 set arc [lindex $arcnos($a) 0]
9826 if {[info exists arcend($arc)]} {
9827 set aend $arcend($arc)
9828 } else {
9829 set aend {}
9831 set a $arcstart($arc)
9832 } else {
9833 set aend $a
9835 if {![info exists arcout($b)]} {
9836 set arc [lindex $arcnos($b) 0]
9837 if {[info exists arcend($arc)]} {
9838 set bend $arcend($arc)
9839 } else {
9840 set bend {}
9842 set b $arcstart($arc)
9843 } else {
9844 set bend $b
9846 if {$a eq $bend} {
9847 return 1
9849 if {$b eq $aend} {
9850 return -1
9852 if {[info exists cached_isanc($a,$bend)]} {
9853 if {$cached_isanc($a,$bend)} {
9854 return 1
9857 if {[info exists cached_isanc($b,$aend)]} {
9858 if {$cached_isanc($b,$aend)} {
9859 return -1
9861 if {[info exists cached_isanc($a,$bend)]} {
9862 return 0
9866 set todo [list $a $b]
9867 set anc($a) a
9868 set anc($b) b
9869 for {set i 0} {$i < [llength $todo]} {incr i} {
9870 set x [lindex $todo $i]
9871 if {$anc($x) eq {}} {
9872 continue
9874 foreach arc $arcnos($x) {
9875 set xd $arcstart($arc)
9876 if {$xd eq $bend} {
9877 set cached_isanc($a,$bend) 1
9878 set cached_isanc($b,$aend) 0
9879 return 1
9880 } elseif {$xd eq $aend} {
9881 set cached_isanc($b,$aend) 1
9882 set cached_isanc($a,$bend) 0
9883 return -1
9885 if {![info exists anc($xd)]} {
9886 set anc($xd) $anc($x)
9887 lappend todo $xd
9888 } elseif {$anc($xd) ne $anc($x)} {
9889 set anc($xd) {}
9893 set cached_isanc($a,$bend) 0
9894 set cached_isanc($b,$aend) 0
9895 return 0
9898 # This identifies whether $desc has an ancestor that is
9899 # a growing tip of the graph and which is not an ancestor of $anc
9900 # and returns 0 if so and 1 if not.
9901 # If we subsequently discover a tag on such a growing tip, and that
9902 # turns out to be a descendent of $anc (which it could, since we
9903 # don't necessarily see children before parents), then $desc
9904 # isn't a good choice to display as a descendent tag of
9905 # $anc (since it is the descendent of another tag which is
9906 # a descendent of $anc). Similarly, $anc isn't a good choice to
9907 # display as a ancestor tag of $desc.
9909 proc is_certain {desc anc} {
9910 global arcnos arcout arcstart arcend growing problems
9912 set certain {}
9913 if {[llength $arcnos($anc)] == 1} {
9914 # tags on the same arc are certain
9915 if {$arcnos($desc) eq $arcnos($anc)} {
9916 return 1
9918 if {![info exists arcout($anc)]} {
9919 # if $anc is partway along an arc, use the start of the arc instead
9920 set a [lindex $arcnos($anc) 0]
9921 set anc $arcstart($a)
9924 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9925 set x $desc
9926 } else {
9927 set a [lindex $arcnos($desc) 0]
9928 set x $arcend($a)
9930 if {$x == $anc} {
9931 return 1
9933 set anclist [list $x]
9934 set dl($x) 1
9935 set nnh 1
9936 set ngrowanc 0
9937 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9938 set x [lindex $anclist $i]
9939 if {$dl($x)} {
9940 incr nnh -1
9942 set done($x) 1
9943 foreach a $arcout($x) {
9944 if {[info exists growing($a)]} {
9945 if {![info exists growanc($x)] && $dl($x)} {
9946 set growanc($x) 1
9947 incr ngrowanc
9949 } else {
9950 set y $arcend($a)
9951 if {[info exists dl($y)]} {
9952 if {$dl($y)} {
9953 if {!$dl($x)} {
9954 set dl($y) 0
9955 if {![info exists done($y)]} {
9956 incr nnh -1
9958 if {[info exists growanc($x)]} {
9959 incr ngrowanc -1
9961 set xl [list $y]
9962 for {set k 0} {$k < [llength $xl]} {incr k} {
9963 set z [lindex $xl $k]
9964 foreach c $arcout($z) {
9965 if {[info exists arcend($c)]} {
9966 set v $arcend($c)
9967 if {[info exists dl($v)] && $dl($v)} {
9968 set dl($v) 0
9969 if {![info exists done($v)]} {
9970 incr nnh -1
9972 if {[info exists growanc($v)]} {
9973 incr ngrowanc -1
9975 lappend xl $v
9982 } elseif {$y eq $anc || !$dl($x)} {
9983 set dl($y) 0
9984 lappend anclist $y
9985 } else {
9986 set dl($y) 1
9987 lappend anclist $y
9988 incr nnh
9993 foreach x [array names growanc] {
9994 if {$dl($x)} {
9995 return 0
9997 return 0
9999 return 1
10002 proc validate_arctags {a} {
10003 global arctags idtags
10005 set i -1
10006 set na $arctags($a)
10007 foreach id $arctags($a) {
10008 incr i
10009 if {![info exists idtags($id)]} {
10010 set na [lreplace $na $i $i]
10011 incr i -1
10014 set arctags($a) $na
10017 proc validate_archeads {a} {
10018 global archeads idheads
10020 set i -1
10021 set na $archeads($a)
10022 foreach id $archeads($a) {
10023 incr i
10024 if {![info exists idheads($id)]} {
10025 set na [lreplace $na $i $i]
10026 incr i -1
10029 set archeads($a) $na
10032 # Return the list of IDs that have tags that are descendents of id,
10033 # ignoring IDs that are descendents of IDs already reported.
10034 proc desctags {id} {
10035 global arcnos arcstart arcids arctags idtags allparents
10036 global growing cached_dtags
10038 if {![info exists allparents($id)]} {
10039 return {}
10041 set t1 [clock clicks -milliseconds]
10042 set argid $id
10043 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10044 # part-way along an arc; check that arc first
10045 set a [lindex $arcnos($id) 0]
10046 if {$arctags($a) ne {}} {
10047 validate_arctags $a
10048 set i [lsearch -exact $arcids($a) $id]
10049 set tid {}
10050 foreach t $arctags($a) {
10051 set j [lsearch -exact $arcids($a) $t]
10052 if {$j >= $i} break
10053 set tid $t
10055 if {$tid ne {}} {
10056 return $tid
10059 set id $arcstart($a)
10060 if {[info exists idtags($id)]} {
10061 return $id
10064 if {[info exists cached_dtags($id)]} {
10065 return $cached_dtags($id)
10068 set origid $id
10069 set todo [list $id]
10070 set queued($id) 1
10071 set nc 1
10072 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10073 set id [lindex $todo $i]
10074 set done($id) 1
10075 set ta [info exists hastaggedancestor($id)]
10076 if {!$ta} {
10077 incr nc -1
10079 # ignore tags on starting node
10080 if {!$ta && $i > 0} {
10081 if {[info exists idtags($id)]} {
10082 set tagloc($id) $id
10083 set ta 1
10084 } elseif {[info exists cached_dtags($id)]} {
10085 set tagloc($id) $cached_dtags($id)
10086 set ta 1
10089 foreach a $arcnos($id) {
10090 set d $arcstart($a)
10091 if {!$ta && $arctags($a) ne {}} {
10092 validate_arctags $a
10093 if {$arctags($a) ne {}} {
10094 lappend tagloc($id) [lindex $arctags($a) end]
10097 if {$ta || $arctags($a) ne {}} {
10098 set tomark [list $d]
10099 for {set j 0} {$j < [llength $tomark]} {incr j} {
10100 set dd [lindex $tomark $j]
10101 if {![info exists hastaggedancestor($dd)]} {
10102 if {[info exists done($dd)]} {
10103 foreach b $arcnos($dd) {
10104 lappend tomark $arcstart($b)
10106 if {[info exists tagloc($dd)]} {
10107 unset tagloc($dd)
10109 } elseif {[info exists queued($dd)]} {
10110 incr nc -1
10112 set hastaggedancestor($dd) 1
10116 if {![info exists queued($d)]} {
10117 lappend todo $d
10118 set queued($d) 1
10119 if {![info exists hastaggedancestor($d)]} {
10120 incr nc
10125 set tags {}
10126 foreach id [array names tagloc] {
10127 if {![info exists hastaggedancestor($id)]} {
10128 foreach t $tagloc($id) {
10129 if {[lsearch -exact $tags $t] < 0} {
10130 lappend tags $t
10135 set t2 [clock clicks -milliseconds]
10136 set loopix $i
10138 # remove tags that are descendents of other tags
10139 for {set i 0} {$i < [llength $tags]} {incr i} {
10140 set a [lindex $tags $i]
10141 for {set j 0} {$j < $i} {incr j} {
10142 set b [lindex $tags $j]
10143 set r [anc_or_desc $a $b]
10144 if {$r == 1} {
10145 set tags [lreplace $tags $j $j]
10146 incr j -1
10147 incr i -1
10148 } elseif {$r == -1} {
10149 set tags [lreplace $tags $i $i]
10150 incr i -1
10151 break
10156 if {[array names growing] ne {}} {
10157 # graph isn't finished, need to check if any tag could get
10158 # eclipsed by another tag coming later. Simply ignore any
10159 # tags that could later get eclipsed.
10160 set ctags {}
10161 foreach t $tags {
10162 if {[is_certain $t $origid]} {
10163 lappend ctags $t
10166 if {$tags eq $ctags} {
10167 set cached_dtags($origid) $tags
10168 } else {
10169 set tags $ctags
10171 } else {
10172 set cached_dtags($origid) $tags
10174 set t3 [clock clicks -milliseconds]
10175 if {0 && $t3 - $t1 >= 100} {
10176 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10177 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10179 return $tags
10182 proc anctags {id} {
10183 global arcnos arcids arcout arcend arctags idtags allparents
10184 global growing cached_atags
10186 if {![info exists allparents($id)]} {
10187 return {}
10189 set t1 [clock clicks -milliseconds]
10190 set argid $id
10191 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10192 # part-way along an arc; check that arc first
10193 set a [lindex $arcnos($id) 0]
10194 if {$arctags($a) ne {}} {
10195 validate_arctags $a
10196 set i [lsearch -exact $arcids($a) $id]
10197 foreach t $arctags($a) {
10198 set j [lsearch -exact $arcids($a) $t]
10199 if {$j > $i} {
10200 return $t
10204 if {![info exists arcend($a)]} {
10205 return {}
10207 set id $arcend($a)
10208 if {[info exists idtags($id)]} {
10209 return $id
10212 if {[info exists cached_atags($id)]} {
10213 return $cached_atags($id)
10216 set origid $id
10217 set todo [list $id]
10218 set queued($id) 1
10219 set taglist {}
10220 set nc 1
10221 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10222 set id [lindex $todo $i]
10223 set done($id) 1
10224 set td [info exists hastaggeddescendent($id)]
10225 if {!$td} {
10226 incr nc -1
10228 # ignore tags on starting node
10229 if {!$td && $i > 0} {
10230 if {[info exists idtags($id)]} {
10231 set tagloc($id) $id
10232 set td 1
10233 } elseif {[info exists cached_atags($id)]} {
10234 set tagloc($id) $cached_atags($id)
10235 set td 1
10238 foreach a $arcout($id) {
10239 if {!$td && $arctags($a) ne {}} {
10240 validate_arctags $a
10241 if {$arctags($a) ne {}} {
10242 lappend tagloc($id) [lindex $arctags($a) 0]
10245 if {![info exists arcend($a)]} continue
10246 set d $arcend($a)
10247 if {$td || $arctags($a) ne {}} {
10248 set tomark [list $d]
10249 for {set j 0} {$j < [llength $tomark]} {incr j} {
10250 set dd [lindex $tomark $j]
10251 if {![info exists hastaggeddescendent($dd)]} {
10252 if {[info exists done($dd)]} {
10253 foreach b $arcout($dd) {
10254 if {[info exists arcend($b)]} {
10255 lappend tomark $arcend($b)
10258 if {[info exists tagloc($dd)]} {
10259 unset tagloc($dd)
10261 } elseif {[info exists queued($dd)]} {
10262 incr nc -1
10264 set hastaggeddescendent($dd) 1
10268 if {![info exists queued($d)]} {
10269 lappend todo $d
10270 set queued($d) 1
10271 if {![info exists hastaggeddescendent($d)]} {
10272 incr nc
10277 set t2 [clock clicks -milliseconds]
10278 set loopix $i
10279 set tags {}
10280 foreach id [array names tagloc] {
10281 if {![info exists hastaggeddescendent($id)]} {
10282 foreach t $tagloc($id) {
10283 if {[lsearch -exact $tags $t] < 0} {
10284 lappend tags $t
10290 # remove tags that are ancestors of other tags
10291 for {set i 0} {$i < [llength $tags]} {incr i} {
10292 set a [lindex $tags $i]
10293 for {set j 0} {$j < $i} {incr j} {
10294 set b [lindex $tags $j]
10295 set r [anc_or_desc $a $b]
10296 if {$r == -1} {
10297 set tags [lreplace $tags $j $j]
10298 incr j -1
10299 incr i -1
10300 } elseif {$r == 1} {
10301 set tags [lreplace $tags $i $i]
10302 incr i -1
10303 break
10308 if {[array names growing] ne {}} {
10309 # graph isn't finished, need to check if any tag could get
10310 # eclipsed by another tag coming later. Simply ignore any
10311 # tags that could later get eclipsed.
10312 set ctags {}
10313 foreach t $tags {
10314 if {[is_certain $origid $t]} {
10315 lappend ctags $t
10318 if {$tags eq $ctags} {
10319 set cached_atags($origid) $tags
10320 } else {
10321 set tags $ctags
10323 } else {
10324 set cached_atags($origid) $tags
10326 set t3 [clock clicks -milliseconds]
10327 if {0 && $t3 - $t1 >= 100} {
10328 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10329 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10331 return $tags
10334 # Return the list of IDs that have heads that are descendents of id,
10335 # including id itself if it has a head.
10336 proc descheads {id} {
10337 global arcnos arcstart arcids archeads idheads cached_dheads
10338 global allparents
10340 if {![info exists allparents($id)]} {
10341 return {}
10343 set aret {}
10344 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10345 # part-way along an arc; check it first
10346 set a [lindex $arcnos($id) 0]
10347 if {$archeads($a) ne {}} {
10348 validate_archeads $a
10349 set i [lsearch -exact $arcids($a) $id]
10350 foreach t $archeads($a) {
10351 set j [lsearch -exact $arcids($a) $t]
10352 if {$j > $i} break
10353 lappend aret $t
10356 set id $arcstart($a)
10358 set origid $id
10359 set todo [list $id]
10360 set seen($id) 1
10361 set ret {}
10362 for {set i 0} {$i < [llength $todo]} {incr i} {
10363 set id [lindex $todo $i]
10364 if {[info exists cached_dheads($id)]} {
10365 set ret [concat $ret $cached_dheads($id)]
10366 } else {
10367 if {[info exists idheads($id)]} {
10368 lappend ret $id
10370 foreach a $arcnos($id) {
10371 if {$archeads($a) ne {}} {
10372 validate_archeads $a
10373 if {$archeads($a) ne {}} {
10374 set ret [concat $ret $archeads($a)]
10377 set d $arcstart($a)
10378 if {![info exists seen($d)]} {
10379 lappend todo $d
10380 set seen($d) 1
10385 set ret [lsort -unique $ret]
10386 set cached_dheads($origid) $ret
10387 return [concat $ret $aret]
10390 proc addedtag {id} {
10391 global arcnos arcout cached_dtags cached_atags
10393 if {![info exists arcnos($id)]} return
10394 if {![info exists arcout($id)]} {
10395 recalcarc [lindex $arcnos($id) 0]
10397 catch {unset cached_dtags}
10398 catch {unset cached_atags}
10401 proc addedhead {hid head} {
10402 global arcnos arcout cached_dheads
10404 if {![info exists arcnos($hid)]} return
10405 if {![info exists arcout($hid)]} {
10406 recalcarc [lindex $arcnos($hid) 0]
10408 catch {unset cached_dheads}
10411 proc removedhead {hid head} {
10412 global cached_dheads
10414 catch {unset cached_dheads}
10417 proc movedhead {hid head} {
10418 global arcnos arcout cached_dheads
10420 if {![info exists arcnos($hid)]} return
10421 if {![info exists arcout($hid)]} {
10422 recalcarc [lindex $arcnos($hid) 0]
10424 catch {unset cached_dheads}
10427 proc changedrefs {} {
10428 global cached_dheads cached_dtags cached_atags
10429 global arctags archeads arcnos arcout idheads idtags
10431 foreach id [concat [array names idheads] [array names idtags]] {
10432 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10433 set a [lindex $arcnos($id) 0]
10434 if {![info exists donearc($a)]} {
10435 recalcarc $a
10436 set donearc($a) 1
10440 catch {unset cached_dtags}
10441 catch {unset cached_atags}
10442 catch {unset cached_dheads}
10445 proc rereadrefs {} {
10446 global idtags idheads idotherrefs mainheadid
10448 set refids [concat [array names idtags] \
10449 [array names idheads] [array names idotherrefs]]
10450 foreach id $refids {
10451 if {![info exists ref($id)]} {
10452 set ref($id) [listrefs $id]
10455 set oldmainhead $mainheadid
10456 readrefs
10457 changedrefs
10458 set refids [lsort -unique [concat $refids [array names idtags] \
10459 [array names idheads] [array names idotherrefs]]]
10460 foreach id $refids {
10461 set v [listrefs $id]
10462 if {![info exists ref($id)] || $ref($id) != $v} {
10463 redrawtags $id
10466 if {$oldmainhead ne $mainheadid} {
10467 redrawtags $oldmainhead
10468 redrawtags $mainheadid
10470 run refill_reflist
10473 proc listrefs {id} {
10474 global idtags idheads idotherrefs
10476 set x {}
10477 if {[info exists idtags($id)]} {
10478 set x $idtags($id)
10480 set y {}
10481 if {[info exists idheads($id)]} {
10482 set y $idheads($id)
10484 set z {}
10485 if {[info exists idotherrefs($id)]} {
10486 set z $idotherrefs($id)
10488 return [list $x $y $z]
10491 proc showtag {tag isnew} {
10492 global ctext tagcontents tagids linknum tagobjid
10494 if {$isnew} {
10495 addtohistory [list showtag $tag 0] savectextpos
10497 $ctext conf -state normal
10498 clear_ctext
10499 settabs 0
10500 set linknum 0
10501 if {![info exists tagcontents($tag)]} {
10502 catch {
10503 set tagcontents($tag) [exec git cat-file tag $tag]
10506 if {[info exists tagcontents($tag)]} {
10507 set text $tagcontents($tag)
10508 } else {
10509 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10511 appendwithlinks $text {}
10512 maybe_scroll_ctext 1
10513 $ctext conf -state disabled
10514 init_flist {}
10517 proc doquit {} {
10518 global stopped
10519 global gitktmpdir
10521 set stopped 100
10522 savestuff .
10523 destroy .
10525 if {[info exists gitktmpdir]} {
10526 catch {file delete -force $gitktmpdir}
10530 proc mkfontdisp {font top which} {
10531 global fontattr fontpref $font NS use_ttk
10533 set fontpref($font) [set $font]
10534 ${NS}::button $top.${font}but -text $which \
10535 -command [list choosefont $font $which]
10536 ${NS}::label $top.$font -relief flat -font $font \
10537 -text $fontattr($font,family) -justify left
10538 grid x $top.${font}but $top.$font -sticky w
10541 proc choosefont {font which} {
10542 global fontparam fontlist fonttop fontattr
10543 global prefstop NS
10545 set fontparam(which) $which
10546 set fontparam(font) $font
10547 set fontparam(family) [font actual $font -family]
10548 set fontparam(size) $fontattr($font,size)
10549 set fontparam(weight) $fontattr($font,weight)
10550 set fontparam(slant) $fontattr($font,slant)
10551 set top .gitkfont
10552 set fonttop $top
10553 if {![winfo exists $top]} {
10554 font create sample
10555 eval font config sample [font actual $font]
10556 ttk_toplevel $top
10557 make_transient $top $prefstop
10558 wm title $top [mc "Gitk font chooser"]
10559 ${NS}::label $top.l -textvariable fontparam(which)
10560 pack $top.l -side top
10561 set fontlist [lsort [font families]]
10562 ${NS}::frame $top.f
10563 listbox $top.f.fam -listvariable fontlist \
10564 -yscrollcommand [list $top.f.sb set]
10565 bind $top.f.fam <<ListboxSelect>> selfontfam
10566 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10567 pack $top.f.sb -side right -fill y
10568 pack $top.f.fam -side left -fill both -expand 1
10569 pack $top.f -side top -fill both -expand 1
10570 ${NS}::frame $top.g
10571 spinbox $top.g.size -from 4 -to 40 -width 4 \
10572 -textvariable fontparam(size) \
10573 -validatecommand {string is integer -strict %s}
10574 checkbutton $top.g.bold -padx 5 \
10575 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10576 -variable fontparam(weight) -onvalue bold -offvalue normal
10577 checkbutton $top.g.ital -padx 5 \
10578 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10579 -variable fontparam(slant) -onvalue italic -offvalue roman
10580 pack $top.g.size $top.g.bold $top.g.ital -side left
10581 pack $top.g -side top
10582 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10583 -background white
10584 $top.c create text 100 25 -anchor center -text $which -font sample \
10585 -fill black -tags text
10586 bind $top.c <Configure> [list centertext $top.c]
10587 pack $top.c -side top -fill x
10588 ${NS}::frame $top.buts
10589 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10590 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10591 bind $top <Key-Return> fontok
10592 bind $top <Key-Escape> fontcan
10593 grid $top.buts.ok $top.buts.can
10594 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10595 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10596 pack $top.buts -side bottom -fill x
10597 trace add variable fontparam write chg_fontparam
10598 } else {
10599 raise $top
10600 $top.c itemconf text -text $which
10602 set i [lsearch -exact $fontlist $fontparam(family)]
10603 if {$i >= 0} {
10604 $top.f.fam selection set $i
10605 $top.f.fam see $i
10609 proc centertext {w} {
10610 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10613 proc fontok {} {
10614 global fontparam fontpref prefstop
10616 set f $fontparam(font)
10617 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10618 if {$fontparam(weight) eq "bold"} {
10619 lappend fontpref($f) "bold"
10621 if {$fontparam(slant) eq "italic"} {
10622 lappend fontpref($f) "italic"
10624 set w $prefstop.$f
10625 $w conf -text $fontparam(family) -font $fontpref($f)
10627 fontcan
10630 proc fontcan {} {
10631 global fonttop fontparam
10633 if {[info exists fonttop]} {
10634 catch {destroy $fonttop}
10635 catch {font delete sample}
10636 unset fonttop
10637 unset fontparam
10641 if {[package vsatisfies [package provide Tk] 8.6]} {
10642 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10643 # function to make use of it.
10644 proc choosefont {font which} {
10645 tk fontchooser configure -title $which -font $font \
10646 -command [list on_choosefont $font $which]
10647 tk fontchooser show
10649 proc on_choosefont {font which newfont} {
10650 global fontparam
10651 puts stderr "$font $newfont"
10652 array set f [font actual $newfont]
10653 set fontparam(which) $which
10654 set fontparam(font) $font
10655 set fontparam(family) $f(-family)
10656 set fontparam(size) $f(-size)
10657 set fontparam(weight) $f(-weight)
10658 set fontparam(slant) $f(-slant)
10659 fontok
10663 proc selfontfam {} {
10664 global fonttop fontparam
10666 set i [$fonttop.f.fam curselection]
10667 if {$i ne {}} {
10668 set fontparam(family) [$fonttop.f.fam get $i]
10672 proc chg_fontparam {v sub op} {
10673 global fontparam
10675 font config sample -$sub $fontparam($sub)
10678 proc doprefs {} {
10679 global maxwidth maxgraphpct use_ttk NS
10680 global oldprefs prefstop showneartags showlocalchanges
10681 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10682 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10683 global hideremotes want_ttk have_ttk
10685 set top .gitkprefs
10686 set prefstop $top
10687 if {[winfo exists $top]} {
10688 raise $top
10689 return
10691 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10692 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10693 set oldprefs($v) [set $v]
10695 ttk_toplevel $top
10696 wm title $top [mc "Gitk preferences"]
10697 make_transient $top .
10698 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10699 grid $top.ldisp - -sticky w -pady 10
10700 ${NS}::label $top.spacer -text " "
10701 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10702 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10703 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10704 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10705 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10706 grid x $top.maxpctl $top.maxpct -sticky w
10707 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10708 -variable showlocalchanges
10709 grid x $top.showlocal -sticky w
10710 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10711 -variable autoselect
10712 grid x $top.autoselect -sticky w
10713 ${NS}::checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10714 -variable hideremotes
10715 grid x $top.hideremotes -sticky w
10717 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10718 grid $top.ddisp - -sticky w -pady 10
10719 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10720 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10721 grid x $top.tabstopl $top.tabstop -sticky w
10722 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10723 -variable showneartags
10724 grid x $top.ntag -sticky w
10725 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10726 -variable limitdiffs
10727 grid x $top.ldiff -sticky w
10728 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10729 -variable perfile_attrs
10730 grid x $top.lattr -sticky w
10732 ${NS}::entry $top.extdifft -textvariable extdifftool
10733 ${NS}::frame $top.extdifff
10734 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10735 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10736 pack $top.extdifff.l $top.extdifff.b -side left
10737 pack configure $top.extdifff.l -padx 10
10738 grid x $top.extdifff $top.extdifft -sticky ew
10740 ${NS}::label $top.lgen -text [mc "General options"]
10741 grid $top.lgen - -sticky w -pady 10
10742 ${NS}::checkbutton $top.want_ttk -variable want_ttk \
10743 -text [mc "Use themed widgets"]
10744 if {$have_ttk} {
10745 ${NS}::label $top.ttk_note -text [mc "(change requires restart)"]
10746 } else {
10747 ${NS}::label $top.ttk_note -text [mc "(currently unavailable)"]
10749 grid x $top.want_ttk $top.ttk_note -sticky w
10751 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10752 grid $top.cdisp - -sticky w -pady 10
10753 label $top.ui -padx 40 -relief sunk -background $uicolor
10754 ${NS}::button $top.uibut -text [mc "Interface"] \
10755 -command [list choosecolor uicolor {} $top.ui [mc "interface"] setui]
10756 grid x $top.uibut $top.ui -sticky w
10757 label $top.bg -padx 40 -relief sunk -background $bgcolor
10758 ${NS}::button $top.bgbut -text [mc "Background"] \
10759 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10760 grid x $top.bgbut $top.bg -sticky w
10761 label $top.fg -padx 40 -relief sunk -background $fgcolor
10762 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10763 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10764 grid x $top.fgbut $top.fg -sticky w
10765 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10766 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10767 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10768 [list $ctext tag conf d0 -foreground]]
10769 grid x $top.diffoldbut $top.diffold -sticky w
10770 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10771 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10772 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10773 [list $ctext tag conf dresult -foreground]]
10774 grid x $top.diffnewbut $top.diffnew -sticky w
10775 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10776 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10777 -command [list choosecolor diffcolors 2 $top.hunksep \
10778 [mc "diff hunk header"] \
10779 [list $ctext tag conf hunksep -foreground]]
10780 grid x $top.hunksepbut $top.hunksep -sticky w
10781 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10782 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10783 -command [list choosecolor markbgcolor {} $top.markbgsep \
10784 [mc "marked line background"] \
10785 [list $ctext tag conf omark -background]]
10786 grid x $top.markbgbut $top.markbgsep -sticky w
10787 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10788 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10789 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10790 grid x $top.selbgbut $top.selbgsep -sticky w
10792 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10793 grid $top.cfont - -sticky w -pady 10
10794 mkfontdisp mainfont $top [mc "Main font"]
10795 mkfontdisp textfont $top [mc "Diff display font"]
10796 mkfontdisp uifont $top [mc "User interface font"]
10798 ${NS}::frame $top.buts
10799 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10800 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10801 bind $top <Key-Return> prefsok
10802 bind $top <Key-Escape> prefscan
10803 grid $top.buts.ok $top.buts.can
10804 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10805 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10806 grid $top.buts - - -pady 10 -sticky ew
10807 grid columnconfigure $top 2 -weight 1
10808 bind $top <Visibility> "focus $top.buts.ok"
10811 proc choose_extdiff {} {
10812 global extdifftool
10814 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10815 if {$prog ne {}} {
10816 set extdifftool $prog
10820 proc choosecolor {v vi w x cmd} {
10821 global $v
10823 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10824 -title [mc "Gitk: choose color for %s" $x]]
10825 if {$c eq {}} return
10826 $w conf -background $c
10827 lset $v $vi $c
10828 eval $cmd $c
10831 proc setselbg {c} {
10832 global bglist cflist
10833 foreach w $bglist {
10834 $w configure -selectbackground $c
10836 $cflist tag configure highlight \
10837 -background [$cflist cget -selectbackground]
10838 allcanvs itemconf secsel -fill $c
10841 # This sets the background color and the color scheme for the whole UI.
10842 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
10843 # if we don't specify one ourselves, which makes the checkbuttons and
10844 # radiobuttons look bad. This chooses white for selectColor if the
10845 # background color is light, or black if it is dark.
10846 proc setui {c} {
10847 set bg [winfo rgb . $c]
10848 set selc black
10849 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
10850 set selc white
10852 tk_setPalette background $c selectColor $selc
10855 proc setbg {c} {
10856 global bglist
10858 foreach w $bglist {
10859 $w conf -background $c
10863 proc setfg {c} {
10864 global fglist canv
10866 foreach w $fglist {
10867 $w conf -foreground $c
10869 allcanvs itemconf text -fill $c
10870 $canv itemconf circle -outline $c
10871 $canv itemconf markid -outline $c
10874 proc prefscan {} {
10875 global oldprefs prefstop
10877 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10878 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10879 global $v
10880 set $v $oldprefs($v)
10882 catch {destroy $prefstop}
10883 unset prefstop
10884 fontcan
10887 proc prefsok {} {
10888 global maxwidth maxgraphpct
10889 global oldprefs prefstop showneartags showlocalchanges
10890 global fontpref mainfont textfont uifont
10891 global limitdiffs treediffs perfile_attrs
10892 global hideremotes
10894 catch {destroy $prefstop}
10895 unset prefstop
10896 fontcan
10897 set fontchanged 0
10898 if {$mainfont ne $fontpref(mainfont)} {
10899 set mainfont $fontpref(mainfont)
10900 parsefont mainfont $mainfont
10901 eval font configure mainfont [fontflags mainfont]
10902 eval font configure mainfontbold [fontflags mainfont 1]
10903 setcoords
10904 set fontchanged 1
10906 if {$textfont ne $fontpref(textfont)} {
10907 set textfont $fontpref(textfont)
10908 parsefont textfont $textfont
10909 eval font configure textfont [fontflags textfont]
10910 eval font configure textfontbold [fontflags textfont 1]
10912 if {$uifont ne $fontpref(uifont)} {
10913 set uifont $fontpref(uifont)
10914 parsefont uifont $uifont
10915 eval font configure uifont [fontflags uifont]
10917 settabs
10918 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10919 if {$showlocalchanges} {
10920 doshowlocalchanges
10921 } else {
10922 dohidelocalchanges
10925 if {$limitdiffs != $oldprefs(limitdiffs) ||
10926 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10927 # treediffs elements are limited by path;
10928 # won't have encodings cached if perfile_attrs was just turned on
10929 catch {unset treediffs}
10931 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10932 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10933 redisplay
10934 } elseif {$showneartags != $oldprefs(showneartags) ||
10935 $limitdiffs != $oldprefs(limitdiffs)} {
10936 reselectline
10938 if {$hideremotes != $oldprefs(hideremotes)} {
10939 rereadrefs
10943 proc formatdate {d} {
10944 global datetimeformat
10945 if {$d ne {}} {
10946 set d [clock format $d -format $datetimeformat]
10948 return $d
10951 # This list of encoding names and aliases is distilled from
10952 # http://www.iana.org/assignments/character-sets.
10953 # Not all of them are supported by Tcl.
10954 set encoding_aliases {
10955 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10956 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10957 { ISO-10646-UTF-1 csISO10646UTF1 }
10958 { ISO_646.basic:1983 ref csISO646basic1983 }
10959 { INVARIANT csINVARIANT }
10960 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10961 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10962 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10963 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10964 { NATS-DANO iso-ir-9-1 csNATSDANO }
10965 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10966 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10967 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10968 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10969 { ISO-2022-KR csISO2022KR }
10970 { EUC-KR csEUCKR }
10971 { ISO-2022-JP csISO2022JP }
10972 { ISO-2022-JP-2 csISO2022JP2 }
10973 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10974 csISO13JISC6220jp }
10975 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10976 { IT iso-ir-15 ISO646-IT csISO15Italian }
10977 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10978 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10979 { greek7-old iso-ir-18 csISO18Greek7Old }
10980 { latin-greek iso-ir-19 csISO19LatinGreek }
10981 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10982 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10983 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10984 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10985 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10986 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10987 { INIS iso-ir-49 csISO49INIS }
10988 { INIS-8 iso-ir-50 csISO50INIS8 }
10989 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10990 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10991 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10992 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10993 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10994 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10995 csISO60Norwegian1 }
10996 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10997 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10998 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10999 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11000 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11001 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11002 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11003 { greek7 iso-ir-88 csISO88Greek7 }
11004 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11005 { iso-ir-90 csISO90 }
11006 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11007 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11008 csISO92JISC62991984b }
11009 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11010 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11011 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11012 csISO95JIS62291984handadd }
11013 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11014 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11015 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11016 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11017 CP819 csISOLatin1 }
11018 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11019 { T.61-7bit iso-ir-102 csISO102T617bit }
11020 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11021 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11022 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11023 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11024 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11025 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11026 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11027 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11028 arabic csISOLatinArabic }
11029 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11030 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11031 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11032 greek greek8 csISOLatinGreek }
11033 { T.101-G2 iso-ir-128 csISO128T101G2 }
11034 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11035 csISOLatinHebrew }
11036 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11037 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11038 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11039 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11040 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11041 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11042 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11043 csISOLatinCyrillic }
11044 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11045 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11046 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11047 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11048 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11049 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11050 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11051 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11052 { ISO_10367-box iso-ir-155 csISO10367Box }
11053 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11054 { latin-lap lap iso-ir-158 csISO158Lap }
11055 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11056 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11057 { us-dk csUSDK }
11058 { dk-us csDKUS }
11059 { JIS_X0201 X0201 csHalfWidthKatakana }
11060 { KSC5636 ISO646-KR csKSC5636 }
11061 { ISO-10646-UCS-2 csUnicode }
11062 { ISO-10646-UCS-4 csUCS4 }
11063 { DEC-MCS dec csDECMCS }
11064 { hp-roman8 roman8 r8 csHPRoman8 }
11065 { macintosh mac csMacintosh }
11066 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11067 csIBM037 }
11068 { IBM038 EBCDIC-INT cp038 csIBM038 }
11069 { IBM273 CP273 csIBM273 }
11070 { IBM274 EBCDIC-BE CP274 csIBM274 }
11071 { IBM275 EBCDIC-BR cp275 csIBM275 }
11072 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11073 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11074 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11075 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11076 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11077 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11078 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11079 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11080 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11081 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11082 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11083 { IBM437 cp437 437 csPC8CodePage437 }
11084 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11085 { IBM775 cp775 csPC775Baltic }
11086 { IBM850 cp850 850 csPC850Multilingual }
11087 { IBM851 cp851 851 csIBM851 }
11088 { IBM852 cp852 852 csPCp852 }
11089 { IBM855 cp855 855 csIBM855 }
11090 { IBM857 cp857 857 csIBM857 }
11091 { IBM860 cp860 860 csIBM860 }
11092 { IBM861 cp861 861 cp-is csIBM861 }
11093 { IBM862 cp862 862 csPC862LatinHebrew }
11094 { IBM863 cp863 863 csIBM863 }
11095 { IBM864 cp864 csIBM864 }
11096 { IBM865 cp865 865 csIBM865 }
11097 { IBM866 cp866 866 csIBM866 }
11098 { IBM868 CP868 cp-ar csIBM868 }
11099 { IBM869 cp869 869 cp-gr csIBM869 }
11100 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11101 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11102 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11103 { IBM891 cp891 csIBM891 }
11104 { IBM903 cp903 csIBM903 }
11105 { IBM904 cp904 904 csIBBM904 }
11106 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11107 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11108 { IBM1026 CP1026 csIBM1026 }
11109 { EBCDIC-AT-DE csIBMEBCDICATDE }
11110 { EBCDIC-AT-DE-A csEBCDICATDEA }
11111 { EBCDIC-CA-FR csEBCDICCAFR }
11112 { EBCDIC-DK-NO csEBCDICDKNO }
11113 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11114 { EBCDIC-FI-SE csEBCDICFISE }
11115 { EBCDIC-FI-SE-A csEBCDICFISEA }
11116 { EBCDIC-FR csEBCDICFR }
11117 { EBCDIC-IT csEBCDICIT }
11118 { EBCDIC-PT csEBCDICPT }
11119 { EBCDIC-ES csEBCDICES }
11120 { EBCDIC-ES-A csEBCDICESA }
11121 { EBCDIC-ES-S csEBCDICESS }
11122 { EBCDIC-UK csEBCDICUK }
11123 { EBCDIC-US csEBCDICUS }
11124 { UNKNOWN-8BIT csUnknown8BiT }
11125 { MNEMONIC csMnemonic }
11126 { MNEM csMnem }
11127 { VISCII csVISCII }
11128 { VIQR csVIQR }
11129 { KOI8-R csKOI8R }
11130 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11131 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11132 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11133 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11134 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11135 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11136 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11137 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11138 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11139 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11140 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11141 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11142 { IBM1047 IBM-1047 }
11143 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11144 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11145 { UNICODE-1-1 csUnicode11 }
11146 { CESU-8 csCESU-8 }
11147 { BOCU-1 csBOCU-1 }
11148 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11149 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11150 l8 }
11151 { ISO-8859-15 ISO_8859-15 Latin-9 }
11152 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11153 { GBK CP936 MS936 windows-936 }
11154 { JIS_Encoding csJISEncoding }
11155 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11156 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11157 EUC-JP }
11158 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11159 { ISO-10646-UCS-Basic csUnicodeASCII }
11160 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11161 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11162 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11163 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11164 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11165 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11166 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11167 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11168 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11169 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11170 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11171 { Ventura-US csVenturaUS }
11172 { Ventura-International csVenturaInternational }
11173 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11174 { PC8-Turkish csPC8Turkish }
11175 { IBM-Symbols csIBMSymbols }
11176 { IBM-Thai csIBMThai }
11177 { HP-Legal csHPLegal }
11178 { HP-Pi-font csHPPiFont }
11179 { HP-Math8 csHPMath8 }
11180 { Adobe-Symbol-Encoding csHPPSMath }
11181 { HP-DeskTop csHPDesktop }
11182 { Ventura-Math csVenturaMath }
11183 { Microsoft-Publishing csMicrosoftPublishing }
11184 { Windows-31J csWindows31J }
11185 { GB2312 csGB2312 }
11186 { Big5 csBig5 }
11189 proc tcl_encoding {enc} {
11190 global encoding_aliases tcl_encoding_cache
11191 if {[info exists tcl_encoding_cache($enc)]} {
11192 return $tcl_encoding_cache($enc)
11194 set names [encoding names]
11195 set lcnames [string tolower $names]
11196 set enc [string tolower $enc]
11197 set i [lsearch -exact $lcnames $enc]
11198 if {$i < 0} {
11199 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11200 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11201 set i [lsearch -exact $lcnames $encx]
11204 if {$i < 0} {
11205 foreach l $encoding_aliases {
11206 set ll [string tolower $l]
11207 if {[lsearch -exact $ll $enc] < 0} continue
11208 # look through the aliases for one that tcl knows about
11209 foreach e $ll {
11210 set i [lsearch -exact $lcnames $e]
11211 if {$i < 0} {
11212 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11213 set i [lsearch -exact $lcnames $ex]
11216 if {$i >= 0} break
11218 break
11221 set tclenc {}
11222 if {$i >= 0} {
11223 set tclenc [lindex $names $i]
11225 set tcl_encoding_cache($enc) $tclenc
11226 return $tclenc
11229 proc gitattr {path attr default} {
11230 global path_attr_cache
11231 if {[info exists path_attr_cache($attr,$path)]} {
11232 set r $path_attr_cache($attr,$path)
11233 } else {
11234 set r "unspecified"
11235 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11236 regexp "(.*): $attr: (.*)" $line m f r
11238 set path_attr_cache($attr,$path) $r
11240 if {$r eq "unspecified"} {
11241 return $default
11243 return $r
11246 proc cache_gitattr {attr pathlist} {
11247 global path_attr_cache
11248 set newlist {}
11249 foreach path $pathlist {
11250 if {![info exists path_attr_cache($attr,$path)]} {
11251 lappend newlist $path
11254 set lim 1000
11255 if {[tk windowingsystem] == "win32"} {
11256 # windows has a 32k limit on the arguments to a command...
11257 set lim 30
11259 while {$newlist ne {}} {
11260 set head [lrange $newlist 0 [expr {$lim - 1}]]
11261 set newlist [lrange $newlist $lim end]
11262 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11263 foreach row [split $rlist "\n"] {
11264 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11265 if {[string index $path 0] eq "\""} {
11266 set path [encoding convertfrom [lindex $path 0]]
11268 set path_attr_cache($attr,$path) $value
11275 proc get_path_encoding {path} {
11276 global gui_encoding perfile_attrs
11277 set tcl_enc $gui_encoding
11278 if {$path ne {} && $perfile_attrs} {
11279 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11280 if {$enc2 ne {}} {
11281 set tcl_enc $enc2
11284 return $tcl_enc
11287 # First check that Tcl/Tk is recent enough
11288 if {[catch {package require Tk 8.4} err]} {
11289 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11290 Gitk requires at least Tcl/Tk 8.4." list
11291 exit 1
11294 # defaults...
11295 set wrcomcmd "git diff-tree --stdin -p --pretty"
11297 set gitencoding {}
11298 catch {
11299 set gitencoding [exec git config --get i18n.commitencoding]
11301 catch {
11302 set gitencoding [exec git config --get i18n.logoutputencoding]
11304 if {$gitencoding == ""} {
11305 set gitencoding "utf-8"
11307 set tclencoding [tcl_encoding $gitencoding]
11308 if {$tclencoding == {}} {
11309 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11312 set gui_encoding [encoding system]
11313 catch {
11314 set enc [exec git config --get gui.encoding]
11315 if {$enc ne {}} {
11316 set tclenc [tcl_encoding $enc]
11317 if {$tclenc ne {}} {
11318 set gui_encoding $tclenc
11319 } else {
11320 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11325 if {[tk windowingsystem] eq "aqua"} {
11326 set mainfont {{Lucida Grande} 9}
11327 set textfont {Monaco 9}
11328 set uifont {{Lucida Grande} 9 bold}
11329 } else {
11330 set mainfont {Helvetica 9}
11331 set textfont {Courier 9}
11332 set uifont {Helvetica 9 bold}
11334 set tabstop 8
11335 set findmergefiles 0
11336 set maxgraphpct 50
11337 set maxwidth 16
11338 set revlistorder 0
11339 set fastdate 0
11340 set uparrowlen 5
11341 set downarrowlen 5
11342 set mingaplen 100
11343 set cmitmode "patch"
11344 set wrapcomment "none"
11345 set showneartags 1
11346 set hideremotes 0
11347 set maxrefs 20
11348 set maxlinelen 200
11349 set showlocalchanges 1
11350 set limitdiffs 1
11351 set datetimeformat "%Y-%m-%d %H:%M:%S"
11352 set autoselect 1
11353 set perfile_attrs 0
11354 set want_ttk 1
11356 if {[tk windowingsystem] eq "aqua"} {
11357 set extdifftool "opendiff"
11358 } else {
11359 set extdifftool "meld"
11362 set colors {green red blue magenta darkgrey brown orange}
11363 if {[tk windowingsystem] eq "win32"} {
11364 set uicolor SystemButtonFace
11365 set bgcolor SystemWindow
11366 set fgcolor SystemButtonText
11367 set selectbgcolor SystemHighlight
11368 } else {
11369 set uicolor grey85
11370 set bgcolor white
11371 set fgcolor black
11372 set selectbgcolor gray85
11374 set diffcolors {red "#00a000" blue}
11375 set diffcontext 3
11376 set ignorespace 0
11377 set markbgcolor "#e0e0ff"
11379 set circlecolors {white blue gray blue blue}
11381 # button for popping up context menus
11382 if {[tk windowingsystem] eq "aqua"} {
11383 set ctxbut <Button-2>
11384 } else {
11385 set ctxbut <Button-3>
11388 ## For msgcat loading, first locate the installation location.
11389 if { [info exists ::env(GITK_MSGSDIR)] } {
11390 ## Msgsdir was manually set in the environment.
11391 set gitk_msgsdir $::env(GITK_MSGSDIR)
11392 } else {
11393 ## Let's guess the prefix from argv0.
11394 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11395 set gitk_libdir [file join $gitk_prefix share gitk lib]
11396 set gitk_msgsdir [file join $gitk_libdir msgs]
11397 unset gitk_prefix
11400 ## Internationalization (i18n) through msgcat and gettext. See
11401 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11402 package require msgcat
11403 namespace import ::msgcat::mc
11404 ## And eventually load the actual message catalog
11405 ::msgcat::mcload $gitk_msgsdir
11407 catch {source ~/.gitk}
11409 parsefont mainfont $mainfont
11410 eval font create mainfont [fontflags mainfont]
11411 eval font create mainfontbold [fontflags mainfont 1]
11413 parsefont textfont $textfont
11414 eval font create textfont [fontflags textfont]
11415 eval font create textfontbold [fontflags textfont 1]
11417 parsefont uifont $uifont
11418 eval font create uifont [fontflags uifont]
11420 setui $uicolor
11422 setoptions
11424 # check that we can find a .git directory somewhere...
11425 if {[catch {set gitdir [gitdir]}]} {
11426 show_error {} . [mc "Cannot find a git repository here."]
11427 exit 1
11429 if {![file isdirectory $gitdir]} {
11430 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11431 exit 1
11434 set selecthead {}
11435 set selectheadid {}
11437 set revtreeargs {}
11438 set cmdline_files {}
11439 set i 0
11440 set revtreeargscmd {}
11441 foreach arg $argv {
11442 switch -glob -- $arg {
11443 "" { }
11444 "--" {
11445 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11446 break
11448 "--select-commit=*" {
11449 set selecthead [string range $arg 16 end]
11451 "--argscmd=*" {
11452 set revtreeargscmd [string range $arg 10 end]
11454 default {
11455 lappend revtreeargs $arg
11458 incr i
11461 if {$selecthead eq "HEAD"} {
11462 set selecthead {}
11465 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11466 # no -- on command line, but some arguments (other than --argscmd)
11467 if {[catch {
11468 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11469 set cmdline_files [split $f "\n"]
11470 set n [llength $cmdline_files]
11471 set revtreeargs [lrange $revtreeargs 0 end-$n]
11472 # Unfortunately git rev-parse doesn't produce an error when
11473 # something is both a revision and a filename. To be consistent
11474 # with git log and git rev-list, check revtreeargs for filenames.
11475 foreach arg $revtreeargs {
11476 if {[file exists $arg]} {
11477 show_error {} . [mc "Ambiguous argument '%s': both revision\
11478 and filename" $arg]
11479 exit 1
11482 } err]} {
11483 # unfortunately we get both stdout and stderr in $err,
11484 # so look for "fatal:".
11485 set i [string first "fatal:" $err]
11486 if {$i > 0} {
11487 set err [string range $err [expr {$i + 6}] end]
11489 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11490 exit 1
11494 set nullid "0000000000000000000000000000000000000000"
11495 set nullid2 "0000000000000000000000000000000000000001"
11496 set nullfile "/dev/null"
11498 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11499 if {![info exists have_ttk]} {
11500 set have_ttk [llength [info commands ::ttk::style]]
11502 set use_ttk [expr {$have_ttk && $want_ttk}]
11503 set NS [expr {$use_ttk ? "ttk" : ""}]
11505 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11507 set runq {}
11508 set history {}
11509 set historyindex 0
11510 set fh_serial 0
11511 set nhl_names {}
11512 set highlight_paths {}
11513 set findpattern {}
11514 set searchdirn -forwards
11515 set boldids {}
11516 set boldnameids {}
11517 set diffelide {0 0}
11518 set markingmatches 0
11519 set linkentercount 0
11520 set need_redisplay 0
11521 set nrows_drawn 0
11522 set firsttabstop 0
11524 set nextviewnum 1
11525 set curview 0
11526 set selectedview 0
11527 set selectedhlview [mc "None"]
11528 set highlight_related [mc "None"]
11529 set highlight_files {}
11530 set viewfiles(0) {}
11531 set viewperm(0) 0
11532 set viewargs(0) {}
11533 set viewargscmd(0) {}
11535 set selectedline {}
11536 set numcommits 0
11537 set loginstance 0
11538 set cmdlineok 0
11539 set stopped 0
11540 set stuffsaved 0
11541 set patchnum 0
11542 set lserial 0
11543 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11544 setcoords
11545 makewindow
11546 catch {
11547 image create photo gitlogo -width 16 -height 16
11549 image create photo gitlogominus -width 4 -height 2
11550 gitlogominus put #C00000 -to 0 0 4 2
11551 gitlogo copy gitlogominus -to 1 5
11552 gitlogo copy gitlogominus -to 6 5
11553 gitlogo copy gitlogominus -to 11 5
11554 image delete gitlogominus
11556 image create photo gitlogoplus -width 4 -height 4
11557 gitlogoplus put #008000 -to 1 0 3 4
11558 gitlogoplus put #008000 -to 0 1 4 3
11559 gitlogo copy gitlogoplus -to 1 9
11560 gitlogo copy gitlogoplus -to 6 9
11561 gitlogo copy gitlogoplus -to 11 9
11562 image delete gitlogoplus
11564 image create photo gitlogo32 -width 32 -height 32
11565 gitlogo32 copy gitlogo -zoom 2 2
11567 wm iconphoto . -default gitlogo gitlogo32
11569 # wait for the window to become visible
11570 tkwait visibility .
11571 wm title . "[file tail $argv0]: [file tail [pwd]]"
11572 update
11573 readrefs
11575 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11576 # create a view for the files/dirs specified on the command line
11577 set curview 1
11578 set selectedview 1
11579 set nextviewnum 2
11580 set viewname(1) [mc "Command line"]
11581 set viewfiles(1) $cmdline_files
11582 set viewargs(1) $revtreeargs
11583 set viewargscmd(1) $revtreeargscmd
11584 set viewperm(1) 0
11585 set vdatemode(1) 0
11586 addviewmenu 1
11587 .bar.view entryconf [mca "Edit view..."] -state normal
11588 .bar.view entryconf [mca "Delete view"] -state normal
11591 if {[info exists permviews]} {
11592 foreach v $permviews {
11593 set n $nextviewnum
11594 incr nextviewnum
11595 set viewname($n) [lindex $v 0]
11596 set viewfiles($n) [lindex $v 1]
11597 set viewargs($n) [lindex $v 2]
11598 set viewargscmd($n) [lindex $v 3]
11599 set viewperm($n) 1
11600 addviewmenu $n
11604 if {[tk windowingsystem] eq "win32"} {
11605 focus -force .
11608 getcommits {}