Skip tests that fail due to incomplete implementations, missing tools...
[git/mingw/j6t.git] / gitk-git / gitk
blob7ebcbf9f25fb5f0ecb9d84946d50a9b1a96aefbe
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2014 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 hasworktree {} {
13 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
14 [exec git rev-parse --is-inside-git-dir] == "false"}]
17 proc reponame {} {
18 global gitdir
19 set n [file normalize $gitdir]
20 if {[string match "*/.git" $n]} {
21 set n [string range $n 0 end-5]
23 return [file tail $n]
26 proc gitworktree {} {
27 variable _gitworktree
28 if {[info exists _gitworktree]} {
29 return $_gitworktree
31 # v1.7.0 introduced --show-toplevel to return the canonical work-tree
32 if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
33 # try to set work tree from environment, core.worktree or use
34 # cdup to obtain a relative path to the top of the worktree. If
35 # run from the top, the ./ prefix ensures normalize expands pwd.
36 if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
37 catch {set _gitworktree [exec git config --get core.worktree]}
38 if {$_gitworktree eq ""} {
39 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
43 return $_gitworktree
46 # A simple scheduler for compute-intensive stuff.
47 # The aim is to make sure that event handlers for GUI actions can
48 # run at least every 50-100 ms. Unfortunately fileevent handlers are
49 # run before X event handlers, so reading from a fast source can
50 # make the GUI completely unresponsive.
51 proc run args {
52 global isonrunq runq currunq
54 set script $args
55 if {[info exists isonrunq($script)]} return
56 if {$runq eq {} && ![info exists currunq]} {
57 after idle dorunq
59 lappend runq [list {} $script]
60 set isonrunq($script) 1
63 proc filerun {fd script} {
64 fileevent $fd readable [list filereadable $fd $script]
67 proc filereadable {fd script} {
68 global runq currunq
70 fileevent $fd readable {}
71 if {$runq eq {} && ![info exists currunq]} {
72 after idle dorunq
74 lappend runq [list $fd $script]
77 proc nukefile {fd} {
78 global runq
80 for {set i 0} {$i < [llength $runq]} {} {
81 if {[lindex $runq $i 0] eq $fd} {
82 set runq [lreplace $runq $i $i]
83 } else {
84 incr i
89 proc dorunq {} {
90 global isonrunq runq currunq
92 set tstart [clock clicks -milliseconds]
93 set t0 $tstart
94 while {[llength $runq] > 0} {
95 set fd [lindex $runq 0 0]
96 set script [lindex $runq 0 1]
97 set currunq [lindex $runq 0]
98 set runq [lrange $runq 1 end]
99 set repeat [eval $script]
100 unset currunq
101 set t1 [clock clicks -milliseconds]
102 set t [expr {$t1 - $t0}]
103 if {$repeat ne {} && $repeat} {
104 if {$fd eq {} || $repeat == 2} {
105 # script returns 1 if it wants to be readded
106 # file readers return 2 if they could do more straight away
107 lappend runq [list $fd $script]
108 } else {
109 fileevent $fd readable [list filereadable $fd $script]
111 } elseif {$fd eq {}} {
112 unset isonrunq($script)
114 set t0 $t1
115 if {$t1 - $tstart >= 80} break
117 if {$runq ne {}} {
118 after idle dorunq
122 proc reg_instance {fd} {
123 global commfd leftover loginstance
125 set i [incr loginstance]
126 set commfd($i) $fd
127 set leftover($i) {}
128 return $i
131 proc unmerged_files {files} {
132 global nr_unmerged
134 # find the list of unmerged files
135 set mlist {}
136 set nr_unmerged 0
137 if {[catch {
138 set fd [open "| git ls-files -u" r]
139 } err]} {
140 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
141 exit 1
143 while {[gets $fd line] >= 0} {
144 set i [string first "\t" $line]
145 if {$i < 0} continue
146 set fname [string range $line [expr {$i+1}] end]
147 if {[lsearch -exact $mlist $fname] >= 0} continue
148 incr nr_unmerged
149 if {$files eq {} || [path_filter $files $fname]} {
150 lappend mlist $fname
153 catch {close $fd}
154 return $mlist
157 proc parseviewargs {n arglist} {
158 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
159 global vinlinediff
160 global worddiff git_version
162 set vdatemode($n) 0
163 set vmergeonly($n) 0
164 set vinlinediff($n) 0
165 set glflags {}
166 set diffargs {}
167 set nextisval 0
168 set revargs {}
169 set origargs $arglist
170 set allknown 1
171 set filtered 0
172 set i -1
173 foreach arg $arglist {
174 incr i
175 if {$nextisval} {
176 lappend glflags $arg
177 set nextisval 0
178 continue
180 switch -glob -- $arg {
181 "-d" -
182 "--date-order" {
183 set vdatemode($n) 1
184 # remove from origargs in case we hit an unknown option
185 set origargs [lreplace $origargs $i $i]
186 incr i -1
188 "-[puabwcrRBMC]" -
189 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
190 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
191 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
192 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
193 "--ignore-space-change" - "-U*" - "--unified=*" {
194 # These request or affect diff output, which we don't want.
195 # Some could be used to set our defaults for diff display.
196 lappend diffargs $arg
198 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
199 "--name-only" - "--name-status" - "--color" -
200 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
201 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
202 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
203 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
204 "--objects" - "--objects-edge" - "--reverse" {
205 # These cause our parsing of git log's output to fail, or else
206 # they're options we want to set ourselves, so ignore them.
208 "--color-words*" - "--word-diff=color" {
209 # These trigger a word diff in the console interface,
210 # so help the user by enabling our own support
211 if {[package vcompare $git_version "1.7.2"] >= 0} {
212 set worddiff [mc "Color words"]
215 "--word-diff*" {
216 if {[package vcompare $git_version "1.7.2"] >= 0} {
217 set worddiff [mc "Markup words"]
220 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
221 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
222 "--full-history" - "--dense" - "--sparse" -
223 "--follow" - "--left-right" - "--encoding=*" {
224 # These are harmless, and some are even useful
225 lappend glflags $arg
227 "--diff-filter=*" - "--no-merges" - "--unpacked" -
228 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
229 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
230 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
231 "--remove-empty" - "--first-parent" - "--cherry-pick" -
232 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
233 "--simplify-by-decoration" {
234 # These mean that we get a subset of the commits
235 set filtered 1
236 lappend glflags $arg
238 "-L*" {
239 # Line-log with 'stuck' argument (unstuck form is
240 # not supported)
241 set filtered 1
242 set vinlinediff($n) 1
243 set allknown 0
244 lappend glflags $arg
246 "-n" {
247 # This appears to be the only one that has a value as a
248 # separate word following it
249 set filtered 1
250 set nextisval 1
251 lappend glflags $arg
253 "--not" - "--all" {
254 lappend revargs $arg
256 "--merge" {
257 set vmergeonly($n) 1
258 # git rev-parse doesn't understand --merge
259 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
261 "--no-replace-objects" {
262 set env(GIT_NO_REPLACE_OBJECTS) "1"
264 "-*" {
265 # Other flag arguments including -<n>
266 if {[string is digit -strict [string range $arg 1 end]]} {
267 set filtered 1
268 } else {
269 # a flag argument that we don't recognize;
270 # that means we can't optimize
271 set allknown 0
273 lappend glflags $arg
275 default {
276 # Non-flag arguments specify commits or ranges of commits
277 if {[string match "*...*" $arg]} {
278 lappend revargs --gitk-symmetric-diff-marker
280 lappend revargs $arg
284 set vdflags($n) $diffargs
285 set vflags($n) $glflags
286 set vrevs($n) $revargs
287 set vfiltered($n) $filtered
288 set vorigargs($n) $origargs
289 return $allknown
292 proc parseviewrevs {view revs} {
293 global vposids vnegids
295 if {$revs eq {}} {
296 set revs HEAD
297 } elseif {[lsearch -exact $revs --all] >= 0} {
298 lappend revs HEAD
300 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
301 # we get stdout followed by stderr in $err
302 # for an unknown rev, git rev-parse echoes it and then errors out
303 set errlines [split $err "\n"]
304 set badrev {}
305 for {set l 0} {$l < [llength $errlines]} {incr l} {
306 set line [lindex $errlines $l]
307 if {!([string length $line] == 40 && [string is xdigit $line])} {
308 if {[string match "fatal:*" $line]} {
309 if {[string match "fatal: ambiguous argument*" $line]
310 && $badrev ne {}} {
311 if {[llength $badrev] == 1} {
312 set err "unknown revision $badrev"
313 } else {
314 set err "unknown revisions: [join $badrev ", "]"
316 } else {
317 set err [join [lrange $errlines $l end] "\n"]
319 break
321 lappend badrev $line
324 error_popup "[mc "Error parsing revisions:"] $err"
325 return {}
327 set ret {}
328 set pos {}
329 set neg {}
330 set sdm 0
331 foreach id [split $ids "\n"] {
332 if {$id eq "--gitk-symmetric-diff-marker"} {
333 set sdm 4
334 } elseif {[string match "^*" $id]} {
335 if {$sdm != 1} {
336 lappend ret $id
337 if {$sdm == 3} {
338 set sdm 0
341 lappend neg [string range $id 1 end]
342 } else {
343 if {$sdm != 2} {
344 lappend ret $id
345 } else {
346 lset ret end $id...[lindex $ret end]
348 lappend pos $id
350 incr sdm -1
352 set vposids($view) $pos
353 set vnegids($view) $neg
354 return $ret
357 # Start off a git log process and arrange to read its output
358 proc start_rev_list {view} {
359 global startmsecs commitidx viewcomplete curview
360 global tclencoding
361 global viewargs viewargscmd viewfiles vfilelimit
362 global showlocalchanges
363 global viewactive viewinstances vmergeonly
364 global mainheadid viewmainheadid viewmainheadid_orig
365 global vcanopt vflags vrevs vorigargs
366 global show_notes
368 set startmsecs [clock clicks -milliseconds]
369 set commitidx($view) 0
370 # these are set this way for the error exits
371 set viewcomplete($view) 1
372 set viewactive($view) 0
373 varcinit $view
375 set args $viewargs($view)
376 if {$viewargscmd($view) ne {}} {
377 if {[catch {
378 set str [exec sh -c $viewargscmd($view)]
379 } err]} {
380 error_popup "[mc "Error executing --argscmd command:"] $err"
381 return 0
383 set args [concat $args [split $str "\n"]]
385 set vcanopt($view) [parseviewargs $view $args]
387 set files $viewfiles($view)
388 if {$vmergeonly($view)} {
389 set files [unmerged_files $files]
390 if {$files eq {}} {
391 global nr_unmerged
392 if {$nr_unmerged == 0} {
393 error_popup [mc "No files selected: --merge specified but\
394 no files are unmerged."]
395 } else {
396 error_popup [mc "No files selected: --merge specified but\
397 no unmerged files are within file limit."]
399 return 0
402 set vfilelimit($view) $files
404 if {$vcanopt($view)} {
405 set revs [parseviewrevs $view $vrevs($view)]
406 if {$revs eq {}} {
407 return 0
409 set args [concat $vflags($view) $revs]
410 } else {
411 set args $vorigargs($view)
414 if {[catch {
415 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
416 --parents --boundary $args "--" $files] r]
417 } err]} {
418 error_popup "[mc "Error executing git log:"] $err"
419 return 0
421 set i [reg_instance $fd]
422 set viewinstances($view) [list $i]
423 set viewmainheadid($view) $mainheadid
424 set viewmainheadid_orig($view) $mainheadid
425 if {$files ne {} && $mainheadid ne {}} {
426 get_viewmainhead $view
428 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
429 interestedin $viewmainheadid($view) dodiffindex
431 fconfigure $fd -blocking 0 -translation lf -eofchar {}
432 if {$tclencoding != {}} {
433 fconfigure $fd -encoding $tclencoding
435 filerun $fd [list getcommitlines $fd $i $view 0]
436 nowbusy $view [mc "Reading"]
437 set viewcomplete($view) 0
438 set viewactive($view) 1
439 return 1
442 proc stop_instance {inst} {
443 global commfd leftover
445 set fd $commfd($inst)
446 catch {
447 set pid [pid $fd]
449 if {$::tcl_platform(platform) eq {windows}} {
450 exec taskkill /pid $pid
451 } else {
452 exec kill $pid
455 catch {close $fd}
456 nukefile $fd
457 unset commfd($inst)
458 unset leftover($inst)
461 proc stop_backends {} {
462 global commfd
464 foreach inst [array names commfd] {
465 stop_instance $inst
469 proc stop_rev_list {view} {
470 global viewinstances
472 foreach inst $viewinstances($view) {
473 stop_instance $inst
475 set viewinstances($view) {}
478 proc reset_pending_select {selid} {
479 global pending_select mainheadid selectheadid
481 if {$selid ne {}} {
482 set pending_select $selid
483 } elseif {$selectheadid ne {}} {
484 set pending_select $selectheadid
485 } else {
486 set pending_select $mainheadid
490 proc getcommits {selid} {
491 global canv curview need_redisplay viewactive
493 initlayout
494 if {[start_rev_list $curview]} {
495 reset_pending_select $selid
496 show_status [mc "Reading commits..."]
497 set need_redisplay 1
498 } else {
499 show_status [mc "No commits selected"]
503 proc updatecommits {} {
504 global curview vcanopt vorigargs vfilelimit viewinstances
505 global viewactive viewcomplete tclencoding
506 global startmsecs showneartags showlocalchanges
507 global mainheadid viewmainheadid viewmainheadid_orig pending_select
508 global hasworktree
509 global varcid vposids vnegids vflags vrevs
510 global show_notes
512 set hasworktree [hasworktree]
513 rereadrefs
514 set view $curview
515 if {$mainheadid ne $viewmainheadid_orig($view)} {
516 if {$showlocalchanges} {
517 dohidelocalchanges
519 set viewmainheadid($view) $mainheadid
520 set viewmainheadid_orig($view) $mainheadid
521 if {$vfilelimit($view) ne {}} {
522 get_viewmainhead $view
525 if {$showlocalchanges} {
526 doshowlocalchanges
528 if {$vcanopt($view)} {
529 set oldpos $vposids($view)
530 set oldneg $vnegids($view)
531 set revs [parseviewrevs $view $vrevs($view)]
532 if {$revs eq {}} {
533 return
535 # note: getting the delta when negative refs change is hard,
536 # and could require multiple git log invocations, so in that
537 # case we ask git log for all the commits (not just the delta)
538 if {$oldneg eq $vnegids($view)} {
539 set newrevs {}
540 set npos 0
541 # take out positive refs that we asked for before or
542 # that we have already seen
543 foreach rev $revs {
544 if {[string length $rev] == 40} {
545 if {[lsearch -exact $oldpos $rev] < 0
546 && ![info exists varcid($view,$rev)]} {
547 lappend newrevs $rev
548 incr npos
550 } else {
551 lappend $newrevs $rev
554 if {$npos == 0} return
555 set revs $newrevs
556 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
558 set args [concat $vflags($view) $revs --not $oldpos]
559 } else {
560 set args $vorigargs($view)
562 if {[catch {
563 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
564 --parents --boundary $args "--" $vfilelimit($view)] r]
565 } err]} {
566 error_popup "[mc "Error executing git log:"] $err"
567 return
569 if {$viewactive($view) == 0} {
570 set startmsecs [clock clicks -milliseconds]
572 set i [reg_instance $fd]
573 lappend viewinstances($view) $i
574 fconfigure $fd -blocking 0 -translation lf -eofchar {}
575 if {$tclencoding != {}} {
576 fconfigure $fd -encoding $tclencoding
578 filerun $fd [list getcommitlines $fd $i $view 1]
579 incr viewactive($view)
580 set viewcomplete($view) 0
581 reset_pending_select {}
582 nowbusy $view [mc "Reading"]
583 if {$showneartags} {
584 getallcommits
588 proc reloadcommits {} {
589 global curview viewcomplete selectedline currentid thickerline
590 global showneartags treediffs commitinterest cached_commitrow
591 global targetid
593 set selid {}
594 if {$selectedline ne {}} {
595 set selid $currentid
598 if {!$viewcomplete($curview)} {
599 stop_rev_list $curview
601 resetvarcs $curview
602 set selectedline {}
603 unset -nocomplain currentid
604 unset -nocomplain thickerline
605 unset -nocomplain treediffs
606 readrefs
607 changedrefs
608 if {$showneartags} {
609 getallcommits
611 clear_display
612 unset -nocomplain commitinterest
613 unset -nocomplain cached_commitrow
614 unset -nocomplain targetid
615 setcanvscroll
616 getcommits $selid
617 return 0
620 # This makes a string representation of a positive integer which
621 # sorts as a string in numerical order
622 proc strrep {n} {
623 if {$n < 16} {
624 return [format "%x" $n]
625 } elseif {$n < 256} {
626 return [format "x%.2x" $n]
627 } elseif {$n < 65536} {
628 return [format "y%.4x" $n]
630 return [format "z%.8x" $n]
633 # Procedures used in reordering commits from git log (without
634 # --topo-order) into the order for display.
636 proc varcinit {view} {
637 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
638 global vtokmod varcmod vrowmod varcix vlastins
640 set varcstart($view) {{}}
641 set vupptr($view) {0}
642 set vdownptr($view) {0}
643 set vleftptr($view) {0}
644 set vbackptr($view) {0}
645 set varctok($view) {{}}
646 set varcrow($view) {{}}
647 set vtokmod($view) {}
648 set varcmod($view) 0
649 set vrowmod($view) 0
650 set varcix($view) {{}}
651 set vlastins($view) {0}
654 proc resetvarcs {view} {
655 global varcid varccommits parents children vseedcount ordertok
656 global vshortids
658 foreach vid [array names varcid $view,*] {
659 unset varcid($vid)
660 unset children($vid)
661 unset parents($vid)
663 foreach vid [array names vshortids $view,*] {
664 unset vshortids($vid)
666 # some commits might have children but haven't been seen yet
667 foreach vid [array names children $view,*] {
668 unset children($vid)
670 foreach va [array names varccommits $view,*] {
671 unset varccommits($va)
673 foreach vd [array names vseedcount $view,*] {
674 unset vseedcount($vd)
676 unset -nocomplain ordertok
679 # returns a list of the commits with no children
680 proc seeds {v} {
681 global vdownptr vleftptr varcstart
683 set ret {}
684 set a [lindex $vdownptr($v) 0]
685 while {$a != 0} {
686 lappend ret [lindex $varcstart($v) $a]
687 set a [lindex $vleftptr($v) $a]
689 return $ret
692 proc newvarc {view id} {
693 global varcid varctok parents children vdatemode
694 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
695 global commitdata commitinfo vseedcount varccommits vlastins
697 set a [llength $varctok($view)]
698 set vid $view,$id
699 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
700 if {![info exists commitinfo($id)]} {
701 parsecommit $id $commitdata($id) 1
703 set cdate [lindex [lindex $commitinfo($id) 4] 0]
704 if {![string is integer -strict $cdate]} {
705 set cdate 0
707 if {![info exists vseedcount($view,$cdate)]} {
708 set vseedcount($view,$cdate) -1
710 set c [incr vseedcount($view,$cdate)]
711 set cdate [expr {$cdate ^ 0xffffffff}]
712 set tok "s[strrep $cdate][strrep $c]"
713 } else {
714 set tok {}
716 set ka 0
717 if {[llength $children($vid)] > 0} {
718 set kid [lindex $children($vid) end]
719 set k $varcid($view,$kid)
720 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
721 set ki $kid
722 set ka $k
723 set tok [lindex $varctok($view) $k]
726 if {$ka != 0} {
727 set i [lsearch -exact $parents($view,$ki) $id]
728 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
729 append tok [strrep $j]
731 set c [lindex $vlastins($view) $ka]
732 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
733 set c $ka
734 set b [lindex $vdownptr($view) $ka]
735 } else {
736 set b [lindex $vleftptr($view) $c]
738 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
739 set c $b
740 set b [lindex $vleftptr($view) $c]
742 if {$c == $ka} {
743 lset vdownptr($view) $ka $a
744 lappend vbackptr($view) 0
745 } else {
746 lset vleftptr($view) $c $a
747 lappend vbackptr($view) $c
749 lset vlastins($view) $ka $a
750 lappend vupptr($view) $ka
751 lappend vleftptr($view) $b
752 if {$b != 0} {
753 lset vbackptr($view) $b $a
755 lappend varctok($view) $tok
756 lappend varcstart($view) $id
757 lappend vdownptr($view) 0
758 lappend varcrow($view) {}
759 lappend varcix($view) {}
760 set varccommits($view,$a) {}
761 lappend vlastins($view) 0
762 return $a
765 proc splitvarc {p v} {
766 global varcid varcstart varccommits varctok vtokmod
767 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
769 set oa $varcid($v,$p)
770 set otok [lindex $varctok($v) $oa]
771 set ac $varccommits($v,$oa)
772 set i [lsearch -exact $varccommits($v,$oa) $p]
773 if {$i <= 0} return
774 set na [llength $varctok($v)]
775 # "%" sorts before "0"...
776 set tok "$otok%[strrep $i]"
777 lappend varctok($v) $tok
778 lappend varcrow($v) {}
779 lappend varcix($v) {}
780 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
781 set varccommits($v,$na) [lrange $ac $i end]
782 lappend varcstart($v) $p
783 foreach id $varccommits($v,$na) {
784 set varcid($v,$id) $na
786 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
787 lappend vlastins($v) [lindex $vlastins($v) $oa]
788 lset vdownptr($v) $oa $na
789 lset vlastins($v) $oa 0
790 lappend vupptr($v) $oa
791 lappend vleftptr($v) 0
792 lappend vbackptr($v) 0
793 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
794 lset vupptr($v) $b $na
796 if {[string compare $otok $vtokmod($v)] <= 0} {
797 modify_arc $v $oa
801 proc renumbervarc {a v} {
802 global parents children varctok varcstart varccommits
803 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
805 set t1 [clock clicks -milliseconds]
806 set todo {}
807 set isrelated($a) 1
808 set kidchanged($a) 1
809 set ntot 0
810 while {$a != 0} {
811 if {[info exists isrelated($a)]} {
812 lappend todo $a
813 set id [lindex $varccommits($v,$a) end]
814 foreach p $parents($v,$id) {
815 if {[info exists varcid($v,$p)]} {
816 set isrelated($varcid($v,$p)) 1
820 incr ntot
821 set b [lindex $vdownptr($v) $a]
822 if {$b == 0} {
823 while {$a != 0} {
824 set b [lindex $vleftptr($v) $a]
825 if {$b != 0} break
826 set a [lindex $vupptr($v) $a]
829 set a $b
831 foreach a $todo {
832 if {![info exists kidchanged($a)]} continue
833 set id [lindex $varcstart($v) $a]
834 if {[llength $children($v,$id)] > 1} {
835 set children($v,$id) [lsort -command [list vtokcmp $v] \
836 $children($v,$id)]
838 set oldtok [lindex $varctok($v) $a]
839 if {!$vdatemode($v)} {
840 set tok {}
841 } else {
842 set tok $oldtok
844 set ka 0
845 set kid [last_real_child $v,$id]
846 if {$kid ne {}} {
847 set k $varcid($v,$kid)
848 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
849 set ki $kid
850 set ka $k
851 set tok [lindex $varctok($v) $k]
854 if {$ka != 0} {
855 set i [lsearch -exact $parents($v,$ki) $id]
856 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
857 append tok [strrep $j]
859 if {$tok eq $oldtok} {
860 continue
862 set id [lindex $varccommits($v,$a) end]
863 foreach p $parents($v,$id) {
864 if {[info exists varcid($v,$p)]} {
865 set kidchanged($varcid($v,$p)) 1
866 } else {
867 set sortkids($p) 1
870 lset varctok($v) $a $tok
871 set b [lindex $vupptr($v) $a]
872 if {$b != $ka} {
873 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
874 modify_arc $v $ka
876 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
877 modify_arc $v $b
879 set c [lindex $vbackptr($v) $a]
880 set d [lindex $vleftptr($v) $a]
881 if {$c == 0} {
882 lset vdownptr($v) $b $d
883 } else {
884 lset vleftptr($v) $c $d
886 if {$d != 0} {
887 lset vbackptr($v) $d $c
889 if {[lindex $vlastins($v) $b] == $a} {
890 lset vlastins($v) $b $c
892 lset vupptr($v) $a $ka
893 set c [lindex $vlastins($v) $ka]
894 if {$c == 0 || \
895 [string compare $tok [lindex $varctok($v) $c]] < 0} {
896 set c $ka
897 set b [lindex $vdownptr($v) $ka]
898 } else {
899 set b [lindex $vleftptr($v) $c]
901 while {$b != 0 && \
902 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
903 set c $b
904 set b [lindex $vleftptr($v) $c]
906 if {$c == $ka} {
907 lset vdownptr($v) $ka $a
908 lset vbackptr($v) $a 0
909 } else {
910 lset vleftptr($v) $c $a
911 lset vbackptr($v) $a $c
913 lset vleftptr($v) $a $b
914 if {$b != 0} {
915 lset vbackptr($v) $b $a
917 lset vlastins($v) $ka $a
920 foreach id [array names sortkids] {
921 if {[llength $children($v,$id)] > 1} {
922 set children($v,$id) [lsort -command [list vtokcmp $v] \
923 $children($v,$id)]
926 set t2 [clock clicks -milliseconds]
927 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
930 # Fix up the graph after we have found out that in view $v,
931 # $p (a commit that we have already seen) is actually the parent
932 # of the last commit in arc $a.
933 proc fix_reversal {p a v} {
934 global varcid varcstart varctok vupptr
936 set pa $varcid($v,$p)
937 if {$p ne [lindex $varcstart($v) $pa]} {
938 splitvarc $p $v
939 set pa $varcid($v,$p)
941 # seeds always need to be renumbered
942 if {[lindex $vupptr($v) $pa] == 0 ||
943 [string compare [lindex $varctok($v) $a] \
944 [lindex $varctok($v) $pa]] > 0} {
945 renumbervarc $pa $v
949 proc insertrow {id p v} {
950 global cmitlisted children parents varcid varctok vtokmod
951 global varccommits ordertok commitidx numcommits curview
952 global targetid targetrow vshortids
954 readcommit $id
955 set vid $v,$id
956 set cmitlisted($vid) 1
957 set children($vid) {}
958 set parents($vid) [list $p]
959 set a [newvarc $v $id]
960 set varcid($vid) $a
961 lappend vshortids($v,[string range $id 0 3]) $id
962 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
963 modify_arc $v $a
965 lappend varccommits($v,$a) $id
966 set vp $v,$p
967 if {[llength [lappend children($vp) $id]] > 1} {
968 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
969 unset -nocomplain ordertok
971 fix_reversal $p $a $v
972 incr commitidx($v)
973 if {$v == $curview} {
974 set numcommits $commitidx($v)
975 setcanvscroll
976 if {[info exists targetid]} {
977 if {![comes_before $targetid $p]} {
978 incr targetrow
984 proc insertfakerow {id p} {
985 global varcid varccommits parents children cmitlisted
986 global commitidx varctok vtokmod targetid targetrow curview numcommits
988 set v $curview
989 set a $varcid($v,$p)
990 set i [lsearch -exact $varccommits($v,$a) $p]
991 if {$i < 0} {
992 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
993 return
995 set children($v,$id) {}
996 set parents($v,$id) [list $p]
997 set varcid($v,$id) $a
998 lappend children($v,$p) $id
999 set cmitlisted($v,$id) 1
1000 set numcommits [incr commitidx($v)]
1001 # note we deliberately don't update varcstart($v) even if $i == 0
1002 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1003 modify_arc $v $a $i
1004 if {[info exists targetid]} {
1005 if {![comes_before $targetid $p]} {
1006 incr targetrow
1009 setcanvscroll
1010 drawvisible
1013 proc removefakerow {id} {
1014 global varcid varccommits parents children commitidx
1015 global varctok vtokmod cmitlisted currentid selectedline
1016 global targetid curview numcommits
1018 set v $curview
1019 if {[llength $parents($v,$id)] != 1} {
1020 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1021 return
1023 set p [lindex $parents($v,$id) 0]
1024 set a $varcid($v,$id)
1025 set i [lsearch -exact $varccommits($v,$a) $id]
1026 if {$i < 0} {
1027 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1028 return
1030 unset varcid($v,$id)
1031 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1032 unset parents($v,$id)
1033 unset children($v,$id)
1034 unset cmitlisted($v,$id)
1035 set numcommits [incr commitidx($v) -1]
1036 set j [lsearch -exact $children($v,$p) $id]
1037 if {$j >= 0} {
1038 set children($v,$p) [lreplace $children($v,$p) $j $j]
1040 modify_arc $v $a $i
1041 if {[info exist currentid] && $id eq $currentid} {
1042 unset currentid
1043 set selectedline {}
1045 if {[info exists targetid] && $targetid eq $id} {
1046 set targetid $p
1048 setcanvscroll
1049 drawvisible
1052 proc real_children {vp} {
1053 global children nullid nullid2
1055 set kids {}
1056 foreach id $children($vp) {
1057 if {$id ne $nullid && $id ne $nullid2} {
1058 lappend kids $id
1061 return $kids
1064 proc first_real_child {vp} {
1065 global children nullid nullid2
1067 foreach id $children($vp) {
1068 if {$id ne $nullid && $id ne $nullid2} {
1069 return $id
1072 return {}
1075 proc last_real_child {vp} {
1076 global children nullid nullid2
1078 set kids $children($vp)
1079 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1080 set id [lindex $kids $i]
1081 if {$id ne $nullid && $id ne $nullid2} {
1082 return $id
1085 return {}
1088 proc vtokcmp {v a b} {
1089 global varctok varcid
1091 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1092 [lindex $varctok($v) $varcid($v,$b)]]
1095 # This assumes that if lim is not given, the caller has checked that
1096 # arc a's token is less than $vtokmod($v)
1097 proc modify_arc {v a {lim {}}} {
1098 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1100 if {$lim ne {}} {
1101 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1102 if {$c > 0} return
1103 if {$c == 0} {
1104 set r [lindex $varcrow($v) $a]
1105 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1108 set vtokmod($v) [lindex $varctok($v) $a]
1109 set varcmod($v) $a
1110 if {$v == $curview} {
1111 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1112 set a [lindex $vupptr($v) $a]
1113 set lim {}
1115 set r 0
1116 if {$a != 0} {
1117 if {$lim eq {}} {
1118 set lim [llength $varccommits($v,$a)]
1120 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1122 set vrowmod($v) $r
1123 undolayout $r
1127 proc update_arcrows {v} {
1128 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1129 global varcid vrownum varcorder varcix varccommits
1130 global vupptr vdownptr vleftptr varctok
1131 global displayorder parentlist curview cached_commitrow
1133 if {$vrowmod($v) == $commitidx($v)} return
1134 if {$v == $curview} {
1135 if {[llength $displayorder] > $vrowmod($v)} {
1136 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1137 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1139 unset -nocomplain cached_commitrow
1141 set narctot [expr {[llength $varctok($v)] - 1}]
1142 set a $varcmod($v)
1143 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1144 # go up the tree until we find something that has a row number,
1145 # or we get to a seed
1146 set a [lindex $vupptr($v) $a]
1148 if {$a == 0} {
1149 set a [lindex $vdownptr($v) 0]
1150 if {$a == 0} return
1151 set vrownum($v) {0}
1152 set varcorder($v) [list $a]
1153 lset varcix($v) $a 0
1154 lset varcrow($v) $a 0
1155 set arcn 0
1156 set row 0
1157 } else {
1158 set arcn [lindex $varcix($v) $a]
1159 if {[llength $vrownum($v)] > $arcn + 1} {
1160 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1161 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1163 set row [lindex $varcrow($v) $a]
1165 while {1} {
1166 set p $a
1167 incr row [llength $varccommits($v,$a)]
1168 # go down if possible
1169 set b [lindex $vdownptr($v) $a]
1170 if {$b == 0} {
1171 # if not, go left, or go up until we can go left
1172 while {$a != 0} {
1173 set b [lindex $vleftptr($v) $a]
1174 if {$b != 0} break
1175 set a [lindex $vupptr($v) $a]
1177 if {$a == 0} break
1179 set a $b
1180 incr arcn
1181 lappend vrownum($v) $row
1182 lappend varcorder($v) $a
1183 lset varcix($v) $a $arcn
1184 lset varcrow($v) $a $row
1186 set vtokmod($v) [lindex $varctok($v) $p]
1187 set varcmod($v) $p
1188 set vrowmod($v) $row
1189 if {[info exists currentid]} {
1190 set selectedline [rowofcommit $currentid]
1194 # Test whether view $v contains commit $id
1195 proc commitinview {id v} {
1196 global varcid
1198 return [info exists varcid($v,$id)]
1201 # Return the row number for commit $id in the current view
1202 proc rowofcommit {id} {
1203 global varcid varccommits varcrow curview cached_commitrow
1204 global varctok vtokmod
1206 set v $curview
1207 if {![info exists varcid($v,$id)]} {
1208 puts "oops rowofcommit no arc for [shortids $id]"
1209 return {}
1211 set a $varcid($v,$id)
1212 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1213 update_arcrows $v
1215 if {[info exists cached_commitrow($id)]} {
1216 return $cached_commitrow($id)
1218 set i [lsearch -exact $varccommits($v,$a) $id]
1219 if {$i < 0} {
1220 puts "oops didn't find commit [shortids $id] in arc $a"
1221 return {}
1223 incr i [lindex $varcrow($v) $a]
1224 set cached_commitrow($id) $i
1225 return $i
1228 # Returns 1 if a is on an earlier row than b, otherwise 0
1229 proc comes_before {a b} {
1230 global varcid varctok curview
1232 set v $curview
1233 if {$a eq $b || ![info exists varcid($v,$a)] || \
1234 ![info exists varcid($v,$b)]} {
1235 return 0
1237 if {$varcid($v,$a) != $varcid($v,$b)} {
1238 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1239 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1241 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1244 proc bsearch {l elt} {
1245 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1246 return 0
1248 set lo 0
1249 set hi [llength $l]
1250 while {$hi - $lo > 1} {
1251 set mid [expr {int(($lo + $hi) / 2)}]
1252 set t [lindex $l $mid]
1253 if {$elt < $t} {
1254 set hi $mid
1255 } elseif {$elt > $t} {
1256 set lo $mid
1257 } else {
1258 return $mid
1261 return $lo
1264 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1265 proc make_disporder {start end} {
1266 global vrownum curview commitidx displayorder parentlist
1267 global varccommits varcorder parents vrowmod varcrow
1268 global d_valid_start d_valid_end
1270 if {$end > $vrowmod($curview)} {
1271 update_arcrows $curview
1273 set ai [bsearch $vrownum($curview) $start]
1274 set start [lindex $vrownum($curview) $ai]
1275 set narc [llength $vrownum($curview)]
1276 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1277 set a [lindex $varcorder($curview) $ai]
1278 set l [llength $displayorder]
1279 set al [llength $varccommits($curview,$a)]
1280 if {$l < $r + $al} {
1281 if {$l < $r} {
1282 set pad [ntimes [expr {$r - $l}] {}]
1283 set displayorder [concat $displayorder $pad]
1284 set parentlist [concat $parentlist $pad]
1285 } elseif {$l > $r} {
1286 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1287 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1289 foreach id $varccommits($curview,$a) {
1290 lappend displayorder $id
1291 lappend parentlist $parents($curview,$id)
1293 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1294 set i $r
1295 foreach id $varccommits($curview,$a) {
1296 lset displayorder $i $id
1297 lset parentlist $i $parents($curview,$id)
1298 incr i
1301 incr r $al
1305 proc commitonrow {row} {
1306 global displayorder
1308 set id [lindex $displayorder $row]
1309 if {$id eq {}} {
1310 make_disporder $row [expr {$row + 1}]
1311 set id [lindex $displayorder $row]
1313 return $id
1316 proc closevarcs {v} {
1317 global varctok varccommits varcid parents children
1318 global cmitlisted commitidx vtokmod
1320 set missing_parents 0
1321 set scripts {}
1322 set narcs [llength $varctok($v)]
1323 for {set a 1} {$a < $narcs} {incr a} {
1324 set id [lindex $varccommits($v,$a) end]
1325 foreach p $parents($v,$id) {
1326 if {[info exists varcid($v,$p)]} continue
1327 # add p as a new commit
1328 incr missing_parents
1329 set cmitlisted($v,$p) 0
1330 set parents($v,$p) {}
1331 if {[llength $children($v,$p)] == 1 &&
1332 [llength $parents($v,$id)] == 1} {
1333 set b $a
1334 } else {
1335 set b [newvarc $v $p]
1337 set varcid($v,$p) $b
1338 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1339 modify_arc $v $b
1341 lappend varccommits($v,$b) $p
1342 incr commitidx($v)
1343 set scripts [check_interest $p $scripts]
1346 if {$missing_parents > 0} {
1347 foreach s $scripts {
1348 eval $s
1353 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1354 # Assumes we already have an arc for $rwid.
1355 proc rewrite_commit {v id rwid} {
1356 global children parents varcid varctok vtokmod varccommits
1358 foreach ch $children($v,$id) {
1359 # make $rwid be $ch's parent in place of $id
1360 set i [lsearch -exact $parents($v,$ch) $id]
1361 if {$i < 0} {
1362 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1364 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1365 # add $ch to $rwid's children and sort the list if necessary
1366 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1367 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1368 $children($v,$rwid)]
1370 # fix the graph after joining $id to $rwid
1371 set a $varcid($v,$ch)
1372 fix_reversal $rwid $a $v
1373 # parentlist is wrong for the last element of arc $a
1374 # even if displayorder is right, hence the 3rd arg here
1375 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1379 # Mechanism for registering a command to be executed when we come
1380 # across a particular commit. To handle the case when only the
1381 # prefix of the commit is known, the commitinterest array is now
1382 # indexed by the first 4 characters of the ID. Each element is a
1383 # list of id, cmd pairs.
1384 proc interestedin {id cmd} {
1385 global commitinterest
1387 lappend commitinterest([string range $id 0 3]) $id $cmd
1390 proc check_interest {id scripts} {
1391 global commitinterest
1393 set prefix [string range $id 0 3]
1394 if {[info exists commitinterest($prefix)]} {
1395 set newlist {}
1396 foreach {i script} $commitinterest($prefix) {
1397 if {[string match "$i*" $id]} {
1398 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1399 } else {
1400 lappend newlist $i $script
1403 if {$newlist ne {}} {
1404 set commitinterest($prefix) $newlist
1405 } else {
1406 unset commitinterest($prefix)
1409 return $scripts
1412 proc getcommitlines {fd inst view updating} {
1413 global cmitlisted leftover
1414 global commitidx commitdata vdatemode
1415 global parents children curview hlview
1416 global idpending ordertok
1417 global varccommits varcid varctok vtokmod vfilelimit vshortids
1419 set stuff [read $fd 500000]
1420 # git log doesn't terminate the last commit with a null...
1421 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1422 set stuff "\0"
1424 if {$stuff == {}} {
1425 if {![eof $fd]} {
1426 return 1
1428 global commfd viewcomplete viewactive viewname
1429 global viewinstances
1430 unset commfd($inst)
1431 set i [lsearch -exact $viewinstances($view) $inst]
1432 if {$i >= 0} {
1433 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1435 # set it blocking so we wait for the process to terminate
1436 fconfigure $fd -blocking 1
1437 if {[catch {close $fd} err]} {
1438 set fv {}
1439 if {$view != $curview} {
1440 set fv " for the \"$viewname($view)\" view"
1442 if {[string range $err 0 4] == "usage"} {
1443 set err "Gitk: error reading commits$fv:\
1444 bad arguments to git log."
1445 if {$viewname($view) eq [mc "Command line"]} {
1446 append err \
1447 " (Note: arguments to gitk are passed to git log\
1448 to allow selection of commits to be displayed.)"
1450 } else {
1451 set err "Error reading commits$fv: $err"
1453 error_popup $err
1455 if {[incr viewactive($view) -1] <= 0} {
1456 set viewcomplete($view) 1
1457 # Check if we have seen any ids listed as parents that haven't
1458 # appeared in the list
1459 closevarcs $view
1460 notbusy $view
1462 if {$view == $curview} {
1463 run chewcommits
1465 return 0
1467 set start 0
1468 set gotsome 0
1469 set scripts {}
1470 while 1 {
1471 set i [string first "\0" $stuff $start]
1472 if {$i < 0} {
1473 append leftover($inst) [string range $stuff $start end]
1474 break
1476 if {$start == 0} {
1477 set cmit $leftover($inst)
1478 append cmit [string range $stuff 0 [expr {$i - 1}]]
1479 set leftover($inst) {}
1480 } else {
1481 set cmit [string range $stuff $start [expr {$i - 1}]]
1483 set start [expr {$i + 1}]
1484 set j [string first "\n" $cmit]
1485 set ok 0
1486 set listed 1
1487 if {$j >= 0 && [string match "commit *" $cmit]} {
1488 set ids [string range $cmit 7 [expr {$j - 1}]]
1489 if {[string match {[-^<>]*} $ids]} {
1490 switch -- [string index $ids 0] {
1491 "-" {set listed 0}
1492 "^" {set listed 2}
1493 "<" {set listed 3}
1494 ">" {set listed 4}
1496 set ids [string range $ids 1 end]
1498 set ok 1
1499 foreach id $ids {
1500 if {[string length $id] != 40} {
1501 set ok 0
1502 break
1506 if {!$ok} {
1507 set shortcmit $cmit
1508 if {[string length $shortcmit] > 80} {
1509 set shortcmit "[string range $shortcmit 0 80]..."
1511 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1512 exit 1
1514 set id [lindex $ids 0]
1515 set vid $view,$id
1517 lappend vshortids($view,[string range $id 0 3]) $id
1519 if {!$listed && $updating && ![info exists varcid($vid)] &&
1520 $vfilelimit($view) ne {}} {
1521 # git log doesn't rewrite parents for unlisted commits
1522 # when doing path limiting, so work around that here
1523 # by working out the rewritten parent with git rev-list
1524 # and if we already know about it, using the rewritten
1525 # parent as a substitute parent for $id's children.
1526 if {![catch {
1527 set rwid [exec git rev-list --first-parent --max-count=1 \
1528 $id -- $vfilelimit($view)]
1529 }]} {
1530 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1531 # use $rwid in place of $id
1532 rewrite_commit $view $id $rwid
1533 continue
1538 set a 0
1539 if {[info exists varcid($vid)]} {
1540 if {$cmitlisted($vid) || !$listed} continue
1541 set a $varcid($vid)
1543 if {$listed} {
1544 set olds [lrange $ids 1 end]
1545 } else {
1546 set olds {}
1548 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1549 set cmitlisted($vid) $listed
1550 set parents($vid) $olds
1551 if {![info exists children($vid)]} {
1552 set children($vid) {}
1553 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1554 set k [lindex $children($vid) 0]
1555 if {[llength $parents($view,$k)] == 1 &&
1556 (!$vdatemode($view) ||
1557 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1558 set a $varcid($view,$k)
1561 if {$a == 0} {
1562 # new arc
1563 set a [newvarc $view $id]
1565 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1566 modify_arc $view $a
1568 if {![info exists varcid($vid)]} {
1569 set varcid($vid) $a
1570 lappend varccommits($view,$a) $id
1571 incr commitidx($view)
1574 set i 0
1575 foreach p $olds {
1576 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1577 set vp $view,$p
1578 if {[llength [lappend children($vp) $id]] > 1 &&
1579 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1580 set children($vp) [lsort -command [list vtokcmp $view] \
1581 $children($vp)]
1582 unset -nocomplain ordertok
1584 if {[info exists varcid($view,$p)]} {
1585 fix_reversal $p $a $view
1588 incr i
1591 set scripts [check_interest $id $scripts]
1592 set gotsome 1
1594 if {$gotsome} {
1595 global numcommits hlview
1597 if {$view == $curview} {
1598 set numcommits $commitidx($view)
1599 run chewcommits
1601 if {[info exists hlview] && $view == $hlview} {
1602 # we never actually get here...
1603 run vhighlightmore
1605 foreach s $scripts {
1606 eval $s
1609 return 2
1612 proc chewcommits {} {
1613 global curview hlview viewcomplete
1614 global pending_select
1616 layoutmore
1617 if {$viewcomplete($curview)} {
1618 global commitidx varctok
1619 global numcommits startmsecs
1621 if {[info exists pending_select]} {
1622 update
1623 reset_pending_select {}
1625 if {[commitinview $pending_select $curview]} {
1626 selectline [rowofcommit $pending_select] 1
1627 } else {
1628 set row [first_real_row]
1629 selectline $row 1
1632 if {$commitidx($curview) > 0} {
1633 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1634 #puts "overall $ms ms for $numcommits commits"
1635 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1636 } else {
1637 show_status [mc "No commits selected"]
1639 notbusy layout
1641 return 0
1644 proc do_readcommit {id} {
1645 global tclencoding
1647 # Invoke git-log to handle automatic encoding conversion
1648 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1649 # Read the results using i18n.logoutputencoding
1650 fconfigure $fd -translation lf -eofchar {}
1651 if {$tclencoding != {}} {
1652 fconfigure $fd -encoding $tclencoding
1654 set contents [read $fd]
1655 close $fd
1656 # Remove the heading line
1657 regsub {^commit [0-9a-f]+\n} $contents {} contents
1659 return $contents
1662 proc readcommit {id} {
1663 if {[catch {set contents [do_readcommit $id]}]} return
1664 parsecommit $id $contents 1
1667 proc parsecommit {id contents listed} {
1668 global commitinfo
1670 set inhdr 1
1671 set comment {}
1672 set headline {}
1673 set auname {}
1674 set audate {}
1675 set comname {}
1676 set comdate {}
1677 set hdrend [string first "\n\n" $contents]
1678 if {$hdrend < 0} {
1679 # should never happen...
1680 set hdrend [string length $contents]
1682 set header [string range $contents 0 [expr {$hdrend - 1}]]
1683 set comment [string range $contents [expr {$hdrend + 2}] end]
1684 foreach line [split $header "\n"] {
1685 set line [split $line " "]
1686 set tag [lindex $line 0]
1687 if {$tag == "author"} {
1688 set audate [lrange $line end-1 end]
1689 set auname [join [lrange $line 1 end-2] " "]
1690 } elseif {$tag == "committer"} {
1691 set comdate [lrange $line end-1 end]
1692 set comname [join [lrange $line 1 end-2] " "]
1695 set headline {}
1696 # take the first non-blank line of the comment as the headline
1697 set headline [string trimleft $comment]
1698 set i [string first "\n" $headline]
1699 if {$i >= 0} {
1700 set headline [string range $headline 0 $i]
1702 set headline [string trimright $headline]
1703 set i [string first "\r" $headline]
1704 if {$i >= 0} {
1705 set headline [string trimright [string range $headline 0 $i]]
1707 if {!$listed} {
1708 # git log indents the comment by 4 spaces;
1709 # if we got this via git cat-file, add the indentation
1710 set newcomment {}
1711 foreach line [split $comment "\n"] {
1712 append newcomment " "
1713 append newcomment $line
1714 append newcomment "\n"
1716 set comment $newcomment
1718 set hasnote [string first "\nNotes:\n" $contents]
1719 set diff ""
1720 # If there is diff output shown in the git-log stream, split it
1721 # out. But get rid of the empty line that always precedes the
1722 # diff.
1723 set i [string first "\n\ndiff" $comment]
1724 if {$i >= 0} {
1725 set diff [string range $comment $i+1 end]
1726 set comment [string range $comment 0 $i-1]
1728 set commitinfo($id) [list $headline $auname $audate \
1729 $comname $comdate $comment $hasnote $diff]
1732 proc getcommit {id} {
1733 global commitdata commitinfo
1735 if {[info exists commitdata($id)]} {
1736 parsecommit $id $commitdata($id) 1
1737 } else {
1738 readcommit $id
1739 if {![info exists commitinfo($id)]} {
1740 set commitinfo($id) [list [mc "No commit information available"]]
1743 return 1
1746 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1747 # and are present in the current view.
1748 # This is fairly slow...
1749 proc longid {prefix} {
1750 global varcid curview vshortids
1752 set ids {}
1753 if {[string length $prefix] >= 4} {
1754 set vshortid $curview,[string range $prefix 0 3]
1755 if {[info exists vshortids($vshortid)]} {
1756 foreach id $vshortids($vshortid) {
1757 if {[string match "$prefix*" $id]} {
1758 if {[lsearch -exact $ids $id] < 0} {
1759 lappend ids $id
1760 if {[llength $ids] >= 2} break
1765 } else {
1766 foreach match [array names varcid "$curview,$prefix*"] {
1767 lappend ids [lindex [split $match ","] 1]
1768 if {[llength $ids] >= 2} break
1771 return $ids
1774 proc readrefs {} {
1775 global tagids idtags headids idheads tagobjid
1776 global otherrefids idotherrefs mainhead mainheadid
1777 global selecthead selectheadid
1778 global hideremotes
1780 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1781 unset -nocomplain $v
1783 set refd [open [list | git show-ref -d] r]
1784 while {[gets $refd line] >= 0} {
1785 if {[string index $line 40] ne " "} continue
1786 set id [string range $line 0 39]
1787 set ref [string range $line 41 end]
1788 if {![string match "refs/*" $ref]} continue
1789 set name [string range $ref 5 end]
1790 if {[string match "remotes/*" $name]} {
1791 if {![string match "*/HEAD" $name] && !$hideremotes} {
1792 set headids($name) $id
1793 lappend idheads($id) $name
1795 } elseif {[string match "heads/*" $name]} {
1796 set name [string range $name 6 end]
1797 set headids($name) $id
1798 lappend idheads($id) $name
1799 } elseif {[string match "tags/*" $name]} {
1800 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1801 # which is what we want since the former is the commit ID
1802 set name [string range $name 5 end]
1803 if {[string match "*^{}" $name]} {
1804 set name [string range $name 0 end-3]
1805 } else {
1806 set tagobjid($name) $id
1808 set tagids($name) $id
1809 lappend idtags($id) $name
1810 } else {
1811 set otherrefids($name) $id
1812 lappend idotherrefs($id) $name
1815 catch {close $refd}
1816 set mainhead {}
1817 set mainheadid {}
1818 catch {
1819 set mainheadid [exec git rev-parse HEAD]
1820 set thehead [exec git symbolic-ref HEAD]
1821 if {[string match "refs/heads/*" $thehead]} {
1822 set mainhead [string range $thehead 11 end]
1825 set selectheadid {}
1826 if {$selecthead ne {}} {
1827 catch {
1828 set selectheadid [exec git rev-parse --verify $selecthead]
1833 # skip over fake commits
1834 proc first_real_row {} {
1835 global nullid nullid2 numcommits
1837 for {set row 0} {$row < $numcommits} {incr row} {
1838 set id [commitonrow $row]
1839 if {$id ne $nullid && $id ne $nullid2} {
1840 break
1843 return $row
1846 # update things for a head moved to a child of its previous location
1847 proc movehead {id name} {
1848 global headids idheads
1850 removehead $headids($name) $name
1851 set headids($name) $id
1852 lappend idheads($id) $name
1855 # update things when a head has been removed
1856 proc removehead {id name} {
1857 global headids idheads
1859 if {$idheads($id) eq $name} {
1860 unset idheads($id)
1861 } else {
1862 set i [lsearch -exact $idheads($id) $name]
1863 if {$i >= 0} {
1864 set idheads($id) [lreplace $idheads($id) $i $i]
1867 unset headids($name)
1870 proc ttk_toplevel {w args} {
1871 global use_ttk
1872 eval [linsert $args 0 ::toplevel $w]
1873 if {$use_ttk} {
1874 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1876 return $w
1879 proc make_transient {window origin} {
1880 global have_tk85
1882 # In MacOS Tk 8.4 transient appears to work by setting
1883 # overrideredirect, which is utterly useless, since the
1884 # windows get no border, and are not even kept above
1885 # the parent.
1886 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1888 wm transient $window $origin
1890 # Windows fails to place transient windows normally, so
1891 # schedule a callback to center them on the parent.
1892 if {[tk windowingsystem] eq {win32}} {
1893 after idle [list tk::PlaceWindow $window widget $origin]
1897 proc show_error {w top msg} {
1898 global NS
1899 if {![info exists NS]} {set NS ""}
1900 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1901 message $w.m -text $msg -justify center -aspect 400
1902 pack $w.m -side top -fill x -padx 20 -pady 20
1903 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1904 pack $w.ok -side bottom -fill x
1905 bind $top <Visibility> "grab $top; focus $top"
1906 bind $top <Key-Return> "destroy $top"
1907 bind $top <Key-space> "destroy $top"
1908 bind $top <Key-Escape> "destroy $top"
1909 tkwait window $top
1912 proc error_popup {msg {owner .}} {
1913 if {[tk windowingsystem] eq "win32"} {
1914 tk_messageBox -icon error -type ok -title [wm title .] \
1915 -parent $owner -message $msg
1916 } else {
1917 set w .error
1918 ttk_toplevel $w
1919 make_transient $w $owner
1920 show_error $w $w $msg
1924 proc confirm_popup {msg {owner .}} {
1925 global confirm_ok NS
1926 set confirm_ok 0
1927 set w .confirm
1928 ttk_toplevel $w
1929 make_transient $w $owner
1930 message $w.m -text $msg -justify center -aspect 400
1931 pack $w.m -side top -fill x -padx 20 -pady 20
1932 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1933 pack $w.ok -side left -fill x
1934 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1935 pack $w.cancel -side right -fill x
1936 bind $w <Visibility> "grab $w; focus $w"
1937 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1938 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1939 bind $w <Key-Escape> "destroy $w"
1940 tk::PlaceWindow $w widget $owner
1941 tkwait window $w
1942 return $confirm_ok
1945 proc setoptions {} {
1946 if {[tk windowingsystem] ne "win32"} {
1947 option add *Panedwindow.showHandle 1 startupFile
1948 option add *Panedwindow.sashRelief raised startupFile
1949 if {[tk windowingsystem] ne "aqua"} {
1950 option add *Menu.font uifont startupFile
1952 } else {
1953 option add *Menu.TearOff 0 startupFile
1955 option add *Button.font uifont startupFile
1956 option add *Checkbutton.font uifont startupFile
1957 option add *Radiobutton.font uifont startupFile
1958 option add *Menubutton.font uifont startupFile
1959 option add *Label.font uifont startupFile
1960 option add *Message.font uifont startupFile
1961 option add *Entry.font textfont startupFile
1962 option add *Text.font textfont startupFile
1963 option add *Labelframe.font uifont startupFile
1964 option add *Spinbox.font textfont startupFile
1965 option add *Listbox.font mainfont startupFile
1968 # Make a menu and submenus.
1969 # m is the window name for the menu, items is the list of menu items to add.
1970 # Each item is a list {mc label type description options...}
1971 # mc is ignored; it's so we can put mc there to alert xgettext
1972 # label is the string that appears in the menu
1973 # type is cascade, command or radiobutton (should add checkbutton)
1974 # description depends on type; it's the sublist for cascade, the
1975 # command to invoke for command, or {variable value} for radiobutton
1976 proc makemenu {m items} {
1977 menu $m
1978 if {[tk windowingsystem] eq {aqua}} {
1979 set Meta1 Cmd
1980 } else {
1981 set Meta1 Ctrl
1983 foreach i $items {
1984 set name [mc [lindex $i 1]]
1985 set type [lindex $i 2]
1986 set thing [lindex $i 3]
1987 set params [list $type]
1988 if {$name ne {}} {
1989 set u [string first "&" [string map {&& x} $name]]
1990 lappend params -label [string map {&& & & {}} $name]
1991 if {$u >= 0} {
1992 lappend params -underline $u
1995 switch -- $type {
1996 "cascade" {
1997 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1998 lappend params -menu $m.$submenu
2000 "command" {
2001 lappend params -command $thing
2003 "radiobutton" {
2004 lappend params -variable [lindex $thing 0] \
2005 -value [lindex $thing 1]
2008 set tail [lrange $i 4 end]
2009 regsub -all {\yMeta1\y} $tail $Meta1 tail
2010 eval $m add $params $tail
2011 if {$type eq "cascade"} {
2012 makemenu $m.$submenu $thing
2017 # translate string and remove ampersands
2018 proc mca {str} {
2019 return [string map {&& & & {}} [mc $str]]
2022 proc cleardropsel {w} {
2023 $w selection clear
2025 proc makedroplist {w varname args} {
2026 global use_ttk
2027 if {$use_ttk} {
2028 set width 0
2029 foreach label $args {
2030 set cx [string length $label]
2031 if {$cx > $width} {set width $cx}
2033 set gm [ttk::combobox $w -width $width -state readonly\
2034 -textvariable $varname -values $args \
2035 -exportselection false]
2036 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2037 } else {
2038 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2040 return $gm
2043 proc makewindow {} {
2044 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2045 global tabstop
2046 global findtype findtypemenu findloc findstring fstring geometry
2047 global entries sha1entry sha1string sha1but
2048 global diffcontextstring diffcontext
2049 global ignorespace
2050 global maincursor textcursor curtextcursor
2051 global rowctxmenu fakerowmenu mergemax wrapcomment
2052 global highlight_files gdttype
2053 global searchstring sstring
2054 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2055 global uifgcolor uifgdisabledcolor
2056 global filesepbgcolor filesepfgcolor
2057 global mergecolors foundbgcolor currentsearchhitbgcolor
2058 global headctxmenu progresscanv progressitem progresscoords statusw
2059 global fprogitem fprogcoord lastprogupdate progupdatepending
2060 global rprogitem rprogcoord rownumsel numcommits
2061 global have_tk85 use_ttk NS
2062 global git_version
2063 global worddiff
2065 # The "mc" arguments here are purely so that xgettext
2066 # sees the following string as needing to be translated
2067 set file {
2068 mc "&File" cascade {
2069 {mc "&Update" command updatecommits -accelerator F5}
2070 {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2071 {mc "Reread re&ferences" command rereadrefs}
2072 {mc "&List references" command showrefs -accelerator F2}
2073 {xx "" separator}
2074 {mc "Start git &gui" command {exec git gui &}}
2075 {xx "" separator}
2076 {mc "&Quit" command doquit -accelerator Meta1-Q}
2078 set edit {
2079 mc "&Edit" cascade {
2080 {mc "&Preferences" command doprefs}
2082 set view {
2083 mc "&View" cascade {
2084 {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2085 {mc "&Edit view..." command editview -state disabled -accelerator F4}
2086 {mc "&Delete view" command delview -state disabled}
2087 {xx "" separator}
2088 {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2090 if {[tk windowingsystem] ne "aqua"} {
2091 set help {
2092 mc "&Help" cascade {
2093 {mc "&About gitk" command about}
2094 {mc "&Key bindings" command keys}
2096 set bar [list $file $edit $view $help]
2097 } else {
2098 proc ::tk::mac::ShowPreferences {} {doprefs}
2099 proc ::tk::mac::Quit {} {doquit}
2100 lset file end [lreplace [lindex $file end] end-1 end]
2101 set apple {
2102 xx "&Apple" cascade {
2103 {mc "&About gitk" command about}
2104 {xx "" separator}
2106 set help {
2107 mc "&Help" cascade {
2108 {mc "&Key bindings" command keys}
2110 set bar [list $apple $file $view $help]
2112 makemenu .bar $bar
2113 . configure -menu .bar
2115 if {$use_ttk} {
2116 # cover the non-themed toplevel with a themed frame.
2117 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2120 # the gui has upper and lower half, parts of a paned window.
2121 ${NS}::panedwindow .ctop -orient vertical
2123 # possibly use assumed geometry
2124 if {![info exists geometry(pwsash0)]} {
2125 set geometry(topheight) [expr {15 * $linespc}]
2126 set geometry(topwidth) [expr {80 * $charspc}]
2127 set geometry(botheight) [expr {15 * $linespc}]
2128 set geometry(botwidth) [expr {50 * $charspc}]
2129 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2130 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2133 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2134 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2135 ${NS}::frame .tf.histframe
2136 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2137 if {!$use_ttk} {
2138 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2141 # create three canvases
2142 set cscroll .tf.histframe.csb
2143 set canv .tf.histframe.pwclist.canv
2144 canvas $canv \
2145 -selectbackground $selectbgcolor \
2146 -background $bgcolor -bd 0 \
2147 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2148 .tf.histframe.pwclist add $canv
2149 set canv2 .tf.histframe.pwclist.canv2
2150 canvas $canv2 \
2151 -selectbackground $selectbgcolor \
2152 -background $bgcolor -bd 0 -yscrollincr $linespc
2153 .tf.histframe.pwclist add $canv2
2154 set canv3 .tf.histframe.pwclist.canv3
2155 canvas $canv3 \
2156 -selectbackground $selectbgcolor \
2157 -background $bgcolor -bd 0 -yscrollincr $linespc
2158 .tf.histframe.pwclist add $canv3
2159 if {$use_ttk} {
2160 bind .tf.histframe.pwclist <Map> {
2161 bind %W <Map> {}
2162 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2163 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2165 } else {
2166 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2167 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2170 # a scroll bar to rule them
2171 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2172 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2173 pack $cscroll -side right -fill y
2174 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2175 lappend bglist $canv $canv2 $canv3
2176 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2178 # we have two button bars at bottom of top frame. Bar 1
2179 ${NS}::frame .tf.bar
2180 ${NS}::frame .tf.lbar -height 15
2182 set sha1entry .tf.bar.sha1
2183 set entries $sha1entry
2184 set sha1but .tf.bar.sha1label
2185 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2186 -command gotocommit -width 8
2187 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2188 pack .tf.bar.sha1label -side left
2189 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2190 trace add variable sha1string write sha1change
2191 pack $sha1entry -side left -pady 2
2193 set bm_left_data {
2194 #define left_width 16
2195 #define left_height 16
2196 static unsigned char left_bits[] = {
2197 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2198 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2199 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2201 set bm_right_data {
2202 #define right_width 16
2203 #define right_height 16
2204 static unsigned char right_bits[] = {
2205 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2206 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2207 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2209 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2210 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2211 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2212 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2214 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2215 if {$use_ttk} {
2216 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2217 } else {
2218 .tf.bar.leftbut configure -image bm-left
2220 pack .tf.bar.leftbut -side left -fill y
2221 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2222 if {$use_ttk} {
2223 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2224 } else {
2225 .tf.bar.rightbut configure -image bm-right
2227 pack .tf.bar.rightbut -side left -fill y
2229 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2230 set rownumsel {}
2231 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2232 -relief sunken -anchor e
2233 ${NS}::label .tf.bar.rowlabel2 -text "/"
2234 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2235 -relief sunken -anchor e
2236 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2237 -side left
2238 if {!$use_ttk} {
2239 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2241 global selectedline
2242 trace add variable selectedline write selectedline_change
2244 # Status label and progress bar
2245 set statusw .tf.bar.status
2246 ${NS}::label $statusw -width 15 -relief sunken
2247 pack $statusw -side left -padx 5
2248 if {$use_ttk} {
2249 set progresscanv [ttk::progressbar .tf.bar.progress]
2250 } else {
2251 set h [expr {[font metrics uifont -linespace] + 2}]
2252 set progresscanv .tf.bar.progress
2253 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2254 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2255 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2256 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2258 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2259 set progresscoords {0 0}
2260 set fprogcoord 0
2261 set rprogcoord 0
2262 bind $progresscanv <Configure> adjustprogress
2263 set lastprogupdate [clock clicks -milliseconds]
2264 set progupdatepending 0
2266 # build up the bottom bar of upper window
2267 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2269 set bm_down_data {
2270 #define down_width 16
2271 #define down_height 16
2272 static unsigned char down_bits[] = {
2273 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2274 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2275 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2276 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2278 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2279 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2280 .tf.lbar.fnext configure -image bm-down
2282 set bm_up_data {
2283 #define up_width 16
2284 #define up_height 16
2285 static unsigned char up_bits[] = {
2286 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2287 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2288 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2289 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2291 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2292 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2293 .tf.lbar.fprev configure -image bm-up
2295 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2297 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2298 -side left -fill y
2299 set gdttype [mc "containing:"]
2300 set gm [makedroplist .tf.lbar.gdttype gdttype \
2301 [mc "containing:"] \
2302 [mc "touching paths:"] \
2303 [mc "adding/removing string:"] \
2304 [mc "changing lines matching:"]]
2305 trace add variable gdttype write gdttype_change
2306 pack .tf.lbar.gdttype -side left -fill y
2308 set findstring {}
2309 set fstring .tf.lbar.findstring
2310 lappend entries $fstring
2311 ${NS}::entry $fstring -width 30 -textvariable findstring
2312 trace add variable findstring write find_change
2313 set findtype [mc "Exact"]
2314 set findtypemenu [makedroplist .tf.lbar.findtype \
2315 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2316 trace add variable findtype write findcom_change
2317 set findloc [mc "All fields"]
2318 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2319 [mc "Comments"] [mc "Author"] [mc "Committer"]
2320 trace add variable findloc write find_change
2321 pack .tf.lbar.findloc -side right
2322 pack .tf.lbar.findtype -side right
2323 pack $fstring -side left -expand 1 -fill x
2325 # Finish putting the upper half of the viewer together
2326 pack .tf.lbar -in .tf -side bottom -fill x
2327 pack .tf.bar -in .tf -side bottom -fill x
2328 pack .tf.histframe -fill both -side top -expand 1
2329 .ctop add .tf
2330 if {!$use_ttk} {
2331 .ctop paneconfigure .tf -height $geometry(topheight)
2332 .ctop paneconfigure .tf -width $geometry(topwidth)
2335 # now build up the bottom
2336 ${NS}::panedwindow .pwbottom -orient horizontal
2338 # lower left, a text box over search bar, scroll bar to the right
2339 # if we know window height, then that will set the lower text height, otherwise
2340 # we set lower text height which will drive window height
2341 if {[info exists geometry(main)]} {
2342 ${NS}::frame .bleft -width $geometry(botwidth)
2343 } else {
2344 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2346 ${NS}::frame .bleft.top
2347 ${NS}::frame .bleft.mid
2348 ${NS}::frame .bleft.bottom
2350 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2351 pack .bleft.top.search -side left -padx 5
2352 set sstring .bleft.top.sstring
2353 set searchstring ""
2354 ${NS}::entry $sstring -width 20 -textvariable searchstring
2355 lappend entries $sstring
2356 trace add variable searchstring write incrsearch
2357 pack $sstring -side left -expand 1 -fill x
2358 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2359 -command changediffdisp -variable diffelide -value {0 0}
2360 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2361 -command changediffdisp -variable diffelide -value {0 1}
2362 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2363 -command changediffdisp -variable diffelide -value {1 0}
2364 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2365 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2366 spinbox .bleft.mid.diffcontext -width 5 \
2367 -from 0 -increment 1 -to 10000000 \
2368 -validate all -validatecommand "diffcontextvalidate %P" \
2369 -textvariable diffcontextstring
2370 .bleft.mid.diffcontext set $diffcontext
2371 trace add variable diffcontextstring write diffcontextchange
2372 lappend entries .bleft.mid.diffcontext
2373 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2374 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2375 -command changeignorespace -variable ignorespace
2376 pack .bleft.mid.ignspace -side left -padx 5
2378 set worddiff [mc "Line diff"]
2379 if {[package vcompare $git_version "1.7.2"] >= 0} {
2380 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2381 [mc "Markup words"] [mc "Color words"]
2382 trace add variable worddiff write changeworddiff
2383 pack .bleft.mid.worddiff -side left -padx 5
2386 set ctext .bleft.bottom.ctext
2387 text $ctext -background $bgcolor -foreground $fgcolor \
2388 -state disabled -font textfont \
2389 -yscrollcommand scrolltext -wrap none \
2390 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2391 if {$have_tk85} {
2392 $ctext conf -tabstyle wordprocessor
2394 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2395 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2396 pack .bleft.top -side top -fill x
2397 pack .bleft.mid -side top -fill x
2398 grid $ctext .bleft.bottom.sb -sticky nsew
2399 grid .bleft.bottom.sbhorizontal -sticky ew
2400 grid columnconfigure .bleft.bottom 0 -weight 1
2401 grid rowconfigure .bleft.bottom 0 -weight 1
2402 grid rowconfigure .bleft.bottom 1 -weight 0
2403 pack .bleft.bottom -side top -fill both -expand 1
2404 lappend bglist $ctext
2405 lappend fglist $ctext
2407 $ctext tag conf comment -wrap $wrapcomment
2408 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2409 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2410 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2411 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2412 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2413 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2414 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2415 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2416 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2417 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2418 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2419 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2420 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2421 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2422 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2423 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2424 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2425 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2426 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2427 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2428 $ctext tag conf mmax -fore darkgrey
2429 set mergemax 16
2430 $ctext tag conf mresult -font textfontbold
2431 $ctext tag conf msep -font textfontbold
2432 $ctext tag conf found -back $foundbgcolor
2433 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2434 $ctext tag conf wwrap -wrap word -lmargin2 1c
2435 $ctext tag conf bold -font textfontbold
2437 .pwbottom add .bleft
2438 if {!$use_ttk} {
2439 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2442 # lower right
2443 ${NS}::frame .bright
2444 ${NS}::frame .bright.mode
2445 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2446 -command reselectline -variable cmitmode -value "patch"
2447 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2448 -command reselectline -variable cmitmode -value "tree"
2449 grid .bright.mode.patch .bright.mode.tree -sticky ew
2450 pack .bright.mode -side top -fill x
2451 set cflist .bright.cfiles
2452 set indent [font measure mainfont "nn"]
2453 text $cflist \
2454 -selectbackground $selectbgcolor \
2455 -background $bgcolor -foreground $fgcolor \
2456 -font mainfont \
2457 -tabs [list $indent [expr {2 * $indent}]] \
2458 -yscrollcommand ".bright.sb set" \
2459 -cursor [. cget -cursor] \
2460 -spacing1 1 -spacing3 1
2461 lappend bglist $cflist
2462 lappend fglist $cflist
2463 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2464 pack .bright.sb -side right -fill y
2465 pack $cflist -side left -fill both -expand 1
2466 $cflist tag configure highlight \
2467 -background [$cflist cget -selectbackground]
2468 $cflist tag configure bold -font mainfontbold
2470 .pwbottom add .bright
2471 .ctop add .pwbottom
2473 # restore window width & height if known
2474 if {[info exists geometry(main)]} {
2475 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2476 if {$w > [winfo screenwidth .]} {
2477 set w [winfo screenwidth .]
2479 if {$h > [winfo screenheight .]} {
2480 set h [winfo screenheight .]
2482 wm geometry . "${w}x$h"
2486 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2487 wm state . $geometry(state)
2490 if {[tk windowingsystem] eq {aqua}} {
2491 set M1B M1
2492 set ::BM "3"
2493 } else {
2494 set M1B Control
2495 set ::BM "2"
2498 if {$use_ttk} {
2499 bind .ctop <Map> {
2500 bind %W <Map> {}
2501 %W sashpos 0 $::geometry(topheight)
2503 bind .pwbottom <Map> {
2504 bind %W <Map> {}
2505 %W sashpos 0 $::geometry(botwidth)
2509 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2510 pack .ctop -fill both -expand 1
2511 bindall <1> {selcanvline %W %x %y}
2512 #bindall <B1-Motion> {selcanvline %W %x %y}
2513 if {[tk windowingsystem] == "win32"} {
2514 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2515 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2516 } else {
2517 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2518 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2519 bind $ctext <Button> {
2520 if {"%b" eq 6} {
2521 $ctext xview scroll -5 units
2522 } elseif {"%b" eq 7} {
2523 $ctext xview scroll 5 units
2526 if {[tk windowingsystem] eq "aqua"} {
2527 bindall <MouseWheel> {
2528 set delta [expr {- (%D)}]
2529 allcanvs yview scroll $delta units
2531 bindall <Shift-MouseWheel> {
2532 set delta [expr {- (%D)}]
2533 $canv xview scroll $delta units
2537 bindall <$::BM> "canvscan mark %W %x %y"
2538 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2539 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2540 bind . <$M1B-Key-w> doquit
2541 bindkey <Home> selfirstline
2542 bindkey <End> sellastline
2543 bind . <Key-Up> "selnextline -1"
2544 bind . <Key-Down> "selnextline 1"
2545 bind . <Shift-Key-Up> "dofind -1 0"
2546 bind . <Shift-Key-Down> "dofind 1 0"
2547 bindkey <Key-Right> "goforw"
2548 bindkey <Key-Left> "goback"
2549 bind . <Key-Prior> "selnextpage -1"
2550 bind . <Key-Next> "selnextpage 1"
2551 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2552 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2553 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2554 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2555 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2556 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2557 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2558 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2559 bindkey <Key-space> "$ctext yview scroll 1 pages"
2560 bindkey p "selnextline -1"
2561 bindkey n "selnextline 1"
2562 bindkey z "goback"
2563 bindkey x "goforw"
2564 bindkey k "selnextline -1"
2565 bindkey j "selnextline 1"
2566 bindkey h "goback"
2567 bindkey l "goforw"
2568 bindkey b prevfile
2569 bindkey d "$ctext yview scroll 18 units"
2570 bindkey u "$ctext yview scroll -18 units"
2571 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2572 bindkey / {focus $fstring}
2573 bindkey <Key-KP_Divide> {focus $fstring}
2574 bindkey <Key-Return> {dofind 1 1}
2575 bindkey ? {dofind -1 1}
2576 bindkey f nextfile
2577 bind . <F5> updatecommits
2578 bindmodfunctionkey Shift 5 reloadcommits
2579 bind . <F2> showrefs
2580 bindmodfunctionkey Shift 4 {newview 0}
2581 bind . <F4> edit_or_newview
2582 bind . <$M1B-q> doquit
2583 bind . <$M1B-f> {dofind 1 1}
2584 bind . <$M1B-g> {dofind 1 0}
2585 bind . <$M1B-r> dosearchback
2586 bind . <$M1B-s> dosearch
2587 bind . <$M1B-equal> {incrfont 1}
2588 bind . <$M1B-plus> {incrfont 1}
2589 bind . <$M1B-KP_Add> {incrfont 1}
2590 bind . <$M1B-minus> {incrfont -1}
2591 bind . <$M1B-KP_Subtract> {incrfont -1}
2592 wm protocol . WM_DELETE_WINDOW doquit
2593 bind . <Destroy> {stop_backends}
2594 bind . <Button-1> "click %W"
2595 bind $fstring <Key-Return> {dofind 1 1}
2596 bind $sha1entry <Key-Return> {gotocommit; break}
2597 bind $sha1entry <<PasteSelection>> clearsha1
2598 bind $sha1entry <<Paste>> clearsha1
2599 bind $cflist <1> {sel_flist %W %x %y; break}
2600 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2601 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2602 global ctxbut
2603 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2604 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2605 bind $ctext <Button-1> {focus %W}
2606 bind $ctext <<Selection>> rehighlight_search_results
2607 for {set i 1} {$i < 10} {incr i} {
2608 bind . <$M1B-Key-$i> [list go_to_parent $i]
2611 set maincursor [. cget -cursor]
2612 set textcursor [$ctext cget -cursor]
2613 set curtextcursor $textcursor
2615 set rowctxmenu .rowctxmenu
2616 makemenu $rowctxmenu {
2617 {mc "Diff this -> selected" command {diffvssel 0}}
2618 {mc "Diff selected -> this" command {diffvssel 1}}
2619 {mc "Make patch" command mkpatch}
2620 {mc "Create tag" command mktag}
2621 {mc "Copy commit summary" command copysummary}
2622 {mc "Write commit to file" command writecommit}
2623 {mc "Create new branch" command mkbranch}
2624 {mc "Cherry-pick this commit" command cherrypick}
2625 {mc "Reset HEAD branch to here" command resethead}
2626 {mc "Mark this commit" command markhere}
2627 {mc "Return to mark" command gotomark}
2628 {mc "Find descendant of this and mark" command find_common_desc}
2629 {mc "Compare with marked commit" command compare_commits}
2630 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2631 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2632 {mc "Revert this commit" command revert}
2634 $rowctxmenu configure -tearoff 0
2636 set fakerowmenu .fakerowmenu
2637 makemenu $fakerowmenu {
2638 {mc "Diff this -> selected" command {diffvssel 0}}
2639 {mc "Diff selected -> this" command {diffvssel 1}}
2640 {mc "Make patch" command mkpatch}
2641 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2642 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2644 $fakerowmenu configure -tearoff 0
2646 set headctxmenu .headctxmenu
2647 makemenu $headctxmenu {
2648 {mc "Check out this branch" command cobranch}
2649 {mc "Remove this branch" command rmbranch}
2650 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2652 $headctxmenu configure -tearoff 0
2654 global flist_menu
2655 set flist_menu .flistctxmenu
2656 makemenu $flist_menu {
2657 {mc "Highlight this too" command {flist_hl 0}}
2658 {mc "Highlight this only" command {flist_hl 1}}
2659 {mc "External diff" command {external_diff}}
2660 {mc "Blame parent commit" command {external_blame 1}}
2661 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2663 $flist_menu configure -tearoff 0
2665 global diff_menu
2666 set diff_menu .diffctxmenu
2667 makemenu $diff_menu {
2668 {mc "Show origin of this line" command show_line_source}
2669 {mc "Run git gui blame on this line" command {external_blame_diff}}
2671 $diff_menu configure -tearoff 0
2674 # Windows sends all mouse wheel events to the current focused window, not
2675 # the one where the mouse hovers, so bind those events here and redirect
2676 # to the correct window
2677 proc windows_mousewheel_redirector {W X Y D} {
2678 global canv canv2 canv3
2679 set w [winfo containing -displayof $W $X $Y]
2680 if {$w ne ""} {
2681 set u [expr {$D < 0 ? 5 : -5}]
2682 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2683 allcanvs yview scroll $u units
2684 } else {
2685 catch {
2686 $w yview scroll $u units
2692 # Update row number label when selectedline changes
2693 proc selectedline_change {n1 n2 op} {
2694 global selectedline rownumsel
2696 if {$selectedline eq {}} {
2697 set rownumsel {}
2698 } else {
2699 set rownumsel [expr {$selectedline + 1}]
2703 # mouse-2 makes all windows scan vertically, but only the one
2704 # the cursor is in scans horizontally
2705 proc canvscan {op w x y} {
2706 global canv canv2 canv3
2707 foreach c [list $canv $canv2 $canv3] {
2708 if {$c == $w} {
2709 $c scan $op $x $y
2710 } else {
2711 $c scan $op 0 $y
2716 proc scrollcanv {cscroll f0 f1} {
2717 $cscroll set $f0 $f1
2718 drawvisible
2719 flushhighlights
2722 # when we make a key binding for the toplevel, make sure
2723 # it doesn't get triggered when that key is pressed in the
2724 # find string entry widget.
2725 proc bindkey {ev script} {
2726 global entries
2727 bind . $ev $script
2728 set escript [bind Entry $ev]
2729 if {$escript == {}} {
2730 set escript [bind Entry <Key>]
2732 foreach e $entries {
2733 bind $e $ev "$escript; break"
2737 proc bindmodfunctionkey {mod n script} {
2738 bind . <$mod-F$n> $script
2739 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2742 # set the focus back to the toplevel for any click outside
2743 # the entry widgets
2744 proc click {w} {
2745 global ctext entries
2746 foreach e [concat $entries $ctext] {
2747 if {$w == $e} return
2749 focus .
2752 # Adjust the progress bar for a change in requested extent or canvas size
2753 proc adjustprogress {} {
2754 global progresscanv progressitem progresscoords
2755 global fprogitem fprogcoord lastprogupdate progupdatepending
2756 global rprogitem rprogcoord use_ttk
2758 if {$use_ttk} {
2759 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2760 return
2763 set w [expr {[winfo width $progresscanv] - 4}]
2764 set x0 [expr {$w * [lindex $progresscoords 0]}]
2765 set x1 [expr {$w * [lindex $progresscoords 1]}]
2766 set h [winfo height $progresscanv]
2767 $progresscanv coords $progressitem $x0 0 $x1 $h
2768 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2769 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2770 set now [clock clicks -milliseconds]
2771 if {$now >= $lastprogupdate + 100} {
2772 set progupdatepending 0
2773 update
2774 } elseif {!$progupdatepending} {
2775 set progupdatepending 1
2776 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2780 proc doprogupdate {} {
2781 global lastprogupdate progupdatepending
2783 if {$progupdatepending} {
2784 set progupdatepending 0
2785 set lastprogupdate [clock clicks -milliseconds]
2786 update
2790 proc config_check_tmp_exists {tries_left} {
2791 global config_file_tmp
2793 if {[file exists $config_file_tmp]} {
2794 incr tries_left -1
2795 if {$tries_left > 0} {
2796 after 100 [list config_check_tmp_exists $tries_left]
2797 } else {
2798 error_popup "There appears to be a stale $config_file_tmp\
2799 file, which will prevent gitk from saving its configuration on exit.\
2800 Please remove it if it is not being used by any existing gitk process."
2805 proc config_init_trace {name} {
2806 global config_variable_changed config_variable_original
2808 upvar #0 $name var
2809 set config_variable_changed($name) 0
2810 set config_variable_original($name) $var
2813 proc config_variable_change_cb {name name2 op} {
2814 global config_variable_changed config_variable_original
2816 upvar #0 $name var
2817 if {$op eq "write" &&
2818 (![info exists config_variable_original($name)] ||
2819 $config_variable_original($name) ne $var)} {
2820 set config_variable_changed($name) 1
2824 proc savestuff {w} {
2825 global stuffsaved
2826 global config_file config_file_tmp
2827 global config_variables config_variable_changed
2828 global viewchanged
2830 upvar #0 viewname current_viewname
2831 upvar #0 viewfiles current_viewfiles
2832 upvar #0 viewargs current_viewargs
2833 upvar #0 viewargscmd current_viewargscmd
2834 upvar #0 viewperm current_viewperm
2835 upvar #0 nextviewnum current_nextviewnum
2836 upvar #0 use_ttk current_use_ttk
2838 if {$stuffsaved} return
2839 if {![winfo viewable .]} return
2840 set remove_tmp 0
2841 if {[catch {
2842 set try_count 0
2843 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2844 if {[incr try_count] > 50} {
2845 error "Unable to write config file: $config_file_tmp exists"
2847 after 100
2849 set remove_tmp 1
2850 if {$::tcl_platform(platform) eq {windows}} {
2851 file attributes $config_file_tmp -hidden true
2853 if {[file exists $config_file]} {
2854 source $config_file
2856 foreach var_name $config_variables {
2857 upvar #0 $var_name var
2858 upvar 0 $var_name old_var
2859 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2860 puts $f [list set $var_name $old_var]
2861 } else {
2862 puts $f [list set $var_name $var]
2866 puts $f "set geometry(main) [wm geometry .]"
2867 puts $f "set geometry(state) [wm state .]"
2868 puts $f "set geometry(topwidth) [winfo width .tf]"
2869 puts $f "set geometry(topheight) [winfo height .tf]"
2870 if {$current_use_ttk} {
2871 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2872 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2873 } else {
2874 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2875 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2877 puts $f "set geometry(botwidth) [winfo width .bleft]"
2878 puts $f "set geometry(botheight) [winfo height .bleft]"
2880 array set view_save {}
2881 array set views {}
2882 if {![info exists permviews]} { set permviews {} }
2883 foreach view $permviews {
2884 set view_save([lindex $view 0]) 1
2885 set views([lindex $view 0]) $view
2887 puts -nonewline $f "set permviews {"
2888 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2889 if {$viewchanged($v)} {
2890 if {$current_viewperm($v)} {
2891 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2892 } else {
2893 set view_save($current_viewname($v)) 0
2897 # write old and updated view to their places and append remaining to the end
2898 foreach view $permviews {
2899 set view_name [lindex $view 0]
2900 if {$view_save($view_name)} {
2901 puts $f "{$views($view_name)}"
2903 unset views($view_name)
2905 foreach view_name [array names views] {
2906 puts $f "{$views($view_name)}"
2908 puts $f "}"
2909 close $f
2910 catch {file delete $config_file}
2911 file rename -force $config_file_tmp $config_file
2912 set remove_tmp 0
2913 } err]} {
2914 puts "Error saving config: $err"
2916 if {$remove_tmp} {
2917 file delete -force $config_file_tmp
2919 set stuffsaved 1
2922 proc resizeclistpanes {win w} {
2923 global oldwidth use_ttk
2924 if {[info exists oldwidth($win)]} {
2925 if {$use_ttk} {
2926 set s0 [$win sashpos 0]
2927 set s1 [$win sashpos 1]
2928 } else {
2929 set s0 [$win sash coord 0]
2930 set s1 [$win sash coord 1]
2932 if {$w < 60} {
2933 set sash0 [expr {int($w/2 - 2)}]
2934 set sash1 [expr {int($w*5/6 - 2)}]
2935 } else {
2936 set factor [expr {1.0 * $w / $oldwidth($win)}]
2937 set sash0 [expr {int($factor * [lindex $s0 0])}]
2938 set sash1 [expr {int($factor * [lindex $s1 0])}]
2939 if {$sash0 < 30} {
2940 set sash0 30
2942 if {$sash1 < $sash0 + 20} {
2943 set sash1 [expr {$sash0 + 20}]
2945 if {$sash1 > $w - 10} {
2946 set sash1 [expr {$w - 10}]
2947 if {$sash0 > $sash1 - 20} {
2948 set sash0 [expr {$sash1 - 20}]
2952 if {$use_ttk} {
2953 $win sashpos 0 $sash0
2954 $win sashpos 1 $sash1
2955 } else {
2956 $win sash place 0 $sash0 [lindex $s0 1]
2957 $win sash place 1 $sash1 [lindex $s1 1]
2960 set oldwidth($win) $w
2963 proc resizecdetpanes {win w} {
2964 global oldwidth use_ttk
2965 if {[info exists oldwidth($win)]} {
2966 if {$use_ttk} {
2967 set s0 [$win sashpos 0]
2968 } else {
2969 set s0 [$win sash coord 0]
2971 if {$w < 60} {
2972 set sash0 [expr {int($w*3/4 - 2)}]
2973 } else {
2974 set factor [expr {1.0 * $w / $oldwidth($win)}]
2975 set sash0 [expr {int($factor * [lindex $s0 0])}]
2976 if {$sash0 < 45} {
2977 set sash0 45
2979 if {$sash0 > $w - 15} {
2980 set sash0 [expr {$w - 15}]
2983 if {$use_ttk} {
2984 $win sashpos 0 $sash0
2985 } else {
2986 $win sash place 0 $sash0 [lindex $s0 1]
2989 set oldwidth($win) $w
2992 proc allcanvs args {
2993 global canv canv2 canv3
2994 eval $canv $args
2995 eval $canv2 $args
2996 eval $canv3 $args
2999 proc bindall {event action} {
3000 global canv canv2 canv3
3001 bind $canv $event $action
3002 bind $canv2 $event $action
3003 bind $canv3 $event $action
3006 proc about {} {
3007 global uifont NS
3008 set w .about
3009 if {[winfo exists $w]} {
3010 raise $w
3011 return
3013 ttk_toplevel $w
3014 wm title $w [mc "About gitk"]
3015 make_transient $w .
3016 message $w.m -text [mc "
3017 Gitk - a commit viewer for git
3019 Copyright \u00a9 2005-2014 Paul Mackerras
3021 Use and redistribute under the terms of the GNU General Public License"] \
3022 -justify center -aspect 400 -border 2 -bg white -relief groove
3023 pack $w.m -side top -fill x -padx 2 -pady 2
3024 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3025 pack $w.ok -side bottom
3026 bind $w <Visibility> "focus $w.ok"
3027 bind $w <Key-Escape> "destroy $w"
3028 bind $w <Key-Return> "destroy $w"
3029 tk::PlaceWindow $w widget .
3032 proc keys {} {
3033 global NS
3034 set w .keys
3035 if {[winfo exists $w]} {
3036 raise $w
3037 return
3039 if {[tk windowingsystem] eq {aqua}} {
3040 set M1T Cmd
3041 } else {
3042 set M1T Ctrl
3044 ttk_toplevel $w
3045 wm title $w [mc "Gitk key bindings"]
3046 make_transient $w .
3047 message $w.m -text "
3048 [mc "Gitk key bindings:"]
3050 [mc "<%s-Q> Quit" $M1T]
3051 [mc "<%s-W> Close window" $M1T]
3052 [mc "<Home> Move to first commit"]
3053 [mc "<End> Move to last commit"]
3054 [mc "<Up>, p, k Move up one commit"]
3055 [mc "<Down>, n, j Move down one commit"]
3056 [mc "<Left>, z, h Go back in history list"]
3057 [mc "<Right>, x, l Go forward in history list"]
3058 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3059 [mc "<PageUp> Move up one page in commit list"]
3060 [mc "<PageDown> Move down one page in commit list"]
3061 [mc "<%s-Home> Scroll to top of commit list" $M1T]
3062 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
3063 [mc "<%s-Up> Scroll commit list up one line" $M1T]
3064 [mc "<%s-Down> Scroll commit list down one line" $M1T]
3065 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3066 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3067 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3068 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3069 [mc "<Delete>, b Scroll diff view up one page"]
3070 [mc "<Backspace> Scroll diff view up one page"]
3071 [mc "<Space> Scroll diff view down one page"]
3072 [mc "u Scroll diff view up 18 lines"]
3073 [mc "d Scroll diff view down 18 lines"]
3074 [mc "<%s-F> Find" $M1T]
3075 [mc "<%s-G> Move to next find hit" $M1T]
3076 [mc "<Return> Move to next find hit"]
3077 [mc "g Go to commit"]
3078 [mc "/ Focus the search box"]
3079 [mc "? Move to previous find hit"]
3080 [mc "f Scroll diff view to next file"]
3081 [mc "<%s-S> Search for next hit in diff view" $M1T]
3082 [mc "<%s-R> Search for previous hit in diff view" $M1T]
3083 [mc "<%s-KP+> Increase font size" $M1T]
3084 [mc "<%s-plus> Increase font size" $M1T]
3085 [mc "<%s-KP-> Decrease font size" $M1T]
3086 [mc "<%s-minus> Decrease font size" $M1T]
3087 [mc "<F5> Update"]
3089 -justify left -bg white -border 2 -relief groove
3090 pack $w.m -side top -fill both -padx 2 -pady 2
3091 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3092 bind $w <Key-Escape> [list destroy $w]
3093 pack $w.ok -side bottom
3094 bind $w <Visibility> "focus $w.ok"
3095 bind $w <Key-Escape> "destroy $w"
3096 bind $w <Key-Return> "destroy $w"
3099 # Procedures for manipulating the file list window at the
3100 # bottom right of the overall window.
3102 proc treeview {w l openlevs} {
3103 global treecontents treediropen treeheight treeparent treeindex
3105 set ix 0
3106 set treeindex() 0
3107 set lev 0
3108 set prefix {}
3109 set prefixend -1
3110 set prefendstack {}
3111 set htstack {}
3112 set ht 0
3113 set treecontents() {}
3114 $w conf -state normal
3115 foreach f $l {
3116 while {[string range $f 0 $prefixend] ne $prefix} {
3117 if {$lev <= $openlevs} {
3118 $w mark set e:$treeindex($prefix) "end -1c"
3119 $w mark gravity e:$treeindex($prefix) left
3121 set treeheight($prefix) $ht
3122 incr ht [lindex $htstack end]
3123 set htstack [lreplace $htstack end end]
3124 set prefixend [lindex $prefendstack end]
3125 set prefendstack [lreplace $prefendstack end end]
3126 set prefix [string range $prefix 0 $prefixend]
3127 incr lev -1
3129 set tail [string range $f [expr {$prefixend+1}] end]
3130 while {[set slash [string first "/" $tail]] >= 0} {
3131 lappend htstack $ht
3132 set ht 0
3133 lappend prefendstack $prefixend
3134 incr prefixend [expr {$slash + 1}]
3135 set d [string range $tail 0 $slash]
3136 lappend treecontents($prefix) $d
3137 set oldprefix $prefix
3138 append prefix $d
3139 set treecontents($prefix) {}
3140 set treeindex($prefix) [incr ix]
3141 set treeparent($prefix) $oldprefix
3142 set tail [string range $tail [expr {$slash+1}] end]
3143 if {$lev <= $openlevs} {
3144 set ht 1
3145 set treediropen($prefix) [expr {$lev < $openlevs}]
3146 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3147 $w mark set d:$ix "end -1c"
3148 $w mark gravity d:$ix left
3149 set str "\n"
3150 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3151 $w insert end $str
3152 $w image create end -align center -image $bm -padx 1 \
3153 -name a:$ix
3154 $w insert end $d [highlight_tag $prefix]
3155 $w mark set s:$ix "end -1c"
3156 $w mark gravity s:$ix left
3158 incr lev
3160 if {$tail ne {}} {
3161 if {$lev <= $openlevs} {
3162 incr ht
3163 set str "\n"
3164 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3165 $w insert end $str
3166 $w insert end $tail [highlight_tag $f]
3168 lappend treecontents($prefix) $tail
3171 while {$htstack ne {}} {
3172 set treeheight($prefix) $ht
3173 incr ht [lindex $htstack end]
3174 set htstack [lreplace $htstack end end]
3175 set prefixend [lindex $prefendstack end]
3176 set prefendstack [lreplace $prefendstack end end]
3177 set prefix [string range $prefix 0 $prefixend]
3179 $w conf -state disabled
3182 proc linetoelt {l} {
3183 global treeheight treecontents
3185 set y 2
3186 set prefix {}
3187 while {1} {
3188 foreach e $treecontents($prefix) {
3189 if {$y == $l} {
3190 return "$prefix$e"
3192 set n 1
3193 if {[string index $e end] eq "/"} {
3194 set n $treeheight($prefix$e)
3195 if {$y + $n > $l} {
3196 append prefix $e
3197 incr y
3198 break
3201 incr y $n
3206 proc highlight_tree {y prefix} {
3207 global treeheight treecontents cflist
3209 foreach e $treecontents($prefix) {
3210 set path $prefix$e
3211 if {[highlight_tag $path] ne {}} {
3212 $cflist tag add bold $y.0 "$y.0 lineend"
3214 incr y
3215 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3216 set y [highlight_tree $y $path]
3219 return $y
3222 proc treeclosedir {w dir} {
3223 global treediropen treeheight treeparent treeindex
3225 set ix $treeindex($dir)
3226 $w conf -state normal
3227 $w delete s:$ix e:$ix
3228 set treediropen($dir) 0
3229 $w image configure a:$ix -image tri-rt
3230 $w conf -state disabled
3231 set n [expr {1 - $treeheight($dir)}]
3232 while {$dir ne {}} {
3233 incr treeheight($dir) $n
3234 set dir $treeparent($dir)
3238 proc treeopendir {w dir} {
3239 global treediropen treeheight treeparent treecontents treeindex
3241 set ix $treeindex($dir)
3242 $w conf -state normal
3243 $w image configure a:$ix -image tri-dn
3244 $w mark set e:$ix s:$ix
3245 $w mark gravity e:$ix right
3246 set lev 0
3247 set str "\n"
3248 set n [llength $treecontents($dir)]
3249 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3250 incr lev
3251 append str "\t"
3252 incr treeheight($x) $n
3254 foreach e $treecontents($dir) {
3255 set de $dir$e
3256 if {[string index $e end] eq "/"} {
3257 set iy $treeindex($de)
3258 $w mark set d:$iy e:$ix
3259 $w mark gravity d:$iy left
3260 $w insert e:$ix $str
3261 set treediropen($de) 0
3262 $w image create e:$ix -align center -image tri-rt -padx 1 \
3263 -name a:$iy
3264 $w insert e:$ix $e [highlight_tag $de]
3265 $w mark set s:$iy e:$ix
3266 $w mark gravity s:$iy left
3267 set treeheight($de) 1
3268 } else {
3269 $w insert e:$ix $str
3270 $w insert e:$ix $e [highlight_tag $de]
3273 $w mark gravity e:$ix right
3274 $w conf -state disabled
3275 set treediropen($dir) 1
3276 set top [lindex [split [$w index @0,0] .] 0]
3277 set ht [$w cget -height]
3278 set l [lindex [split [$w index s:$ix] .] 0]
3279 if {$l < $top} {
3280 $w yview $l.0
3281 } elseif {$l + $n + 1 > $top + $ht} {
3282 set top [expr {$l + $n + 2 - $ht}]
3283 if {$l < $top} {
3284 set top $l
3286 $w yview $top.0
3290 proc treeclick {w x y} {
3291 global treediropen cmitmode ctext cflist cflist_top
3293 if {$cmitmode ne "tree"} return
3294 if {![info exists cflist_top]} return
3295 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3296 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3297 $cflist tag add highlight $l.0 "$l.0 lineend"
3298 set cflist_top $l
3299 if {$l == 1} {
3300 $ctext yview 1.0
3301 return
3303 set e [linetoelt $l]
3304 if {[string index $e end] ne "/"} {
3305 showfile $e
3306 } elseif {$treediropen($e)} {
3307 treeclosedir $w $e
3308 } else {
3309 treeopendir $w $e
3313 proc setfilelist {id} {
3314 global treefilelist cflist jump_to_here
3316 treeview $cflist $treefilelist($id) 0
3317 if {$jump_to_here ne {}} {
3318 set f [lindex $jump_to_here 0]
3319 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3320 showfile $f
3325 image create bitmap tri-rt -background black -foreground blue -data {
3326 #define tri-rt_width 13
3327 #define tri-rt_height 13
3328 static unsigned char tri-rt_bits[] = {
3329 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3330 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3331 0x00, 0x00};
3332 } -maskdata {
3333 #define tri-rt-mask_width 13
3334 #define tri-rt-mask_height 13
3335 static unsigned char tri-rt-mask_bits[] = {
3336 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3337 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3338 0x08, 0x00};
3340 image create bitmap tri-dn -background black -foreground blue -data {
3341 #define tri-dn_width 13
3342 #define tri-dn_height 13
3343 static unsigned char tri-dn_bits[] = {
3344 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3345 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3346 0x00, 0x00};
3347 } -maskdata {
3348 #define tri-dn-mask_width 13
3349 #define tri-dn-mask_height 13
3350 static unsigned char tri-dn-mask_bits[] = {
3351 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3352 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3353 0x00, 0x00};
3356 image create bitmap reficon-T -background black -foreground yellow -data {
3357 #define tagicon_width 13
3358 #define tagicon_height 9
3359 static unsigned char tagicon_bits[] = {
3360 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3361 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3362 } -maskdata {
3363 #define tagicon-mask_width 13
3364 #define tagicon-mask_height 9
3365 static unsigned char tagicon-mask_bits[] = {
3366 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3367 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3369 set rectdata {
3370 #define headicon_width 13
3371 #define headicon_height 9
3372 static unsigned char headicon_bits[] = {
3373 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3374 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3376 set rectmask {
3377 #define headicon-mask_width 13
3378 #define headicon-mask_height 9
3379 static unsigned char headicon-mask_bits[] = {
3380 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3381 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3383 image create bitmap reficon-H -background black -foreground green \
3384 -data $rectdata -maskdata $rectmask
3385 image create bitmap reficon-o -background black -foreground "#ddddff" \
3386 -data $rectdata -maskdata $rectmask
3388 proc init_flist {first} {
3389 global cflist cflist_top difffilestart
3391 $cflist conf -state normal
3392 $cflist delete 0.0 end
3393 if {$first ne {}} {
3394 $cflist insert end $first
3395 set cflist_top 1
3396 $cflist tag add highlight 1.0 "1.0 lineend"
3397 } else {
3398 unset -nocomplain cflist_top
3400 $cflist conf -state disabled
3401 set difffilestart {}
3404 proc highlight_tag {f} {
3405 global highlight_paths
3407 foreach p $highlight_paths {
3408 if {[string match $p $f]} {
3409 return "bold"
3412 return {}
3415 proc highlight_filelist {} {
3416 global cmitmode cflist
3418 $cflist conf -state normal
3419 if {$cmitmode ne "tree"} {
3420 set end [lindex [split [$cflist index end] .] 0]
3421 for {set l 2} {$l < $end} {incr l} {
3422 set line [$cflist get $l.0 "$l.0 lineend"]
3423 if {[highlight_tag $line] ne {}} {
3424 $cflist tag add bold $l.0 "$l.0 lineend"
3427 } else {
3428 highlight_tree 2 {}
3430 $cflist conf -state disabled
3433 proc unhighlight_filelist {} {
3434 global cflist
3436 $cflist conf -state normal
3437 $cflist tag remove bold 1.0 end
3438 $cflist conf -state disabled
3441 proc add_flist {fl} {
3442 global cflist
3444 $cflist conf -state normal
3445 foreach f $fl {
3446 $cflist insert end "\n"
3447 $cflist insert end $f [highlight_tag $f]
3449 $cflist conf -state disabled
3452 proc sel_flist {w x y} {
3453 global ctext difffilestart cflist cflist_top cmitmode
3455 if {$cmitmode eq "tree"} return
3456 if {![info exists cflist_top]} return
3457 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3458 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3459 $cflist tag add highlight $l.0 "$l.0 lineend"
3460 set cflist_top $l
3461 if {$l == 1} {
3462 $ctext yview 1.0
3463 } else {
3464 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3466 suppress_highlighting_file_for_current_scrollpos
3469 proc pop_flist_menu {w X Y x y} {
3470 global ctext cflist cmitmode flist_menu flist_menu_file
3471 global treediffs diffids
3473 stopfinding
3474 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3475 if {$l <= 1} return
3476 if {$cmitmode eq "tree"} {
3477 set e [linetoelt $l]
3478 if {[string index $e end] eq "/"} return
3479 } else {
3480 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3482 set flist_menu_file $e
3483 set xdiffstate "normal"
3484 if {$cmitmode eq "tree"} {
3485 set xdiffstate "disabled"
3487 # Disable "External diff" item in tree mode
3488 $flist_menu entryconf 2 -state $xdiffstate
3489 tk_popup $flist_menu $X $Y
3492 proc find_ctext_fileinfo {line} {
3493 global ctext_file_names ctext_file_lines
3495 set ok [bsearch $ctext_file_lines $line]
3496 set tline [lindex $ctext_file_lines $ok]
3498 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3499 return {}
3500 } else {
3501 return [list [lindex $ctext_file_names $ok] $tline]
3505 proc pop_diff_menu {w X Y x y} {
3506 global ctext diff_menu flist_menu_file
3507 global diff_menu_txtpos diff_menu_line
3508 global diff_menu_filebase
3510 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3511 set diff_menu_line [lindex $diff_menu_txtpos 0]
3512 # don't pop up the menu on hunk-separator or file-separator lines
3513 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3514 return
3516 stopfinding
3517 set f [find_ctext_fileinfo $diff_menu_line]
3518 if {$f eq {}} return
3519 set flist_menu_file [lindex $f 0]
3520 set diff_menu_filebase [lindex $f 1]
3521 tk_popup $diff_menu $X $Y
3524 proc flist_hl {only} {
3525 global flist_menu_file findstring gdttype
3527 set x [shellquote $flist_menu_file]
3528 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3529 set findstring $x
3530 } else {
3531 append findstring " " $x
3533 set gdttype [mc "touching paths:"]
3536 proc gitknewtmpdir {} {
3537 global diffnum gitktmpdir gitdir env
3539 if {![info exists gitktmpdir]} {
3540 if {[info exists env(GITK_TMPDIR)]} {
3541 set tmpdir $env(GITK_TMPDIR)
3542 } elseif {[info exists env(TMPDIR)]} {
3543 set tmpdir $env(TMPDIR)
3544 } else {
3545 set tmpdir $gitdir
3547 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3548 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3549 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3551 if {[catch {file mkdir $gitktmpdir} err]} {
3552 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3553 unset gitktmpdir
3554 return {}
3556 set diffnum 0
3558 incr diffnum
3559 set diffdir [file join $gitktmpdir $diffnum]
3560 if {[catch {file mkdir $diffdir} err]} {
3561 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3562 return {}
3564 return $diffdir
3567 proc save_file_from_commit {filename output what} {
3568 global nullfile
3570 if {[catch {exec git show $filename -- > $output} err]} {
3571 if {[string match "fatal: bad revision *" $err]} {
3572 return $nullfile
3574 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3575 return {}
3577 return $output
3580 proc external_diff_get_one_file {diffid filename diffdir} {
3581 global nullid nullid2 nullfile
3582 global worktree
3584 if {$diffid == $nullid} {
3585 set difffile [file join $worktree $filename]
3586 if {[file exists $difffile]} {
3587 return $difffile
3589 return $nullfile
3591 if {$diffid == $nullid2} {
3592 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3593 return [save_file_from_commit :$filename $difffile index]
3595 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3596 return [save_file_from_commit $diffid:$filename $difffile \
3597 "revision $diffid"]
3600 proc external_diff {} {
3601 global nullid nullid2
3602 global flist_menu_file
3603 global diffids
3604 global extdifftool
3606 if {[llength $diffids] == 1} {
3607 # no reference commit given
3608 set diffidto [lindex $diffids 0]
3609 if {$diffidto eq $nullid} {
3610 # diffing working copy with index
3611 set diffidfrom $nullid2
3612 } elseif {$diffidto eq $nullid2} {
3613 # diffing index with HEAD
3614 set diffidfrom "HEAD"
3615 } else {
3616 # use first parent commit
3617 global parentlist selectedline
3618 set diffidfrom [lindex $parentlist $selectedline 0]
3620 } else {
3621 set diffidfrom [lindex $diffids 0]
3622 set diffidto [lindex $diffids 1]
3625 # make sure that several diffs wont collide
3626 set diffdir [gitknewtmpdir]
3627 if {$diffdir eq {}} return
3629 # gather files to diff
3630 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3631 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3633 if {$difffromfile ne {} && $difftofile ne {}} {
3634 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3635 if {[catch {set fl [open |$cmd r]} err]} {
3636 file delete -force $diffdir
3637 error_popup "$extdifftool: [mc "command failed:"] $err"
3638 } else {
3639 fconfigure $fl -blocking 0
3640 filerun $fl [list delete_at_eof $fl $diffdir]
3645 proc find_hunk_blamespec {base line} {
3646 global ctext
3648 # Find and parse the hunk header
3649 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3650 if {$s_lix eq {}} return
3652 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3653 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3654 s_line old_specs osz osz1 new_line nsz]} {
3655 return
3658 # base lines for the parents
3659 set base_lines [list $new_line]
3660 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3661 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3662 old_spec old_line osz]} {
3663 return
3665 lappend base_lines $old_line
3668 # Now scan the lines to determine offset within the hunk
3669 set max_parent [expr {[llength $base_lines]-2}]
3670 set dline 0
3671 set s_lno [lindex [split $s_lix "."] 0]
3673 # Determine if the line is removed
3674 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3675 if {[string match {[-+ ]*} $chunk]} {
3676 set removed_idx [string first "-" $chunk]
3677 # Choose a parent index
3678 if {$removed_idx >= 0} {
3679 set parent $removed_idx
3680 } else {
3681 set unchanged_idx [string first " " $chunk]
3682 if {$unchanged_idx >= 0} {
3683 set parent $unchanged_idx
3684 } else {
3685 # blame the current commit
3686 set parent -1
3689 # then count other lines that belong to it
3690 for {set i $line} {[incr i -1] > $s_lno} {} {
3691 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3692 # Determine if the line is removed
3693 set removed_idx [string first "-" $chunk]
3694 if {$parent >= 0} {
3695 set code [string index $chunk $parent]
3696 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3697 incr dline
3699 } else {
3700 if {$removed_idx < 0} {
3701 incr dline
3705 incr parent
3706 } else {
3707 set parent 0
3710 incr dline [lindex $base_lines $parent]
3711 return [list $parent $dline]
3714 proc external_blame_diff {} {
3715 global currentid cmitmode
3716 global diff_menu_txtpos diff_menu_line
3717 global diff_menu_filebase flist_menu_file
3719 if {$cmitmode eq "tree"} {
3720 set parent_idx 0
3721 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3722 } else {
3723 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3724 if {$hinfo ne {}} {
3725 set parent_idx [lindex $hinfo 0]
3726 set line [lindex $hinfo 1]
3727 } else {
3728 set parent_idx 0
3729 set line 0
3733 external_blame $parent_idx $line
3736 # Find the SHA1 ID of the blob for file $fname in the index
3737 # at stage 0 or 2
3738 proc index_sha1 {fname} {
3739 set f [open [list | git ls-files -s $fname] r]
3740 while {[gets $f line] >= 0} {
3741 set info [lindex [split $line "\t"] 0]
3742 set stage [lindex $info 2]
3743 if {$stage eq "0" || $stage eq "2"} {
3744 close $f
3745 return [lindex $info 1]
3748 close $f
3749 return {}
3752 # Turn an absolute path into one relative to the current directory
3753 proc make_relative {f} {
3754 if {[file pathtype $f] eq "relative"} {
3755 return $f
3757 set elts [file split $f]
3758 set here [file split [pwd]]
3759 set ei 0
3760 set hi 0
3761 set res {}
3762 foreach d $here {
3763 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3764 lappend res ".."
3765 } else {
3766 incr ei
3768 incr hi
3770 set elts [concat $res [lrange $elts $ei end]]
3771 return [eval file join $elts]
3774 proc external_blame {parent_idx {line {}}} {
3775 global flist_menu_file cdup
3776 global nullid nullid2
3777 global parentlist selectedline currentid
3779 if {$parent_idx > 0} {
3780 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3781 } else {
3782 set base_commit $currentid
3785 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3786 error_popup [mc "No such commit"]
3787 return
3790 set cmdline [list git gui blame]
3791 if {$line ne {} && $line > 1} {
3792 lappend cmdline "--line=$line"
3794 set f [file join $cdup $flist_menu_file]
3795 # Unfortunately it seems git gui blame doesn't like
3796 # being given an absolute path...
3797 set f [make_relative $f]
3798 lappend cmdline $base_commit $f
3799 if {[catch {eval exec $cmdline &} err]} {
3800 error_popup "[mc "git gui blame: command failed:"] $err"
3804 proc show_line_source {} {
3805 global cmitmode currentid parents curview blamestuff blameinst
3806 global diff_menu_line diff_menu_filebase flist_menu_file
3807 global nullid nullid2 gitdir cdup
3809 set from_index {}
3810 if {$cmitmode eq "tree"} {
3811 set id $currentid
3812 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3813 } else {
3814 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3815 if {$h eq {}} return
3816 set pi [lindex $h 0]
3817 if {$pi == 0} {
3818 mark_ctext_line $diff_menu_line
3819 return
3821 incr pi -1
3822 if {$currentid eq $nullid} {
3823 if {$pi > 0} {
3824 # must be a merge in progress...
3825 if {[catch {
3826 # get the last line from .git/MERGE_HEAD
3827 set f [open [file join $gitdir MERGE_HEAD] r]
3828 set id [lindex [split [read $f] "\n"] end-1]
3829 close $f
3830 } err]} {
3831 error_popup [mc "Couldn't read merge head: %s" $err]
3832 return
3834 } elseif {$parents($curview,$currentid) eq $nullid2} {
3835 # need to do the blame from the index
3836 if {[catch {
3837 set from_index [index_sha1 $flist_menu_file]
3838 } err]} {
3839 error_popup [mc "Error reading index: %s" $err]
3840 return
3842 } else {
3843 set id $parents($curview,$currentid)
3845 } else {
3846 set id [lindex $parents($curview,$currentid) $pi]
3848 set line [lindex $h 1]
3850 set blameargs {}
3851 if {$from_index ne {}} {
3852 lappend blameargs | git cat-file blob $from_index
3854 lappend blameargs | git blame -p -L$line,+1
3855 if {$from_index ne {}} {
3856 lappend blameargs --contents -
3857 } else {
3858 lappend blameargs $id
3860 lappend blameargs -- [file join $cdup $flist_menu_file]
3861 if {[catch {
3862 set f [open $blameargs r]
3863 } err]} {
3864 error_popup [mc "Couldn't start git blame: %s" $err]
3865 return
3867 nowbusy blaming [mc "Searching"]
3868 fconfigure $f -blocking 0
3869 set i [reg_instance $f]
3870 set blamestuff($i) {}
3871 set blameinst $i
3872 filerun $f [list read_line_source $f $i]
3875 proc stopblaming {} {
3876 global blameinst
3878 if {[info exists blameinst]} {
3879 stop_instance $blameinst
3880 unset blameinst
3881 notbusy blaming
3885 proc read_line_source {fd inst} {
3886 global blamestuff curview commfd blameinst nullid nullid2
3888 while {[gets $fd line] >= 0} {
3889 lappend blamestuff($inst) $line
3891 if {![eof $fd]} {
3892 return 1
3894 unset commfd($inst)
3895 unset blameinst
3896 notbusy blaming
3897 fconfigure $fd -blocking 1
3898 if {[catch {close $fd} err]} {
3899 error_popup [mc "Error running git blame: %s" $err]
3900 return 0
3903 set fname {}
3904 set line [split [lindex $blamestuff($inst) 0] " "]
3905 set id [lindex $line 0]
3906 set lnum [lindex $line 1]
3907 if {[string length $id] == 40 && [string is xdigit $id] &&
3908 [string is digit -strict $lnum]} {
3909 # look for "filename" line
3910 foreach l $blamestuff($inst) {
3911 if {[string match "filename *" $l]} {
3912 set fname [string range $l 9 end]
3913 break
3917 if {$fname ne {}} {
3918 # all looks good, select it
3919 if {$id eq $nullid} {
3920 # blame uses all-zeroes to mean not committed,
3921 # which would mean a change in the index
3922 set id $nullid2
3924 if {[commitinview $id $curview]} {
3925 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3926 } else {
3927 error_popup [mc "That line comes from commit %s, \
3928 which is not in this view" [shortids $id]]
3930 } else {
3931 puts "oops couldn't parse git blame output"
3933 return 0
3936 # delete $dir when we see eof on $f (presumably because the child has exited)
3937 proc delete_at_eof {f dir} {
3938 while {[gets $f line] >= 0} {}
3939 if {[eof $f]} {
3940 if {[catch {close $f} err]} {
3941 error_popup "[mc "External diff viewer failed:"] $err"
3943 file delete -force $dir
3944 return 0
3946 return 1
3949 # Functions for adding and removing shell-type quoting
3951 proc shellquote {str} {
3952 if {![string match "*\['\"\\ \t]*" $str]} {
3953 return $str
3955 if {![string match "*\['\"\\]*" $str]} {
3956 return "\"$str\""
3958 if {![string match "*'*" $str]} {
3959 return "'$str'"
3961 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3964 proc shellarglist {l} {
3965 set str {}
3966 foreach a $l {
3967 if {$str ne {}} {
3968 append str " "
3970 append str [shellquote $a]
3972 return $str
3975 proc shelldequote {str} {
3976 set ret {}
3977 set used -1
3978 while {1} {
3979 incr used
3980 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3981 append ret [string range $str $used end]
3982 set used [string length $str]
3983 break
3985 set first [lindex $first 0]
3986 set ch [string index $str $first]
3987 if {$first > $used} {
3988 append ret [string range $str $used [expr {$first - 1}]]
3989 set used $first
3991 if {$ch eq " " || $ch eq "\t"} break
3992 incr used
3993 if {$ch eq "'"} {
3994 set first [string first "'" $str $used]
3995 if {$first < 0} {
3996 error "unmatched single-quote"
3998 append ret [string range $str $used [expr {$first - 1}]]
3999 set used $first
4000 continue
4002 if {$ch eq "\\"} {
4003 if {$used >= [string length $str]} {
4004 error "trailing backslash"
4006 append ret [string index $str $used]
4007 continue
4009 # here ch == "\""
4010 while {1} {
4011 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4012 error "unmatched double-quote"
4014 set first [lindex $first 0]
4015 set ch [string index $str $first]
4016 if {$first > $used} {
4017 append ret [string range $str $used [expr {$first - 1}]]
4018 set used $first
4020 if {$ch eq "\""} break
4021 incr used
4022 append ret [string index $str $used]
4023 incr used
4026 return [list $used $ret]
4029 proc shellsplit {str} {
4030 set l {}
4031 while {1} {
4032 set str [string trimleft $str]
4033 if {$str eq {}} break
4034 set dq [shelldequote $str]
4035 set n [lindex $dq 0]
4036 set word [lindex $dq 1]
4037 set str [string range $str $n end]
4038 lappend l $word
4040 return $l
4043 proc set_window_title {} {
4044 global appname curview viewname vrevs
4045 set rev [mc "All files"]
4046 if {$curview ne 0} {
4047 if {$viewname($curview) eq [mc "Command line"]} {
4048 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4049 } else {
4050 set rev $viewname($curview)
4053 wm title . "[reponame]: $rev - $appname"
4056 # Code to implement multiple views
4058 proc newview {ishighlight} {
4059 global nextviewnum newviewname newishighlight
4060 global revtreeargs viewargscmd newviewopts curview
4062 set newishighlight $ishighlight
4063 set top .gitkview
4064 if {[winfo exists $top]} {
4065 raise $top
4066 return
4068 decode_view_opts $nextviewnum $revtreeargs
4069 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4070 set newviewopts($nextviewnum,perm) 0
4071 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4072 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4075 set known_view_options {
4076 {perm b . {} {mc "Remember this view"}}
4077 {reflabel l + {} {mc "References (space separated list):"}}
4078 {refs t15 .. {} {mc "Branches & tags:"}}
4079 {allrefs b *. "--all" {mc "All refs"}}
4080 {branches b . "--branches" {mc "All (local) branches"}}
4081 {tags b . "--tags" {mc "All tags"}}
4082 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4083 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4084 {author t15 .. "--author=*" {mc "Author:"}}
4085 {committer t15 . "--committer=*" {mc "Committer:"}}
4086 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4087 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4088 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4089 {changes_l l + {} {mc "Changes to Files:"}}
4090 {pickaxe_s r0 . {} {mc "Fixed String"}}
4091 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4092 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4093 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4094 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4095 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4096 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4097 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4098 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4099 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4100 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4101 {lright b . "--left-right" {mc "Mark branch sides"}}
4102 {first b . "--first-parent" {mc "Limit to first parent"}}
4103 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4104 {args t50 *. {} {mc "Additional arguments to git log:"}}
4105 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4106 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4109 # Convert $newviewopts($n, ...) into args for git log.
4110 proc encode_view_opts {n} {
4111 global known_view_options newviewopts
4113 set rargs [list]
4114 foreach opt $known_view_options {
4115 set patterns [lindex $opt 3]
4116 if {$patterns eq {}} continue
4117 set pattern [lindex $patterns 0]
4119 if {[lindex $opt 1] eq "b"} {
4120 set val $newviewopts($n,[lindex $opt 0])
4121 if {$val} {
4122 lappend rargs $pattern
4124 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4125 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4126 set val $newviewopts($n,$button_id)
4127 if {$val eq $value} {
4128 lappend rargs $pattern
4130 } else {
4131 set val $newviewopts($n,[lindex $opt 0])
4132 set val [string trim $val]
4133 if {$val ne {}} {
4134 set pfix [string range $pattern 0 end-1]
4135 lappend rargs $pfix$val
4139 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4140 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4143 # Fill $newviewopts($n, ...) based on args for git log.
4144 proc decode_view_opts {n view_args} {
4145 global known_view_options newviewopts
4147 foreach opt $known_view_options {
4148 set id [lindex $opt 0]
4149 if {[lindex $opt 1] eq "b"} {
4150 # Checkboxes
4151 set val 0
4152 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4153 # Radiobuttons
4154 regexp {^(.*_)} $id uselessvar id
4155 set val 0
4156 } else {
4157 # Text fields
4158 set val {}
4160 set newviewopts($n,$id) $val
4162 set oargs [list]
4163 set refargs [list]
4164 foreach arg $view_args {
4165 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4166 && ![info exists found(limit)]} {
4167 set newviewopts($n,limit) $cnt
4168 set found(limit) 1
4169 continue
4171 catch { unset val }
4172 foreach opt $known_view_options {
4173 set id [lindex $opt 0]
4174 if {[info exists found($id)]} continue
4175 foreach pattern [lindex $opt 3] {
4176 if {![string match $pattern $arg]} continue
4177 if {[lindex $opt 1] eq "b"} {
4178 # Check buttons
4179 set val 1
4180 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4181 # Radio buttons
4182 regexp {^(.*_)} $id uselessvar id
4183 set val $num
4184 } else {
4185 # Text input fields
4186 set size [string length $pattern]
4187 set val [string range $arg [expr {$size-1}] end]
4189 set newviewopts($n,$id) $val
4190 set found($id) 1
4191 break
4193 if {[info exists val]} break
4195 if {[info exists val]} continue
4196 if {[regexp {^-} $arg]} {
4197 lappend oargs $arg
4198 } else {
4199 lappend refargs $arg
4202 set newviewopts($n,refs) [shellarglist $refargs]
4203 set newviewopts($n,args) [shellarglist $oargs]
4206 proc edit_or_newview {} {
4207 global curview
4209 if {$curview > 0} {
4210 editview
4211 } else {
4212 newview 0
4216 proc editview {} {
4217 global curview
4218 global viewname viewperm newviewname newviewopts
4219 global viewargs viewargscmd
4221 set top .gitkvedit-$curview
4222 if {[winfo exists $top]} {
4223 raise $top
4224 return
4226 decode_view_opts $curview $viewargs($curview)
4227 set newviewname($curview) $viewname($curview)
4228 set newviewopts($curview,perm) $viewperm($curview)
4229 set newviewopts($curview,cmd) $viewargscmd($curview)
4230 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4233 proc vieweditor {top n title} {
4234 global newviewname newviewopts viewfiles bgcolor
4235 global known_view_options NS
4237 ttk_toplevel $top
4238 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4239 make_transient $top .
4241 # View name
4242 ${NS}::frame $top.nfr
4243 ${NS}::label $top.nl -text [mc "View Name"]
4244 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4245 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4246 pack $top.nl -in $top.nfr -side left -padx {0 5}
4247 pack $top.name -in $top.nfr -side left -padx {0 25}
4249 # View options
4250 set cframe $top.nfr
4251 set cexpand 0
4252 set cnt 0
4253 foreach opt $known_view_options {
4254 set id [lindex $opt 0]
4255 set type [lindex $opt 1]
4256 set flags [lindex $opt 2]
4257 set title [eval [lindex $opt 4]]
4258 set lxpad 0
4260 if {$flags eq "+" || $flags eq "*"} {
4261 set cframe $top.fr$cnt
4262 incr cnt
4263 ${NS}::frame $cframe
4264 pack $cframe -in $top -fill x -pady 3 -padx 3
4265 set cexpand [expr {$flags eq "*"}]
4266 } elseif {$flags eq ".." || $flags eq "*."} {
4267 set cframe $top.fr$cnt
4268 incr cnt
4269 ${NS}::frame $cframe
4270 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4271 set cexpand [expr {$flags eq "*."}]
4272 } else {
4273 set lxpad 5
4276 if {$type eq "l"} {
4277 ${NS}::label $cframe.l_$id -text $title
4278 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4279 } elseif {$type eq "b"} {
4280 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4281 pack $cframe.c_$id -in $cframe -side left \
4282 -padx [list $lxpad 0] -expand $cexpand -anchor w
4283 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4284 regexp {^(.*_)} $id uselessvar button_id
4285 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4286 pack $cframe.c_$id -in $cframe -side left \
4287 -padx [list $lxpad 0] -expand $cexpand -anchor w
4288 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4289 ${NS}::label $cframe.l_$id -text $title
4290 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4291 -textvariable newviewopts($n,$id)
4292 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4293 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4294 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4295 ${NS}::label $cframe.l_$id -text $title
4296 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4297 -textvariable newviewopts($n,$id)
4298 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4299 pack $cframe.e_$id -in $cframe -side top -fill x
4300 } elseif {$type eq "path"} {
4301 ${NS}::label $top.l -text $title
4302 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4303 text $top.t -width 40 -height 5 -background $bgcolor
4304 if {[info exists viewfiles($n)]} {
4305 foreach f $viewfiles($n) {
4306 $top.t insert end $f
4307 $top.t insert end "\n"
4309 $top.t delete {end - 1c} end
4310 $top.t mark set insert 0.0
4312 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4316 ${NS}::frame $top.buts
4317 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4318 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4319 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4320 bind $top <Control-Return> [list newviewok $top $n]
4321 bind $top <F5> [list newviewok $top $n 1]
4322 bind $top <Escape> [list destroy $top]
4323 grid $top.buts.ok $top.buts.apply $top.buts.can
4324 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4325 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4326 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4327 pack $top.buts -in $top -side top -fill x
4328 focus $top.t
4331 proc doviewmenu {m first cmd op argv} {
4332 set nmenu [$m index end]
4333 for {set i $first} {$i <= $nmenu} {incr i} {
4334 if {[$m entrycget $i -command] eq $cmd} {
4335 eval $m $op $i $argv
4336 break
4341 proc allviewmenus {n op args} {
4342 # global viewhlmenu
4344 doviewmenu .bar.view 5 [list showview $n] $op $args
4345 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4348 proc newviewok {top n {apply 0}} {
4349 global nextviewnum newviewperm newviewname newishighlight
4350 global viewname viewfiles viewperm viewchanged selectedview curview
4351 global viewargs viewargscmd newviewopts viewhlmenu
4353 if {[catch {
4354 set newargs [encode_view_opts $n]
4355 } err]} {
4356 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4357 return
4359 set files {}
4360 foreach f [split [$top.t get 0.0 end] "\n"] {
4361 set ft [string trim $f]
4362 if {$ft ne {}} {
4363 lappend files $ft
4366 if {![info exists viewfiles($n)]} {
4367 # creating a new view
4368 incr nextviewnum
4369 set viewname($n) $newviewname($n)
4370 set viewperm($n) $newviewopts($n,perm)
4371 set viewchanged($n) 1
4372 set viewfiles($n) $files
4373 set viewargs($n) $newargs
4374 set viewargscmd($n) $newviewopts($n,cmd)
4375 addviewmenu $n
4376 if {!$newishighlight} {
4377 run showview $n
4378 } else {
4379 run addvhighlight $n
4381 } else {
4382 # editing an existing view
4383 set viewperm($n) $newviewopts($n,perm)
4384 set viewchanged($n) 1
4385 if {$newviewname($n) ne $viewname($n)} {
4386 set viewname($n) $newviewname($n)
4387 doviewmenu .bar.view 5 [list showview $n] \
4388 entryconf [list -label $viewname($n)]
4389 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4390 # entryconf [list -label $viewname($n) -value $viewname($n)]
4392 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4393 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4394 set viewfiles($n) $files
4395 set viewargs($n) $newargs
4396 set viewargscmd($n) $newviewopts($n,cmd)
4397 if {$curview == $n} {
4398 run reloadcommits
4402 if {$apply} return
4403 catch {destroy $top}
4406 proc delview {} {
4407 global curview viewperm hlview selectedhlview viewchanged
4409 if {$curview == 0} return
4410 if {[info exists hlview] && $hlview == $curview} {
4411 set selectedhlview [mc "None"]
4412 unset hlview
4414 allviewmenus $curview delete
4415 set viewperm($curview) 0
4416 set viewchanged($curview) 1
4417 showview 0
4420 proc addviewmenu {n} {
4421 global viewname viewhlmenu
4423 .bar.view add radiobutton -label $viewname($n) \
4424 -command [list showview $n] -variable selectedview -value $n
4425 #$viewhlmenu add radiobutton -label $viewname($n) \
4426 # -command [list addvhighlight $n] -variable selectedhlview
4429 proc showview {n} {
4430 global curview cached_commitrow ordertok
4431 global displayorder parentlist rowidlist rowisopt rowfinal
4432 global colormap rowtextx nextcolor canvxmax
4433 global numcommits viewcomplete
4434 global selectedline currentid canv canvy0
4435 global treediffs
4436 global pending_select mainheadid
4437 global commitidx
4438 global selectedview
4439 global hlview selectedhlview commitinterest
4441 if {$n == $curview} return
4442 set selid {}
4443 set ymax [lindex [$canv cget -scrollregion] 3]
4444 set span [$canv yview]
4445 set ytop [expr {[lindex $span 0] * $ymax}]
4446 set ybot [expr {[lindex $span 1] * $ymax}]
4447 set yscreen [expr {($ybot - $ytop) / 2}]
4448 if {$selectedline ne {}} {
4449 set selid $currentid
4450 set y [yc $selectedline]
4451 if {$ytop < $y && $y < $ybot} {
4452 set yscreen [expr {$y - $ytop}]
4454 } elseif {[info exists pending_select]} {
4455 set selid $pending_select
4456 unset pending_select
4458 unselectline
4459 normalline
4460 unset -nocomplain treediffs
4461 clear_display
4462 if {[info exists hlview] && $hlview == $n} {
4463 unset hlview
4464 set selectedhlview [mc "None"]
4466 unset -nocomplain commitinterest
4467 unset -nocomplain cached_commitrow
4468 unset -nocomplain ordertok
4470 set curview $n
4471 set selectedview $n
4472 .bar.view entryconf [mca "&Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4473 .bar.view entryconf [mca "&Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4475 run refill_reflist
4476 if {![info exists viewcomplete($n)]} {
4477 getcommits $selid
4478 return
4481 set displayorder {}
4482 set parentlist {}
4483 set rowidlist {}
4484 set rowisopt {}
4485 set rowfinal {}
4486 set numcommits $commitidx($n)
4488 unset -nocomplain colormap
4489 unset -nocomplain rowtextx
4490 set nextcolor 0
4491 set canvxmax [$canv cget -width]
4492 set curview $n
4493 set row 0
4494 setcanvscroll
4495 set yf 0
4496 set row {}
4497 if {$selid ne {} && [commitinview $selid $n]} {
4498 set row [rowofcommit $selid]
4499 # try to get the selected row in the same position on the screen
4500 set ymax [lindex [$canv cget -scrollregion] 3]
4501 set ytop [expr {[yc $row] - $yscreen}]
4502 if {$ytop < 0} {
4503 set ytop 0
4505 set yf [expr {$ytop * 1.0 / $ymax}]
4507 allcanvs yview moveto $yf
4508 drawvisible
4509 if {$row ne {}} {
4510 selectline $row 0
4511 } elseif {!$viewcomplete($n)} {
4512 reset_pending_select $selid
4513 } else {
4514 reset_pending_select {}
4516 if {[commitinview $pending_select $curview]} {
4517 selectline [rowofcommit $pending_select] 1
4518 } else {
4519 set row [first_real_row]
4520 if {$row < $numcommits} {
4521 selectline $row 0
4525 if {!$viewcomplete($n)} {
4526 if {$numcommits == 0} {
4527 show_status [mc "Reading commits..."]
4529 } elseif {$numcommits == 0} {
4530 show_status [mc "No commits selected"]
4532 set_window_title
4535 # Stuff relating to the highlighting facility
4537 proc ishighlighted {id} {
4538 global vhighlights fhighlights nhighlights rhighlights
4540 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4541 return $nhighlights($id)
4543 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4544 return $vhighlights($id)
4546 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4547 return $fhighlights($id)
4549 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4550 return $rhighlights($id)
4552 return 0
4555 proc bolden {id font} {
4556 global canv linehtag currentid boldids need_redisplay markedid
4558 # need_redisplay = 1 means the display is stale and about to be redrawn
4559 if {$need_redisplay} return
4560 lappend boldids $id
4561 $canv itemconf $linehtag($id) -font $font
4562 if {[info exists currentid] && $id eq $currentid} {
4563 $canv delete secsel
4564 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4565 -outline {{}} -tags secsel \
4566 -fill [$canv cget -selectbackground]]
4567 $canv lower $t
4569 if {[info exists markedid] && $id eq $markedid} {
4570 make_idmark $id
4574 proc bolden_name {id font} {
4575 global canv2 linentag currentid boldnameids need_redisplay
4577 if {$need_redisplay} return
4578 lappend boldnameids $id
4579 $canv2 itemconf $linentag($id) -font $font
4580 if {[info exists currentid] && $id eq $currentid} {
4581 $canv2 delete secsel
4582 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4583 -outline {{}} -tags secsel \
4584 -fill [$canv2 cget -selectbackground]]
4585 $canv2 lower $t
4589 proc unbolden {} {
4590 global boldids
4592 set stillbold {}
4593 foreach id $boldids {
4594 if {![ishighlighted $id]} {
4595 bolden $id mainfont
4596 } else {
4597 lappend stillbold $id
4600 set boldids $stillbold
4603 proc addvhighlight {n} {
4604 global hlview viewcomplete curview vhl_done commitidx
4606 if {[info exists hlview]} {
4607 delvhighlight
4609 set hlview $n
4610 if {$n != $curview && ![info exists viewcomplete($n)]} {
4611 start_rev_list $n
4613 set vhl_done $commitidx($hlview)
4614 if {$vhl_done > 0} {
4615 drawvisible
4619 proc delvhighlight {} {
4620 global hlview vhighlights
4622 if {![info exists hlview]} return
4623 unset hlview
4624 unset -nocomplain vhighlights
4625 unbolden
4628 proc vhighlightmore {} {
4629 global hlview vhl_done commitidx vhighlights curview
4631 set max $commitidx($hlview)
4632 set vr [visiblerows]
4633 set r0 [lindex $vr 0]
4634 set r1 [lindex $vr 1]
4635 for {set i $vhl_done} {$i < $max} {incr i} {
4636 set id [commitonrow $i $hlview]
4637 if {[commitinview $id $curview]} {
4638 set row [rowofcommit $id]
4639 if {$r0 <= $row && $row <= $r1} {
4640 if {![highlighted $row]} {
4641 bolden $id mainfontbold
4643 set vhighlights($id) 1
4647 set vhl_done $max
4648 return 0
4651 proc askvhighlight {row id} {
4652 global hlview vhighlights iddrawn
4654 if {[commitinview $id $hlview]} {
4655 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4656 bolden $id mainfontbold
4658 set vhighlights($id) 1
4659 } else {
4660 set vhighlights($id) 0
4664 proc hfiles_change {} {
4665 global highlight_files filehighlight fhighlights fh_serial
4666 global highlight_paths
4668 if {[info exists filehighlight]} {
4669 # delete previous highlights
4670 catch {close $filehighlight}
4671 unset filehighlight
4672 unset -nocomplain fhighlights
4673 unbolden
4674 unhighlight_filelist
4676 set highlight_paths {}
4677 after cancel do_file_hl $fh_serial
4678 incr fh_serial
4679 if {$highlight_files ne {}} {
4680 after 300 do_file_hl $fh_serial
4684 proc gdttype_change {name ix op} {
4685 global gdttype highlight_files findstring findpattern
4687 stopfinding
4688 if {$findstring ne {}} {
4689 if {$gdttype eq [mc "containing:"]} {
4690 if {$highlight_files ne {}} {
4691 set highlight_files {}
4692 hfiles_change
4694 findcom_change
4695 } else {
4696 if {$findpattern ne {}} {
4697 set findpattern {}
4698 findcom_change
4700 set highlight_files $findstring
4701 hfiles_change
4703 drawvisible
4705 # enable/disable findtype/findloc menus too
4708 proc find_change {name ix op} {
4709 global gdttype findstring highlight_files
4711 stopfinding
4712 if {$gdttype eq [mc "containing:"]} {
4713 findcom_change
4714 } else {
4715 if {$highlight_files ne $findstring} {
4716 set highlight_files $findstring
4717 hfiles_change
4720 drawvisible
4723 proc findcom_change args {
4724 global nhighlights boldnameids
4725 global findpattern findtype findstring gdttype
4727 stopfinding
4728 # delete previous highlights, if any
4729 foreach id $boldnameids {
4730 bolden_name $id mainfont
4732 set boldnameids {}
4733 unset -nocomplain nhighlights
4734 unbolden
4735 unmarkmatches
4736 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4737 set findpattern {}
4738 } elseif {$findtype eq [mc "Regexp"]} {
4739 set findpattern $findstring
4740 } else {
4741 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4742 $findstring]
4743 set findpattern "*$e*"
4747 proc makepatterns {l} {
4748 set ret {}
4749 foreach e $l {
4750 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4751 if {[string index $ee end] eq "/"} {
4752 lappend ret "$ee*"
4753 } else {
4754 lappend ret $ee
4755 lappend ret "$ee/*"
4758 return $ret
4761 proc do_file_hl {serial} {
4762 global highlight_files filehighlight highlight_paths gdttype fhl_list
4763 global cdup findtype
4765 if {$gdttype eq [mc "touching paths:"]} {
4766 # If "exact" match then convert backslashes to forward slashes.
4767 # Most useful to support Windows-flavoured file paths.
4768 if {$findtype eq [mc "Exact"]} {
4769 set highlight_files [string map {"\\" "/"} $highlight_files]
4771 if {[catch {set paths [shellsplit $highlight_files]}]} return
4772 set highlight_paths [makepatterns $paths]
4773 highlight_filelist
4774 set relative_paths {}
4775 foreach path $paths {
4776 lappend relative_paths [file join $cdup $path]
4778 set gdtargs [concat -- $relative_paths]
4779 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4780 set gdtargs [list "-S$highlight_files"]
4781 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4782 set gdtargs [list "-G$highlight_files"]
4783 } else {
4784 # must be "containing:", i.e. we're searching commit info
4785 return
4787 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4788 set filehighlight [open $cmd r+]
4789 fconfigure $filehighlight -blocking 0
4790 filerun $filehighlight readfhighlight
4791 set fhl_list {}
4792 drawvisible
4793 flushhighlights
4796 proc flushhighlights {} {
4797 global filehighlight fhl_list
4799 if {[info exists filehighlight]} {
4800 lappend fhl_list {}
4801 puts $filehighlight ""
4802 flush $filehighlight
4806 proc askfilehighlight {row id} {
4807 global filehighlight fhighlights fhl_list
4809 lappend fhl_list $id
4810 set fhighlights($id) -1
4811 puts $filehighlight $id
4814 proc readfhighlight {} {
4815 global filehighlight fhighlights curview iddrawn
4816 global fhl_list find_dirn
4818 if {![info exists filehighlight]} {
4819 return 0
4821 set nr 0
4822 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4823 set line [string trim $line]
4824 set i [lsearch -exact $fhl_list $line]
4825 if {$i < 0} continue
4826 for {set j 0} {$j < $i} {incr j} {
4827 set id [lindex $fhl_list $j]
4828 set fhighlights($id) 0
4830 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4831 if {$line eq {}} continue
4832 if {![commitinview $line $curview]} continue
4833 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4834 bolden $line mainfontbold
4836 set fhighlights($line) 1
4838 if {[eof $filehighlight]} {
4839 # strange...
4840 puts "oops, git diff-tree died"
4841 catch {close $filehighlight}
4842 unset filehighlight
4843 return 0
4845 if {[info exists find_dirn]} {
4846 run findmore
4848 return 1
4851 proc doesmatch {f} {
4852 global findtype findpattern
4854 if {$findtype eq [mc "Regexp"]} {
4855 return [regexp $findpattern $f]
4856 } elseif {$findtype eq [mc "IgnCase"]} {
4857 return [string match -nocase $findpattern $f]
4858 } else {
4859 return [string match $findpattern $f]
4863 proc askfindhighlight {row id} {
4864 global nhighlights commitinfo iddrawn
4865 global findloc
4866 global markingmatches
4868 if {![info exists commitinfo($id)]} {
4869 getcommit $id
4871 set info $commitinfo($id)
4872 set isbold 0
4873 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4874 foreach f $info ty $fldtypes {
4875 if {$ty eq ""} continue
4876 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4877 [doesmatch $f]} {
4878 if {$ty eq [mc "Author"]} {
4879 set isbold 2
4880 break
4882 set isbold 1
4885 if {$isbold && [info exists iddrawn($id)]} {
4886 if {![ishighlighted $id]} {
4887 bolden $id mainfontbold
4888 if {$isbold > 1} {
4889 bolden_name $id mainfontbold
4892 if {$markingmatches} {
4893 markrowmatches $row $id
4896 set nhighlights($id) $isbold
4899 proc markrowmatches {row id} {
4900 global canv canv2 linehtag linentag commitinfo findloc
4902 set headline [lindex $commitinfo($id) 0]
4903 set author [lindex $commitinfo($id) 1]
4904 $canv delete match$row
4905 $canv2 delete match$row
4906 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4907 set m [findmatches $headline]
4908 if {$m ne {}} {
4909 markmatches $canv $row $headline $linehtag($id) $m \
4910 [$canv itemcget $linehtag($id) -font] $row
4913 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4914 set m [findmatches $author]
4915 if {$m ne {}} {
4916 markmatches $canv2 $row $author $linentag($id) $m \
4917 [$canv2 itemcget $linentag($id) -font] $row
4922 proc vrel_change {name ix op} {
4923 global highlight_related
4925 rhighlight_none
4926 if {$highlight_related ne [mc "None"]} {
4927 run drawvisible
4931 # prepare for testing whether commits are descendents or ancestors of a
4932 proc rhighlight_sel {a} {
4933 global descendent desc_todo ancestor anc_todo
4934 global highlight_related
4936 unset -nocomplain descendent
4937 set desc_todo [list $a]
4938 unset -nocomplain ancestor
4939 set anc_todo [list $a]
4940 if {$highlight_related ne [mc "None"]} {
4941 rhighlight_none
4942 run drawvisible
4946 proc rhighlight_none {} {
4947 global rhighlights
4949 unset -nocomplain rhighlights
4950 unbolden
4953 proc is_descendent {a} {
4954 global curview children descendent desc_todo
4956 set v $curview
4957 set la [rowofcommit $a]
4958 set todo $desc_todo
4959 set leftover {}
4960 set done 0
4961 for {set i 0} {$i < [llength $todo]} {incr i} {
4962 set do [lindex $todo $i]
4963 if {[rowofcommit $do] < $la} {
4964 lappend leftover $do
4965 continue
4967 foreach nk $children($v,$do) {
4968 if {![info exists descendent($nk)]} {
4969 set descendent($nk) 1
4970 lappend todo $nk
4971 if {$nk eq $a} {
4972 set done 1
4976 if {$done} {
4977 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4978 return
4981 set descendent($a) 0
4982 set desc_todo $leftover
4985 proc is_ancestor {a} {
4986 global curview parents ancestor anc_todo
4988 set v $curview
4989 set la [rowofcommit $a]
4990 set todo $anc_todo
4991 set leftover {}
4992 set done 0
4993 for {set i 0} {$i < [llength $todo]} {incr i} {
4994 set do [lindex $todo $i]
4995 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4996 lappend leftover $do
4997 continue
4999 foreach np $parents($v,$do) {
5000 if {![info exists ancestor($np)]} {
5001 set ancestor($np) 1
5002 lappend todo $np
5003 if {$np eq $a} {
5004 set done 1
5008 if {$done} {
5009 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5010 return
5013 set ancestor($a) 0
5014 set anc_todo $leftover
5017 proc askrelhighlight {row id} {
5018 global descendent highlight_related iddrawn rhighlights
5019 global selectedline ancestor
5021 if {$selectedline eq {}} return
5022 set isbold 0
5023 if {$highlight_related eq [mc "Descendant"] ||
5024 $highlight_related eq [mc "Not descendant"]} {
5025 if {![info exists descendent($id)]} {
5026 is_descendent $id
5028 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5029 set isbold 1
5031 } elseif {$highlight_related eq [mc "Ancestor"] ||
5032 $highlight_related eq [mc "Not ancestor"]} {
5033 if {![info exists ancestor($id)]} {
5034 is_ancestor $id
5036 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5037 set isbold 1
5040 if {[info exists iddrawn($id)]} {
5041 if {$isbold && ![ishighlighted $id]} {
5042 bolden $id mainfontbold
5045 set rhighlights($id) $isbold
5048 # Graph layout functions
5050 proc shortids {ids} {
5051 set res {}
5052 foreach id $ids {
5053 if {[llength $id] > 1} {
5054 lappend res [shortids $id]
5055 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5056 lappend res [string range $id 0 7]
5057 } else {
5058 lappend res $id
5061 return $res
5064 proc ntimes {n o} {
5065 set ret {}
5066 set o [list $o]
5067 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5068 if {($n & $mask) != 0} {
5069 set ret [concat $ret $o]
5071 set o [concat $o $o]
5073 return $ret
5076 proc ordertoken {id} {
5077 global ordertok curview varcid varcstart varctok curview parents children
5078 global nullid nullid2
5080 if {[info exists ordertok($id)]} {
5081 return $ordertok($id)
5083 set origid $id
5084 set todo {}
5085 while {1} {
5086 if {[info exists varcid($curview,$id)]} {
5087 set a $varcid($curview,$id)
5088 set p [lindex $varcstart($curview) $a]
5089 } else {
5090 set p [lindex $children($curview,$id) 0]
5092 if {[info exists ordertok($p)]} {
5093 set tok $ordertok($p)
5094 break
5096 set id [first_real_child $curview,$p]
5097 if {$id eq {}} {
5098 # it's a root
5099 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5100 break
5102 if {[llength $parents($curview,$id)] == 1} {
5103 lappend todo [list $p {}]
5104 } else {
5105 set j [lsearch -exact $parents($curview,$id) $p]
5106 if {$j < 0} {
5107 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5109 lappend todo [list $p [strrep $j]]
5112 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5113 set p [lindex $todo $i 0]
5114 append tok [lindex $todo $i 1]
5115 set ordertok($p) $tok
5117 set ordertok($origid) $tok
5118 return $tok
5121 # Work out where id should go in idlist so that order-token
5122 # values increase from left to right
5123 proc idcol {idlist id {i 0}} {
5124 set t [ordertoken $id]
5125 if {$i < 0} {
5126 set i 0
5128 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5129 if {$i > [llength $idlist]} {
5130 set i [llength $idlist]
5132 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5133 incr i
5134 } else {
5135 if {$t > [ordertoken [lindex $idlist $i]]} {
5136 while {[incr i] < [llength $idlist] &&
5137 $t >= [ordertoken [lindex $idlist $i]]} {}
5140 return $i
5143 proc initlayout {} {
5144 global rowidlist rowisopt rowfinal displayorder parentlist
5145 global numcommits canvxmax canv
5146 global nextcolor
5147 global colormap rowtextx
5149 set numcommits 0
5150 set displayorder {}
5151 set parentlist {}
5152 set nextcolor 0
5153 set rowidlist {}
5154 set rowisopt {}
5155 set rowfinal {}
5156 set canvxmax [$canv cget -width]
5157 unset -nocomplain colormap
5158 unset -nocomplain rowtextx
5159 setcanvscroll
5162 proc setcanvscroll {} {
5163 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5164 global lastscrollset lastscrollrows
5166 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5167 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5168 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5169 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5170 set lastscrollset [clock clicks -milliseconds]
5171 set lastscrollrows $numcommits
5174 proc visiblerows {} {
5175 global canv numcommits linespc
5177 set ymax [lindex [$canv cget -scrollregion] 3]
5178 if {$ymax eq {} || $ymax == 0} return
5179 set f [$canv yview]
5180 set y0 [expr {int([lindex $f 0] * $ymax)}]
5181 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5182 if {$r0 < 0} {
5183 set r0 0
5185 set y1 [expr {int([lindex $f 1] * $ymax)}]
5186 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5187 if {$r1 >= $numcommits} {
5188 set r1 [expr {$numcommits - 1}]
5190 return [list $r0 $r1]
5193 proc layoutmore {} {
5194 global commitidx viewcomplete curview
5195 global numcommits pending_select curview
5196 global lastscrollset lastscrollrows
5198 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5199 [clock clicks -milliseconds] - $lastscrollset > 500} {
5200 setcanvscroll
5202 if {[info exists pending_select] &&
5203 [commitinview $pending_select $curview]} {
5204 update
5205 selectline [rowofcommit $pending_select] 1
5207 drawvisible
5210 # With path limiting, we mightn't get the actual HEAD commit,
5211 # so ask git rev-list what is the first ancestor of HEAD that
5212 # touches a file in the path limit.
5213 proc get_viewmainhead {view} {
5214 global viewmainheadid vfilelimit viewinstances mainheadid
5216 catch {
5217 set rfd [open [concat | git rev-list -1 $mainheadid \
5218 -- $vfilelimit($view)] r]
5219 set j [reg_instance $rfd]
5220 lappend viewinstances($view) $j
5221 fconfigure $rfd -blocking 0
5222 filerun $rfd [list getviewhead $rfd $j $view]
5223 set viewmainheadid($curview) {}
5227 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5228 proc getviewhead {fd inst view} {
5229 global viewmainheadid commfd curview viewinstances showlocalchanges
5231 set id {}
5232 if {[gets $fd line] < 0} {
5233 if {![eof $fd]} {
5234 return 1
5236 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5237 set id $line
5239 set viewmainheadid($view) $id
5240 close $fd
5241 unset commfd($inst)
5242 set i [lsearch -exact $viewinstances($view) $inst]
5243 if {$i >= 0} {
5244 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5246 if {$showlocalchanges && $id ne {} && $view == $curview} {
5247 doshowlocalchanges
5249 return 0
5252 proc doshowlocalchanges {} {
5253 global curview viewmainheadid
5255 if {$viewmainheadid($curview) eq {}} return
5256 if {[commitinview $viewmainheadid($curview) $curview]} {
5257 dodiffindex
5258 } else {
5259 interestedin $viewmainheadid($curview) dodiffindex
5263 proc dohidelocalchanges {} {
5264 global nullid nullid2 lserial curview
5266 if {[commitinview $nullid $curview]} {
5267 removefakerow $nullid
5269 if {[commitinview $nullid2 $curview]} {
5270 removefakerow $nullid2
5272 incr lserial
5275 # spawn off a process to do git diff-index --cached HEAD
5276 proc dodiffindex {} {
5277 global lserial showlocalchanges vfilelimit curview
5278 global hasworktree git_version
5280 if {!$showlocalchanges || !$hasworktree} return
5281 incr lserial
5282 if {[package vcompare $git_version "1.7.2"] >= 0} {
5283 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5284 } else {
5285 set cmd "|git diff-index --cached HEAD"
5287 if {$vfilelimit($curview) ne {}} {
5288 set cmd [concat $cmd -- $vfilelimit($curview)]
5290 set fd [open $cmd r]
5291 fconfigure $fd -blocking 0
5292 set i [reg_instance $fd]
5293 filerun $fd [list readdiffindex $fd $lserial $i]
5296 proc readdiffindex {fd serial inst} {
5297 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5298 global vfilelimit
5300 set isdiff 1
5301 if {[gets $fd line] < 0} {
5302 if {![eof $fd]} {
5303 return 1
5305 set isdiff 0
5307 # we only need to see one line and we don't really care what it says...
5308 stop_instance $inst
5310 if {$serial != $lserial} {
5311 return 0
5314 # now see if there are any local changes not checked in to the index
5315 set cmd "|git diff-files"
5316 if {$vfilelimit($curview) ne {}} {
5317 set cmd [concat $cmd -- $vfilelimit($curview)]
5319 set fd [open $cmd r]
5320 fconfigure $fd -blocking 0
5321 set i [reg_instance $fd]
5322 filerun $fd [list readdifffiles $fd $serial $i]
5324 if {$isdiff && ![commitinview $nullid2 $curview]} {
5325 # add the line for the changes in the index to the graph
5326 set hl [mc "Local changes checked in to index but not committed"]
5327 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5328 set commitdata($nullid2) "\n $hl\n"
5329 if {[commitinview $nullid $curview]} {
5330 removefakerow $nullid
5332 insertfakerow $nullid2 $viewmainheadid($curview)
5333 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5334 if {[commitinview $nullid $curview]} {
5335 removefakerow $nullid
5337 removefakerow $nullid2
5339 return 0
5342 proc readdifffiles {fd serial inst} {
5343 global viewmainheadid nullid nullid2 curview
5344 global commitinfo commitdata lserial
5346 set isdiff 1
5347 if {[gets $fd line] < 0} {
5348 if {![eof $fd]} {
5349 return 1
5351 set isdiff 0
5353 # we only need to see one line and we don't really care what it says...
5354 stop_instance $inst
5356 if {$serial != $lserial} {
5357 return 0
5360 if {$isdiff && ![commitinview $nullid $curview]} {
5361 # add the line for the local diff to the graph
5362 set hl [mc "Local uncommitted changes, not checked in to index"]
5363 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5364 set commitdata($nullid) "\n $hl\n"
5365 if {[commitinview $nullid2 $curview]} {
5366 set p $nullid2
5367 } else {
5368 set p $viewmainheadid($curview)
5370 insertfakerow $nullid $p
5371 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5372 removefakerow $nullid
5374 return 0
5377 proc nextuse {id row} {
5378 global curview children
5380 if {[info exists children($curview,$id)]} {
5381 foreach kid $children($curview,$id) {
5382 if {![commitinview $kid $curview]} {
5383 return -1
5385 if {[rowofcommit $kid] > $row} {
5386 return [rowofcommit $kid]
5390 if {[commitinview $id $curview]} {
5391 return [rowofcommit $id]
5393 return -1
5396 proc prevuse {id row} {
5397 global curview children
5399 set ret -1
5400 if {[info exists children($curview,$id)]} {
5401 foreach kid $children($curview,$id) {
5402 if {![commitinview $kid $curview]} break
5403 if {[rowofcommit $kid] < $row} {
5404 set ret [rowofcommit $kid]
5408 return $ret
5411 proc make_idlist {row} {
5412 global displayorder parentlist uparrowlen downarrowlen mingaplen
5413 global commitidx curview children
5415 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5416 if {$r < 0} {
5417 set r 0
5419 set ra [expr {$row - $downarrowlen}]
5420 if {$ra < 0} {
5421 set ra 0
5423 set rb [expr {$row + $uparrowlen}]
5424 if {$rb > $commitidx($curview)} {
5425 set rb $commitidx($curview)
5427 make_disporder $r [expr {$rb + 1}]
5428 set ids {}
5429 for {} {$r < $ra} {incr r} {
5430 set nextid [lindex $displayorder [expr {$r + 1}]]
5431 foreach p [lindex $parentlist $r] {
5432 if {$p eq $nextid} continue
5433 set rn [nextuse $p $r]
5434 if {$rn >= $row &&
5435 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5436 lappend ids [list [ordertoken $p] $p]
5440 for {} {$r < $row} {incr r} {
5441 set nextid [lindex $displayorder [expr {$r + 1}]]
5442 foreach p [lindex $parentlist $r] {
5443 if {$p eq $nextid} continue
5444 set rn [nextuse $p $r]
5445 if {$rn < 0 || $rn >= $row} {
5446 lappend ids [list [ordertoken $p] $p]
5450 set id [lindex $displayorder $row]
5451 lappend ids [list [ordertoken $id] $id]
5452 while {$r < $rb} {
5453 foreach p [lindex $parentlist $r] {
5454 set firstkid [lindex $children($curview,$p) 0]
5455 if {[rowofcommit $firstkid] < $row} {
5456 lappend ids [list [ordertoken $p] $p]
5459 incr r
5460 set id [lindex $displayorder $r]
5461 if {$id ne {}} {
5462 set firstkid [lindex $children($curview,$id) 0]
5463 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5464 lappend ids [list [ordertoken $id] $id]
5468 set idlist {}
5469 foreach idx [lsort -unique $ids] {
5470 lappend idlist [lindex $idx 1]
5472 return $idlist
5475 proc rowsequal {a b} {
5476 while {[set i [lsearch -exact $a {}]] >= 0} {
5477 set a [lreplace $a $i $i]
5479 while {[set i [lsearch -exact $b {}]] >= 0} {
5480 set b [lreplace $b $i $i]
5482 return [expr {$a eq $b}]
5485 proc makeupline {id row rend col} {
5486 global rowidlist uparrowlen downarrowlen mingaplen
5488 for {set r $rend} {1} {set r $rstart} {
5489 set rstart [prevuse $id $r]
5490 if {$rstart < 0} return
5491 if {$rstart < $row} break
5493 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5494 set rstart [expr {$rend - $uparrowlen - 1}]
5496 for {set r $rstart} {[incr r] <= $row} {} {
5497 set idlist [lindex $rowidlist $r]
5498 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5499 set col [idcol $idlist $id $col]
5500 lset rowidlist $r [linsert $idlist $col $id]
5501 changedrow $r
5506 proc layoutrows {row endrow} {
5507 global rowidlist rowisopt rowfinal displayorder
5508 global uparrowlen downarrowlen maxwidth mingaplen
5509 global children parentlist
5510 global commitidx viewcomplete curview
5512 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5513 set idlist {}
5514 if {$row > 0} {
5515 set rm1 [expr {$row - 1}]
5516 foreach id [lindex $rowidlist $rm1] {
5517 if {$id ne {}} {
5518 lappend idlist $id
5521 set final [lindex $rowfinal $rm1]
5523 for {} {$row < $endrow} {incr row} {
5524 set rm1 [expr {$row - 1}]
5525 if {$rm1 < 0 || $idlist eq {}} {
5526 set idlist [make_idlist $row]
5527 set final 1
5528 } else {
5529 set id [lindex $displayorder $rm1]
5530 set col [lsearch -exact $idlist $id]
5531 set idlist [lreplace $idlist $col $col]
5532 foreach p [lindex $parentlist $rm1] {
5533 if {[lsearch -exact $idlist $p] < 0} {
5534 set col [idcol $idlist $p $col]
5535 set idlist [linsert $idlist $col $p]
5536 # if not the first child, we have to insert a line going up
5537 if {$id ne [lindex $children($curview,$p) 0]} {
5538 makeupline $p $rm1 $row $col
5542 set id [lindex $displayorder $row]
5543 if {$row > $downarrowlen} {
5544 set termrow [expr {$row - $downarrowlen - 1}]
5545 foreach p [lindex $parentlist $termrow] {
5546 set i [lsearch -exact $idlist $p]
5547 if {$i < 0} continue
5548 set nr [nextuse $p $termrow]
5549 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5550 set idlist [lreplace $idlist $i $i]
5554 set col [lsearch -exact $idlist $id]
5555 if {$col < 0} {
5556 set col [idcol $idlist $id]
5557 set idlist [linsert $idlist $col $id]
5558 if {$children($curview,$id) ne {}} {
5559 makeupline $id $rm1 $row $col
5562 set r [expr {$row + $uparrowlen - 1}]
5563 if {$r < $commitidx($curview)} {
5564 set x $col
5565 foreach p [lindex $parentlist $r] {
5566 if {[lsearch -exact $idlist $p] >= 0} continue
5567 set fk [lindex $children($curview,$p) 0]
5568 if {[rowofcommit $fk] < $row} {
5569 set x [idcol $idlist $p $x]
5570 set idlist [linsert $idlist $x $p]
5573 if {[incr r] < $commitidx($curview)} {
5574 set p [lindex $displayorder $r]
5575 if {[lsearch -exact $idlist $p] < 0} {
5576 set fk [lindex $children($curview,$p) 0]
5577 if {$fk ne {} && [rowofcommit $fk] < $row} {
5578 set x [idcol $idlist $p $x]
5579 set idlist [linsert $idlist $x $p]
5585 if {$final && !$viewcomplete($curview) &&
5586 $row + $uparrowlen + $mingaplen + $downarrowlen
5587 >= $commitidx($curview)} {
5588 set final 0
5590 set l [llength $rowidlist]
5591 if {$row == $l} {
5592 lappend rowidlist $idlist
5593 lappend rowisopt 0
5594 lappend rowfinal $final
5595 } elseif {$row < $l} {
5596 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5597 lset rowidlist $row $idlist
5598 changedrow $row
5600 lset rowfinal $row $final
5601 } else {
5602 set pad [ntimes [expr {$row - $l}] {}]
5603 set rowidlist [concat $rowidlist $pad]
5604 lappend rowidlist $idlist
5605 set rowfinal [concat $rowfinal $pad]
5606 lappend rowfinal $final
5607 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5610 return $row
5613 proc changedrow {row} {
5614 global displayorder iddrawn rowisopt need_redisplay
5616 set l [llength $rowisopt]
5617 if {$row < $l} {
5618 lset rowisopt $row 0
5619 if {$row + 1 < $l} {
5620 lset rowisopt [expr {$row + 1}] 0
5621 if {$row + 2 < $l} {
5622 lset rowisopt [expr {$row + 2}] 0
5626 set id [lindex $displayorder $row]
5627 if {[info exists iddrawn($id)]} {
5628 set need_redisplay 1
5632 proc insert_pad {row col npad} {
5633 global rowidlist
5635 set pad [ntimes $npad {}]
5636 set idlist [lindex $rowidlist $row]
5637 set bef [lrange $idlist 0 [expr {$col - 1}]]
5638 set aft [lrange $idlist $col end]
5639 set i [lsearch -exact $aft {}]
5640 if {$i > 0} {
5641 set aft [lreplace $aft $i $i]
5643 lset rowidlist $row [concat $bef $pad $aft]
5644 changedrow $row
5647 proc optimize_rows {row col endrow} {
5648 global rowidlist rowisopt displayorder curview children
5650 if {$row < 1} {
5651 set row 1
5653 for {} {$row < $endrow} {incr row; set col 0} {
5654 if {[lindex $rowisopt $row]} continue
5655 set haspad 0
5656 set y0 [expr {$row - 1}]
5657 set ym [expr {$row - 2}]
5658 set idlist [lindex $rowidlist $row]
5659 set previdlist [lindex $rowidlist $y0]
5660 if {$idlist eq {} || $previdlist eq {}} continue
5661 if {$ym >= 0} {
5662 set pprevidlist [lindex $rowidlist $ym]
5663 if {$pprevidlist eq {}} continue
5664 } else {
5665 set pprevidlist {}
5667 set x0 -1
5668 set xm -1
5669 for {} {$col < [llength $idlist]} {incr col} {
5670 set id [lindex $idlist $col]
5671 if {[lindex $previdlist $col] eq $id} continue
5672 if {$id eq {}} {
5673 set haspad 1
5674 continue
5676 set x0 [lsearch -exact $previdlist $id]
5677 if {$x0 < 0} continue
5678 set z [expr {$x0 - $col}]
5679 set isarrow 0
5680 set z0 {}
5681 if {$ym >= 0} {
5682 set xm [lsearch -exact $pprevidlist $id]
5683 if {$xm >= 0} {
5684 set z0 [expr {$xm - $x0}]
5687 if {$z0 eq {}} {
5688 # if row y0 is the first child of $id then it's not an arrow
5689 if {[lindex $children($curview,$id) 0] ne
5690 [lindex $displayorder $y0]} {
5691 set isarrow 1
5694 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5695 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5696 set isarrow 1
5698 # Looking at lines from this row to the previous row,
5699 # make them go straight up if they end in an arrow on
5700 # the previous row; otherwise make them go straight up
5701 # or at 45 degrees.
5702 if {$z < -1 || ($z < 0 && $isarrow)} {
5703 # Line currently goes left too much;
5704 # insert pads in the previous row, then optimize it
5705 set npad [expr {-1 - $z + $isarrow}]
5706 insert_pad $y0 $x0 $npad
5707 if {$y0 > 0} {
5708 optimize_rows $y0 $x0 $row
5710 set previdlist [lindex $rowidlist $y0]
5711 set x0 [lsearch -exact $previdlist $id]
5712 set z [expr {$x0 - $col}]
5713 if {$z0 ne {}} {
5714 set pprevidlist [lindex $rowidlist $ym]
5715 set xm [lsearch -exact $pprevidlist $id]
5716 set z0 [expr {$xm - $x0}]
5718 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5719 # Line currently goes right too much;
5720 # insert pads in this line
5721 set npad [expr {$z - 1 + $isarrow}]
5722 insert_pad $row $col $npad
5723 set idlist [lindex $rowidlist $row]
5724 incr col $npad
5725 set z [expr {$x0 - $col}]
5726 set haspad 1
5728 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5729 # this line links to its first child on row $row-2
5730 set id [lindex $displayorder $ym]
5731 set xc [lsearch -exact $pprevidlist $id]
5732 if {$xc >= 0} {
5733 set z0 [expr {$xc - $x0}]
5736 # avoid lines jigging left then immediately right
5737 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5738 insert_pad $y0 $x0 1
5739 incr x0
5740 optimize_rows $y0 $x0 $row
5741 set previdlist [lindex $rowidlist $y0]
5744 if {!$haspad} {
5745 # Find the first column that doesn't have a line going right
5746 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5747 set id [lindex $idlist $col]
5748 if {$id eq {}} break
5749 set x0 [lsearch -exact $previdlist $id]
5750 if {$x0 < 0} {
5751 # check if this is the link to the first child
5752 set kid [lindex $displayorder $y0]
5753 if {[lindex $children($curview,$id) 0] eq $kid} {
5754 # it is, work out offset to child
5755 set x0 [lsearch -exact $previdlist $kid]
5758 if {$x0 <= $col} break
5760 # Insert a pad at that column as long as it has a line and
5761 # isn't the last column
5762 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5763 set idlist [linsert $idlist $col {}]
5764 lset rowidlist $row $idlist
5765 changedrow $row
5771 proc xc {row col} {
5772 global canvx0 linespc
5773 return [expr {$canvx0 + $col * $linespc}]
5776 proc yc {row} {
5777 global canvy0 linespc
5778 return [expr {$canvy0 + $row * $linespc}]
5781 proc linewidth {id} {
5782 global thickerline lthickness
5784 set wid $lthickness
5785 if {[info exists thickerline] && $id eq $thickerline} {
5786 set wid [expr {2 * $lthickness}]
5788 return $wid
5791 proc rowranges {id} {
5792 global curview children uparrowlen downarrowlen
5793 global rowidlist
5795 set kids $children($curview,$id)
5796 if {$kids eq {}} {
5797 return {}
5799 set ret {}
5800 lappend kids $id
5801 foreach child $kids {
5802 if {![commitinview $child $curview]} break
5803 set row [rowofcommit $child]
5804 if {![info exists prev]} {
5805 lappend ret [expr {$row + 1}]
5806 } else {
5807 if {$row <= $prevrow} {
5808 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5810 # see if the line extends the whole way from prevrow to row
5811 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5812 [lsearch -exact [lindex $rowidlist \
5813 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5814 # it doesn't, see where it ends
5815 set r [expr {$prevrow + $downarrowlen}]
5816 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5817 while {[incr r -1] > $prevrow &&
5818 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5819 } else {
5820 while {[incr r] <= $row &&
5821 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5822 incr r -1
5824 lappend ret $r
5825 # see where it starts up again
5826 set r [expr {$row - $uparrowlen}]
5827 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5828 while {[incr r] < $row &&
5829 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5830 } else {
5831 while {[incr r -1] >= $prevrow &&
5832 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5833 incr r
5835 lappend ret $r
5838 if {$child eq $id} {
5839 lappend ret $row
5841 set prev $child
5842 set prevrow $row
5844 return $ret
5847 proc drawlineseg {id row endrow arrowlow} {
5848 global rowidlist displayorder iddrawn linesegs
5849 global canv colormap linespc curview maxlinelen parentlist
5851 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5852 set le [expr {$row + 1}]
5853 set arrowhigh 1
5854 while {1} {
5855 set c [lsearch -exact [lindex $rowidlist $le] $id]
5856 if {$c < 0} {
5857 incr le -1
5858 break
5860 lappend cols $c
5861 set x [lindex $displayorder $le]
5862 if {$x eq $id} {
5863 set arrowhigh 0
5864 break
5866 if {[info exists iddrawn($x)] || $le == $endrow} {
5867 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5868 if {$c >= 0} {
5869 lappend cols $c
5870 set arrowhigh 0
5872 break
5874 incr le
5876 if {$le <= $row} {
5877 return $row
5880 set lines {}
5881 set i 0
5882 set joinhigh 0
5883 if {[info exists linesegs($id)]} {
5884 set lines $linesegs($id)
5885 foreach li $lines {
5886 set r0 [lindex $li 0]
5887 if {$r0 > $row} {
5888 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5889 set joinhigh 1
5891 break
5893 incr i
5896 set joinlow 0
5897 if {$i > 0} {
5898 set li [lindex $lines [expr {$i-1}]]
5899 set r1 [lindex $li 1]
5900 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5901 set joinlow 1
5905 set x [lindex $cols [expr {$le - $row}]]
5906 set xp [lindex $cols [expr {$le - 1 - $row}]]
5907 set dir [expr {$xp - $x}]
5908 if {$joinhigh} {
5909 set ith [lindex $lines $i 2]
5910 set coords [$canv coords $ith]
5911 set ah [$canv itemcget $ith -arrow]
5912 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5913 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5914 if {$x2 ne {} && $x - $x2 == $dir} {
5915 set coords [lrange $coords 0 end-2]
5917 } else {
5918 set coords [list [xc $le $x] [yc $le]]
5920 if {$joinlow} {
5921 set itl [lindex $lines [expr {$i-1}] 2]
5922 set al [$canv itemcget $itl -arrow]
5923 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5924 } elseif {$arrowlow} {
5925 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5926 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5927 set arrowlow 0
5930 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5931 for {set y $le} {[incr y -1] > $row} {} {
5932 set x $xp
5933 set xp [lindex $cols [expr {$y - 1 - $row}]]
5934 set ndir [expr {$xp - $x}]
5935 if {$dir != $ndir || $xp < 0} {
5936 lappend coords [xc $y $x] [yc $y]
5938 set dir $ndir
5940 if {!$joinlow} {
5941 if {$xp < 0} {
5942 # join parent line to first child
5943 set ch [lindex $displayorder $row]
5944 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5945 if {$xc < 0} {
5946 puts "oops: drawlineseg: child $ch not on row $row"
5947 } elseif {$xc != $x} {
5948 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5949 set d [expr {int(0.5 * $linespc)}]
5950 set x1 [xc $row $x]
5951 if {$xc < $x} {
5952 set x2 [expr {$x1 - $d}]
5953 } else {
5954 set x2 [expr {$x1 + $d}]
5956 set y2 [yc $row]
5957 set y1 [expr {$y2 + $d}]
5958 lappend coords $x1 $y1 $x2 $y2
5959 } elseif {$xc < $x - 1} {
5960 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5961 } elseif {$xc > $x + 1} {
5962 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5964 set x $xc
5966 lappend coords [xc $row $x] [yc $row]
5967 } else {
5968 set xn [xc $row $xp]
5969 set yn [yc $row]
5970 lappend coords $xn $yn
5972 if {!$joinhigh} {
5973 assigncolor $id
5974 set t [$canv create line $coords -width [linewidth $id] \
5975 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5976 $canv lower $t
5977 bindline $t $id
5978 set lines [linsert $lines $i [list $row $le $t]]
5979 } else {
5980 $canv coords $ith $coords
5981 if {$arrow ne $ah} {
5982 $canv itemconf $ith -arrow $arrow
5984 lset lines $i 0 $row
5986 } else {
5987 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5988 set ndir [expr {$xo - $xp}]
5989 set clow [$canv coords $itl]
5990 if {$dir == $ndir} {
5991 set clow [lrange $clow 2 end]
5993 set coords [concat $coords $clow]
5994 if {!$joinhigh} {
5995 lset lines [expr {$i-1}] 1 $le
5996 } else {
5997 # coalesce two pieces
5998 $canv delete $ith
5999 set b [lindex $lines [expr {$i-1}] 0]
6000 set e [lindex $lines $i 1]
6001 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6003 $canv coords $itl $coords
6004 if {$arrow ne $al} {
6005 $canv itemconf $itl -arrow $arrow
6009 set linesegs($id) $lines
6010 return $le
6013 proc drawparentlinks {id row} {
6014 global rowidlist canv colormap curview parentlist
6015 global idpos linespc
6017 set rowids [lindex $rowidlist $row]
6018 set col [lsearch -exact $rowids $id]
6019 if {$col < 0} return
6020 set olds [lindex $parentlist $row]
6021 set row2 [expr {$row + 1}]
6022 set x [xc $row $col]
6023 set y [yc $row]
6024 set y2 [yc $row2]
6025 set d [expr {int(0.5 * $linespc)}]
6026 set ymid [expr {$y + $d}]
6027 set ids [lindex $rowidlist $row2]
6028 # rmx = right-most X coord used
6029 set rmx 0
6030 foreach p $olds {
6031 set i [lsearch -exact $ids $p]
6032 if {$i < 0} {
6033 puts "oops, parent $p of $id not in list"
6034 continue
6036 set x2 [xc $row2 $i]
6037 if {$x2 > $rmx} {
6038 set rmx $x2
6040 set j [lsearch -exact $rowids $p]
6041 if {$j < 0} {
6042 # drawlineseg will do this one for us
6043 continue
6045 assigncolor $p
6046 # should handle duplicated parents here...
6047 set coords [list $x $y]
6048 if {$i != $col} {
6049 # if attaching to a vertical segment, draw a smaller
6050 # slant for visual distinctness
6051 if {$i == $j} {
6052 if {$i < $col} {
6053 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6054 } else {
6055 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6057 } elseif {$i < $col && $i < $j} {
6058 # segment slants towards us already
6059 lappend coords [xc $row $j] $y
6060 } else {
6061 if {$i < $col - 1} {
6062 lappend coords [expr {$x2 + $linespc}] $y
6063 } elseif {$i > $col + 1} {
6064 lappend coords [expr {$x2 - $linespc}] $y
6066 lappend coords $x2 $y2
6068 } else {
6069 lappend coords $x2 $y2
6071 set t [$canv create line $coords -width [linewidth $p] \
6072 -fill $colormap($p) -tags lines.$p]
6073 $canv lower $t
6074 bindline $t $p
6076 if {$rmx > [lindex $idpos($id) 1]} {
6077 lset idpos($id) 1 $rmx
6078 redrawtags $id
6082 proc drawlines {id} {
6083 global canv
6085 $canv itemconf lines.$id -width [linewidth $id]
6088 proc drawcmittext {id row col} {
6089 global linespc canv canv2 canv3 fgcolor curview
6090 global cmitlisted commitinfo rowidlist parentlist
6091 global rowtextx idpos idtags idheads idotherrefs
6092 global linehtag linentag linedtag selectedline
6093 global canvxmax boldids boldnameids fgcolor markedid
6094 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6095 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6096 global circleoutlinecolor
6098 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6099 set listed $cmitlisted($curview,$id)
6100 if {$id eq $nullid} {
6101 set ofill $workingfilescirclecolor
6102 } elseif {$id eq $nullid2} {
6103 set ofill $indexcirclecolor
6104 } elseif {$id eq $mainheadid} {
6105 set ofill $mainheadcirclecolor
6106 } else {
6107 set ofill [lindex $circlecolors $listed]
6109 set x [xc $row $col]
6110 set y [yc $row]
6111 set orad [expr {$linespc / 3}]
6112 if {$listed <= 2} {
6113 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6114 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6115 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6116 } elseif {$listed == 3} {
6117 # triangle pointing left for left-side commits
6118 set t [$canv create polygon \
6119 [expr {$x - $orad}] $y \
6120 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6121 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6122 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6123 } else {
6124 # triangle pointing right for right-side commits
6125 set t [$canv create polygon \
6126 [expr {$x + $orad - 1}] $y \
6127 [expr {$x - $orad}] [expr {$y - $orad}] \
6128 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6129 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6131 set circleitem($row) $t
6132 $canv raise $t
6133 $canv bind $t <1> {selcanvline {} %x %y}
6134 set rmx [llength [lindex $rowidlist $row]]
6135 set olds [lindex $parentlist $row]
6136 if {$olds ne {}} {
6137 set nextids [lindex $rowidlist [expr {$row + 1}]]
6138 foreach p $olds {
6139 set i [lsearch -exact $nextids $p]
6140 if {$i > $rmx} {
6141 set rmx $i
6145 set xt [xc $row $rmx]
6146 set rowtextx($row) $xt
6147 set idpos($id) [list $x $xt $y]
6148 if {[info exists idtags($id)] || [info exists idheads($id)]
6149 || [info exists idotherrefs($id)]} {
6150 set xt [drawtags $id $x $xt $y]
6152 if {[lindex $commitinfo($id) 6] > 0} {
6153 set xt [drawnotesign $xt $y]
6155 set headline [lindex $commitinfo($id) 0]
6156 set name [lindex $commitinfo($id) 1]
6157 set date [lindex $commitinfo($id) 2]
6158 set date [formatdate $date]
6159 set font mainfont
6160 set nfont mainfont
6161 set isbold [ishighlighted $id]
6162 if {$isbold > 0} {
6163 lappend boldids $id
6164 set font mainfontbold
6165 if {$isbold > 1} {
6166 lappend boldnameids $id
6167 set nfont mainfontbold
6170 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6171 -text $headline -font $font -tags text]
6172 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6173 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6174 -text $name -font $nfont -tags text]
6175 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6176 -text $date -font mainfont -tags text]
6177 if {$selectedline == $row} {
6178 make_secsel $id
6180 if {[info exists markedid] && $markedid eq $id} {
6181 make_idmark $id
6183 set xr [expr {$xt + [font measure $font $headline]}]
6184 if {$xr > $canvxmax} {
6185 set canvxmax $xr
6186 setcanvscroll
6190 proc drawcmitrow {row} {
6191 global displayorder rowidlist nrows_drawn
6192 global iddrawn markingmatches
6193 global commitinfo numcommits
6194 global filehighlight fhighlights findpattern nhighlights
6195 global hlview vhighlights
6196 global highlight_related rhighlights
6198 if {$row >= $numcommits} return
6200 set id [lindex $displayorder $row]
6201 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6202 askvhighlight $row $id
6204 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6205 askfilehighlight $row $id
6207 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6208 askfindhighlight $row $id
6210 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6211 askrelhighlight $row $id
6213 if {![info exists iddrawn($id)]} {
6214 set col [lsearch -exact [lindex $rowidlist $row] $id]
6215 if {$col < 0} {
6216 puts "oops, row $row id $id not in list"
6217 return
6219 if {![info exists commitinfo($id)]} {
6220 getcommit $id
6222 assigncolor $id
6223 drawcmittext $id $row $col
6224 set iddrawn($id) 1
6225 incr nrows_drawn
6227 if {$markingmatches} {
6228 markrowmatches $row $id
6232 proc drawcommits {row {endrow {}}} {
6233 global numcommits iddrawn displayorder curview need_redisplay
6234 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6236 if {$row < 0} {
6237 set row 0
6239 if {$endrow eq {}} {
6240 set endrow $row
6242 if {$endrow >= $numcommits} {
6243 set endrow [expr {$numcommits - 1}]
6246 set rl1 [expr {$row - $downarrowlen - 3}]
6247 if {$rl1 < 0} {
6248 set rl1 0
6250 set ro1 [expr {$row - 3}]
6251 if {$ro1 < 0} {
6252 set ro1 0
6254 set r2 [expr {$endrow + $uparrowlen + 3}]
6255 if {$r2 > $numcommits} {
6256 set r2 $numcommits
6258 for {set r $rl1} {$r < $r2} {incr r} {
6259 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6260 if {$rl1 < $r} {
6261 layoutrows $rl1 $r
6263 set rl1 [expr {$r + 1}]
6266 if {$rl1 < $r} {
6267 layoutrows $rl1 $r
6269 optimize_rows $ro1 0 $r2
6270 if {$need_redisplay || $nrows_drawn > 2000} {
6271 clear_display
6274 # make the lines join to already-drawn rows either side
6275 set r [expr {$row - 1}]
6276 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6277 set r $row
6279 set er [expr {$endrow + 1}]
6280 if {$er >= $numcommits ||
6281 ![info exists iddrawn([lindex $displayorder $er])]} {
6282 set er $endrow
6284 for {} {$r <= $er} {incr r} {
6285 set id [lindex $displayorder $r]
6286 set wasdrawn [info exists iddrawn($id)]
6287 drawcmitrow $r
6288 if {$r == $er} break
6289 set nextid [lindex $displayorder [expr {$r + 1}]]
6290 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6291 drawparentlinks $id $r
6293 set rowids [lindex $rowidlist $r]
6294 foreach lid $rowids {
6295 if {$lid eq {}} continue
6296 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6297 if {$lid eq $id} {
6298 # see if this is the first child of any of its parents
6299 foreach p [lindex $parentlist $r] {
6300 if {[lsearch -exact $rowids $p] < 0} {
6301 # make this line extend up to the child
6302 set lineend($p) [drawlineseg $p $r $er 0]
6305 } else {
6306 set lineend($lid) [drawlineseg $lid $r $er 1]
6312 proc undolayout {row} {
6313 global uparrowlen mingaplen downarrowlen
6314 global rowidlist rowisopt rowfinal need_redisplay
6316 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6317 if {$r < 0} {
6318 set r 0
6320 if {[llength $rowidlist] > $r} {
6321 incr r -1
6322 set rowidlist [lrange $rowidlist 0 $r]
6323 set rowfinal [lrange $rowfinal 0 $r]
6324 set rowisopt [lrange $rowisopt 0 $r]
6325 set need_redisplay 1
6326 run drawvisible
6330 proc drawvisible {} {
6331 global canv linespc curview vrowmod selectedline targetrow targetid
6332 global need_redisplay cscroll numcommits
6334 set fs [$canv yview]
6335 set ymax [lindex [$canv cget -scrollregion] 3]
6336 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6337 set f0 [lindex $fs 0]
6338 set f1 [lindex $fs 1]
6339 set y0 [expr {int($f0 * $ymax)}]
6340 set y1 [expr {int($f1 * $ymax)}]
6342 if {[info exists targetid]} {
6343 if {[commitinview $targetid $curview]} {
6344 set r [rowofcommit $targetid]
6345 if {$r != $targetrow} {
6346 # Fix up the scrollregion and change the scrolling position
6347 # now that our target row has moved.
6348 set diff [expr {($r - $targetrow) * $linespc}]
6349 set targetrow $r
6350 setcanvscroll
6351 set ymax [lindex [$canv cget -scrollregion] 3]
6352 incr y0 $diff
6353 incr y1 $diff
6354 set f0 [expr {$y0 / $ymax}]
6355 set f1 [expr {$y1 / $ymax}]
6356 allcanvs yview moveto $f0
6357 $cscroll set $f0 $f1
6358 set need_redisplay 1
6360 } else {
6361 unset targetid
6365 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6366 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6367 if {$endrow >= $vrowmod($curview)} {
6368 update_arcrows $curview
6370 if {$selectedline ne {} &&
6371 $row <= $selectedline && $selectedline <= $endrow} {
6372 set targetrow $selectedline
6373 } elseif {[info exists targetid]} {
6374 set targetrow [expr {int(($row + $endrow) / 2)}]
6376 if {[info exists targetrow]} {
6377 if {$targetrow >= $numcommits} {
6378 set targetrow [expr {$numcommits - 1}]
6380 set targetid [commitonrow $targetrow]
6382 drawcommits $row $endrow
6385 proc clear_display {} {
6386 global iddrawn linesegs need_redisplay nrows_drawn
6387 global vhighlights fhighlights nhighlights rhighlights
6388 global linehtag linentag linedtag boldids boldnameids
6390 allcanvs delete all
6391 unset -nocomplain iddrawn
6392 unset -nocomplain linesegs
6393 unset -nocomplain linehtag
6394 unset -nocomplain linentag
6395 unset -nocomplain linedtag
6396 set boldids {}
6397 set boldnameids {}
6398 unset -nocomplain vhighlights
6399 unset -nocomplain fhighlights
6400 unset -nocomplain nhighlights
6401 unset -nocomplain rhighlights
6402 set need_redisplay 0
6403 set nrows_drawn 0
6406 proc findcrossings {id} {
6407 global rowidlist parentlist numcommits displayorder
6409 set cross {}
6410 set ccross {}
6411 foreach {s e} [rowranges $id] {
6412 if {$e >= $numcommits} {
6413 set e [expr {$numcommits - 1}]
6415 if {$e <= $s} continue
6416 for {set row $e} {[incr row -1] >= $s} {} {
6417 set x [lsearch -exact [lindex $rowidlist $row] $id]
6418 if {$x < 0} break
6419 set olds [lindex $parentlist $row]
6420 set kid [lindex $displayorder $row]
6421 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6422 if {$kidx < 0} continue
6423 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6424 foreach p $olds {
6425 set px [lsearch -exact $nextrow $p]
6426 if {$px < 0} continue
6427 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6428 if {[lsearch -exact $ccross $p] >= 0} continue
6429 if {$x == $px + ($kidx < $px? -1: 1)} {
6430 lappend ccross $p
6431 } elseif {[lsearch -exact $cross $p] < 0} {
6432 lappend cross $p
6438 return [concat $ccross {{}} $cross]
6441 proc assigncolor {id} {
6442 global colormap colors nextcolor
6443 global parents children children curview
6445 if {[info exists colormap($id)]} return
6446 set ncolors [llength $colors]
6447 if {[info exists children($curview,$id)]} {
6448 set kids $children($curview,$id)
6449 } else {
6450 set kids {}
6452 if {[llength $kids] == 1} {
6453 set child [lindex $kids 0]
6454 if {[info exists colormap($child)]
6455 && [llength $parents($curview,$child)] == 1} {
6456 set colormap($id) $colormap($child)
6457 return
6460 set badcolors {}
6461 set origbad {}
6462 foreach x [findcrossings $id] {
6463 if {$x eq {}} {
6464 # delimiter between corner crossings and other crossings
6465 if {[llength $badcolors] >= $ncolors - 1} break
6466 set origbad $badcolors
6468 if {[info exists colormap($x)]
6469 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6470 lappend badcolors $colormap($x)
6473 if {[llength $badcolors] >= $ncolors} {
6474 set badcolors $origbad
6476 set origbad $badcolors
6477 if {[llength $badcolors] < $ncolors - 1} {
6478 foreach child $kids {
6479 if {[info exists colormap($child)]
6480 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6481 lappend badcolors $colormap($child)
6483 foreach p $parents($curview,$child) {
6484 if {[info exists colormap($p)]
6485 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6486 lappend badcolors $colormap($p)
6490 if {[llength $badcolors] >= $ncolors} {
6491 set badcolors $origbad
6494 for {set i 0} {$i <= $ncolors} {incr i} {
6495 set c [lindex $colors $nextcolor]
6496 if {[incr nextcolor] >= $ncolors} {
6497 set nextcolor 0
6499 if {[lsearch -exact $badcolors $c]} break
6501 set colormap($id) $c
6504 proc bindline {t id} {
6505 global canv
6507 $canv bind $t <Enter> "lineenter %x %y $id"
6508 $canv bind $t <Motion> "linemotion %x %y $id"
6509 $canv bind $t <Leave> "lineleave $id"
6510 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6513 proc graph_pane_width {} {
6514 global use_ttk
6516 if {$use_ttk} {
6517 set g [.tf.histframe.pwclist sashpos 0]
6518 } else {
6519 set g [.tf.histframe.pwclist sash coord 0]
6521 return [lindex $g 0]
6524 proc totalwidth {l font extra} {
6525 set tot 0
6526 foreach str $l {
6527 set tot [expr {$tot + [font measure $font $str] + $extra}]
6529 return $tot
6532 proc drawtags {id x xt y1} {
6533 global idtags idheads idotherrefs mainhead
6534 global linespc lthickness
6535 global canv rowtextx curview fgcolor bgcolor ctxbut
6536 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6537 global tagbgcolor tagfgcolor tagoutlinecolor
6538 global reflinecolor
6540 set marks {}
6541 set ntags 0
6542 set nheads 0
6543 set singletag 0
6544 set maxtags 3
6545 set maxtagpct 25
6546 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6547 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6548 set extra [expr {$delta + $lthickness + $linespc}]
6550 if {[info exists idtags($id)]} {
6551 set marks $idtags($id)
6552 set ntags [llength $marks]
6553 if {$ntags > $maxtags ||
6554 [totalwidth $marks mainfont $extra] > $maxwidth} {
6555 # show just a single "n tags..." tag
6556 set singletag 1
6557 if {$ntags == 1} {
6558 set marks [list "tag..."]
6559 } else {
6560 set marks [list [format "%d tags..." $ntags]]
6562 set ntags 1
6565 if {[info exists idheads($id)]} {
6566 set marks [concat $marks $idheads($id)]
6567 set nheads [llength $idheads($id)]
6569 if {[info exists idotherrefs($id)]} {
6570 set marks [concat $marks $idotherrefs($id)]
6572 if {$marks eq {}} {
6573 return $xt
6576 set yt [expr {$y1 - 0.5 * $linespc}]
6577 set yb [expr {$yt + $linespc - 1}]
6578 set xvals {}
6579 set wvals {}
6580 set i -1
6581 foreach tag $marks {
6582 incr i
6583 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6584 set wid [font measure mainfontbold $tag]
6585 } else {
6586 set wid [font measure mainfont $tag]
6588 lappend xvals $xt
6589 lappend wvals $wid
6590 set xt [expr {$xt + $wid + $extra}]
6592 set yl [expr {$y1 - $lthickness}]
6593 set t [$canv create line $x $yl [lindex $xvals end] $yl \
6594 -width $lthickness -fill $reflinecolor -tags tag.$id]
6595 $canv lower $t
6596 foreach tag $marks x $xvals wid $wvals {
6597 set tag_quoted [string map {% %%} $tag]
6598 set xl [expr {$x + $delta}]
6599 set xr [expr {$x + $delta + $wid + $lthickness}]
6600 set font mainfont
6601 if {[incr ntags -1] >= 0} {
6602 # draw a tag
6603 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6604 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6605 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6606 -tags tag.$id]
6607 if {$singletag} {
6608 set tagclick [list showtags $id 1]
6609 } else {
6610 set tagclick [list showtag $tag_quoted 1]
6612 $canv bind $t <1> $tagclick
6613 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6614 } else {
6615 # draw a head or other ref
6616 if {[incr nheads -1] >= 0} {
6617 set col $headbgcolor
6618 if {$tag eq $mainhead} {
6619 set font mainfontbold
6621 } else {
6622 set col "#ddddff"
6624 set xl [expr {$xl - $delta/2}]
6625 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6626 -width 1 -outline black -fill $col -tags tag.$id
6627 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6628 set rwid [font measure mainfont $remoteprefix]
6629 set xi [expr {$x + 1}]
6630 set yti [expr {$yt + 1}]
6631 set xri [expr {$x + $rwid}]
6632 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6633 -width 0 -fill $remotebgcolor -tags tag.$id
6636 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6637 -font $font -tags [list tag.$id text]]
6638 if {$ntags >= 0} {
6639 $canv bind $t <1> $tagclick
6640 } elseif {$nheads >= 0} {
6641 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6644 return $xt
6647 proc drawnotesign {xt y} {
6648 global linespc canv fgcolor
6650 set orad [expr {$linespc / 3}]
6651 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6652 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6653 -fill yellow -outline $fgcolor -width 1 -tags circle]
6654 set xt [expr {$xt + $orad * 3}]
6655 return $xt
6658 proc xcoord {i level ln} {
6659 global canvx0 xspc1 xspc2
6661 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6662 if {$i > 0 && $i == $level} {
6663 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6664 } elseif {$i > $level} {
6665 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6667 return $x
6670 proc show_status {msg} {
6671 global canv fgcolor
6673 clear_display
6674 set_window_title
6675 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6676 -tags text -fill $fgcolor
6679 # Don't change the text pane cursor if it is currently the hand cursor,
6680 # showing that we are over a sha1 ID link.
6681 proc settextcursor {c} {
6682 global ctext curtextcursor
6684 if {[$ctext cget -cursor] == $curtextcursor} {
6685 $ctext config -cursor $c
6687 set curtextcursor $c
6690 proc nowbusy {what {name {}}} {
6691 global isbusy busyname statusw
6693 if {[array names isbusy] eq {}} {
6694 . config -cursor watch
6695 settextcursor watch
6697 set isbusy($what) 1
6698 set busyname($what) $name
6699 if {$name ne {}} {
6700 $statusw conf -text $name
6704 proc notbusy {what} {
6705 global isbusy maincursor textcursor busyname statusw
6707 catch {
6708 unset isbusy($what)
6709 if {$busyname($what) ne {} &&
6710 [$statusw cget -text] eq $busyname($what)} {
6711 $statusw conf -text {}
6714 if {[array names isbusy] eq {}} {
6715 . config -cursor $maincursor
6716 settextcursor $textcursor
6720 proc findmatches {f} {
6721 global findtype findstring
6722 if {$findtype == [mc "Regexp"]} {
6723 set matches [regexp -indices -all -inline $findstring $f]
6724 } else {
6725 set fs $findstring
6726 if {$findtype == [mc "IgnCase"]} {
6727 set f [string tolower $f]
6728 set fs [string tolower $fs]
6730 set matches {}
6731 set i 0
6732 set l [string length $fs]
6733 while {[set j [string first $fs $f $i]] >= 0} {
6734 lappend matches [list $j [expr {$j+$l-1}]]
6735 set i [expr {$j + $l}]
6738 return $matches
6741 proc dofind {{dirn 1} {wrap 1}} {
6742 global findstring findstartline findcurline selectedline numcommits
6743 global gdttype filehighlight fh_serial find_dirn findallowwrap
6745 if {[info exists find_dirn]} {
6746 if {$find_dirn == $dirn} return
6747 stopfinding
6749 focus .
6750 if {$findstring eq {} || $numcommits == 0} return
6751 if {$selectedline eq {}} {
6752 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6753 } else {
6754 set findstartline $selectedline
6756 set findcurline $findstartline
6757 nowbusy finding [mc "Searching"]
6758 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6759 after cancel do_file_hl $fh_serial
6760 do_file_hl $fh_serial
6762 set find_dirn $dirn
6763 set findallowwrap $wrap
6764 run findmore
6767 proc stopfinding {} {
6768 global find_dirn findcurline fprogcoord
6770 if {[info exists find_dirn]} {
6771 unset find_dirn
6772 unset findcurline
6773 notbusy finding
6774 set fprogcoord 0
6775 adjustprogress
6777 stopblaming
6780 proc findmore {} {
6781 global commitdata commitinfo numcommits findpattern findloc
6782 global findstartline findcurline findallowwrap
6783 global find_dirn gdttype fhighlights fprogcoord
6784 global curview varcorder vrownum varccommits vrowmod
6786 if {![info exists find_dirn]} {
6787 return 0
6789 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6790 set l $findcurline
6791 set moretodo 0
6792 if {$find_dirn > 0} {
6793 incr l
6794 if {$l >= $numcommits} {
6795 set l 0
6797 if {$l <= $findstartline} {
6798 set lim [expr {$findstartline + 1}]
6799 } else {
6800 set lim $numcommits
6801 set moretodo $findallowwrap
6803 } else {
6804 if {$l == 0} {
6805 set l $numcommits
6807 incr l -1
6808 if {$l >= $findstartline} {
6809 set lim [expr {$findstartline - 1}]
6810 } else {
6811 set lim -1
6812 set moretodo $findallowwrap
6815 set n [expr {($lim - $l) * $find_dirn}]
6816 if {$n > 500} {
6817 set n 500
6818 set moretodo 1
6820 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6821 update_arcrows $curview
6823 set found 0
6824 set domore 1
6825 set ai [bsearch $vrownum($curview) $l]
6826 set a [lindex $varcorder($curview) $ai]
6827 set arow [lindex $vrownum($curview) $ai]
6828 set ids [lindex $varccommits($curview,$a)]
6829 set arowend [expr {$arow + [llength $ids]}]
6830 if {$gdttype eq [mc "containing:"]} {
6831 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6832 if {$l < $arow || $l >= $arowend} {
6833 incr ai $find_dirn
6834 set a [lindex $varcorder($curview) $ai]
6835 set arow [lindex $vrownum($curview) $ai]
6836 set ids [lindex $varccommits($curview,$a)]
6837 set arowend [expr {$arow + [llength $ids]}]
6839 set id [lindex $ids [expr {$l - $arow}]]
6840 # shouldn't happen unless git log doesn't give all the commits...
6841 if {![info exists commitdata($id)] ||
6842 ![doesmatch $commitdata($id)]} {
6843 continue
6845 if {![info exists commitinfo($id)]} {
6846 getcommit $id
6848 set info $commitinfo($id)
6849 foreach f $info ty $fldtypes {
6850 if {$ty eq ""} continue
6851 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6852 [doesmatch $f]} {
6853 set found 1
6854 break
6857 if {$found} break
6859 } else {
6860 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6861 if {$l < $arow || $l >= $arowend} {
6862 incr ai $find_dirn
6863 set a [lindex $varcorder($curview) $ai]
6864 set arow [lindex $vrownum($curview) $ai]
6865 set ids [lindex $varccommits($curview,$a)]
6866 set arowend [expr {$arow + [llength $ids]}]
6868 set id [lindex $ids [expr {$l - $arow}]]
6869 if {![info exists fhighlights($id)]} {
6870 # this sets fhighlights($id) to -1
6871 askfilehighlight $l $id
6873 if {$fhighlights($id) > 0} {
6874 set found $domore
6875 break
6877 if {$fhighlights($id) < 0} {
6878 if {$domore} {
6879 set domore 0
6880 set findcurline [expr {$l - $find_dirn}]
6885 if {$found || ($domore && !$moretodo)} {
6886 unset findcurline
6887 unset find_dirn
6888 notbusy finding
6889 set fprogcoord 0
6890 adjustprogress
6891 if {$found} {
6892 findselectline $l
6893 } else {
6894 bell
6896 return 0
6898 if {!$domore} {
6899 flushhighlights
6900 } else {
6901 set findcurline [expr {$l - $find_dirn}]
6903 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6904 if {$n < 0} {
6905 incr n $numcommits
6907 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6908 adjustprogress
6909 return $domore
6912 proc findselectline {l} {
6913 global findloc commentend ctext findcurline markingmatches gdttype
6915 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6916 set findcurline $l
6917 selectline $l 1
6918 if {$markingmatches &&
6919 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6920 # highlight the matches in the comments
6921 set f [$ctext get 1.0 $commentend]
6922 set matches [findmatches $f]
6923 foreach match $matches {
6924 set start [lindex $match 0]
6925 set end [expr {[lindex $match 1] + 1}]
6926 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6929 drawvisible
6932 # mark the bits of a headline or author that match a find string
6933 proc markmatches {canv l str tag matches font row} {
6934 global selectedline
6936 set bbox [$canv bbox $tag]
6937 set x0 [lindex $bbox 0]
6938 set y0 [lindex $bbox 1]
6939 set y1 [lindex $bbox 3]
6940 foreach match $matches {
6941 set start [lindex $match 0]
6942 set end [lindex $match 1]
6943 if {$start > $end} continue
6944 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6945 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6946 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6947 [expr {$x0+$xlen+2}] $y1 \
6948 -outline {} -tags [list match$l matches] -fill yellow]
6949 $canv lower $t
6950 if {$row == $selectedline} {
6951 $canv raise $t secsel
6956 proc unmarkmatches {} {
6957 global markingmatches
6959 allcanvs delete matches
6960 set markingmatches 0
6961 stopfinding
6964 proc selcanvline {w x y} {
6965 global canv canvy0 ctext linespc
6966 global rowtextx
6967 set ymax [lindex [$canv cget -scrollregion] 3]
6968 if {$ymax == {}} return
6969 set yfrac [lindex [$canv yview] 0]
6970 set y [expr {$y + $yfrac * $ymax}]
6971 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6972 if {$l < 0} {
6973 set l 0
6975 if {$w eq $canv} {
6976 set xmax [lindex [$canv cget -scrollregion] 2]
6977 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6978 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6980 unmarkmatches
6981 selectline $l 1
6984 proc commit_descriptor {p} {
6985 global commitinfo
6986 if {![info exists commitinfo($p)]} {
6987 getcommit $p
6989 set l "..."
6990 if {[llength $commitinfo($p)] > 1} {
6991 set l [lindex $commitinfo($p) 0]
6993 return "$p ($l)\n"
6996 # append some text to the ctext widget, and make any SHA1 ID
6997 # that we know about be a clickable link.
6998 proc appendwithlinks {text tags} {
6999 global ctext linknum curview
7001 set start [$ctext index "end - 1c"]
7002 $ctext insert end $text $tags
7003 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
7004 foreach l $links {
7005 set s [lindex $l 0]
7006 set e [lindex $l 1]
7007 set linkid [string range $text $s $e]
7008 incr e
7009 $ctext tag delete link$linknum
7010 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7011 setlink $linkid link$linknum
7012 incr linknum
7016 proc setlink {id lk} {
7017 global curview ctext pendinglinks
7018 global linkfgcolor
7020 if {[string range $id 0 1] eq "-g"} {
7021 set id [string range $id 2 end]
7024 set known 0
7025 if {[string length $id] < 40} {
7026 set matches [longid $id]
7027 if {[llength $matches] > 0} {
7028 if {[llength $matches] > 1} return
7029 set known 1
7030 set id [lindex $matches 0]
7032 } else {
7033 set known [commitinview $id $curview]
7035 if {$known} {
7036 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7037 $ctext tag bind $lk <1> [list selbyid $id]
7038 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7039 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7040 } else {
7041 lappend pendinglinks($id) $lk
7042 interestedin $id {makelink %P}
7046 proc appendshortlink {id {pre {}} {post {}}} {
7047 global ctext linknum
7049 $ctext insert end $pre
7050 $ctext tag delete link$linknum
7051 $ctext insert end [string range $id 0 7] link$linknum
7052 $ctext insert end $post
7053 setlink $id link$linknum
7054 incr linknum
7057 proc makelink {id} {
7058 global pendinglinks
7060 if {![info exists pendinglinks($id)]} return
7061 foreach lk $pendinglinks($id) {
7062 setlink $id $lk
7064 unset pendinglinks($id)
7067 proc linkcursor {w inc} {
7068 global linkentercount curtextcursor
7070 if {[incr linkentercount $inc] > 0} {
7071 $w configure -cursor hand2
7072 } else {
7073 $w configure -cursor $curtextcursor
7074 if {$linkentercount < 0} {
7075 set linkentercount 0
7080 proc viewnextline {dir} {
7081 global canv linespc
7083 $canv delete hover
7084 set ymax [lindex [$canv cget -scrollregion] 3]
7085 set wnow [$canv yview]
7086 set wtop [expr {[lindex $wnow 0] * $ymax}]
7087 set newtop [expr {$wtop + $dir * $linespc}]
7088 if {$newtop < 0} {
7089 set newtop 0
7090 } elseif {$newtop > $ymax} {
7091 set newtop $ymax
7093 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7096 # add a list of tag or branch names at position pos
7097 # returns the number of names inserted
7098 proc appendrefs {pos ids var} {
7099 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7101 if {[catch {$ctext index $pos}]} {
7102 return 0
7104 $ctext conf -state normal
7105 $ctext delete $pos "$pos lineend"
7106 set tags {}
7107 foreach id $ids {
7108 foreach tag [set $var\($id\)] {
7109 lappend tags [list $tag $id]
7113 set sep {}
7114 set tags [lsort -index 0 -decreasing $tags]
7115 set nutags 0
7117 if {[llength $tags] > $maxrefs} {
7118 # If we are displaying heads, and there are too many,
7119 # see if there are some important heads to display.
7120 # Currently that are the current head and heads listed in $visiblerefs option
7121 set itags {}
7122 if {$var eq "idheads"} {
7123 set utags {}
7124 foreach ti $tags {
7125 set hname [lindex $ti 0]
7126 set id [lindex $ti 1]
7127 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7128 [llength $itags] < $maxrefs} {
7129 lappend itags $ti
7130 } else {
7131 lappend utags $ti
7134 set tags $utags
7136 if {$itags ne {}} {
7137 set str [mc "and many more"]
7138 set sep " "
7139 } else {
7140 set str [mc "many"]
7142 $ctext insert $pos "$str ([llength $tags])"
7143 set nutags [llength $tags]
7144 set tags $itags
7147 foreach ti $tags {
7148 set id [lindex $ti 1]
7149 set lk link$linknum
7150 incr linknum
7151 $ctext tag delete $lk
7152 $ctext insert $pos $sep
7153 $ctext insert $pos [lindex $ti 0] $lk
7154 setlink $id $lk
7155 set sep ", "
7157 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7158 $ctext conf -state disabled
7159 return [expr {[llength $tags] + $nutags}]
7162 # called when we have finished computing the nearby tags
7163 proc dispneartags {delay} {
7164 global selectedline currentid showneartags tagphase
7166 if {$selectedline eq {} || !$showneartags} return
7167 after cancel dispnexttag
7168 if {$delay} {
7169 after 200 dispnexttag
7170 set tagphase -1
7171 } else {
7172 after idle dispnexttag
7173 set tagphase 0
7177 proc dispnexttag {} {
7178 global selectedline currentid showneartags tagphase ctext
7180 if {$selectedline eq {} || !$showneartags} return
7181 switch -- $tagphase {
7183 set dtags [desctags $currentid]
7184 if {$dtags ne {}} {
7185 appendrefs precedes $dtags idtags
7189 set atags [anctags $currentid]
7190 if {$atags ne {}} {
7191 appendrefs follows $atags idtags
7195 set dheads [descheads $currentid]
7196 if {$dheads ne {}} {
7197 if {[appendrefs branch $dheads idheads] > 1
7198 && [$ctext get "branch -3c"] eq "h"} {
7199 # turn "Branch" into "Branches"
7200 $ctext conf -state normal
7201 $ctext insert "branch -2c" "es"
7202 $ctext conf -state disabled
7207 if {[incr tagphase] <= 2} {
7208 after idle dispnexttag
7212 proc make_secsel {id} {
7213 global linehtag linentag linedtag canv canv2 canv3
7215 if {![info exists linehtag($id)]} return
7216 $canv delete secsel
7217 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7218 -tags secsel -fill [$canv cget -selectbackground]]
7219 $canv lower $t
7220 $canv2 delete secsel
7221 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7222 -tags secsel -fill [$canv2 cget -selectbackground]]
7223 $canv2 lower $t
7224 $canv3 delete secsel
7225 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7226 -tags secsel -fill [$canv3 cget -selectbackground]]
7227 $canv3 lower $t
7230 proc make_idmark {id} {
7231 global linehtag canv fgcolor
7233 if {![info exists linehtag($id)]} return
7234 $canv delete markid
7235 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7236 -tags markid -outline $fgcolor]
7237 $canv raise $t
7240 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7241 global canv ctext commitinfo selectedline
7242 global canvy0 linespc parents children curview
7243 global currentid sha1entry
7244 global commentend idtags linknum
7245 global mergemax numcommits pending_select
7246 global cmitmode showneartags allcommits
7247 global targetrow targetid lastscrollrows
7248 global autoselect autosellen jump_to_here
7249 global vinlinediff
7251 unset -nocomplain pending_select
7252 $canv delete hover
7253 normalline
7254 unsel_reflist
7255 stopfinding
7256 if {$l < 0 || $l >= $numcommits} return
7257 set id [commitonrow $l]
7258 set targetid $id
7259 set targetrow $l
7260 set selectedline $l
7261 set currentid $id
7262 if {$lastscrollrows < $numcommits} {
7263 setcanvscroll
7266 if {$cmitmode ne "patch" && $switch_to_patch} {
7267 set cmitmode "patch"
7270 set y [expr {$canvy0 + $l * $linespc}]
7271 set ymax [lindex [$canv cget -scrollregion] 3]
7272 set ytop [expr {$y - $linespc - 1}]
7273 set ybot [expr {$y + $linespc + 1}]
7274 set wnow [$canv yview]
7275 set wtop [expr {[lindex $wnow 0] * $ymax}]
7276 set wbot [expr {[lindex $wnow 1] * $ymax}]
7277 set wh [expr {$wbot - $wtop}]
7278 set newtop $wtop
7279 if {$ytop < $wtop} {
7280 if {$ybot < $wtop} {
7281 set newtop [expr {$y - $wh / 2.0}]
7282 } else {
7283 set newtop $ytop
7284 if {$newtop > $wtop - $linespc} {
7285 set newtop [expr {$wtop - $linespc}]
7288 } elseif {$ybot > $wbot} {
7289 if {$ytop > $wbot} {
7290 set newtop [expr {$y - $wh / 2.0}]
7291 } else {
7292 set newtop [expr {$ybot - $wh}]
7293 if {$newtop < $wtop + $linespc} {
7294 set newtop [expr {$wtop + $linespc}]
7298 if {$newtop != $wtop} {
7299 if {$newtop < 0} {
7300 set newtop 0
7302 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7303 drawvisible
7306 make_secsel $id
7308 if {$isnew} {
7309 addtohistory [list selbyid $id 0] savecmitpos
7312 $sha1entry delete 0 end
7313 $sha1entry insert 0 $id
7314 if {$autoselect} {
7315 $sha1entry selection range 0 $autosellen
7317 rhighlight_sel $id
7319 $ctext conf -state normal
7320 clear_ctext
7321 set linknum 0
7322 if {![info exists commitinfo($id)]} {
7323 getcommit $id
7325 set info $commitinfo($id)
7326 set date [formatdate [lindex $info 2]]
7327 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7328 set date [formatdate [lindex $info 4]]
7329 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7330 if {[info exists idtags($id)]} {
7331 $ctext insert end [mc "Tags:"]
7332 foreach tag $idtags($id) {
7333 $ctext insert end " $tag"
7335 $ctext insert end "\n"
7338 set headers {}
7339 set olds $parents($curview,$id)
7340 if {[llength $olds] > 1} {
7341 set np 0
7342 foreach p $olds {
7343 if {$np >= $mergemax} {
7344 set tag mmax
7345 } else {
7346 set tag m$np
7348 $ctext insert end "[mc "Parent"]: " $tag
7349 appendwithlinks [commit_descriptor $p] {}
7350 incr np
7352 } else {
7353 foreach p $olds {
7354 append headers "[mc "Parent"]: [commit_descriptor $p]"
7358 foreach c $children($curview,$id) {
7359 append headers "[mc "Child"]: [commit_descriptor $c]"
7362 # make anything that looks like a SHA1 ID be a clickable link
7363 appendwithlinks $headers {}
7364 if {$showneartags} {
7365 if {![info exists allcommits]} {
7366 getallcommits
7368 $ctext insert end "[mc "Branch"]: "
7369 $ctext mark set branch "end -1c"
7370 $ctext mark gravity branch left
7371 $ctext insert end "\n[mc "Follows"]: "
7372 $ctext mark set follows "end -1c"
7373 $ctext mark gravity follows left
7374 $ctext insert end "\n[mc "Precedes"]: "
7375 $ctext mark set precedes "end -1c"
7376 $ctext mark gravity precedes left
7377 $ctext insert end "\n"
7378 dispneartags 1
7380 $ctext insert end "\n"
7381 set comment [lindex $info 5]
7382 if {[string first "\r" $comment] >= 0} {
7383 set comment [string map {"\r" "\n "} $comment]
7385 appendwithlinks $comment {comment}
7387 $ctext tag remove found 1.0 end
7388 $ctext conf -state disabled
7389 set commentend [$ctext index "end - 1c"]
7391 set jump_to_here $desired_loc
7392 init_flist [mc "Comments"]
7393 if {$cmitmode eq "tree"} {
7394 gettree $id
7395 } elseif {$vinlinediff($curview) == 1} {
7396 showinlinediff $id
7397 } elseif {[llength $olds] <= 1} {
7398 startdiff $id
7399 } else {
7400 mergediff $id
7404 proc selfirstline {} {
7405 unmarkmatches
7406 selectline 0 1
7409 proc sellastline {} {
7410 global numcommits
7411 unmarkmatches
7412 set l [expr {$numcommits - 1}]
7413 selectline $l 1
7416 proc selnextline {dir} {
7417 global selectedline
7418 focus .
7419 if {$selectedline eq {}} return
7420 set l [expr {$selectedline + $dir}]
7421 unmarkmatches
7422 selectline $l 1
7425 proc selnextpage {dir} {
7426 global canv linespc selectedline numcommits
7428 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7429 if {$lpp < 1} {
7430 set lpp 1
7432 allcanvs yview scroll [expr {$dir * $lpp}] units
7433 drawvisible
7434 if {$selectedline eq {}} return
7435 set l [expr {$selectedline + $dir * $lpp}]
7436 if {$l < 0} {
7437 set l 0
7438 } elseif {$l >= $numcommits} {
7439 set l [expr $numcommits - 1]
7441 unmarkmatches
7442 selectline $l 1
7445 proc unselectline {} {
7446 global selectedline currentid
7448 set selectedline {}
7449 unset -nocomplain currentid
7450 allcanvs delete secsel
7451 rhighlight_none
7454 proc reselectline {} {
7455 global selectedline
7457 if {$selectedline ne {}} {
7458 selectline $selectedline 0
7462 proc addtohistory {cmd {saveproc {}}} {
7463 global history historyindex curview
7465 unset_posvars
7466 save_position
7467 set elt [list $curview $cmd $saveproc {}]
7468 if {$historyindex > 0
7469 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7470 return
7473 if {$historyindex < [llength $history]} {
7474 set history [lreplace $history $historyindex end $elt]
7475 } else {
7476 lappend history $elt
7478 incr historyindex
7479 if {$historyindex > 1} {
7480 .tf.bar.leftbut conf -state normal
7481 } else {
7482 .tf.bar.leftbut conf -state disabled
7484 .tf.bar.rightbut conf -state disabled
7487 # save the scrolling position of the diff display pane
7488 proc save_position {} {
7489 global historyindex history
7491 if {$historyindex < 1} return
7492 set hi [expr {$historyindex - 1}]
7493 set fn [lindex $history $hi 2]
7494 if {$fn ne {}} {
7495 lset history $hi 3 [eval $fn]
7499 proc unset_posvars {} {
7500 global last_posvars
7502 if {[info exists last_posvars]} {
7503 foreach {var val} $last_posvars {
7504 global $var
7505 unset -nocomplain $var
7507 unset last_posvars
7511 proc godo {elt} {
7512 global curview last_posvars
7514 set view [lindex $elt 0]
7515 set cmd [lindex $elt 1]
7516 set pv [lindex $elt 3]
7517 if {$curview != $view} {
7518 showview $view
7520 unset_posvars
7521 foreach {var val} $pv {
7522 global $var
7523 set $var $val
7525 set last_posvars $pv
7526 eval $cmd
7529 proc goback {} {
7530 global history historyindex
7531 focus .
7533 if {$historyindex > 1} {
7534 save_position
7535 incr historyindex -1
7536 godo [lindex $history [expr {$historyindex - 1}]]
7537 .tf.bar.rightbut conf -state normal
7539 if {$historyindex <= 1} {
7540 .tf.bar.leftbut conf -state disabled
7544 proc goforw {} {
7545 global history historyindex
7546 focus .
7548 if {$historyindex < [llength $history]} {
7549 save_position
7550 set cmd [lindex $history $historyindex]
7551 incr historyindex
7552 godo $cmd
7553 .tf.bar.leftbut conf -state normal
7555 if {$historyindex >= [llength $history]} {
7556 .tf.bar.rightbut conf -state disabled
7560 proc go_to_parent {i} {
7561 global parents curview targetid
7562 set ps $parents($curview,$targetid)
7563 if {[llength $ps] >= $i} {
7564 selbyid [lindex $ps [expr $i - 1]]
7568 proc gettree {id} {
7569 global treefilelist treeidlist diffids diffmergeid treepending
7570 global nullid nullid2
7572 set diffids $id
7573 unset -nocomplain diffmergeid
7574 if {![info exists treefilelist($id)]} {
7575 if {![info exists treepending]} {
7576 if {$id eq $nullid} {
7577 set cmd [list | git ls-files]
7578 } elseif {$id eq $nullid2} {
7579 set cmd [list | git ls-files --stage -t]
7580 } else {
7581 set cmd [list | git ls-tree -r $id]
7583 if {[catch {set gtf [open $cmd r]}]} {
7584 return
7586 set treepending $id
7587 set treefilelist($id) {}
7588 set treeidlist($id) {}
7589 fconfigure $gtf -blocking 0 -encoding binary
7590 filerun $gtf [list gettreeline $gtf $id]
7592 } else {
7593 setfilelist $id
7597 proc gettreeline {gtf id} {
7598 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7600 set nl 0
7601 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7602 if {$diffids eq $nullid} {
7603 set fname $line
7604 } else {
7605 set i [string first "\t" $line]
7606 if {$i < 0} continue
7607 set fname [string range $line [expr {$i+1}] end]
7608 set line [string range $line 0 [expr {$i-1}]]
7609 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7610 set sha1 [lindex $line 2]
7611 lappend treeidlist($id) $sha1
7613 if {[string index $fname 0] eq "\""} {
7614 set fname [lindex $fname 0]
7616 set fname [encoding convertfrom $fname]
7617 lappend treefilelist($id) $fname
7619 if {![eof $gtf]} {
7620 return [expr {$nl >= 1000? 2: 1}]
7622 close $gtf
7623 unset treepending
7624 if {$cmitmode ne "tree"} {
7625 if {![info exists diffmergeid]} {
7626 gettreediffs $diffids
7628 } elseif {$id ne $diffids} {
7629 gettree $diffids
7630 } else {
7631 setfilelist $id
7633 return 0
7636 proc showfile {f} {
7637 global treefilelist treeidlist diffids nullid nullid2
7638 global ctext_file_names ctext_file_lines
7639 global ctext commentend
7641 set i [lsearch -exact $treefilelist($diffids) $f]
7642 if {$i < 0} {
7643 puts "oops, $f not in list for id $diffids"
7644 return
7646 if {$diffids eq $nullid} {
7647 if {[catch {set bf [open $f r]} err]} {
7648 puts "oops, can't read $f: $err"
7649 return
7651 } else {
7652 set blob [lindex $treeidlist($diffids) $i]
7653 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7654 puts "oops, error reading blob $blob: $err"
7655 return
7658 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7659 filerun $bf [list getblobline $bf $diffids]
7660 $ctext config -state normal
7661 clear_ctext $commentend
7662 lappend ctext_file_names $f
7663 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7664 $ctext insert end "\n"
7665 $ctext insert end "$f\n" filesep
7666 $ctext config -state disabled
7667 $ctext yview $commentend
7668 settabs 0
7671 proc getblobline {bf id} {
7672 global diffids cmitmode ctext
7674 if {$id ne $diffids || $cmitmode ne "tree"} {
7675 catch {close $bf}
7676 return 0
7678 $ctext config -state normal
7679 set nl 0
7680 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7681 $ctext insert end "$line\n"
7683 if {[eof $bf]} {
7684 global jump_to_here ctext_file_names commentend
7686 # delete last newline
7687 $ctext delete "end - 2c" "end - 1c"
7688 close $bf
7689 if {$jump_to_here ne {} &&
7690 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7691 set lnum [expr {[lindex $jump_to_here 1] +
7692 [lindex [split $commentend .] 0]}]
7693 mark_ctext_line $lnum
7695 $ctext config -state disabled
7696 return 0
7698 $ctext config -state disabled
7699 return [expr {$nl >= 1000? 2: 1}]
7702 proc mark_ctext_line {lnum} {
7703 global ctext markbgcolor
7705 $ctext tag delete omark
7706 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7707 $ctext tag conf omark -background $markbgcolor
7708 $ctext see $lnum.0
7711 proc mergediff {id} {
7712 global diffmergeid
7713 global diffids treediffs
7714 global parents curview
7716 set diffmergeid $id
7717 set diffids $id
7718 set treediffs($id) {}
7719 set np [llength $parents($curview,$id)]
7720 settabs $np
7721 getblobdiffs $id
7724 proc startdiff {ids} {
7725 global treediffs diffids treepending diffmergeid nullid nullid2
7727 settabs 1
7728 set diffids $ids
7729 unset -nocomplain diffmergeid
7730 if {![info exists treediffs($ids)] ||
7731 [lsearch -exact $ids $nullid] >= 0 ||
7732 [lsearch -exact $ids $nullid2] >= 0} {
7733 if {![info exists treepending]} {
7734 gettreediffs $ids
7736 } else {
7737 addtocflist $ids
7741 proc showinlinediff {ids} {
7742 global commitinfo commitdata ctext
7743 global treediffs
7745 set info $commitinfo($ids)
7746 set diff [lindex $info 7]
7747 set difflines [split $diff "\n"]
7749 initblobdiffvars
7750 set treediff {}
7752 set inhdr 0
7753 foreach line $difflines {
7754 if {![string compare -length 5 "diff " $line]} {
7755 set inhdr 1
7756 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7757 # offset also accounts for the b/ prefix
7758 lappend treediff [string range $line 6 end]
7759 set inhdr 0
7763 set treediffs($ids) $treediff
7764 add_flist $treediff
7766 $ctext conf -state normal
7767 foreach line $difflines {
7768 parseblobdiffline $ids $line
7770 maybe_scroll_ctext 1
7771 $ctext conf -state disabled
7774 # If the filename (name) is under any of the passed filter paths
7775 # then return true to include the file in the listing.
7776 proc path_filter {filter name} {
7777 set worktree [gitworktree]
7778 foreach p $filter {
7779 set fq_p [file normalize $p]
7780 set fq_n [file normalize [file join $worktree $name]]
7781 if {[string match [file normalize $fq_p]* $fq_n]} {
7782 return 1
7785 return 0
7788 proc addtocflist {ids} {
7789 global treediffs
7791 add_flist $treediffs($ids)
7792 getblobdiffs $ids
7795 proc diffcmd {ids flags} {
7796 global log_showroot nullid nullid2 git_version
7798 set i [lsearch -exact $ids $nullid]
7799 set j [lsearch -exact $ids $nullid2]
7800 if {$i >= 0} {
7801 if {[llength $ids] > 1 && $j < 0} {
7802 # comparing working directory with some specific revision
7803 set cmd [concat | git diff-index $flags]
7804 if {$i == 0} {
7805 lappend cmd -R [lindex $ids 1]
7806 } else {
7807 lappend cmd [lindex $ids 0]
7809 } else {
7810 # comparing working directory with index
7811 set cmd [concat | git diff-files $flags]
7812 if {$j == 1} {
7813 lappend cmd -R
7816 } elseif {$j >= 0} {
7817 if {[package vcompare $git_version "1.7.2"] >= 0} {
7818 set flags "$flags --ignore-submodules=dirty"
7820 set cmd [concat | git diff-index --cached $flags]
7821 if {[llength $ids] > 1} {
7822 # comparing index with specific revision
7823 if {$j == 0} {
7824 lappend cmd -R [lindex $ids 1]
7825 } else {
7826 lappend cmd [lindex $ids 0]
7828 } else {
7829 # comparing index with HEAD
7830 lappend cmd HEAD
7832 } else {
7833 if {$log_showroot} {
7834 lappend flags --root
7836 set cmd [concat | git diff-tree -r $flags $ids]
7838 return $cmd
7841 proc gettreediffs {ids} {
7842 global treediff treepending limitdiffs vfilelimit curview
7844 set cmd [diffcmd $ids {--no-commit-id}]
7845 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7846 set cmd [concat $cmd -- $vfilelimit($curview)]
7848 if {[catch {set gdtf [open $cmd r]}]} return
7850 set treepending $ids
7851 set treediff {}
7852 fconfigure $gdtf -blocking 0 -encoding binary
7853 filerun $gdtf [list gettreediffline $gdtf $ids]
7856 proc gettreediffline {gdtf ids} {
7857 global treediff treediffs treepending diffids diffmergeid
7858 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7860 set nr 0
7861 set sublist {}
7862 set max 1000
7863 if {$perfile_attrs} {
7864 # cache_gitattr is slow, and even slower on win32 where we
7865 # have to invoke it for only about 30 paths at a time
7866 set max 500
7867 if {[tk windowingsystem] == "win32"} {
7868 set max 120
7871 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7872 set i [string first "\t" $line]
7873 if {$i >= 0} {
7874 set file [string range $line [expr {$i+1}] end]
7875 if {[string index $file 0] eq "\""} {
7876 set file [lindex $file 0]
7878 set file [encoding convertfrom $file]
7879 if {$file ne [lindex $treediff end]} {
7880 lappend treediff $file
7881 lappend sublist $file
7885 if {$perfile_attrs} {
7886 cache_gitattr encoding $sublist
7888 if {![eof $gdtf]} {
7889 return [expr {$nr >= $max? 2: 1}]
7891 close $gdtf
7892 set treediffs($ids) $treediff
7893 unset treepending
7894 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7895 gettree $diffids
7896 } elseif {$ids != $diffids} {
7897 if {![info exists diffmergeid]} {
7898 gettreediffs $diffids
7900 } else {
7901 addtocflist $ids
7903 return 0
7906 # empty string or positive integer
7907 proc diffcontextvalidate {v} {
7908 return [regexp {^(|[1-9][0-9]*)$} $v]
7911 proc diffcontextchange {n1 n2 op} {
7912 global diffcontextstring diffcontext
7914 if {[string is integer -strict $diffcontextstring]} {
7915 if {$diffcontextstring >= 0} {
7916 set diffcontext $diffcontextstring
7917 reselectline
7922 proc changeignorespace {} {
7923 reselectline
7926 proc changeworddiff {name ix op} {
7927 reselectline
7930 proc initblobdiffvars {} {
7931 global diffencoding targetline diffnparents
7932 global diffinhdr currdiffsubmod diffseehere
7933 set targetline {}
7934 set diffnparents 0
7935 set diffinhdr 0
7936 set diffencoding [get_path_encoding {}]
7937 set currdiffsubmod ""
7938 set diffseehere -1
7941 proc getblobdiffs {ids} {
7942 global blobdifffd diffids env
7943 global treediffs
7944 global diffcontext
7945 global ignorespace
7946 global worddiff
7947 global limitdiffs vfilelimit curview
7948 global git_version
7950 set textconv {}
7951 if {[package vcompare $git_version "1.6.1"] >= 0} {
7952 set textconv "--textconv"
7954 set submodule {}
7955 if {[package vcompare $git_version "1.6.6"] >= 0} {
7956 set submodule "--submodule"
7958 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7959 if {$ignorespace} {
7960 append cmd " -w"
7962 if {$worddiff ne [mc "Line diff"]} {
7963 append cmd " --word-diff=porcelain"
7965 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7966 set cmd [concat $cmd -- $vfilelimit($curview)]
7968 if {[catch {set bdf [open $cmd r]} err]} {
7969 error_popup [mc "Error getting diffs: %s" $err]
7970 return
7972 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7973 set blobdifffd($ids) $bdf
7974 initblobdiffvars
7975 filerun $bdf [list getblobdiffline $bdf $diffids]
7978 proc savecmitpos {} {
7979 global ctext cmitmode
7981 if {$cmitmode eq "tree"} {
7982 return {}
7984 return [list target_scrollpos [$ctext index @0,0]]
7987 proc savectextpos {} {
7988 global ctext
7990 return [list target_scrollpos [$ctext index @0,0]]
7993 proc maybe_scroll_ctext {ateof} {
7994 global ctext target_scrollpos
7996 if {![info exists target_scrollpos]} return
7997 if {!$ateof} {
7998 set nlines [expr {[winfo height $ctext]
7999 / [font metrics textfont -linespace]}]
8000 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
8002 $ctext yview $target_scrollpos
8003 unset target_scrollpos
8006 proc setinlist {var i val} {
8007 global $var
8009 while {[llength [set $var]] < $i} {
8010 lappend $var {}
8012 if {[llength [set $var]] == $i} {
8013 lappend $var $val
8014 } else {
8015 lset $var $i $val
8019 proc makediffhdr {fname ids} {
8020 global ctext curdiffstart treediffs diffencoding
8021 global ctext_file_names jump_to_here targetline diffline
8023 set fname [encoding convertfrom $fname]
8024 set diffencoding [get_path_encoding $fname]
8025 set i [lsearch -exact $treediffs($ids) $fname]
8026 if {$i >= 0} {
8027 setinlist difffilestart $i $curdiffstart
8029 lset ctext_file_names end $fname
8030 set l [expr {(78 - [string length $fname]) / 2}]
8031 set pad [string range "----------------------------------------" 1 $l]
8032 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8033 set targetline {}
8034 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8035 set targetline [lindex $jump_to_here 1]
8037 set diffline 0
8040 proc blobdiffmaybeseehere {ateof} {
8041 global diffseehere
8042 if {$diffseehere >= 0} {
8043 mark_ctext_line [lindex [split $diffseehere .] 0]
8045 maybe_scroll_ctext $ateof
8048 proc getblobdiffline {bdf ids} {
8049 global diffids blobdifffd
8050 global ctext
8052 set nr 0
8053 $ctext conf -state normal
8054 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8055 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8056 catch {close $bdf}
8057 return 0
8059 parseblobdiffline $ids $line
8061 $ctext conf -state disabled
8062 blobdiffmaybeseehere [eof $bdf]
8063 if {[eof $bdf]} {
8064 catch {close $bdf}
8065 return 0
8067 return [expr {$nr >= 1000? 2: 1}]
8070 proc parseblobdiffline {ids line} {
8071 global ctext curdiffstart
8072 global diffnexthead diffnextnote difffilestart
8073 global ctext_file_names ctext_file_lines
8074 global diffinhdr treediffs mergemax diffnparents
8075 global diffencoding jump_to_here targetline diffline currdiffsubmod
8076 global worddiff diffseehere
8078 if {![string compare -length 5 "diff " $line]} {
8079 if {![regexp {^diff (--cc|--git) } $line m type]} {
8080 set line [encoding convertfrom $line]
8081 $ctext insert end "$line\n" hunksep
8082 continue
8084 # start of a new file
8085 set diffinhdr 1
8086 $ctext insert end "\n"
8087 set curdiffstart [$ctext index "end - 1c"]
8088 lappend ctext_file_names ""
8089 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8090 $ctext insert end "\n" filesep
8092 if {$type eq "--cc"} {
8093 # start of a new file in a merge diff
8094 set fname [string range $line 10 end]
8095 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8096 lappend treediffs($ids) $fname
8097 add_flist [list $fname]
8100 } else {
8101 set line [string range $line 11 end]
8102 # If the name hasn't changed the length will be odd,
8103 # the middle char will be a space, and the two bits either
8104 # side will be a/name and b/name, or "a/name" and "b/name".
8105 # If the name has changed we'll get "rename from" and
8106 # "rename to" or "copy from" and "copy to" lines following
8107 # this, and we'll use them to get the filenames.
8108 # This complexity is necessary because spaces in the
8109 # filename(s) don't get escaped.
8110 set l [string length $line]
8111 set i [expr {$l / 2}]
8112 if {!(($l & 1) && [string index $line $i] eq " " &&
8113 [string range $line 2 [expr {$i - 1}]] eq \
8114 [string range $line [expr {$i + 3}] end])} {
8115 return
8117 # unescape if quoted and chop off the a/ from the front
8118 if {[string index $line 0] eq "\""} {
8119 set fname [string range [lindex $line 0] 2 end]
8120 } else {
8121 set fname [string range $line 2 [expr {$i - 1}]]
8124 makediffhdr $fname $ids
8126 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8127 set fname [encoding convertfrom [string range $line 16 end]]
8128 $ctext insert end "\n"
8129 set curdiffstart [$ctext index "end - 1c"]
8130 lappend ctext_file_names $fname
8131 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8132 $ctext insert end "$line\n" filesep
8133 set i [lsearch -exact $treediffs($ids) $fname]
8134 if {$i >= 0} {
8135 setinlist difffilestart $i $curdiffstart
8138 } elseif {![string compare -length 2 "@@" $line]} {
8139 regexp {^@@+} $line ats
8140 set line [encoding convertfrom $diffencoding $line]
8141 $ctext insert end "$line\n" hunksep
8142 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8143 set diffline $nl
8145 set diffnparents [expr {[string length $ats] - 1}]
8146 set diffinhdr 0
8148 } elseif {![string compare -length 10 "Submodule " $line]} {
8149 # start of a new submodule
8150 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8151 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8152 } else {
8153 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8155 if {$currdiffsubmod != $fname} {
8156 $ctext insert end "\n"; # Add newline after commit message
8158 set curdiffstart [$ctext index "end - 1c"]
8159 lappend ctext_file_names ""
8160 if {$currdiffsubmod != $fname} {
8161 lappend ctext_file_lines $fname
8162 makediffhdr $fname $ids
8163 set currdiffsubmod $fname
8164 $ctext insert end "\n$line\n" filesep
8165 } else {
8166 $ctext insert end "$line\n" filesep
8168 } elseif {![string compare -length 3 " >" $line]} {
8169 set $currdiffsubmod ""
8170 set line [encoding convertfrom $diffencoding $line]
8171 $ctext insert end "$line\n" dresult
8172 } elseif {![string compare -length 3 " <" $line]} {
8173 set $currdiffsubmod ""
8174 set line [encoding convertfrom $diffencoding $line]
8175 $ctext insert end "$line\n" d0
8176 } elseif {$diffinhdr} {
8177 if {![string compare -length 12 "rename from " $line]} {
8178 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8179 if {[string index $fname 0] eq "\""} {
8180 set fname [lindex $fname 0]
8182 set fname [encoding convertfrom $fname]
8183 set i [lsearch -exact $treediffs($ids) $fname]
8184 if {$i >= 0} {
8185 setinlist difffilestart $i $curdiffstart
8187 } elseif {![string compare -length 10 $line "rename to "] ||
8188 ![string compare -length 8 $line "copy to "]} {
8189 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8190 if {[string index $fname 0] eq "\""} {
8191 set fname [lindex $fname 0]
8193 makediffhdr $fname $ids
8194 } elseif {[string compare -length 3 $line "---"] == 0} {
8195 # do nothing
8196 return
8197 } elseif {[string compare -length 3 $line "+++"] == 0} {
8198 set diffinhdr 0
8199 return
8201 $ctext insert end "$line\n" filesep
8203 } else {
8204 set line [string map {\x1A ^Z} \
8205 [encoding convertfrom $diffencoding $line]]
8206 # parse the prefix - one ' ', '-' or '+' for each parent
8207 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8208 set tag [expr {$diffnparents > 1? "m": "d"}]
8209 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8210 set words_pre_markup ""
8211 set words_post_markup ""
8212 if {[string trim $prefix " -+"] eq {}} {
8213 # prefix only has " ", "-" and "+" in it: normal diff line
8214 set num [string first "-" $prefix]
8215 if {$dowords} {
8216 set line [string range $line 1 end]
8218 if {$num >= 0} {
8219 # removed line, first parent with line is $num
8220 if {$num >= $mergemax} {
8221 set num "max"
8223 if {$dowords && $worddiff eq [mc "Markup words"]} {
8224 $ctext insert end "\[-$line-\]" $tag$num
8225 } else {
8226 $ctext insert end "$line" $tag$num
8228 if {!$dowords} {
8229 $ctext insert end "\n" $tag$num
8231 } else {
8232 set tags {}
8233 if {[string first "+" $prefix] >= 0} {
8234 # added line
8235 lappend tags ${tag}result
8236 if {$diffnparents > 1} {
8237 set num [string first " " $prefix]
8238 if {$num >= 0} {
8239 if {$num >= $mergemax} {
8240 set num "max"
8242 lappend tags m$num
8245 set words_pre_markup "{+"
8246 set words_post_markup "+}"
8248 if {$targetline ne {}} {
8249 if {$diffline == $targetline} {
8250 set diffseehere [$ctext index "end - 1 chars"]
8251 set targetline {}
8252 } else {
8253 incr diffline
8256 if {$dowords && $worddiff eq [mc "Markup words"]} {
8257 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8258 } else {
8259 $ctext insert end "$line" $tags
8261 if {!$dowords} {
8262 $ctext insert end "\n" $tags
8265 } elseif {$dowords && $prefix eq "~"} {
8266 $ctext insert end "\n" {}
8267 } else {
8268 # "\ No newline at end of file",
8269 # or something else we don't recognize
8270 $ctext insert end "$line\n" hunksep
8275 proc changediffdisp {} {
8276 global ctext diffelide
8278 $ctext tag conf d0 -elide [lindex $diffelide 0]
8279 $ctext tag conf dresult -elide [lindex $diffelide 1]
8282 proc highlightfile {cline} {
8283 global cflist cflist_top
8285 if {![info exists cflist_top]} return
8287 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8288 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8289 $cflist see $cline.0
8290 set cflist_top $cline
8293 proc highlightfile_for_scrollpos {topidx} {
8294 global cmitmode difffilestart
8296 if {$cmitmode eq "tree"} return
8297 if {![info exists difffilestart]} return
8299 set top [lindex [split $topidx .] 0]
8300 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8301 highlightfile 0
8302 } else {
8303 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8307 proc prevfile {} {
8308 global difffilestart ctext cmitmode
8310 if {$cmitmode eq "tree"} return
8311 set prev 0.0
8312 set here [$ctext index @0,0]
8313 foreach loc $difffilestart {
8314 if {[$ctext compare $loc >= $here]} {
8315 $ctext yview $prev
8316 return
8318 set prev $loc
8320 $ctext yview $prev
8323 proc nextfile {} {
8324 global difffilestart ctext cmitmode
8326 if {$cmitmode eq "tree"} return
8327 set here [$ctext index @0,0]
8328 foreach loc $difffilestart {
8329 if {[$ctext compare $loc > $here]} {
8330 $ctext yview $loc
8331 return
8336 proc clear_ctext {{first 1.0}} {
8337 global ctext smarktop smarkbot
8338 global ctext_file_names ctext_file_lines
8339 global pendinglinks
8341 set l [lindex [split $first .] 0]
8342 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8343 set smarktop $l
8345 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8346 set smarkbot $l
8348 $ctext delete $first end
8349 if {$first eq "1.0"} {
8350 unset -nocomplain pendinglinks
8352 set ctext_file_names {}
8353 set ctext_file_lines {}
8356 proc settabs {{firstab {}}} {
8357 global firsttabstop tabstop ctext have_tk85
8359 if {$firstab ne {} && $have_tk85} {
8360 set firsttabstop $firstab
8362 set w [font measure textfont "0"]
8363 if {$firsttabstop != 0} {
8364 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8365 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8366 } elseif {$have_tk85 || $tabstop != 8} {
8367 $ctext conf -tabs [expr {$tabstop * $w}]
8368 } else {
8369 $ctext conf -tabs {}
8373 proc incrsearch {name ix op} {
8374 global ctext searchstring searchdirn
8376 if {[catch {$ctext index anchor}]} {
8377 # no anchor set, use start of selection, or of visible area
8378 set sel [$ctext tag ranges sel]
8379 if {$sel ne {}} {
8380 $ctext mark set anchor [lindex $sel 0]
8381 } elseif {$searchdirn eq "-forwards"} {
8382 $ctext mark set anchor @0,0
8383 } else {
8384 $ctext mark set anchor @0,[winfo height $ctext]
8387 if {$searchstring ne {}} {
8388 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8389 if {$here ne {}} {
8390 $ctext see $here
8391 set mend "$here + $mlen c"
8392 $ctext tag remove sel 1.0 end
8393 $ctext tag add sel $here $mend
8394 suppress_highlighting_file_for_current_scrollpos
8395 highlightfile_for_scrollpos $here
8398 rehighlight_search_results
8401 proc dosearch {} {
8402 global sstring ctext searchstring searchdirn
8404 focus $sstring
8405 $sstring icursor end
8406 set searchdirn -forwards
8407 if {$searchstring ne {}} {
8408 set sel [$ctext tag ranges sel]
8409 if {$sel ne {}} {
8410 set start "[lindex $sel 0] + 1c"
8411 } elseif {[catch {set start [$ctext index anchor]}]} {
8412 set start "@0,0"
8414 set match [$ctext search -count mlen -- $searchstring $start]
8415 $ctext tag remove sel 1.0 end
8416 if {$match eq {}} {
8417 bell
8418 return
8420 $ctext see $match
8421 suppress_highlighting_file_for_current_scrollpos
8422 highlightfile_for_scrollpos $match
8423 set mend "$match + $mlen c"
8424 $ctext tag add sel $match $mend
8425 $ctext mark unset anchor
8426 rehighlight_search_results
8430 proc dosearchback {} {
8431 global sstring ctext searchstring searchdirn
8433 focus $sstring
8434 $sstring icursor end
8435 set searchdirn -backwards
8436 if {$searchstring ne {}} {
8437 set sel [$ctext tag ranges sel]
8438 if {$sel ne {}} {
8439 set start [lindex $sel 0]
8440 } elseif {[catch {set start [$ctext index anchor]}]} {
8441 set start @0,[winfo height $ctext]
8443 set match [$ctext search -backwards -count ml -- $searchstring $start]
8444 $ctext tag remove sel 1.0 end
8445 if {$match eq {}} {
8446 bell
8447 return
8449 $ctext see $match
8450 suppress_highlighting_file_for_current_scrollpos
8451 highlightfile_for_scrollpos $match
8452 set mend "$match + $ml c"
8453 $ctext tag add sel $match $mend
8454 $ctext mark unset anchor
8455 rehighlight_search_results
8459 proc rehighlight_search_results {} {
8460 global ctext searchstring
8462 $ctext tag remove found 1.0 end
8463 $ctext tag remove currentsearchhit 1.0 end
8465 if {$searchstring ne {}} {
8466 searchmarkvisible 1
8470 proc searchmark {first last} {
8471 global ctext searchstring
8473 set sel [$ctext tag ranges sel]
8475 set mend $first.0
8476 while {1} {
8477 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8478 if {$match eq {}} break
8479 set mend "$match + $mlen c"
8480 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8481 $ctext tag add currentsearchhit $match $mend
8482 } else {
8483 $ctext tag add found $match $mend
8488 proc searchmarkvisible {doall} {
8489 global ctext smarktop smarkbot
8491 set topline [lindex [split [$ctext index @0,0] .] 0]
8492 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8493 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8494 # no overlap with previous
8495 searchmark $topline $botline
8496 set smarktop $topline
8497 set smarkbot $botline
8498 } else {
8499 if {$topline < $smarktop} {
8500 searchmark $topline [expr {$smarktop-1}]
8501 set smarktop $topline
8503 if {$botline > $smarkbot} {
8504 searchmark [expr {$smarkbot+1}] $botline
8505 set smarkbot $botline
8510 proc suppress_highlighting_file_for_current_scrollpos {} {
8511 global ctext suppress_highlighting_file_for_this_scrollpos
8513 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8516 proc scrolltext {f0 f1} {
8517 global searchstring cmitmode ctext
8518 global suppress_highlighting_file_for_this_scrollpos
8520 set topidx [$ctext index @0,0]
8521 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8522 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8523 highlightfile_for_scrollpos $topidx
8526 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8528 .bleft.bottom.sb set $f0 $f1
8529 if {$searchstring ne {}} {
8530 searchmarkvisible 0
8534 proc setcoords {} {
8535 global linespc charspc canvx0 canvy0
8536 global xspc1 xspc2 lthickness
8538 set linespc [font metrics mainfont -linespace]
8539 set charspc [font measure mainfont "m"]
8540 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8541 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8542 set lthickness [expr {int($linespc / 9) + 1}]
8543 set xspc1(0) $linespc
8544 set xspc2 $linespc
8547 proc redisplay {} {
8548 global canv
8549 global selectedline
8551 set ymax [lindex [$canv cget -scrollregion] 3]
8552 if {$ymax eq {} || $ymax == 0} return
8553 set span [$canv yview]
8554 clear_display
8555 setcanvscroll
8556 allcanvs yview moveto [lindex $span 0]
8557 drawvisible
8558 if {$selectedline ne {}} {
8559 selectline $selectedline 0
8560 allcanvs yview moveto [lindex $span 0]
8564 proc parsefont {f n} {
8565 global fontattr
8567 set fontattr($f,family) [lindex $n 0]
8568 set s [lindex $n 1]
8569 if {$s eq {} || $s == 0} {
8570 set s 10
8571 } elseif {$s < 0} {
8572 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8574 set fontattr($f,size) $s
8575 set fontattr($f,weight) normal
8576 set fontattr($f,slant) roman
8577 foreach style [lrange $n 2 end] {
8578 switch -- $style {
8579 "normal" -
8580 "bold" {set fontattr($f,weight) $style}
8581 "roman" -
8582 "italic" {set fontattr($f,slant) $style}
8587 proc fontflags {f {isbold 0}} {
8588 global fontattr
8590 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8591 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8592 -slant $fontattr($f,slant)]
8595 proc fontname {f} {
8596 global fontattr
8598 set n [list $fontattr($f,family) $fontattr($f,size)]
8599 if {$fontattr($f,weight) eq "bold"} {
8600 lappend n "bold"
8602 if {$fontattr($f,slant) eq "italic"} {
8603 lappend n "italic"
8605 return $n
8608 proc incrfont {inc} {
8609 global mainfont textfont ctext canv cflist showrefstop
8610 global stopped entries fontattr
8612 unmarkmatches
8613 set s $fontattr(mainfont,size)
8614 incr s $inc
8615 if {$s < 1} {
8616 set s 1
8618 set fontattr(mainfont,size) $s
8619 font config mainfont -size $s
8620 font config mainfontbold -size $s
8621 set mainfont [fontname mainfont]
8622 set s $fontattr(textfont,size)
8623 incr s $inc
8624 if {$s < 1} {
8625 set s 1
8627 set fontattr(textfont,size) $s
8628 font config textfont -size $s
8629 font config textfontbold -size $s
8630 set textfont [fontname textfont]
8631 setcoords
8632 settabs
8633 redisplay
8636 proc clearsha1 {} {
8637 global sha1entry sha1string
8638 if {[string length $sha1string] == 40} {
8639 $sha1entry delete 0 end
8643 proc sha1change {n1 n2 op} {
8644 global sha1string currentid sha1but
8645 if {$sha1string == {}
8646 || ([info exists currentid] && $sha1string == $currentid)} {
8647 set state disabled
8648 } else {
8649 set state normal
8651 if {[$sha1but cget -state] == $state} return
8652 if {$state == "normal"} {
8653 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8654 } else {
8655 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8659 proc gotocommit {} {
8660 global sha1string tagids headids curview varcid
8662 if {$sha1string == {}
8663 || ([info exists currentid] && $sha1string == $currentid)} return
8664 if {[info exists tagids($sha1string)]} {
8665 set id $tagids($sha1string)
8666 } elseif {[info exists headids($sha1string)]} {
8667 set id $headids($sha1string)
8668 } else {
8669 set id [string tolower $sha1string]
8670 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8671 set matches [longid $id]
8672 if {$matches ne {}} {
8673 if {[llength $matches] > 1} {
8674 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8675 return
8677 set id [lindex $matches 0]
8679 } else {
8680 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8681 error_popup [mc "Revision %s is not known" $sha1string]
8682 return
8686 if {[commitinview $id $curview]} {
8687 selectline [rowofcommit $id] 1
8688 return
8690 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8691 set msg [mc "SHA1 id %s is not known" $sha1string]
8692 } else {
8693 set msg [mc "Revision %s is not in the current view" $sha1string]
8695 error_popup $msg
8698 proc lineenter {x y id} {
8699 global hoverx hovery hoverid hovertimer
8700 global commitinfo canv
8702 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8703 set hoverx $x
8704 set hovery $y
8705 set hoverid $id
8706 if {[info exists hovertimer]} {
8707 after cancel $hovertimer
8709 set hovertimer [after 500 linehover]
8710 $canv delete hover
8713 proc linemotion {x y id} {
8714 global hoverx hovery hoverid hovertimer
8716 if {[info exists hoverid] && $id == $hoverid} {
8717 set hoverx $x
8718 set hovery $y
8719 if {[info exists hovertimer]} {
8720 after cancel $hovertimer
8722 set hovertimer [after 500 linehover]
8726 proc lineleave {id} {
8727 global hoverid hovertimer canv
8729 if {[info exists hoverid] && $id == $hoverid} {
8730 $canv delete hover
8731 if {[info exists hovertimer]} {
8732 after cancel $hovertimer
8733 unset hovertimer
8735 unset hoverid
8739 proc linehover {} {
8740 global hoverx hovery hoverid hovertimer
8741 global canv linespc lthickness
8742 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8744 global commitinfo
8746 set text [lindex $commitinfo($hoverid) 0]
8747 set ymax [lindex [$canv cget -scrollregion] 3]
8748 if {$ymax == {}} return
8749 set yfrac [lindex [$canv yview] 0]
8750 set x [expr {$hoverx + 2 * $linespc}]
8751 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8752 set x0 [expr {$x - 2 * $lthickness}]
8753 set y0 [expr {$y - 2 * $lthickness}]
8754 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8755 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8756 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8757 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8758 -width 1 -tags hover]
8759 $canv raise $t
8760 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8761 -font mainfont -fill $linehoverfgcolor]
8762 $canv raise $t
8765 proc clickisonarrow {id y} {
8766 global lthickness
8768 set ranges [rowranges $id]
8769 set thresh [expr {2 * $lthickness + 6}]
8770 set n [expr {[llength $ranges] - 1}]
8771 for {set i 1} {$i < $n} {incr i} {
8772 set row [lindex $ranges $i]
8773 if {abs([yc $row] - $y) < $thresh} {
8774 return $i
8777 return {}
8780 proc arrowjump {id n y} {
8781 global canv
8783 # 1 <-> 2, 3 <-> 4, etc...
8784 set n [expr {(($n - 1) ^ 1) + 1}]
8785 set row [lindex [rowranges $id] $n]
8786 set yt [yc $row]
8787 set ymax [lindex [$canv cget -scrollregion] 3]
8788 if {$ymax eq {} || $ymax <= 0} return
8789 set view [$canv yview]
8790 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8791 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8792 if {$yfrac < 0} {
8793 set yfrac 0
8795 allcanvs yview moveto $yfrac
8798 proc lineclick {x y id isnew} {
8799 global ctext commitinfo children canv thickerline curview
8801 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8802 unmarkmatches
8803 unselectline
8804 normalline
8805 $canv delete hover
8806 # draw this line thicker than normal
8807 set thickerline $id
8808 drawlines $id
8809 if {$isnew} {
8810 set ymax [lindex [$canv cget -scrollregion] 3]
8811 if {$ymax eq {}} return
8812 set yfrac [lindex [$canv yview] 0]
8813 set y [expr {$y + $yfrac * $ymax}]
8815 set dirn [clickisonarrow $id $y]
8816 if {$dirn ne {}} {
8817 arrowjump $id $dirn $y
8818 return
8821 if {$isnew} {
8822 addtohistory [list lineclick $x $y $id 0] savectextpos
8824 # fill the details pane with info about this line
8825 $ctext conf -state normal
8826 clear_ctext
8827 settabs 0
8828 $ctext insert end "[mc "Parent"]:\t"
8829 $ctext insert end $id link0
8830 setlink $id link0
8831 set info $commitinfo($id)
8832 $ctext insert end "\n\t[lindex $info 0]\n"
8833 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8834 set date [formatdate [lindex $info 2]]
8835 $ctext insert end "\t[mc "Date"]:\t$date\n"
8836 set kids $children($curview,$id)
8837 if {$kids ne {}} {
8838 $ctext insert end "\n[mc "Children"]:"
8839 set i 0
8840 foreach child $kids {
8841 incr i
8842 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8843 set info $commitinfo($child)
8844 $ctext insert end "\n\t"
8845 $ctext insert end $child link$i
8846 setlink $child link$i
8847 $ctext insert end "\n\t[lindex $info 0]"
8848 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8849 set date [formatdate [lindex $info 2]]
8850 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8853 maybe_scroll_ctext 1
8854 $ctext conf -state disabled
8855 init_flist {}
8858 proc normalline {} {
8859 global thickerline
8860 if {[info exists thickerline]} {
8861 set id $thickerline
8862 unset thickerline
8863 drawlines $id
8867 proc selbyid {id {isnew 1}} {
8868 global curview
8869 if {[commitinview $id $curview]} {
8870 selectline [rowofcommit $id] $isnew
8874 proc mstime {} {
8875 global startmstime
8876 if {![info exists startmstime]} {
8877 set startmstime [clock clicks -milliseconds]
8879 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8882 proc rowmenu {x y id} {
8883 global rowctxmenu selectedline rowmenuid curview
8884 global nullid nullid2 fakerowmenu mainhead markedid
8886 stopfinding
8887 set rowmenuid $id
8888 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8889 set state disabled
8890 } else {
8891 set state normal
8893 if {[info exists markedid] && $markedid ne $id} {
8894 set mstate normal
8895 } else {
8896 set mstate disabled
8898 if {$id ne $nullid && $id ne $nullid2} {
8899 set menu $rowctxmenu
8900 if {$mainhead ne {}} {
8901 $menu entryconfigure 8 -label [mc "Reset %s branch to here" $mainhead] -state normal
8902 } else {
8903 $menu entryconfigure 8 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8905 $menu entryconfigure 10 -state $mstate
8906 $menu entryconfigure 11 -state $mstate
8907 $menu entryconfigure 12 -state $mstate
8908 } else {
8909 set menu $fakerowmenu
8911 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8912 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8913 $menu entryconfigure [mca "Make patch"] -state $state
8914 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8915 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8916 tk_popup $menu $x $y
8919 proc markhere {} {
8920 global rowmenuid markedid canv
8922 set markedid $rowmenuid
8923 make_idmark $markedid
8926 proc gotomark {} {
8927 global markedid
8929 if {[info exists markedid]} {
8930 selbyid $markedid
8934 proc replace_by_kids {l r} {
8935 global curview children
8937 set id [commitonrow $r]
8938 set l [lreplace $l 0 0]
8939 foreach kid $children($curview,$id) {
8940 lappend l [rowofcommit $kid]
8942 return [lsort -integer -decreasing -unique $l]
8945 proc find_common_desc {} {
8946 global markedid rowmenuid curview children
8948 if {![info exists markedid]} return
8949 if {![commitinview $markedid $curview] ||
8950 ![commitinview $rowmenuid $curview]} return
8951 #set t1 [clock clicks -milliseconds]
8952 set l1 [list [rowofcommit $markedid]]
8953 set l2 [list [rowofcommit $rowmenuid]]
8954 while 1 {
8955 set r1 [lindex $l1 0]
8956 set r2 [lindex $l2 0]
8957 if {$r1 eq {} || $r2 eq {}} break
8958 if {$r1 == $r2} {
8959 selectline $r1 1
8960 break
8962 if {$r1 > $r2} {
8963 set l1 [replace_by_kids $l1 $r1]
8964 } else {
8965 set l2 [replace_by_kids $l2 $r2]
8968 #set t2 [clock clicks -milliseconds]
8969 #puts "took [expr {$t2-$t1}]ms"
8972 proc compare_commits {} {
8973 global markedid rowmenuid curview children
8975 if {![info exists markedid]} return
8976 if {![commitinview $markedid $curview]} return
8977 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8978 do_cmp_commits $markedid $rowmenuid
8981 proc getpatchid {id} {
8982 global patchids
8984 if {![info exists patchids($id)]} {
8985 set cmd [diffcmd [list $id] {-p --root}]
8986 # trim off the initial "|"
8987 set cmd [lrange $cmd 1 end]
8988 if {[catch {
8989 set x [eval exec $cmd | git patch-id]
8990 set patchids($id) [lindex $x 0]
8991 }]} {
8992 set patchids($id) "error"
8995 return $patchids($id)
8998 proc do_cmp_commits {a b} {
8999 global ctext curview parents children patchids commitinfo
9001 $ctext conf -state normal
9002 clear_ctext
9003 init_flist {}
9004 for {set i 0} {$i < 100} {incr i} {
9005 set skipa 0
9006 set skipb 0
9007 if {[llength $parents($curview,$a)] > 1} {
9008 appendshortlink $a [mc "Skipping merge commit "] "\n"
9009 set skipa 1
9010 } else {
9011 set patcha [getpatchid $a]
9013 if {[llength $parents($curview,$b)] > 1} {
9014 appendshortlink $b [mc "Skipping merge commit "] "\n"
9015 set skipb 1
9016 } else {
9017 set patchb [getpatchid $b]
9019 if {!$skipa && !$skipb} {
9020 set heada [lindex $commitinfo($a) 0]
9021 set headb [lindex $commitinfo($b) 0]
9022 if {$patcha eq "error"} {
9023 appendshortlink $a [mc "Error getting patch ID for "] \
9024 [mc " - stopping\n"]
9025 break
9027 if {$patchb eq "error"} {
9028 appendshortlink $b [mc "Error getting patch ID for "] \
9029 [mc " - stopping\n"]
9030 break
9032 if {$patcha eq $patchb} {
9033 if {$heada eq $headb} {
9034 appendshortlink $a [mc "Commit "]
9035 appendshortlink $b " == " " $heada\n"
9036 } else {
9037 appendshortlink $a [mc "Commit "] " $heada\n"
9038 appendshortlink $b [mc " is the same patch as\n "] \
9039 " $headb\n"
9041 set skipa 1
9042 set skipb 1
9043 } else {
9044 $ctext insert end "\n"
9045 appendshortlink $a [mc "Commit "] " $heada\n"
9046 appendshortlink $b [mc " differs from\n "] \
9047 " $headb\n"
9048 $ctext insert end [mc "Diff of commits:\n\n"]
9049 $ctext conf -state disabled
9050 update
9051 diffcommits $a $b
9052 return
9055 if {$skipa} {
9056 set kids [real_children $curview,$a]
9057 if {[llength $kids] != 1} {
9058 $ctext insert end "\n"
9059 appendshortlink $a [mc "Commit "] \
9060 [mc " has %s children - stopping\n" [llength $kids]]
9061 break
9063 set a [lindex $kids 0]
9065 if {$skipb} {
9066 set kids [real_children $curview,$b]
9067 if {[llength $kids] != 1} {
9068 appendshortlink $b [mc "Commit "] \
9069 [mc " has %s children - stopping\n" [llength $kids]]
9070 break
9072 set b [lindex $kids 0]
9075 $ctext conf -state disabled
9078 proc diffcommits {a b} {
9079 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9081 set tmpdir [gitknewtmpdir]
9082 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9083 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9084 if {[catch {
9085 exec git diff-tree -p --pretty $a >$fna
9086 exec git diff-tree -p --pretty $b >$fnb
9087 } err]} {
9088 error_popup [mc "Error writing commit to file: %s" $err]
9089 return
9091 if {[catch {
9092 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9093 } err]} {
9094 error_popup [mc "Error diffing commits: %s" $err]
9095 return
9097 set diffids [list commits $a $b]
9098 set blobdifffd($diffids) $fd
9099 set diffinhdr 0
9100 set currdiffsubmod ""
9101 filerun $fd [list getblobdiffline $fd $diffids]
9104 proc diffvssel {dirn} {
9105 global rowmenuid selectedline
9107 if {$selectedline eq {}} return
9108 if {$dirn} {
9109 set oldid [commitonrow $selectedline]
9110 set newid $rowmenuid
9111 } else {
9112 set oldid $rowmenuid
9113 set newid [commitonrow $selectedline]
9115 addtohistory [list doseldiff $oldid $newid] savectextpos
9116 doseldiff $oldid $newid
9119 proc diffvsmark {dirn} {
9120 global rowmenuid markedid
9122 if {![info exists markedid]} return
9123 if {$dirn} {
9124 set oldid $markedid
9125 set newid $rowmenuid
9126 } else {
9127 set oldid $rowmenuid
9128 set newid $markedid
9130 addtohistory [list doseldiff $oldid $newid] savectextpos
9131 doseldiff $oldid $newid
9134 proc doseldiff {oldid newid} {
9135 global ctext
9136 global commitinfo
9138 $ctext conf -state normal
9139 clear_ctext
9140 init_flist [mc "Top"]
9141 $ctext insert end "[mc "From"] "
9142 $ctext insert end $oldid link0
9143 setlink $oldid link0
9144 $ctext insert end "\n "
9145 $ctext insert end [lindex $commitinfo($oldid) 0]
9146 $ctext insert end "\n\n[mc "To"] "
9147 $ctext insert end $newid link1
9148 setlink $newid link1
9149 $ctext insert end "\n "
9150 $ctext insert end [lindex $commitinfo($newid) 0]
9151 $ctext insert end "\n"
9152 $ctext conf -state disabled
9153 $ctext tag remove found 1.0 end
9154 startdiff [list $oldid $newid]
9157 proc mkpatch {} {
9158 global rowmenuid currentid commitinfo patchtop patchnum NS
9160 if {![info exists currentid]} return
9161 set oldid $currentid
9162 set oldhead [lindex $commitinfo($oldid) 0]
9163 set newid $rowmenuid
9164 set newhead [lindex $commitinfo($newid) 0]
9165 set top .patch
9166 set patchtop $top
9167 catch {destroy $top}
9168 ttk_toplevel $top
9169 make_transient $top .
9170 ${NS}::label $top.title -text [mc "Generate patch"]
9171 grid $top.title - -pady 10
9172 ${NS}::label $top.from -text [mc "From:"]
9173 ${NS}::entry $top.fromsha1 -width 40
9174 $top.fromsha1 insert 0 $oldid
9175 $top.fromsha1 conf -state readonly
9176 grid $top.from $top.fromsha1 -sticky w
9177 ${NS}::entry $top.fromhead -width 60
9178 $top.fromhead insert 0 $oldhead
9179 $top.fromhead conf -state readonly
9180 grid x $top.fromhead -sticky w
9181 ${NS}::label $top.to -text [mc "To:"]
9182 ${NS}::entry $top.tosha1 -width 40
9183 $top.tosha1 insert 0 $newid
9184 $top.tosha1 conf -state readonly
9185 grid $top.to $top.tosha1 -sticky w
9186 ${NS}::entry $top.tohead -width 60
9187 $top.tohead insert 0 $newhead
9188 $top.tohead conf -state readonly
9189 grid x $top.tohead -sticky w
9190 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9191 grid $top.rev x -pady 10 -padx 5
9192 ${NS}::label $top.flab -text [mc "Output file:"]
9193 ${NS}::entry $top.fname -width 60
9194 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9195 incr patchnum
9196 grid $top.flab $top.fname -sticky w
9197 ${NS}::frame $top.buts
9198 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9199 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9200 bind $top <Key-Return> mkpatchgo
9201 bind $top <Key-Escape> mkpatchcan
9202 grid $top.buts.gen $top.buts.can
9203 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9204 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9205 grid $top.buts - -pady 10 -sticky ew
9206 focus $top.fname
9209 proc mkpatchrev {} {
9210 global patchtop
9212 set oldid [$patchtop.fromsha1 get]
9213 set oldhead [$patchtop.fromhead get]
9214 set newid [$patchtop.tosha1 get]
9215 set newhead [$patchtop.tohead get]
9216 foreach e [list fromsha1 fromhead tosha1 tohead] \
9217 v [list $newid $newhead $oldid $oldhead] {
9218 $patchtop.$e conf -state normal
9219 $patchtop.$e delete 0 end
9220 $patchtop.$e insert 0 $v
9221 $patchtop.$e conf -state readonly
9225 proc mkpatchgo {} {
9226 global patchtop nullid nullid2
9228 set oldid [$patchtop.fromsha1 get]
9229 set newid [$patchtop.tosha1 get]
9230 set fname [$patchtop.fname get]
9231 set cmd [diffcmd [list $oldid $newid] -p]
9232 # trim off the initial "|"
9233 set cmd [lrange $cmd 1 end]
9234 lappend cmd >$fname &
9235 if {[catch {eval exec $cmd} err]} {
9236 error_popup "[mc "Error creating patch:"] $err" $patchtop
9238 catch {destroy $patchtop}
9239 unset patchtop
9242 proc mkpatchcan {} {
9243 global patchtop
9245 catch {destroy $patchtop}
9246 unset patchtop
9249 proc mktag {} {
9250 global rowmenuid mktagtop commitinfo NS
9252 set top .maketag
9253 set mktagtop $top
9254 catch {destroy $top}
9255 ttk_toplevel $top
9256 make_transient $top .
9257 ${NS}::label $top.title -text [mc "Create tag"]
9258 grid $top.title - -pady 10
9259 ${NS}::label $top.id -text [mc "ID:"]
9260 ${NS}::entry $top.sha1 -width 40
9261 $top.sha1 insert 0 $rowmenuid
9262 $top.sha1 conf -state readonly
9263 grid $top.id $top.sha1 -sticky w
9264 ${NS}::entry $top.head -width 60
9265 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9266 $top.head conf -state readonly
9267 grid x $top.head -sticky w
9268 ${NS}::label $top.tlab -text [mc "Tag name:"]
9269 ${NS}::entry $top.tag -width 60
9270 grid $top.tlab $top.tag -sticky w
9271 ${NS}::label $top.op -text [mc "Tag message is optional"]
9272 grid $top.op -columnspan 2 -sticky we
9273 ${NS}::label $top.mlab -text [mc "Tag message:"]
9274 ${NS}::entry $top.msg -width 60
9275 grid $top.mlab $top.msg -sticky w
9276 ${NS}::frame $top.buts
9277 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9278 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9279 bind $top <Key-Return> mktaggo
9280 bind $top <Key-Escape> mktagcan
9281 grid $top.buts.gen $top.buts.can
9282 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9283 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9284 grid $top.buts - -pady 10 -sticky ew
9285 focus $top.tag
9288 proc domktag {} {
9289 global mktagtop env tagids idtags
9291 set id [$mktagtop.sha1 get]
9292 set tag [$mktagtop.tag get]
9293 set msg [$mktagtop.msg get]
9294 if {$tag == {}} {
9295 error_popup [mc "No tag name specified"] $mktagtop
9296 return 0
9298 if {[info exists tagids($tag)]} {
9299 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9300 return 0
9302 if {[catch {
9303 if {$msg != {}} {
9304 exec git tag -a -m $msg $tag $id
9305 } else {
9306 exec git tag $tag $id
9308 } err]} {
9309 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9310 return 0
9313 set tagids($tag) $id
9314 lappend idtags($id) $tag
9315 redrawtags $id
9316 addedtag $id
9317 dispneartags 0
9318 run refill_reflist
9319 return 1
9322 proc redrawtags {id} {
9323 global canv linehtag idpos currentid curview cmitlisted markedid
9324 global canvxmax iddrawn circleitem mainheadid circlecolors
9325 global mainheadcirclecolor
9327 if {![commitinview $id $curview]} return
9328 if {![info exists iddrawn($id)]} return
9329 set row [rowofcommit $id]
9330 if {$id eq $mainheadid} {
9331 set ofill $mainheadcirclecolor
9332 } else {
9333 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9335 $canv itemconf $circleitem($row) -fill $ofill
9336 $canv delete tag.$id
9337 set xt [eval drawtags $id $idpos($id)]
9338 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9339 set text [$canv itemcget $linehtag($id) -text]
9340 set font [$canv itemcget $linehtag($id) -font]
9341 set xr [expr {$xt + [font measure $font $text]}]
9342 if {$xr > $canvxmax} {
9343 set canvxmax $xr
9344 setcanvscroll
9346 if {[info exists currentid] && $currentid == $id} {
9347 make_secsel $id
9349 if {[info exists markedid] && $markedid eq $id} {
9350 make_idmark $id
9354 proc mktagcan {} {
9355 global mktagtop
9357 catch {destroy $mktagtop}
9358 unset mktagtop
9361 proc mktaggo {} {
9362 if {![domktag]} return
9363 mktagcan
9366 proc copysummary {} {
9367 global rowmenuid autosellen
9369 set format "%h (\"%s\", %ad)"
9370 set cmd [list git show -s --pretty=format:$format --date=short]
9371 if {$autosellen < 40} {
9372 lappend cmd --abbrev=$autosellen
9374 set summary [eval exec $cmd $rowmenuid]
9376 clipboard clear
9377 clipboard append $summary
9380 proc writecommit {} {
9381 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9383 set top .writecommit
9384 set wrcomtop $top
9385 catch {destroy $top}
9386 ttk_toplevel $top
9387 make_transient $top .
9388 ${NS}::label $top.title -text [mc "Write commit to file"]
9389 grid $top.title - -pady 10
9390 ${NS}::label $top.id -text [mc "ID:"]
9391 ${NS}::entry $top.sha1 -width 40
9392 $top.sha1 insert 0 $rowmenuid
9393 $top.sha1 conf -state readonly
9394 grid $top.id $top.sha1 -sticky w
9395 ${NS}::entry $top.head -width 60
9396 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9397 $top.head conf -state readonly
9398 grid x $top.head -sticky w
9399 ${NS}::label $top.clab -text [mc "Command:"]
9400 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9401 grid $top.clab $top.cmd -sticky w -pady 10
9402 ${NS}::label $top.flab -text [mc "Output file:"]
9403 ${NS}::entry $top.fname -width 60
9404 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9405 grid $top.flab $top.fname -sticky w
9406 ${NS}::frame $top.buts
9407 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9408 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9409 bind $top <Key-Return> wrcomgo
9410 bind $top <Key-Escape> wrcomcan
9411 grid $top.buts.gen $top.buts.can
9412 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9413 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9414 grid $top.buts - -pady 10 -sticky ew
9415 focus $top.fname
9418 proc wrcomgo {} {
9419 global wrcomtop
9421 set id [$wrcomtop.sha1 get]
9422 set cmd "echo $id | [$wrcomtop.cmd get]"
9423 set fname [$wrcomtop.fname get]
9424 if {[catch {exec sh -c $cmd >$fname &} err]} {
9425 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9427 catch {destroy $wrcomtop}
9428 unset wrcomtop
9431 proc wrcomcan {} {
9432 global wrcomtop
9434 catch {destroy $wrcomtop}
9435 unset wrcomtop
9438 proc mkbranch {} {
9439 global rowmenuid mkbrtop NS
9441 set top .makebranch
9442 catch {destroy $top}
9443 ttk_toplevel $top
9444 make_transient $top .
9445 ${NS}::label $top.title -text [mc "Create new branch"]
9446 grid $top.title - -pady 10
9447 ${NS}::label $top.id -text [mc "ID:"]
9448 ${NS}::entry $top.sha1 -width 40
9449 $top.sha1 insert 0 $rowmenuid
9450 $top.sha1 conf -state readonly
9451 grid $top.id $top.sha1 -sticky w
9452 ${NS}::label $top.nlab -text [mc "Name:"]
9453 ${NS}::entry $top.name -width 40
9454 grid $top.nlab $top.name -sticky w
9455 ${NS}::frame $top.buts
9456 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9457 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9458 bind $top <Key-Return> [list mkbrgo $top]
9459 bind $top <Key-Escape> "catch {destroy $top}"
9460 grid $top.buts.go $top.buts.can
9461 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9462 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9463 grid $top.buts - -pady 10 -sticky ew
9464 focus $top.name
9467 proc mkbrgo {top} {
9468 global headids idheads
9470 set name [$top.name get]
9471 set id [$top.sha1 get]
9472 set cmdargs {}
9473 set old_id {}
9474 if {$name eq {}} {
9475 error_popup [mc "Please specify a name for the new branch"] $top
9476 return
9478 if {[info exists headids($name)]} {
9479 if {![confirm_popup [mc \
9480 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9481 return
9483 set old_id $headids($name)
9484 lappend cmdargs -f
9486 catch {destroy $top}
9487 lappend cmdargs $name $id
9488 nowbusy newbranch
9489 update
9490 if {[catch {
9491 eval exec git branch $cmdargs
9492 } err]} {
9493 notbusy newbranch
9494 error_popup $err
9495 } else {
9496 notbusy newbranch
9497 if {$old_id ne {}} {
9498 movehead $id $name
9499 movedhead $id $name
9500 redrawtags $old_id
9501 redrawtags $id
9502 } else {
9503 set headids($name) $id
9504 lappend idheads($id) $name
9505 addedhead $id $name
9506 redrawtags $id
9508 dispneartags 0
9509 run refill_reflist
9513 proc exec_citool {tool_args {baseid {}}} {
9514 global commitinfo env
9516 set save_env [array get env GIT_AUTHOR_*]
9518 if {$baseid ne {}} {
9519 if {![info exists commitinfo($baseid)]} {
9520 getcommit $baseid
9522 set author [lindex $commitinfo($baseid) 1]
9523 set date [lindex $commitinfo($baseid) 2]
9524 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9525 $author author name email]
9526 && $date ne {}} {
9527 set env(GIT_AUTHOR_NAME) $name
9528 set env(GIT_AUTHOR_EMAIL) $email
9529 set env(GIT_AUTHOR_DATE) $date
9533 eval exec git citool $tool_args &
9535 array unset env GIT_AUTHOR_*
9536 array set env $save_env
9539 proc cherrypick {} {
9540 global rowmenuid curview
9541 global mainhead mainheadid
9542 global gitdir
9544 set oldhead [exec git rev-parse HEAD]
9545 set dheads [descheads $rowmenuid]
9546 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9547 set ok [confirm_popup [mc "Commit %s is already\
9548 included in branch %s -- really re-apply it?" \
9549 [string range $rowmenuid 0 7] $mainhead]]
9550 if {!$ok} return
9552 nowbusy cherrypick [mc "Cherry-picking"]
9553 update
9554 # Unfortunately git-cherry-pick writes stuff to stderr even when
9555 # no error occurs, and exec takes that as an indication of error...
9556 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9557 notbusy cherrypick
9558 if {[regexp -line \
9559 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9560 $err msg fname]} {
9561 error_popup [mc "Cherry-pick failed because of local changes\
9562 to file '%s'.\nPlease commit, reset or stash\
9563 your changes and try again." $fname]
9564 } elseif {[regexp -line \
9565 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9566 $err]} {
9567 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9568 conflict.\nDo you wish to run git citool to\
9569 resolve it?"]]} {
9570 # Force citool to read MERGE_MSG
9571 file delete [file join $gitdir "GITGUI_MSG"]
9572 exec_citool {} $rowmenuid
9574 } else {
9575 error_popup $err
9577 run updatecommits
9578 return
9580 set newhead [exec git rev-parse HEAD]
9581 if {$newhead eq $oldhead} {
9582 notbusy cherrypick
9583 error_popup [mc "No changes committed"]
9584 return
9586 addnewchild $newhead $oldhead
9587 if {[commitinview $oldhead $curview]} {
9588 # XXX this isn't right if we have a path limit...
9589 insertrow $newhead $oldhead $curview
9590 if {$mainhead ne {}} {
9591 movehead $newhead $mainhead
9592 movedhead $newhead $mainhead
9594 set mainheadid $newhead
9595 redrawtags $oldhead
9596 redrawtags $newhead
9597 selbyid $newhead
9599 notbusy cherrypick
9602 proc revert {} {
9603 global rowmenuid curview
9604 global mainhead mainheadid
9605 global gitdir
9607 set oldhead [exec git rev-parse HEAD]
9608 set dheads [descheads $rowmenuid]
9609 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9610 set ok [confirm_popup [mc "Commit %s is not\
9611 included in branch %s -- really revert it?" \
9612 [string range $rowmenuid 0 7] $mainhead]]
9613 if {!$ok} return
9615 nowbusy revert [mc "Reverting"]
9616 update
9618 if [catch {exec git revert --no-edit $rowmenuid} err] {
9619 notbusy revert
9620 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9621 $err match files] {
9622 regsub {\n( |\t)+} $files "\n" files
9623 error_popup [mc "Revert failed because of local changes to\
9624 the following files:%s Please commit, reset or stash \
9625 your changes and try again." $files]
9626 } elseif [regexp {error: could not revert} $err] {
9627 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9628 Do you wish to run git citool to resolve it?"]] {
9629 # Force citool to read MERGE_MSG
9630 file delete [file join $gitdir "GITGUI_MSG"]
9631 exec_citool {} $rowmenuid
9633 } else { error_popup $err }
9634 run updatecommits
9635 return
9638 set newhead [exec git rev-parse HEAD]
9639 if { $newhead eq $oldhead } {
9640 notbusy revert
9641 error_popup [mc "No changes committed"]
9642 return
9645 addnewchild $newhead $oldhead
9647 if [commitinview $oldhead $curview] {
9648 # XXX this isn't right if we have a path limit...
9649 insertrow $newhead $oldhead $curview
9650 if {$mainhead ne {}} {
9651 movehead $newhead $mainhead
9652 movedhead $newhead $mainhead
9654 set mainheadid $newhead
9655 redrawtags $oldhead
9656 redrawtags $newhead
9657 selbyid $newhead
9660 notbusy revert
9663 proc resethead {} {
9664 global mainhead rowmenuid confirm_ok resettype NS
9666 set confirm_ok 0
9667 set w ".confirmreset"
9668 ttk_toplevel $w
9669 make_transient $w .
9670 wm title $w [mc "Confirm reset"]
9671 ${NS}::label $w.m -text \
9672 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9673 pack $w.m -side top -fill x -padx 20 -pady 20
9674 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9675 set resettype mixed
9676 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9677 -text [mc "Soft: Leave working tree and index untouched"]
9678 grid $w.f.soft -sticky w
9679 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9680 -text [mc "Mixed: Leave working tree untouched, reset index"]
9681 grid $w.f.mixed -sticky w
9682 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9683 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9684 grid $w.f.hard -sticky w
9685 pack $w.f -side top -fill x -padx 4
9686 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9687 pack $w.ok -side left -fill x -padx 20 -pady 20
9688 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9689 bind $w <Key-Escape> [list destroy $w]
9690 pack $w.cancel -side right -fill x -padx 20 -pady 20
9691 bind $w <Visibility> "grab $w; focus $w"
9692 tkwait window $w
9693 if {!$confirm_ok} return
9694 if {[catch {set fd [open \
9695 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9696 error_popup $err
9697 } else {
9698 dohidelocalchanges
9699 filerun $fd [list readresetstat $fd]
9700 nowbusy reset [mc "Resetting"]
9701 selbyid $rowmenuid
9705 proc readresetstat {fd} {
9706 global mainhead mainheadid showlocalchanges rprogcoord
9708 if {[gets $fd line] >= 0} {
9709 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9710 set rprogcoord [expr {1.0 * $m / $n}]
9711 adjustprogress
9713 return 1
9715 set rprogcoord 0
9716 adjustprogress
9717 notbusy reset
9718 if {[catch {close $fd} err]} {
9719 error_popup $err
9721 set oldhead $mainheadid
9722 set newhead [exec git rev-parse HEAD]
9723 if {$newhead ne $oldhead} {
9724 movehead $newhead $mainhead
9725 movedhead $newhead $mainhead
9726 set mainheadid $newhead
9727 redrawtags $oldhead
9728 redrawtags $newhead
9730 if {$showlocalchanges} {
9731 doshowlocalchanges
9733 return 0
9736 # context menu for a head
9737 proc headmenu {x y id head} {
9738 global headmenuid headmenuhead headctxmenu mainhead
9740 stopfinding
9741 set headmenuid $id
9742 set headmenuhead $head
9743 set state normal
9744 if {[string match "remotes/*" $head]} {
9745 set state disabled
9747 if {$head eq $mainhead} {
9748 set state disabled
9750 $headctxmenu entryconfigure 0 -state $state
9751 $headctxmenu entryconfigure 1 -state $state
9752 tk_popup $headctxmenu $x $y
9755 proc cobranch {} {
9756 global headmenuid headmenuhead headids
9757 global showlocalchanges
9759 # check the tree is clean first??
9760 nowbusy checkout [mc "Checking out"]
9761 update
9762 dohidelocalchanges
9763 if {[catch {
9764 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9765 } err]} {
9766 notbusy checkout
9767 error_popup $err
9768 if {$showlocalchanges} {
9769 dodiffindex
9771 } else {
9772 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9776 proc readcheckoutstat {fd newhead newheadid} {
9777 global mainhead mainheadid headids showlocalchanges progresscoords
9778 global viewmainheadid curview
9780 if {[gets $fd line] >= 0} {
9781 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9782 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9783 adjustprogress
9785 return 1
9787 set progresscoords {0 0}
9788 adjustprogress
9789 notbusy checkout
9790 if {[catch {close $fd} err]} {
9791 error_popup $err
9793 set oldmainid $mainheadid
9794 set mainhead $newhead
9795 set mainheadid $newheadid
9796 set viewmainheadid($curview) $newheadid
9797 redrawtags $oldmainid
9798 redrawtags $newheadid
9799 selbyid $newheadid
9800 if {$showlocalchanges} {
9801 dodiffindex
9805 proc rmbranch {} {
9806 global headmenuid headmenuhead mainhead
9807 global idheads
9809 set head $headmenuhead
9810 set id $headmenuid
9811 # this check shouldn't be needed any more...
9812 if {$head eq $mainhead} {
9813 error_popup [mc "Cannot delete the currently checked-out branch"]
9814 return
9816 set dheads [descheads $id]
9817 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9818 # the stuff on this branch isn't on any other branch
9819 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9820 branch.\nReally delete branch %s?" $head $head]]} return
9822 nowbusy rmbranch
9823 update
9824 if {[catch {exec git branch -D $head} err]} {
9825 notbusy rmbranch
9826 error_popup $err
9827 return
9829 removehead $id $head
9830 removedhead $id $head
9831 redrawtags $id
9832 notbusy rmbranch
9833 dispneartags 0
9834 run refill_reflist
9837 # Display a list of tags and heads
9838 proc showrefs {} {
9839 global showrefstop bgcolor fgcolor selectbgcolor NS
9840 global bglist fglist reflistfilter reflist maincursor
9842 set top .showrefs
9843 set showrefstop $top
9844 if {[winfo exists $top]} {
9845 raise $top
9846 refill_reflist
9847 return
9849 ttk_toplevel $top
9850 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9851 make_transient $top .
9852 text $top.list -background $bgcolor -foreground $fgcolor \
9853 -selectbackground $selectbgcolor -font mainfont \
9854 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9855 -width 30 -height 20 -cursor $maincursor \
9856 -spacing1 1 -spacing3 1 -state disabled
9857 $top.list tag configure highlight -background $selectbgcolor
9858 if {![lsearch -exact $bglist $top.list]} {
9859 lappend bglist $top.list
9860 lappend fglist $top.list
9862 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9863 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9864 grid $top.list $top.ysb -sticky nsew
9865 grid $top.xsb x -sticky ew
9866 ${NS}::frame $top.f
9867 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9868 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9869 set reflistfilter "*"
9870 trace add variable reflistfilter write reflistfilter_change
9871 pack $top.f.e -side right -fill x -expand 1
9872 pack $top.f.l -side left
9873 grid $top.f - -sticky ew -pady 2
9874 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9875 bind $top <Key-Escape> [list destroy $top]
9876 grid $top.close -
9877 grid columnconfigure $top 0 -weight 1
9878 grid rowconfigure $top 0 -weight 1
9879 bind $top.list <1> {break}
9880 bind $top.list <B1-Motion> {break}
9881 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9882 set reflist {}
9883 refill_reflist
9886 proc sel_reflist {w x y} {
9887 global showrefstop reflist headids tagids otherrefids
9889 if {![winfo exists $showrefstop]} return
9890 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9891 set ref [lindex $reflist [expr {$l-1}]]
9892 set n [lindex $ref 0]
9893 switch -- [lindex $ref 1] {
9894 "H" {selbyid $headids($n)}
9895 "T" {selbyid $tagids($n)}
9896 "o" {selbyid $otherrefids($n)}
9898 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9901 proc unsel_reflist {} {
9902 global showrefstop
9904 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9905 $showrefstop.list tag remove highlight 0.0 end
9908 proc reflistfilter_change {n1 n2 op} {
9909 global reflistfilter
9911 after cancel refill_reflist
9912 after 200 refill_reflist
9915 proc refill_reflist {} {
9916 global reflist reflistfilter showrefstop headids tagids otherrefids
9917 global curview
9919 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9920 set refs {}
9921 foreach n [array names headids] {
9922 if {[string match $reflistfilter $n]} {
9923 if {[commitinview $headids($n) $curview]} {
9924 lappend refs [list $n H]
9925 } else {
9926 interestedin $headids($n) {run refill_reflist}
9930 foreach n [array names tagids] {
9931 if {[string match $reflistfilter $n]} {
9932 if {[commitinview $tagids($n) $curview]} {
9933 lappend refs [list $n T]
9934 } else {
9935 interestedin $tagids($n) {run refill_reflist}
9939 foreach n [array names otherrefids] {
9940 if {[string match $reflistfilter $n]} {
9941 if {[commitinview $otherrefids($n) $curview]} {
9942 lappend refs [list $n o]
9943 } else {
9944 interestedin $otherrefids($n) {run refill_reflist}
9948 set refs [lsort -index 0 $refs]
9949 if {$refs eq $reflist} return
9951 # Update the contents of $showrefstop.list according to the
9952 # differences between $reflist (old) and $refs (new)
9953 $showrefstop.list conf -state normal
9954 $showrefstop.list insert end "\n"
9955 set i 0
9956 set j 0
9957 while {$i < [llength $reflist] || $j < [llength $refs]} {
9958 if {$i < [llength $reflist]} {
9959 if {$j < [llength $refs]} {
9960 set cmp [string compare [lindex $reflist $i 0] \
9961 [lindex $refs $j 0]]
9962 if {$cmp == 0} {
9963 set cmp [string compare [lindex $reflist $i 1] \
9964 [lindex $refs $j 1]]
9966 } else {
9967 set cmp -1
9969 } else {
9970 set cmp 1
9972 switch -- $cmp {
9973 -1 {
9974 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9975 incr i
9978 incr i
9979 incr j
9982 set l [expr {$j + 1}]
9983 $showrefstop.list image create $l.0 -align baseline \
9984 -image reficon-[lindex $refs $j 1] -padx 2
9985 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9986 incr j
9990 set reflist $refs
9991 # delete last newline
9992 $showrefstop.list delete end-2c end-1c
9993 $showrefstop.list conf -state disabled
9996 # Stuff for finding nearby tags
9997 proc getallcommits {} {
9998 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9999 global idheads idtags idotherrefs allparents tagobjid
10000 global gitdir
10002 if {![info exists allcommits]} {
10003 set nextarc 0
10004 set allcommits 0
10005 set seeds {}
10006 set allcwait 0
10007 set cachedarcs 0
10008 set allccache [file join $gitdir "gitk.cache"]
10009 if {![catch {
10010 set f [open $allccache r]
10011 set allcwait 1
10012 getcache $f
10013 }]} return
10016 if {$allcwait} {
10017 return
10019 set cmd [list | git rev-list --parents]
10020 set allcupdate [expr {$seeds ne {}}]
10021 if {!$allcupdate} {
10022 set ids "--all"
10023 } else {
10024 set refs [concat [array names idheads] [array names idtags] \
10025 [array names idotherrefs]]
10026 set ids {}
10027 set tagobjs {}
10028 foreach name [array names tagobjid] {
10029 lappend tagobjs $tagobjid($name)
10031 foreach id [lsort -unique $refs] {
10032 if {![info exists allparents($id)] &&
10033 [lsearch -exact $tagobjs $id] < 0} {
10034 lappend ids $id
10037 if {$ids ne {}} {
10038 foreach id $seeds {
10039 lappend ids "^$id"
10043 if {$ids ne {}} {
10044 set fd [open [concat $cmd $ids] r]
10045 fconfigure $fd -blocking 0
10046 incr allcommits
10047 nowbusy allcommits
10048 filerun $fd [list getallclines $fd]
10049 } else {
10050 dispneartags 0
10054 # Since most commits have 1 parent and 1 child, we group strings of
10055 # such commits into "arcs" joining branch/merge points (BMPs), which
10056 # are commits that either don't have 1 parent or don't have 1 child.
10058 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10059 # arcout(id) - outgoing arcs for BMP
10060 # arcids(a) - list of IDs on arc including end but not start
10061 # arcstart(a) - BMP ID at start of arc
10062 # arcend(a) - BMP ID at end of arc
10063 # growing(a) - arc a is still growing
10064 # arctags(a) - IDs out of arcids (excluding end) that have tags
10065 # archeads(a) - IDs out of arcids (excluding end) that have heads
10066 # The start of an arc is at the descendent end, so "incoming" means
10067 # coming from descendents, and "outgoing" means going towards ancestors.
10069 proc getallclines {fd} {
10070 global allparents allchildren idtags idheads nextarc
10071 global arcnos arcids arctags arcout arcend arcstart archeads growing
10072 global seeds allcommits cachedarcs allcupdate
10074 set nid 0
10075 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10076 set id [lindex $line 0]
10077 if {[info exists allparents($id)]} {
10078 # seen it already
10079 continue
10081 set cachedarcs 0
10082 set olds [lrange $line 1 end]
10083 set allparents($id) $olds
10084 if {![info exists allchildren($id)]} {
10085 set allchildren($id) {}
10086 set arcnos($id) {}
10087 lappend seeds $id
10088 } else {
10089 set a $arcnos($id)
10090 if {[llength $olds] == 1 && [llength $a] == 1} {
10091 lappend arcids($a) $id
10092 if {[info exists idtags($id)]} {
10093 lappend arctags($a) $id
10095 if {[info exists idheads($id)]} {
10096 lappend archeads($a) $id
10098 if {[info exists allparents($olds)]} {
10099 # seen parent already
10100 if {![info exists arcout($olds)]} {
10101 splitarc $olds
10103 lappend arcids($a) $olds
10104 set arcend($a) $olds
10105 unset growing($a)
10107 lappend allchildren($olds) $id
10108 lappend arcnos($olds) $a
10109 continue
10112 foreach a $arcnos($id) {
10113 lappend arcids($a) $id
10114 set arcend($a) $id
10115 unset growing($a)
10118 set ao {}
10119 foreach p $olds {
10120 lappend allchildren($p) $id
10121 set a [incr nextarc]
10122 set arcstart($a) $id
10123 set archeads($a) {}
10124 set arctags($a) {}
10125 set archeads($a) {}
10126 set arcids($a) {}
10127 lappend ao $a
10128 set growing($a) 1
10129 if {[info exists allparents($p)]} {
10130 # seen it already, may need to make a new branch
10131 if {![info exists arcout($p)]} {
10132 splitarc $p
10134 lappend arcids($a) $p
10135 set arcend($a) $p
10136 unset growing($a)
10138 lappend arcnos($p) $a
10140 set arcout($id) $ao
10142 if {$nid > 0} {
10143 global cached_dheads cached_dtags cached_atags
10144 unset -nocomplain cached_dheads
10145 unset -nocomplain cached_dtags
10146 unset -nocomplain cached_atags
10148 if {![eof $fd]} {
10149 return [expr {$nid >= 1000? 2: 1}]
10151 set cacheok 1
10152 if {[catch {
10153 fconfigure $fd -blocking 1
10154 close $fd
10155 } err]} {
10156 # got an error reading the list of commits
10157 # if we were updating, try rereading the whole thing again
10158 if {$allcupdate} {
10159 incr allcommits -1
10160 dropcache $err
10161 return
10163 error_popup "[mc "Error reading commit topology information;\
10164 branch and preceding/following tag information\
10165 will be incomplete."]\n($err)"
10166 set cacheok 0
10168 if {[incr allcommits -1] == 0} {
10169 notbusy allcommits
10170 if {$cacheok} {
10171 run savecache
10174 dispneartags 0
10175 return 0
10178 proc recalcarc {a} {
10179 global arctags archeads arcids idtags idheads
10181 set at {}
10182 set ah {}
10183 foreach id [lrange $arcids($a) 0 end-1] {
10184 if {[info exists idtags($id)]} {
10185 lappend at $id
10187 if {[info exists idheads($id)]} {
10188 lappend ah $id
10191 set arctags($a) $at
10192 set archeads($a) $ah
10195 proc splitarc {p} {
10196 global arcnos arcids nextarc arctags archeads idtags idheads
10197 global arcstart arcend arcout allparents growing
10199 set a $arcnos($p)
10200 if {[llength $a] != 1} {
10201 puts "oops splitarc called but [llength $a] arcs already"
10202 return
10204 set a [lindex $a 0]
10205 set i [lsearch -exact $arcids($a) $p]
10206 if {$i < 0} {
10207 puts "oops splitarc $p not in arc $a"
10208 return
10210 set na [incr nextarc]
10211 if {[info exists arcend($a)]} {
10212 set arcend($na) $arcend($a)
10213 } else {
10214 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10215 set j [lsearch -exact $arcnos($l) $a]
10216 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10218 set tail [lrange $arcids($a) [expr {$i+1}] end]
10219 set arcids($a) [lrange $arcids($a) 0 $i]
10220 set arcend($a) $p
10221 set arcstart($na) $p
10222 set arcout($p) $na
10223 set arcids($na) $tail
10224 if {[info exists growing($a)]} {
10225 set growing($na) 1
10226 unset growing($a)
10229 foreach id $tail {
10230 if {[llength $arcnos($id)] == 1} {
10231 set arcnos($id) $na
10232 } else {
10233 set j [lsearch -exact $arcnos($id) $a]
10234 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10238 # reconstruct tags and heads lists
10239 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10240 recalcarc $a
10241 recalcarc $na
10242 } else {
10243 set arctags($na) {}
10244 set archeads($na) {}
10248 # Update things for a new commit added that is a child of one
10249 # existing commit. Used when cherry-picking.
10250 proc addnewchild {id p} {
10251 global allparents allchildren idtags nextarc
10252 global arcnos arcids arctags arcout arcend arcstart archeads growing
10253 global seeds allcommits
10255 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10256 set allparents($id) [list $p]
10257 set allchildren($id) {}
10258 set arcnos($id) {}
10259 lappend seeds $id
10260 lappend allchildren($p) $id
10261 set a [incr nextarc]
10262 set arcstart($a) $id
10263 set archeads($a) {}
10264 set arctags($a) {}
10265 set arcids($a) [list $p]
10266 set arcend($a) $p
10267 if {![info exists arcout($p)]} {
10268 splitarc $p
10270 lappend arcnos($p) $a
10271 set arcout($id) [list $a]
10274 # This implements a cache for the topology information.
10275 # The cache saves, for each arc, the start and end of the arc,
10276 # the ids on the arc, and the outgoing arcs from the end.
10277 proc readcache {f} {
10278 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10279 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10280 global allcwait
10282 set a $nextarc
10283 set lim $cachedarcs
10284 if {$lim - $a > 500} {
10285 set lim [expr {$a + 500}]
10287 if {[catch {
10288 if {$a == $lim} {
10289 # finish reading the cache and setting up arctags, etc.
10290 set line [gets $f]
10291 if {$line ne "1"} {error "bad final version"}
10292 close $f
10293 foreach id [array names idtags] {
10294 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10295 [llength $allparents($id)] == 1} {
10296 set a [lindex $arcnos($id) 0]
10297 if {$arctags($a) eq {}} {
10298 recalcarc $a
10302 foreach id [array names idheads] {
10303 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10304 [llength $allparents($id)] == 1} {
10305 set a [lindex $arcnos($id) 0]
10306 if {$archeads($a) eq {}} {
10307 recalcarc $a
10311 foreach id [lsort -unique $possible_seeds] {
10312 if {$arcnos($id) eq {}} {
10313 lappend seeds $id
10316 set allcwait 0
10317 } else {
10318 while {[incr a] <= $lim} {
10319 set line [gets $f]
10320 if {[llength $line] != 3} {error "bad line"}
10321 set s [lindex $line 0]
10322 set arcstart($a) $s
10323 lappend arcout($s) $a
10324 if {![info exists arcnos($s)]} {
10325 lappend possible_seeds $s
10326 set arcnos($s) {}
10328 set e [lindex $line 1]
10329 if {$e eq {}} {
10330 set growing($a) 1
10331 } else {
10332 set arcend($a) $e
10333 if {![info exists arcout($e)]} {
10334 set arcout($e) {}
10337 set arcids($a) [lindex $line 2]
10338 foreach id $arcids($a) {
10339 lappend allparents($s) $id
10340 set s $id
10341 lappend arcnos($id) $a
10343 if {![info exists allparents($s)]} {
10344 set allparents($s) {}
10346 set arctags($a) {}
10347 set archeads($a) {}
10349 set nextarc [expr {$a - 1}]
10351 } err]} {
10352 dropcache $err
10353 return 0
10355 if {!$allcwait} {
10356 getallcommits
10358 return $allcwait
10361 proc getcache {f} {
10362 global nextarc cachedarcs possible_seeds
10364 if {[catch {
10365 set line [gets $f]
10366 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10367 # make sure it's an integer
10368 set cachedarcs [expr {int([lindex $line 1])}]
10369 if {$cachedarcs < 0} {error "bad number of arcs"}
10370 set nextarc 0
10371 set possible_seeds {}
10372 run readcache $f
10373 } err]} {
10374 dropcache $err
10376 return 0
10379 proc dropcache {err} {
10380 global allcwait nextarc cachedarcs seeds
10382 #puts "dropping cache ($err)"
10383 foreach v {arcnos arcout arcids arcstart arcend growing \
10384 arctags archeads allparents allchildren} {
10385 global $v
10386 unset -nocomplain $v
10388 set allcwait 0
10389 set nextarc 0
10390 set cachedarcs 0
10391 set seeds {}
10392 getallcommits
10395 proc writecache {f} {
10396 global cachearc cachedarcs allccache
10397 global arcstart arcend arcnos arcids arcout
10399 set a $cachearc
10400 set lim $cachedarcs
10401 if {$lim - $a > 1000} {
10402 set lim [expr {$a + 1000}]
10404 if {[catch {
10405 while {[incr a] <= $lim} {
10406 if {[info exists arcend($a)]} {
10407 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10408 } else {
10409 puts $f [list $arcstart($a) {} $arcids($a)]
10412 } err]} {
10413 catch {close $f}
10414 catch {file delete $allccache}
10415 #puts "writing cache failed ($err)"
10416 return 0
10418 set cachearc [expr {$a - 1}]
10419 if {$a > $cachedarcs} {
10420 puts $f "1"
10421 close $f
10422 return 0
10424 return 1
10427 proc savecache {} {
10428 global nextarc cachedarcs cachearc allccache
10430 if {$nextarc == $cachedarcs} return
10431 set cachearc 0
10432 set cachedarcs $nextarc
10433 catch {
10434 set f [open $allccache w]
10435 puts $f [list 1 $cachedarcs]
10436 run writecache $f
10440 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10441 # or 0 if neither is true.
10442 proc anc_or_desc {a b} {
10443 global arcout arcstart arcend arcnos cached_isanc
10445 if {$arcnos($a) eq $arcnos($b)} {
10446 # Both are on the same arc(s); either both are the same BMP,
10447 # or if one is not a BMP, the other is also not a BMP or is
10448 # the BMP at end of the arc (and it only has 1 incoming arc).
10449 # Or both can be BMPs with no incoming arcs.
10450 if {$a eq $b || $arcnos($a) eq {}} {
10451 return 0
10453 # assert {[llength $arcnos($a)] == 1}
10454 set arc [lindex $arcnos($a) 0]
10455 set i [lsearch -exact $arcids($arc) $a]
10456 set j [lsearch -exact $arcids($arc) $b]
10457 if {$i < 0 || $i > $j} {
10458 return 1
10459 } else {
10460 return -1
10464 if {![info exists arcout($a)]} {
10465 set arc [lindex $arcnos($a) 0]
10466 if {[info exists arcend($arc)]} {
10467 set aend $arcend($arc)
10468 } else {
10469 set aend {}
10471 set a $arcstart($arc)
10472 } else {
10473 set aend $a
10475 if {![info exists arcout($b)]} {
10476 set arc [lindex $arcnos($b) 0]
10477 if {[info exists arcend($arc)]} {
10478 set bend $arcend($arc)
10479 } else {
10480 set bend {}
10482 set b $arcstart($arc)
10483 } else {
10484 set bend $b
10486 if {$a eq $bend} {
10487 return 1
10489 if {$b eq $aend} {
10490 return -1
10492 if {[info exists cached_isanc($a,$bend)]} {
10493 if {$cached_isanc($a,$bend)} {
10494 return 1
10497 if {[info exists cached_isanc($b,$aend)]} {
10498 if {$cached_isanc($b,$aend)} {
10499 return -1
10501 if {[info exists cached_isanc($a,$bend)]} {
10502 return 0
10506 set todo [list $a $b]
10507 set anc($a) a
10508 set anc($b) b
10509 for {set i 0} {$i < [llength $todo]} {incr i} {
10510 set x [lindex $todo $i]
10511 if {$anc($x) eq {}} {
10512 continue
10514 foreach arc $arcnos($x) {
10515 set xd $arcstart($arc)
10516 if {$xd eq $bend} {
10517 set cached_isanc($a,$bend) 1
10518 set cached_isanc($b,$aend) 0
10519 return 1
10520 } elseif {$xd eq $aend} {
10521 set cached_isanc($b,$aend) 1
10522 set cached_isanc($a,$bend) 0
10523 return -1
10525 if {![info exists anc($xd)]} {
10526 set anc($xd) $anc($x)
10527 lappend todo $xd
10528 } elseif {$anc($xd) ne $anc($x)} {
10529 set anc($xd) {}
10533 set cached_isanc($a,$bend) 0
10534 set cached_isanc($b,$aend) 0
10535 return 0
10538 # This identifies whether $desc has an ancestor that is
10539 # a growing tip of the graph and which is not an ancestor of $anc
10540 # and returns 0 if so and 1 if not.
10541 # If we subsequently discover a tag on such a growing tip, and that
10542 # turns out to be a descendent of $anc (which it could, since we
10543 # don't necessarily see children before parents), then $desc
10544 # isn't a good choice to display as a descendent tag of
10545 # $anc (since it is the descendent of another tag which is
10546 # a descendent of $anc). Similarly, $anc isn't a good choice to
10547 # display as a ancestor tag of $desc.
10549 proc is_certain {desc anc} {
10550 global arcnos arcout arcstart arcend growing problems
10552 set certain {}
10553 if {[llength $arcnos($anc)] == 1} {
10554 # tags on the same arc are certain
10555 if {$arcnos($desc) eq $arcnos($anc)} {
10556 return 1
10558 if {![info exists arcout($anc)]} {
10559 # if $anc is partway along an arc, use the start of the arc instead
10560 set a [lindex $arcnos($anc) 0]
10561 set anc $arcstart($a)
10564 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10565 set x $desc
10566 } else {
10567 set a [lindex $arcnos($desc) 0]
10568 set x $arcend($a)
10570 if {$x == $anc} {
10571 return 1
10573 set anclist [list $x]
10574 set dl($x) 1
10575 set nnh 1
10576 set ngrowanc 0
10577 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10578 set x [lindex $anclist $i]
10579 if {$dl($x)} {
10580 incr nnh -1
10582 set done($x) 1
10583 foreach a $arcout($x) {
10584 if {[info exists growing($a)]} {
10585 if {![info exists growanc($x)] && $dl($x)} {
10586 set growanc($x) 1
10587 incr ngrowanc
10589 } else {
10590 set y $arcend($a)
10591 if {[info exists dl($y)]} {
10592 if {$dl($y)} {
10593 if {!$dl($x)} {
10594 set dl($y) 0
10595 if {![info exists done($y)]} {
10596 incr nnh -1
10598 if {[info exists growanc($x)]} {
10599 incr ngrowanc -1
10601 set xl [list $y]
10602 for {set k 0} {$k < [llength $xl]} {incr k} {
10603 set z [lindex $xl $k]
10604 foreach c $arcout($z) {
10605 if {[info exists arcend($c)]} {
10606 set v $arcend($c)
10607 if {[info exists dl($v)] && $dl($v)} {
10608 set dl($v) 0
10609 if {![info exists done($v)]} {
10610 incr nnh -1
10612 if {[info exists growanc($v)]} {
10613 incr ngrowanc -1
10615 lappend xl $v
10622 } elseif {$y eq $anc || !$dl($x)} {
10623 set dl($y) 0
10624 lappend anclist $y
10625 } else {
10626 set dl($y) 1
10627 lappend anclist $y
10628 incr nnh
10633 foreach x [array names growanc] {
10634 if {$dl($x)} {
10635 return 0
10637 return 0
10639 return 1
10642 proc validate_arctags {a} {
10643 global arctags idtags
10645 set i -1
10646 set na $arctags($a)
10647 foreach id $arctags($a) {
10648 incr i
10649 if {![info exists idtags($id)]} {
10650 set na [lreplace $na $i $i]
10651 incr i -1
10654 set arctags($a) $na
10657 proc validate_archeads {a} {
10658 global archeads idheads
10660 set i -1
10661 set na $archeads($a)
10662 foreach id $archeads($a) {
10663 incr i
10664 if {![info exists idheads($id)]} {
10665 set na [lreplace $na $i $i]
10666 incr i -1
10669 set archeads($a) $na
10672 # Return the list of IDs that have tags that are descendents of id,
10673 # ignoring IDs that are descendents of IDs already reported.
10674 proc desctags {id} {
10675 global arcnos arcstart arcids arctags idtags allparents
10676 global growing cached_dtags
10678 if {![info exists allparents($id)]} {
10679 return {}
10681 set t1 [clock clicks -milliseconds]
10682 set argid $id
10683 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10684 # part-way along an arc; check that arc first
10685 set a [lindex $arcnos($id) 0]
10686 if {$arctags($a) ne {}} {
10687 validate_arctags $a
10688 set i [lsearch -exact $arcids($a) $id]
10689 set tid {}
10690 foreach t $arctags($a) {
10691 set j [lsearch -exact $arcids($a) $t]
10692 if {$j >= $i} break
10693 set tid $t
10695 if {$tid ne {}} {
10696 return $tid
10699 set id $arcstart($a)
10700 if {[info exists idtags($id)]} {
10701 return $id
10704 if {[info exists cached_dtags($id)]} {
10705 return $cached_dtags($id)
10708 set origid $id
10709 set todo [list $id]
10710 set queued($id) 1
10711 set nc 1
10712 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10713 set id [lindex $todo $i]
10714 set done($id) 1
10715 set ta [info exists hastaggedancestor($id)]
10716 if {!$ta} {
10717 incr nc -1
10719 # ignore tags on starting node
10720 if {!$ta && $i > 0} {
10721 if {[info exists idtags($id)]} {
10722 set tagloc($id) $id
10723 set ta 1
10724 } elseif {[info exists cached_dtags($id)]} {
10725 set tagloc($id) $cached_dtags($id)
10726 set ta 1
10729 foreach a $arcnos($id) {
10730 set d $arcstart($a)
10731 if {!$ta && $arctags($a) ne {}} {
10732 validate_arctags $a
10733 if {$arctags($a) ne {}} {
10734 lappend tagloc($id) [lindex $arctags($a) end]
10737 if {$ta || $arctags($a) ne {}} {
10738 set tomark [list $d]
10739 for {set j 0} {$j < [llength $tomark]} {incr j} {
10740 set dd [lindex $tomark $j]
10741 if {![info exists hastaggedancestor($dd)]} {
10742 if {[info exists done($dd)]} {
10743 foreach b $arcnos($dd) {
10744 lappend tomark $arcstart($b)
10746 if {[info exists tagloc($dd)]} {
10747 unset tagloc($dd)
10749 } elseif {[info exists queued($dd)]} {
10750 incr nc -1
10752 set hastaggedancestor($dd) 1
10756 if {![info exists queued($d)]} {
10757 lappend todo $d
10758 set queued($d) 1
10759 if {![info exists hastaggedancestor($d)]} {
10760 incr nc
10765 set tags {}
10766 foreach id [array names tagloc] {
10767 if {![info exists hastaggedancestor($id)]} {
10768 foreach t $tagloc($id) {
10769 if {[lsearch -exact $tags $t] < 0} {
10770 lappend tags $t
10775 set t2 [clock clicks -milliseconds]
10776 set loopix $i
10778 # remove tags that are descendents of other tags
10779 for {set i 0} {$i < [llength $tags]} {incr i} {
10780 set a [lindex $tags $i]
10781 for {set j 0} {$j < $i} {incr j} {
10782 set b [lindex $tags $j]
10783 set r [anc_or_desc $a $b]
10784 if {$r == 1} {
10785 set tags [lreplace $tags $j $j]
10786 incr j -1
10787 incr i -1
10788 } elseif {$r == -1} {
10789 set tags [lreplace $tags $i $i]
10790 incr i -1
10791 break
10796 if {[array names growing] ne {}} {
10797 # graph isn't finished, need to check if any tag could get
10798 # eclipsed by another tag coming later. Simply ignore any
10799 # tags that could later get eclipsed.
10800 set ctags {}
10801 foreach t $tags {
10802 if {[is_certain $t $origid]} {
10803 lappend ctags $t
10806 if {$tags eq $ctags} {
10807 set cached_dtags($origid) $tags
10808 } else {
10809 set tags $ctags
10811 } else {
10812 set cached_dtags($origid) $tags
10814 set t3 [clock clicks -milliseconds]
10815 if {0 && $t3 - $t1 >= 100} {
10816 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10817 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10819 return $tags
10822 proc anctags {id} {
10823 global arcnos arcids arcout arcend arctags idtags allparents
10824 global growing cached_atags
10826 if {![info exists allparents($id)]} {
10827 return {}
10829 set t1 [clock clicks -milliseconds]
10830 set argid $id
10831 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10832 # part-way along an arc; check that arc first
10833 set a [lindex $arcnos($id) 0]
10834 if {$arctags($a) ne {}} {
10835 validate_arctags $a
10836 set i [lsearch -exact $arcids($a) $id]
10837 foreach t $arctags($a) {
10838 set j [lsearch -exact $arcids($a) $t]
10839 if {$j > $i} {
10840 return $t
10844 if {![info exists arcend($a)]} {
10845 return {}
10847 set id $arcend($a)
10848 if {[info exists idtags($id)]} {
10849 return $id
10852 if {[info exists cached_atags($id)]} {
10853 return $cached_atags($id)
10856 set origid $id
10857 set todo [list $id]
10858 set queued($id) 1
10859 set taglist {}
10860 set nc 1
10861 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10862 set id [lindex $todo $i]
10863 set done($id) 1
10864 set td [info exists hastaggeddescendent($id)]
10865 if {!$td} {
10866 incr nc -1
10868 # ignore tags on starting node
10869 if {!$td && $i > 0} {
10870 if {[info exists idtags($id)]} {
10871 set tagloc($id) $id
10872 set td 1
10873 } elseif {[info exists cached_atags($id)]} {
10874 set tagloc($id) $cached_atags($id)
10875 set td 1
10878 foreach a $arcout($id) {
10879 if {!$td && $arctags($a) ne {}} {
10880 validate_arctags $a
10881 if {$arctags($a) ne {}} {
10882 lappend tagloc($id) [lindex $arctags($a) 0]
10885 if {![info exists arcend($a)]} continue
10886 set d $arcend($a)
10887 if {$td || $arctags($a) ne {}} {
10888 set tomark [list $d]
10889 for {set j 0} {$j < [llength $tomark]} {incr j} {
10890 set dd [lindex $tomark $j]
10891 if {![info exists hastaggeddescendent($dd)]} {
10892 if {[info exists done($dd)]} {
10893 foreach b $arcout($dd) {
10894 if {[info exists arcend($b)]} {
10895 lappend tomark $arcend($b)
10898 if {[info exists tagloc($dd)]} {
10899 unset tagloc($dd)
10901 } elseif {[info exists queued($dd)]} {
10902 incr nc -1
10904 set hastaggeddescendent($dd) 1
10908 if {![info exists queued($d)]} {
10909 lappend todo $d
10910 set queued($d) 1
10911 if {![info exists hastaggeddescendent($d)]} {
10912 incr nc
10917 set t2 [clock clicks -milliseconds]
10918 set loopix $i
10919 set tags {}
10920 foreach id [array names tagloc] {
10921 if {![info exists hastaggeddescendent($id)]} {
10922 foreach t $tagloc($id) {
10923 if {[lsearch -exact $tags $t] < 0} {
10924 lappend tags $t
10930 # remove tags that are ancestors of other tags
10931 for {set i 0} {$i < [llength $tags]} {incr i} {
10932 set a [lindex $tags $i]
10933 for {set j 0} {$j < $i} {incr j} {
10934 set b [lindex $tags $j]
10935 set r [anc_or_desc $a $b]
10936 if {$r == -1} {
10937 set tags [lreplace $tags $j $j]
10938 incr j -1
10939 incr i -1
10940 } elseif {$r == 1} {
10941 set tags [lreplace $tags $i $i]
10942 incr i -1
10943 break
10948 if {[array names growing] ne {}} {
10949 # graph isn't finished, need to check if any tag could get
10950 # eclipsed by another tag coming later. Simply ignore any
10951 # tags that could later get eclipsed.
10952 set ctags {}
10953 foreach t $tags {
10954 if {[is_certain $origid $t]} {
10955 lappend ctags $t
10958 if {$tags eq $ctags} {
10959 set cached_atags($origid) $tags
10960 } else {
10961 set tags $ctags
10963 } else {
10964 set cached_atags($origid) $tags
10966 set t3 [clock clicks -milliseconds]
10967 if {0 && $t3 - $t1 >= 100} {
10968 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10969 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10971 return $tags
10974 # Return the list of IDs that have heads that are descendents of id,
10975 # including id itself if it has a head.
10976 proc descheads {id} {
10977 global arcnos arcstart arcids archeads idheads cached_dheads
10978 global allparents arcout
10980 if {![info exists allparents($id)]} {
10981 return {}
10983 set aret {}
10984 if {![info exists arcout($id)]} {
10985 # part-way along an arc; check it first
10986 set a [lindex $arcnos($id) 0]
10987 if {$archeads($a) ne {}} {
10988 validate_archeads $a
10989 set i [lsearch -exact $arcids($a) $id]
10990 foreach t $archeads($a) {
10991 set j [lsearch -exact $arcids($a) $t]
10992 if {$j > $i} break
10993 lappend aret $t
10996 set id $arcstart($a)
10998 set origid $id
10999 set todo [list $id]
11000 set seen($id) 1
11001 set ret {}
11002 for {set i 0} {$i < [llength $todo]} {incr i} {
11003 set id [lindex $todo $i]
11004 if {[info exists cached_dheads($id)]} {
11005 set ret [concat $ret $cached_dheads($id)]
11006 } else {
11007 if {[info exists idheads($id)]} {
11008 lappend ret $id
11010 foreach a $arcnos($id) {
11011 if {$archeads($a) ne {}} {
11012 validate_archeads $a
11013 if {$archeads($a) ne {}} {
11014 set ret [concat $ret $archeads($a)]
11017 set d $arcstart($a)
11018 if {![info exists seen($d)]} {
11019 lappend todo $d
11020 set seen($d) 1
11025 set ret [lsort -unique $ret]
11026 set cached_dheads($origid) $ret
11027 return [concat $ret $aret]
11030 proc addedtag {id} {
11031 global arcnos arcout cached_dtags cached_atags
11033 if {![info exists arcnos($id)]} return
11034 if {![info exists arcout($id)]} {
11035 recalcarc [lindex $arcnos($id) 0]
11037 unset -nocomplain cached_dtags
11038 unset -nocomplain cached_atags
11041 proc addedhead {hid head} {
11042 global arcnos arcout cached_dheads
11044 if {![info exists arcnos($hid)]} return
11045 if {![info exists arcout($hid)]} {
11046 recalcarc [lindex $arcnos($hid) 0]
11048 unset -nocomplain cached_dheads
11051 proc removedhead {hid head} {
11052 global cached_dheads
11054 unset -nocomplain cached_dheads
11057 proc movedhead {hid head} {
11058 global arcnos arcout cached_dheads
11060 if {![info exists arcnos($hid)]} return
11061 if {![info exists arcout($hid)]} {
11062 recalcarc [lindex $arcnos($hid) 0]
11064 unset -nocomplain cached_dheads
11067 proc changedrefs {} {
11068 global cached_dheads cached_dtags cached_atags cached_tagcontent
11069 global arctags archeads arcnos arcout idheads idtags
11071 foreach id [concat [array names idheads] [array names idtags]] {
11072 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11073 set a [lindex $arcnos($id) 0]
11074 if {![info exists donearc($a)]} {
11075 recalcarc $a
11076 set donearc($a) 1
11080 unset -nocomplain cached_tagcontent
11081 unset -nocomplain cached_dtags
11082 unset -nocomplain cached_atags
11083 unset -nocomplain cached_dheads
11086 proc rereadrefs {} {
11087 global idtags idheads idotherrefs mainheadid
11089 set refids [concat [array names idtags] \
11090 [array names idheads] [array names idotherrefs]]
11091 foreach id $refids {
11092 if {![info exists ref($id)]} {
11093 set ref($id) [listrefs $id]
11096 set oldmainhead $mainheadid
11097 readrefs
11098 changedrefs
11099 set refids [lsort -unique [concat $refids [array names idtags] \
11100 [array names idheads] [array names idotherrefs]]]
11101 foreach id $refids {
11102 set v [listrefs $id]
11103 if {![info exists ref($id)] || $ref($id) != $v} {
11104 redrawtags $id
11107 if {$oldmainhead ne $mainheadid} {
11108 redrawtags $oldmainhead
11109 redrawtags $mainheadid
11111 run refill_reflist
11114 proc listrefs {id} {
11115 global idtags idheads idotherrefs
11117 set x {}
11118 if {[info exists idtags($id)]} {
11119 set x $idtags($id)
11121 set y {}
11122 if {[info exists idheads($id)]} {
11123 set y $idheads($id)
11125 set z {}
11126 if {[info exists idotherrefs($id)]} {
11127 set z $idotherrefs($id)
11129 return [list $x $y $z]
11132 proc add_tag_ctext {tag} {
11133 global ctext cached_tagcontent tagids
11135 if {![info exists cached_tagcontent($tag)]} {
11136 catch {
11137 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11140 $ctext insert end "[mc "Tag"]: $tag\n" bold
11141 if {[info exists cached_tagcontent($tag)]} {
11142 set text $cached_tagcontent($tag)
11143 } else {
11144 set text "[mc "Id"]: $tagids($tag)"
11146 appendwithlinks $text {}
11149 proc showtag {tag isnew} {
11150 global ctext cached_tagcontent tagids linknum tagobjid
11152 if {$isnew} {
11153 addtohistory [list showtag $tag 0] savectextpos
11155 $ctext conf -state normal
11156 clear_ctext
11157 settabs 0
11158 set linknum 0
11159 add_tag_ctext $tag
11160 maybe_scroll_ctext 1
11161 $ctext conf -state disabled
11162 init_flist {}
11165 proc showtags {id isnew} {
11166 global idtags ctext linknum
11168 if {$isnew} {
11169 addtohistory [list showtags $id 0] savectextpos
11171 $ctext conf -state normal
11172 clear_ctext
11173 settabs 0
11174 set linknum 0
11175 set sep {}
11176 foreach tag $idtags($id) {
11177 $ctext insert end $sep
11178 add_tag_ctext $tag
11179 set sep "\n\n"
11181 maybe_scroll_ctext 1
11182 $ctext conf -state disabled
11183 init_flist {}
11186 proc doquit {} {
11187 global stopped
11188 global gitktmpdir
11190 set stopped 100
11191 savestuff .
11192 destroy .
11194 if {[info exists gitktmpdir]} {
11195 catch {file delete -force $gitktmpdir}
11199 proc mkfontdisp {font top which} {
11200 global fontattr fontpref $font NS use_ttk
11202 set fontpref($font) [set $font]
11203 ${NS}::button $top.${font}but -text $which \
11204 -command [list choosefont $font $which]
11205 ${NS}::label $top.$font -relief flat -font $font \
11206 -text $fontattr($font,family) -justify left
11207 grid x $top.${font}but $top.$font -sticky w
11210 proc choosefont {font which} {
11211 global fontparam fontlist fonttop fontattr
11212 global prefstop NS
11214 set fontparam(which) $which
11215 set fontparam(font) $font
11216 set fontparam(family) [font actual $font -family]
11217 set fontparam(size) $fontattr($font,size)
11218 set fontparam(weight) $fontattr($font,weight)
11219 set fontparam(slant) $fontattr($font,slant)
11220 set top .gitkfont
11221 set fonttop $top
11222 if {![winfo exists $top]} {
11223 font create sample
11224 eval font config sample [font actual $font]
11225 ttk_toplevel $top
11226 make_transient $top $prefstop
11227 wm title $top [mc "Gitk font chooser"]
11228 ${NS}::label $top.l -textvariable fontparam(which)
11229 pack $top.l -side top
11230 set fontlist [lsort [font families]]
11231 ${NS}::frame $top.f
11232 listbox $top.f.fam -listvariable fontlist \
11233 -yscrollcommand [list $top.f.sb set]
11234 bind $top.f.fam <<ListboxSelect>> selfontfam
11235 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11236 pack $top.f.sb -side right -fill y
11237 pack $top.f.fam -side left -fill both -expand 1
11238 pack $top.f -side top -fill both -expand 1
11239 ${NS}::frame $top.g
11240 spinbox $top.g.size -from 4 -to 40 -width 4 \
11241 -textvariable fontparam(size) \
11242 -validatecommand {string is integer -strict %s}
11243 checkbutton $top.g.bold -padx 5 \
11244 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11245 -variable fontparam(weight) -onvalue bold -offvalue normal
11246 checkbutton $top.g.ital -padx 5 \
11247 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11248 -variable fontparam(slant) -onvalue italic -offvalue roman
11249 pack $top.g.size $top.g.bold $top.g.ital -side left
11250 pack $top.g -side top
11251 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11252 -background white
11253 $top.c create text 100 25 -anchor center -text $which -font sample \
11254 -fill black -tags text
11255 bind $top.c <Configure> [list centertext $top.c]
11256 pack $top.c -side top -fill x
11257 ${NS}::frame $top.buts
11258 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11259 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11260 bind $top <Key-Return> fontok
11261 bind $top <Key-Escape> fontcan
11262 grid $top.buts.ok $top.buts.can
11263 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11264 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11265 pack $top.buts -side bottom -fill x
11266 trace add variable fontparam write chg_fontparam
11267 } else {
11268 raise $top
11269 $top.c itemconf text -text $which
11271 set i [lsearch -exact $fontlist $fontparam(family)]
11272 if {$i >= 0} {
11273 $top.f.fam selection set $i
11274 $top.f.fam see $i
11278 proc centertext {w} {
11279 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11282 proc fontok {} {
11283 global fontparam fontpref prefstop
11285 set f $fontparam(font)
11286 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11287 if {$fontparam(weight) eq "bold"} {
11288 lappend fontpref($f) "bold"
11290 if {$fontparam(slant) eq "italic"} {
11291 lappend fontpref($f) "italic"
11293 set w $prefstop.notebook.fonts.$f
11294 $w conf -text $fontparam(family) -font $fontpref($f)
11296 fontcan
11299 proc fontcan {} {
11300 global fonttop fontparam
11302 if {[info exists fonttop]} {
11303 catch {destroy $fonttop}
11304 catch {font delete sample}
11305 unset fonttop
11306 unset fontparam
11310 if {[package vsatisfies [package provide Tk] 8.6]} {
11311 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11312 # function to make use of it.
11313 proc choosefont {font which} {
11314 tk fontchooser configure -title $which -font $font \
11315 -command [list on_choosefont $font $which]
11316 tk fontchooser show
11318 proc on_choosefont {font which newfont} {
11319 global fontparam
11320 puts stderr "$font $newfont"
11321 array set f [font actual $newfont]
11322 set fontparam(which) $which
11323 set fontparam(font) $font
11324 set fontparam(family) $f(-family)
11325 set fontparam(size) $f(-size)
11326 set fontparam(weight) $f(-weight)
11327 set fontparam(slant) $f(-slant)
11328 fontok
11332 proc selfontfam {} {
11333 global fonttop fontparam
11335 set i [$fonttop.f.fam curselection]
11336 if {$i ne {}} {
11337 set fontparam(family) [$fonttop.f.fam get $i]
11341 proc chg_fontparam {v sub op} {
11342 global fontparam
11344 font config sample -$sub $fontparam($sub)
11347 # Create a property sheet tab page
11348 proc create_prefs_page {w} {
11349 global NS
11350 set parent [join [lrange [split $w .] 0 end-1] .]
11351 if {[winfo class $parent] eq "TNotebook"} {
11352 ${NS}::frame $w
11353 } else {
11354 ${NS}::labelframe $w
11358 proc prefspage_general {notebook} {
11359 global NS maxwidth maxgraphpct showneartags showlocalchanges
11360 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11361 global hideremotes want_ttk have_ttk maxrefs
11363 set page [create_prefs_page $notebook.general]
11365 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11366 grid $page.ldisp - -sticky w -pady 10
11367 ${NS}::label $page.spacer -text " "
11368 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11369 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11370 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11371 #xgettext:no-tcl-format
11372 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11373 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11374 grid x $page.maxpctl $page.maxpct -sticky w
11375 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11376 -variable showlocalchanges
11377 grid x $page.showlocal -sticky w
11378 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11379 -variable autoselect
11380 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11381 grid x $page.autoselect $page.autosellen -sticky w
11382 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11383 -variable hideremotes
11384 grid x $page.hideremotes -sticky w
11386 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11387 grid $page.ddisp - -sticky w -pady 10
11388 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11389 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11390 grid x $page.tabstopl $page.tabstop -sticky w
11391 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11392 -variable showneartags
11393 grid x $page.ntag -sticky w
11394 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11395 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11396 grid x $page.maxrefsl $page.maxrefs -sticky w
11397 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11398 -variable limitdiffs
11399 grid x $page.ldiff -sticky w
11400 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11401 -variable perfile_attrs
11402 grid x $page.lattr -sticky w
11404 ${NS}::entry $page.extdifft -textvariable extdifftool
11405 ${NS}::frame $page.extdifff
11406 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11407 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11408 pack $page.extdifff.l $page.extdifff.b -side left
11409 pack configure $page.extdifff.l -padx 10
11410 grid x $page.extdifff $page.extdifft -sticky ew
11412 ${NS}::label $page.lgen -text [mc "General options"]
11413 grid $page.lgen - -sticky w -pady 10
11414 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11415 -text [mc "Use themed widgets"]
11416 if {$have_ttk} {
11417 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11418 } else {
11419 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11421 grid x $page.want_ttk $page.ttk_note -sticky w
11422 return $page
11425 proc prefspage_colors {notebook} {
11426 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11428 set page [create_prefs_page $notebook.colors]
11430 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11431 grid $page.cdisp - -sticky w -pady 10
11432 label $page.ui -padx 40 -relief sunk -background $uicolor
11433 ${NS}::button $page.uibut -text [mc "Interface"] \
11434 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11435 grid x $page.uibut $page.ui -sticky w
11436 label $page.bg -padx 40 -relief sunk -background $bgcolor
11437 ${NS}::button $page.bgbut -text [mc "Background"] \
11438 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11439 grid x $page.bgbut $page.bg -sticky w
11440 label $page.fg -padx 40 -relief sunk -background $fgcolor
11441 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11442 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11443 grid x $page.fgbut $page.fg -sticky w
11444 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11445 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11446 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11447 [list $ctext tag conf d0 -foreground]]
11448 grid x $page.diffoldbut $page.diffold -sticky w
11449 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11450 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11451 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11452 [list $ctext tag conf dresult -foreground]]
11453 grid x $page.diffnewbut $page.diffnew -sticky w
11454 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11455 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11456 -command [list choosecolor diffcolors 2 $page.hunksep \
11457 [mc "diff hunk header"] \
11458 [list $ctext tag conf hunksep -foreground]]
11459 grid x $page.hunksepbut $page.hunksep -sticky w
11460 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11461 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11462 -command [list choosecolor markbgcolor {} $page.markbgsep \
11463 [mc "marked line background"] \
11464 [list $ctext tag conf omark -background]]
11465 grid x $page.markbgbut $page.markbgsep -sticky w
11466 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11467 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11468 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11469 grid x $page.selbgbut $page.selbgsep -sticky w
11470 return $page
11473 proc prefspage_fonts {notebook} {
11474 global NS
11475 set page [create_prefs_page $notebook.fonts]
11476 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11477 grid $page.cfont - -sticky w -pady 10
11478 mkfontdisp mainfont $page [mc "Main font"]
11479 mkfontdisp textfont $page [mc "Diff display font"]
11480 mkfontdisp uifont $page [mc "User interface font"]
11481 return $page
11484 proc doprefs {} {
11485 global maxwidth maxgraphpct use_ttk NS
11486 global oldprefs prefstop showneartags showlocalchanges
11487 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11488 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11489 global hideremotes want_ttk have_ttk
11491 set top .gitkprefs
11492 set prefstop $top
11493 if {[winfo exists $top]} {
11494 raise $top
11495 return
11497 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11498 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11499 set oldprefs($v) [set $v]
11501 ttk_toplevel $top
11502 wm title $top [mc "Gitk preferences"]
11503 make_transient $top .
11505 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11506 set notebook [ttk::notebook $top.notebook]
11507 } else {
11508 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11511 lappend pages [prefspage_general $notebook] [mc "General"]
11512 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11513 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11514 set col 0
11515 foreach {page title} $pages {
11516 if {$use_notebook} {
11517 $notebook add $page -text $title
11518 } else {
11519 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11520 -text $title -command [list raise $page]]
11521 $page configure -text $title
11522 grid $btn -row 0 -column [incr col] -sticky w
11523 grid $page -row 1 -column 0 -sticky news -columnspan 100
11527 if {!$use_notebook} {
11528 grid columnconfigure $notebook 0 -weight 1
11529 grid rowconfigure $notebook 1 -weight 1
11530 raise [lindex $pages 0]
11533 grid $notebook -sticky news -padx 2 -pady 2
11534 grid rowconfigure $top 0 -weight 1
11535 grid columnconfigure $top 0 -weight 1
11537 ${NS}::frame $top.buts
11538 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11539 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11540 bind $top <Key-Return> prefsok
11541 bind $top <Key-Escape> prefscan
11542 grid $top.buts.ok $top.buts.can
11543 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11544 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11545 grid $top.buts - - -pady 10 -sticky ew
11546 grid columnconfigure $top 2 -weight 1
11547 bind $top <Visibility> [list focus $top.buts.ok]
11550 proc choose_extdiff {} {
11551 global extdifftool
11553 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11554 if {$prog ne {}} {
11555 set extdifftool $prog
11559 proc choosecolor {v vi w x cmd} {
11560 global $v
11562 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11563 -title [mc "Gitk: choose color for %s" $x]]
11564 if {$c eq {}} return
11565 $w conf -background $c
11566 lset $v $vi $c
11567 eval $cmd $c
11570 proc setselbg {c} {
11571 global bglist cflist
11572 foreach w $bglist {
11573 if {[winfo exists $w]} {
11574 $w configure -selectbackground $c
11577 $cflist tag configure highlight \
11578 -background [$cflist cget -selectbackground]
11579 allcanvs itemconf secsel -fill $c
11582 # This sets the background color and the color scheme for the whole UI.
11583 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11584 # if we don't specify one ourselves, which makes the checkbuttons and
11585 # radiobuttons look bad. This chooses white for selectColor if the
11586 # background color is light, or black if it is dark.
11587 proc setui {c} {
11588 if {[tk windowingsystem] eq "win32"} { return }
11589 set bg [winfo rgb . $c]
11590 set selc black
11591 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11592 set selc white
11594 tk_setPalette background $c selectColor $selc
11597 proc setbg {c} {
11598 global bglist
11600 foreach w $bglist {
11601 if {[winfo exists $w]} {
11602 $w conf -background $c
11607 proc setfg {c} {
11608 global fglist canv
11610 foreach w $fglist {
11611 if {[winfo exists $w]} {
11612 $w conf -foreground $c
11615 allcanvs itemconf text -fill $c
11616 $canv itemconf circle -outline $c
11617 $canv itemconf markid -outline $c
11620 proc prefscan {} {
11621 global oldprefs prefstop
11623 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11624 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11625 global $v
11626 set $v $oldprefs($v)
11628 catch {destroy $prefstop}
11629 unset prefstop
11630 fontcan
11633 proc prefsok {} {
11634 global maxwidth maxgraphpct
11635 global oldprefs prefstop showneartags showlocalchanges
11636 global fontpref mainfont textfont uifont
11637 global limitdiffs treediffs perfile_attrs
11638 global hideremotes
11640 catch {destroy $prefstop}
11641 unset prefstop
11642 fontcan
11643 set fontchanged 0
11644 if {$mainfont ne $fontpref(mainfont)} {
11645 set mainfont $fontpref(mainfont)
11646 parsefont mainfont $mainfont
11647 eval font configure mainfont [fontflags mainfont]
11648 eval font configure mainfontbold [fontflags mainfont 1]
11649 setcoords
11650 set fontchanged 1
11652 if {$textfont ne $fontpref(textfont)} {
11653 set textfont $fontpref(textfont)
11654 parsefont textfont $textfont
11655 eval font configure textfont [fontflags textfont]
11656 eval font configure textfontbold [fontflags textfont 1]
11658 if {$uifont ne $fontpref(uifont)} {
11659 set uifont $fontpref(uifont)
11660 parsefont uifont $uifont
11661 eval font configure uifont [fontflags uifont]
11663 settabs
11664 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11665 if {$showlocalchanges} {
11666 doshowlocalchanges
11667 } else {
11668 dohidelocalchanges
11671 if {$limitdiffs != $oldprefs(limitdiffs) ||
11672 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11673 # treediffs elements are limited by path;
11674 # won't have encodings cached if perfile_attrs was just turned on
11675 unset -nocomplain treediffs
11677 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11678 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11679 redisplay
11680 } elseif {$showneartags != $oldprefs(showneartags) ||
11681 $limitdiffs != $oldprefs(limitdiffs)} {
11682 reselectline
11684 if {$hideremotes != $oldprefs(hideremotes)} {
11685 rereadrefs
11689 proc formatdate {d} {
11690 global datetimeformat
11691 if {$d ne {}} {
11692 # If $datetimeformat includes a timezone, display in the
11693 # timezone of the argument. Otherwise, display in local time.
11694 if {[string match {*%[zZ]*} $datetimeformat]} {
11695 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11696 # Tcl < 8.5 does not support -timezone. Emulate it by
11697 # setting TZ (e.g. TZ=<-0430>+04:30).
11698 global env
11699 if {[info exists env(TZ)]} {
11700 set savedTZ $env(TZ)
11702 set zone [lindex $d 1]
11703 set sign [string map {+ - - +} [string index $zone 0]]
11704 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11705 set d [clock format [lindex $d 0] -format $datetimeformat]
11706 if {[info exists savedTZ]} {
11707 set env(TZ) $savedTZ
11708 } else {
11709 unset env(TZ)
11712 } else {
11713 set d [clock format [lindex $d 0] -format $datetimeformat]
11716 return $d
11719 # This list of encoding names and aliases is distilled from
11720 # http://www.iana.org/assignments/character-sets.
11721 # Not all of them are supported by Tcl.
11722 set encoding_aliases {
11723 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11724 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11725 { ISO-10646-UTF-1 csISO10646UTF1 }
11726 { ISO_646.basic:1983 ref csISO646basic1983 }
11727 { INVARIANT csINVARIANT }
11728 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11729 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11730 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11731 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11732 { NATS-DANO iso-ir-9-1 csNATSDANO }
11733 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11734 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11735 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11736 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11737 { ISO-2022-KR csISO2022KR }
11738 { EUC-KR csEUCKR }
11739 { ISO-2022-JP csISO2022JP }
11740 { ISO-2022-JP-2 csISO2022JP2 }
11741 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11742 csISO13JISC6220jp }
11743 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11744 { IT iso-ir-15 ISO646-IT csISO15Italian }
11745 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11746 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11747 { greek7-old iso-ir-18 csISO18Greek7Old }
11748 { latin-greek iso-ir-19 csISO19LatinGreek }
11749 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11750 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11751 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11752 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11753 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11754 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11755 { INIS iso-ir-49 csISO49INIS }
11756 { INIS-8 iso-ir-50 csISO50INIS8 }
11757 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11758 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11759 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11760 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11761 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11762 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11763 csISO60Norwegian1 }
11764 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11765 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11766 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11767 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11768 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11769 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11770 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11771 { greek7 iso-ir-88 csISO88Greek7 }
11772 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11773 { iso-ir-90 csISO90 }
11774 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11775 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11776 csISO92JISC62991984b }
11777 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11778 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11779 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11780 csISO95JIS62291984handadd }
11781 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11782 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11783 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11784 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11785 CP819 csISOLatin1 }
11786 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11787 { T.61-7bit iso-ir-102 csISO102T617bit }
11788 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11789 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11790 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11791 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11792 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11793 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11794 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11795 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11796 arabic csISOLatinArabic }
11797 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11798 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11799 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11800 greek greek8 csISOLatinGreek }
11801 { T.101-G2 iso-ir-128 csISO128T101G2 }
11802 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11803 csISOLatinHebrew }
11804 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11805 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11806 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11807 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11808 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11809 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11810 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11811 csISOLatinCyrillic }
11812 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11813 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11814 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11815 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11816 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11817 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11818 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11819 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11820 { ISO_10367-box iso-ir-155 csISO10367Box }
11821 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11822 { latin-lap lap iso-ir-158 csISO158Lap }
11823 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11824 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11825 { us-dk csUSDK }
11826 { dk-us csDKUS }
11827 { JIS_X0201 X0201 csHalfWidthKatakana }
11828 { KSC5636 ISO646-KR csKSC5636 }
11829 { ISO-10646-UCS-2 csUnicode }
11830 { ISO-10646-UCS-4 csUCS4 }
11831 { DEC-MCS dec csDECMCS }
11832 { hp-roman8 roman8 r8 csHPRoman8 }
11833 { macintosh mac csMacintosh }
11834 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11835 csIBM037 }
11836 { IBM038 EBCDIC-INT cp038 csIBM038 }
11837 { IBM273 CP273 csIBM273 }
11838 { IBM274 EBCDIC-BE CP274 csIBM274 }
11839 { IBM275 EBCDIC-BR cp275 csIBM275 }
11840 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11841 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11842 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11843 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11844 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11845 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11846 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11847 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11848 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11849 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11850 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11851 { IBM437 cp437 437 csPC8CodePage437 }
11852 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11853 { IBM775 cp775 csPC775Baltic }
11854 { IBM850 cp850 850 csPC850Multilingual }
11855 { IBM851 cp851 851 csIBM851 }
11856 { IBM852 cp852 852 csPCp852 }
11857 { IBM855 cp855 855 csIBM855 }
11858 { IBM857 cp857 857 csIBM857 }
11859 { IBM860 cp860 860 csIBM860 }
11860 { IBM861 cp861 861 cp-is csIBM861 }
11861 { IBM862 cp862 862 csPC862LatinHebrew }
11862 { IBM863 cp863 863 csIBM863 }
11863 { IBM864 cp864 csIBM864 }
11864 { IBM865 cp865 865 csIBM865 }
11865 { IBM866 cp866 866 csIBM866 }
11866 { IBM868 CP868 cp-ar csIBM868 }
11867 { IBM869 cp869 869 cp-gr csIBM869 }
11868 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11869 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11870 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11871 { IBM891 cp891 csIBM891 }
11872 { IBM903 cp903 csIBM903 }
11873 { IBM904 cp904 904 csIBBM904 }
11874 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11875 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11876 { IBM1026 CP1026 csIBM1026 }
11877 { EBCDIC-AT-DE csIBMEBCDICATDE }
11878 { EBCDIC-AT-DE-A csEBCDICATDEA }
11879 { EBCDIC-CA-FR csEBCDICCAFR }
11880 { EBCDIC-DK-NO csEBCDICDKNO }
11881 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11882 { EBCDIC-FI-SE csEBCDICFISE }
11883 { EBCDIC-FI-SE-A csEBCDICFISEA }
11884 { EBCDIC-FR csEBCDICFR }
11885 { EBCDIC-IT csEBCDICIT }
11886 { EBCDIC-PT csEBCDICPT }
11887 { EBCDIC-ES csEBCDICES }
11888 { EBCDIC-ES-A csEBCDICESA }
11889 { EBCDIC-ES-S csEBCDICESS }
11890 { EBCDIC-UK csEBCDICUK }
11891 { EBCDIC-US csEBCDICUS }
11892 { UNKNOWN-8BIT csUnknown8BiT }
11893 { MNEMONIC csMnemonic }
11894 { MNEM csMnem }
11895 { VISCII csVISCII }
11896 { VIQR csVIQR }
11897 { KOI8-R csKOI8R }
11898 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11899 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11900 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11901 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11902 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11903 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11904 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11905 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11906 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11907 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11908 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11909 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11910 { IBM1047 IBM-1047 }
11911 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11912 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11913 { UNICODE-1-1 csUnicode11 }
11914 { CESU-8 csCESU-8 }
11915 { BOCU-1 csBOCU-1 }
11916 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11917 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11918 l8 }
11919 { ISO-8859-15 ISO_8859-15 Latin-9 }
11920 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11921 { GBK CP936 MS936 windows-936 }
11922 { JIS_Encoding csJISEncoding }
11923 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11924 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11925 EUC-JP }
11926 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11927 { ISO-10646-UCS-Basic csUnicodeASCII }
11928 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11929 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11930 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11931 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11932 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11933 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11934 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11935 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11936 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11937 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11938 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11939 { Ventura-US csVenturaUS }
11940 { Ventura-International csVenturaInternational }
11941 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11942 { PC8-Turkish csPC8Turkish }
11943 { IBM-Symbols csIBMSymbols }
11944 { IBM-Thai csIBMThai }
11945 { HP-Legal csHPLegal }
11946 { HP-Pi-font csHPPiFont }
11947 { HP-Math8 csHPMath8 }
11948 { Adobe-Symbol-Encoding csHPPSMath }
11949 { HP-DeskTop csHPDesktop }
11950 { Ventura-Math csVenturaMath }
11951 { Microsoft-Publishing csMicrosoftPublishing }
11952 { Windows-31J csWindows31J }
11953 { GB2312 csGB2312 }
11954 { Big5 csBig5 }
11957 proc tcl_encoding {enc} {
11958 global encoding_aliases tcl_encoding_cache
11959 if {[info exists tcl_encoding_cache($enc)]} {
11960 return $tcl_encoding_cache($enc)
11962 set names [encoding names]
11963 set lcnames [string tolower $names]
11964 set enc [string tolower $enc]
11965 set i [lsearch -exact $lcnames $enc]
11966 if {$i < 0} {
11967 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11968 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11969 set i [lsearch -exact $lcnames $encx]
11972 if {$i < 0} {
11973 foreach l $encoding_aliases {
11974 set ll [string tolower $l]
11975 if {[lsearch -exact $ll $enc] < 0} continue
11976 # look through the aliases for one that tcl knows about
11977 foreach e $ll {
11978 set i [lsearch -exact $lcnames $e]
11979 if {$i < 0} {
11980 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11981 set i [lsearch -exact $lcnames $ex]
11984 if {$i >= 0} break
11986 break
11989 set tclenc {}
11990 if {$i >= 0} {
11991 set tclenc [lindex $names $i]
11993 set tcl_encoding_cache($enc) $tclenc
11994 return $tclenc
11997 proc gitattr {path attr default} {
11998 global path_attr_cache
11999 if {[info exists path_attr_cache($attr,$path)]} {
12000 set r $path_attr_cache($attr,$path)
12001 } else {
12002 set r "unspecified"
12003 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
12004 regexp "(.*): $attr: (.*)" $line m f r
12006 set path_attr_cache($attr,$path) $r
12008 if {$r eq "unspecified"} {
12009 return $default
12011 return $r
12014 proc cache_gitattr {attr pathlist} {
12015 global path_attr_cache
12016 set newlist {}
12017 foreach path $pathlist {
12018 if {![info exists path_attr_cache($attr,$path)]} {
12019 lappend newlist $path
12022 set lim 1000
12023 if {[tk windowingsystem] == "win32"} {
12024 # windows has a 32k limit on the arguments to a command...
12025 set lim 30
12027 while {$newlist ne {}} {
12028 set head [lrange $newlist 0 [expr {$lim - 1}]]
12029 set newlist [lrange $newlist $lim end]
12030 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
12031 foreach row [split $rlist "\n"] {
12032 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12033 if {[string index $path 0] eq "\""} {
12034 set path [encoding convertfrom [lindex $path 0]]
12036 set path_attr_cache($attr,$path) $value
12043 proc get_path_encoding {path} {
12044 global gui_encoding perfile_attrs
12045 set tcl_enc $gui_encoding
12046 if {$path ne {} && $perfile_attrs} {
12047 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12048 if {$enc2 ne {}} {
12049 set tcl_enc $enc2
12052 return $tcl_enc
12055 ## For msgcat loading, first locate the installation location.
12056 if { [info exists ::env(GITK_MSGSDIR)] } {
12057 ## Msgsdir was manually set in the environment.
12058 set gitk_msgsdir $::env(GITK_MSGSDIR)
12059 } else {
12060 ## Let's guess the prefix from argv0.
12061 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12062 set gitk_libdir [file join $gitk_prefix share gitk lib]
12063 set gitk_msgsdir [file join $gitk_libdir msgs]
12064 unset gitk_prefix
12067 ## Internationalization (i18n) through msgcat and gettext. See
12068 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12069 package require msgcat
12070 namespace import ::msgcat::mc
12071 ## And eventually load the actual message catalog
12072 ::msgcat::mcload $gitk_msgsdir
12074 # First check that Tcl/Tk is recent enough
12075 if {[catch {package require Tk 8.4} err]} {
12076 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12077 Gitk requires at least Tcl/Tk 8.4."]
12078 exit 1
12081 # on OSX bring the current Wish process window to front
12082 if {[tk windowingsystem] eq "aqua"} {
12083 exec osascript -e [format {
12084 tell application "System Events"
12085 set frontmost of processes whose unix id is %d to true
12086 end tell
12087 } [pid] ]
12090 # Unset GIT_TRACE var if set
12091 if { [info exists ::env(GIT_TRACE)] } {
12092 unset ::env(GIT_TRACE)
12095 # defaults...
12096 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12098 set gitencoding {}
12099 catch {
12100 set gitencoding [exec git config --get i18n.commitencoding]
12102 catch {
12103 set gitencoding [exec git config --get i18n.logoutputencoding]
12105 if {$gitencoding == ""} {
12106 set gitencoding "utf-8"
12108 set tclencoding [tcl_encoding $gitencoding]
12109 if {$tclencoding == {}} {
12110 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12113 set gui_encoding [encoding system]
12114 catch {
12115 set enc [exec git config --get gui.encoding]
12116 if {$enc ne {}} {
12117 set tclenc [tcl_encoding $enc]
12118 if {$tclenc ne {}} {
12119 set gui_encoding $tclenc
12120 } else {
12121 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12126 set log_showroot true
12127 catch {
12128 set log_showroot [exec git config --bool --get log.showroot]
12131 if {[tk windowingsystem] eq "aqua"} {
12132 set mainfont {{Lucida Grande} 9}
12133 set textfont {Monaco 9}
12134 set uifont {{Lucida Grande} 9 bold}
12135 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12136 # fontconfig!
12137 set mainfont {sans 9}
12138 set textfont {monospace 9}
12139 set uifont {sans 9 bold}
12140 } else {
12141 set mainfont {Helvetica 9}
12142 set textfont {Courier 9}
12143 set uifont {Helvetica 9 bold}
12145 set tabstop 8
12146 set findmergefiles 0
12147 set maxgraphpct 50
12148 set maxwidth 16
12149 set revlistorder 0
12150 set fastdate 0
12151 set uparrowlen 5
12152 set downarrowlen 5
12153 set mingaplen 100
12154 set cmitmode "patch"
12155 set wrapcomment "none"
12156 set showneartags 1
12157 set hideremotes 0
12158 set maxrefs 20
12159 set visiblerefs {"master"}
12160 set maxlinelen 200
12161 set showlocalchanges 1
12162 set limitdiffs 1
12163 set datetimeformat "%Y-%m-%d %H:%M:%S"
12164 set autoselect 1
12165 set autosellen 40
12166 set perfile_attrs 0
12167 set want_ttk 1
12169 if {[tk windowingsystem] eq "aqua"} {
12170 set extdifftool "opendiff"
12171 } else {
12172 set extdifftool "meld"
12175 set colors {green red blue magenta darkgrey brown orange}
12176 if {[tk windowingsystem] eq "win32"} {
12177 set uicolor SystemButtonFace
12178 set uifgcolor SystemButtonText
12179 set uifgdisabledcolor SystemDisabledText
12180 set bgcolor SystemWindow
12181 set fgcolor SystemWindowText
12182 set selectbgcolor SystemHighlight
12183 } else {
12184 set uicolor grey85
12185 set uifgcolor black
12186 set uifgdisabledcolor "#999"
12187 set bgcolor white
12188 set fgcolor black
12189 set selectbgcolor gray85
12191 set diffcolors {red "#00a000" blue}
12192 set diffcontext 3
12193 set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12194 set ignorespace 0
12195 set worddiff ""
12196 set markbgcolor "#e0e0ff"
12198 set headbgcolor green
12199 set headfgcolor black
12200 set headoutlinecolor black
12201 set remotebgcolor #ffddaa
12202 set tagbgcolor yellow
12203 set tagfgcolor black
12204 set tagoutlinecolor black
12205 set reflinecolor black
12206 set filesepbgcolor #aaaaaa
12207 set filesepfgcolor black
12208 set linehoverbgcolor #ffff80
12209 set linehoverfgcolor black
12210 set linehoveroutlinecolor black
12211 set mainheadcirclecolor yellow
12212 set workingfilescirclecolor red
12213 set indexcirclecolor green
12214 set circlecolors {white blue gray blue blue}
12215 set linkfgcolor blue
12216 set circleoutlinecolor $fgcolor
12217 set foundbgcolor yellow
12218 set currentsearchhitbgcolor orange
12220 # button for popping up context menus
12221 if {[tk windowingsystem] eq "aqua"} {
12222 set ctxbut <Button-2>
12223 } else {
12224 set ctxbut <Button-3>
12227 catch {
12228 # follow the XDG base directory specification by default. See
12229 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12230 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12231 # XDG_CONFIG_HOME environment variable is set
12232 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12233 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12234 } else {
12235 # default XDG_CONFIG_HOME
12236 set config_file "~/.config/git/gitk"
12237 set config_file_tmp "~/.config/git/gitk-tmp"
12239 if {![file exists $config_file]} {
12240 # for backward compatibility use the old config file if it exists
12241 if {[file exists "~/.gitk"]} {
12242 set config_file "~/.gitk"
12243 set config_file_tmp "~/.gitk-tmp"
12244 } elseif {![file exists [file dirname $config_file]]} {
12245 file mkdir [file dirname $config_file]
12248 source $config_file
12250 config_check_tmp_exists 50
12252 set config_variables {
12253 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12254 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12255 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12256 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12257 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12258 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12259 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12260 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12261 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12262 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12264 foreach var $config_variables {
12265 config_init_trace $var
12266 trace add variable $var write config_variable_change_cb
12269 parsefont mainfont $mainfont
12270 eval font create mainfont [fontflags mainfont]
12271 eval font create mainfontbold [fontflags mainfont 1]
12273 parsefont textfont $textfont
12274 eval font create textfont [fontflags textfont]
12275 eval font create textfontbold [fontflags textfont 1]
12277 parsefont uifont $uifont
12278 eval font create uifont [fontflags uifont]
12280 setui $uicolor
12282 setoptions
12284 # check that we can find a .git directory somewhere...
12285 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12286 show_error {} . [mc "Cannot find a git repository here."]
12287 exit 1
12290 set selecthead {}
12291 set selectheadid {}
12293 set revtreeargs {}
12294 set cmdline_files {}
12295 set i 0
12296 set revtreeargscmd {}
12297 foreach arg $argv {
12298 switch -glob -- $arg {
12299 "" { }
12300 "--" {
12301 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12302 break
12304 "--select-commit=*" {
12305 set selecthead [string range $arg 16 end]
12307 "--argscmd=*" {
12308 set revtreeargscmd [string range $arg 10 end]
12310 default {
12311 lappend revtreeargs $arg
12314 incr i
12317 if {$selecthead eq "HEAD"} {
12318 set selecthead {}
12321 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12322 # no -- on command line, but some arguments (other than --argscmd)
12323 if {[catch {
12324 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12325 set cmdline_files [split $f "\n"]
12326 set n [llength $cmdline_files]
12327 set revtreeargs [lrange $revtreeargs 0 end-$n]
12328 # Unfortunately git rev-parse doesn't produce an error when
12329 # something is both a revision and a filename. To be consistent
12330 # with git log and git rev-list, check revtreeargs for filenames.
12331 foreach arg $revtreeargs {
12332 if {[file exists $arg]} {
12333 show_error {} . [mc "Ambiguous argument '%s': both revision\
12334 and filename" $arg]
12335 exit 1
12338 } err]} {
12339 # unfortunately we get both stdout and stderr in $err,
12340 # so look for "fatal:".
12341 set i [string first "fatal:" $err]
12342 if {$i > 0} {
12343 set err [string range $err [expr {$i + 6}] end]
12345 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12346 exit 1
12350 set nullid "0000000000000000000000000000000000000000"
12351 set nullid2 "0000000000000000000000000000000000000001"
12352 set nullfile "/dev/null"
12354 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12355 if {![info exists have_ttk]} {
12356 set have_ttk [llength [info commands ::ttk::style]]
12358 set use_ttk [expr {$have_ttk && $want_ttk}]
12359 set NS [expr {$use_ttk ? "ttk" : ""}]
12361 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12363 set show_notes {}
12364 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12365 set show_notes "--show-notes"
12368 set appname "gitk"
12370 set runq {}
12371 set history {}
12372 set historyindex 0
12373 set fh_serial 0
12374 set nhl_names {}
12375 set highlight_paths {}
12376 set findpattern {}
12377 set searchdirn -forwards
12378 set boldids {}
12379 set boldnameids {}
12380 set diffelide {0 0}
12381 set markingmatches 0
12382 set linkentercount 0
12383 set need_redisplay 0
12384 set nrows_drawn 0
12385 set firsttabstop 0
12387 set nextviewnum 1
12388 set curview 0
12389 set selectedview 0
12390 set selectedhlview [mc "None"]
12391 set highlight_related [mc "None"]
12392 set highlight_files {}
12393 set viewfiles(0) {}
12394 set viewperm(0) 0
12395 set viewchanged(0) 0
12396 set viewargs(0) {}
12397 set viewargscmd(0) {}
12399 set selectedline {}
12400 set numcommits 0
12401 set loginstance 0
12402 set cmdlineok 0
12403 set stopped 0
12404 set stuffsaved 0
12405 set patchnum 0
12406 set lserial 0
12407 set hasworktree [hasworktree]
12408 set cdup {}
12409 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12410 set cdup [exec git rev-parse --show-cdup]
12412 set worktree [exec git rev-parse --show-toplevel]
12413 setcoords
12414 makewindow
12415 catch {
12416 image create photo gitlogo -width 16 -height 16
12418 image create photo gitlogominus -width 4 -height 2
12419 gitlogominus put #C00000 -to 0 0 4 2
12420 gitlogo copy gitlogominus -to 1 5
12421 gitlogo copy gitlogominus -to 6 5
12422 gitlogo copy gitlogominus -to 11 5
12423 image delete gitlogominus
12425 image create photo gitlogoplus -width 4 -height 4
12426 gitlogoplus put #008000 -to 1 0 3 4
12427 gitlogoplus put #008000 -to 0 1 4 3
12428 gitlogo copy gitlogoplus -to 1 9
12429 gitlogo copy gitlogoplus -to 6 9
12430 gitlogo copy gitlogoplus -to 11 9
12431 image delete gitlogoplus
12433 image create photo gitlogo32 -width 32 -height 32
12434 gitlogo32 copy gitlogo -zoom 2 2
12436 wm iconphoto . -default gitlogo gitlogo32
12438 # wait for the window to become visible
12439 tkwait visibility .
12440 set_window_title
12441 update
12442 readrefs
12444 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12445 # create a view for the files/dirs specified on the command line
12446 set curview 1
12447 set selectedview 1
12448 set nextviewnum 2
12449 set viewname(1) [mc "Command line"]
12450 set viewfiles(1) $cmdline_files
12451 set viewargs(1) $revtreeargs
12452 set viewargscmd(1) $revtreeargscmd
12453 set viewperm(1) 0
12454 set viewchanged(1) 0
12455 set vdatemode(1) 0
12456 addviewmenu 1
12457 .bar.view entryconf [mca "&Edit view..."] -state normal
12458 .bar.view entryconf [mca "&Delete view"] -state normal
12461 if {[info exists permviews]} {
12462 foreach v $permviews {
12463 set n $nextviewnum
12464 incr nextviewnum
12465 set viewname($n) [lindex $v 0]
12466 set viewfiles($n) [lindex $v 1]
12467 set viewargs($n) [lindex $v 2]
12468 set viewargscmd($n) [lindex $v 3]
12469 set viewperm($n) 1
12470 set viewchanged($n) 0
12471 addviewmenu $n
12475 if {[tk windowingsystem] eq "win32"} {
12476 focus -force .
12479 getcommits {}
12481 # Local variables:
12482 # mode: tcl
12483 # indent-tabs-mode: t
12484 # tab-width: 8
12485 # End: