Merge branch 'sg/test-bool-env'
[alt-git.git] / gitk-git / gitk
blobabe4805adedb3c3559bf0048ae49df2e2ac37337
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2016 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 commitinfo
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 commitinfo
613 unset -nocomplain commitinterest
614 unset -nocomplain cached_commitrow
615 unset -nocomplain targetid
616 setcanvscroll
617 getcommits $selid
618 return 0
621 # This makes a string representation of a positive integer which
622 # sorts as a string in numerical order
623 proc strrep {n} {
624 if {$n < 16} {
625 return [format "%x" $n]
626 } elseif {$n < 256} {
627 return [format "x%.2x" $n]
628 } elseif {$n < 65536} {
629 return [format "y%.4x" $n]
631 return [format "z%.8x" $n]
634 # Procedures used in reordering commits from git log (without
635 # --topo-order) into the order for display.
637 proc varcinit {view} {
638 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
639 global vtokmod varcmod vrowmod varcix vlastins
641 set varcstart($view) {{}}
642 set vupptr($view) {0}
643 set vdownptr($view) {0}
644 set vleftptr($view) {0}
645 set vbackptr($view) {0}
646 set varctok($view) {{}}
647 set varcrow($view) {{}}
648 set vtokmod($view) {}
649 set varcmod($view) 0
650 set vrowmod($view) 0
651 set varcix($view) {{}}
652 set vlastins($view) {0}
655 proc resetvarcs {view} {
656 global varcid varccommits parents children vseedcount ordertok
657 global vshortids
659 foreach vid [array names varcid $view,*] {
660 unset varcid($vid)
661 unset children($vid)
662 unset parents($vid)
664 foreach vid [array names vshortids $view,*] {
665 unset vshortids($vid)
667 # some commits might have children but haven't been seen yet
668 foreach vid [array names children $view,*] {
669 unset children($vid)
671 foreach va [array names varccommits $view,*] {
672 unset varccommits($va)
674 foreach vd [array names vseedcount $view,*] {
675 unset vseedcount($vd)
677 unset -nocomplain ordertok
680 # returns a list of the commits with no children
681 proc seeds {v} {
682 global vdownptr vleftptr varcstart
684 set ret {}
685 set a [lindex $vdownptr($v) 0]
686 while {$a != 0} {
687 lappend ret [lindex $varcstart($v) $a]
688 set a [lindex $vleftptr($v) $a]
690 return $ret
693 proc newvarc {view id} {
694 global varcid varctok parents children vdatemode
695 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
696 global commitdata commitinfo vseedcount varccommits vlastins
698 set a [llength $varctok($view)]
699 set vid $view,$id
700 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
701 if {![info exists commitinfo($id)]} {
702 parsecommit $id $commitdata($id) 1
704 set cdate [lindex [lindex $commitinfo($id) 4] 0]
705 if {![string is integer -strict $cdate]} {
706 set cdate 0
708 if {![info exists vseedcount($view,$cdate)]} {
709 set vseedcount($view,$cdate) -1
711 set c [incr vseedcount($view,$cdate)]
712 set cdate [expr {$cdate ^ 0xffffffff}]
713 set tok "s[strrep $cdate][strrep $c]"
714 } else {
715 set tok {}
717 set ka 0
718 if {[llength $children($vid)] > 0} {
719 set kid [lindex $children($vid) end]
720 set k $varcid($view,$kid)
721 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
722 set ki $kid
723 set ka $k
724 set tok [lindex $varctok($view) $k]
727 if {$ka != 0} {
728 set i [lsearch -exact $parents($view,$ki) $id]
729 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
730 append tok [strrep $j]
732 set c [lindex $vlastins($view) $ka]
733 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
734 set c $ka
735 set b [lindex $vdownptr($view) $ka]
736 } else {
737 set b [lindex $vleftptr($view) $c]
739 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
740 set c $b
741 set b [lindex $vleftptr($view) $c]
743 if {$c == $ka} {
744 lset vdownptr($view) $ka $a
745 lappend vbackptr($view) 0
746 } else {
747 lset vleftptr($view) $c $a
748 lappend vbackptr($view) $c
750 lset vlastins($view) $ka $a
751 lappend vupptr($view) $ka
752 lappend vleftptr($view) $b
753 if {$b != 0} {
754 lset vbackptr($view) $b $a
756 lappend varctok($view) $tok
757 lappend varcstart($view) $id
758 lappend vdownptr($view) 0
759 lappend varcrow($view) {}
760 lappend varcix($view) {}
761 set varccommits($view,$a) {}
762 lappend vlastins($view) 0
763 return $a
766 proc splitvarc {p v} {
767 global varcid varcstart varccommits varctok vtokmod
768 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
770 set oa $varcid($v,$p)
771 set otok [lindex $varctok($v) $oa]
772 set ac $varccommits($v,$oa)
773 set i [lsearch -exact $varccommits($v,$oa) $p]
774 if {$i <= 0} return
775 set na [llength $varctok($v)]
776 # "%" sorts before "0"...
777 set tok "$otok%[strrep $i]"
778 lappend varctok($v) $tok
779 lappend varcrow($v) {}
780 lappend varcix($v) {}
781 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
782 set varccommits($v,$na) [lrange $ac $i end]
783 lappend varcstart($v) $p
784 foreach id $varccommits($v,$na) {
785 set varcid($v,$id) $na
787 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
788 lappend vlastins($v) [lindex $vlastins($v) $oa]
789 lset vdownptr($v) $oa $na
790 lset vlastins($v) $oa 0
791 lappend vupptr($v) $oa
792 lappend vleftptr($v) 0
793 lappend vbackptr($v) 0
794 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
795 lset vupptr($v) $b $na
797 if {[string compare $otok $vtokmod($v)] <= 0} {
798 modify_arc $v $oa
802 proc renumbervarc {a v} {
803 global parents children varctok varcstart varccommits
804 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
806 set t1 [clock clicks -milliseconds]
807 set todo {}
808 set isrelated($a) 1
809 set kidchanged($a) 1
810 set ntot 0
811 while {$a != 0} {
812 if {[info exists isrelated($a)]} {
813 lappend todo $a
814 set id [lindex $varccommits($v,$a) end]
815 foreach p $parents($v,$id) {
816 if {[info exists varcid($v,$p)]} {
817 set isrelated($varcid($v,$p)) 1
821 incr ntot
822 set b [lindex $vdownptr($v) $a]
823 if {$b == 0} {
824 while {$a != 0} {
825 set b [lindex $vleftptr($v) $a]
826 if {$b != 0} break
827 set a [lindex $vupptr($v) $a]
830 set a $b
832 foreach a $todo {
833 if {![info exists kidchanged($a)]} continue
834 set id [lindex $varcstart($v) $a]
835 if {[llength $children($v,$id)] > 1} {
836 set children($v,$id) [lsort -command [list vtokcmp $v] \
837 $children($v,$id)]
839 set oldtok [lindex $varctok($v) $a]
840 if {!$vdatemode($v)} {
841 set tok {}
842 } else {
843 set tok $oldtok
845 set ka 0
846 set kid [last_real_child $v,$id]
847 if {$kid ne {}} {
848 set k $varcid($v,$kid)
849 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
850 set ki $kid
851 set ka $k
852 set tok [lindex $varctok($v) $k]
855 if {$ka != 0} {
856 set i [lsearch -exact $parents($v,$ki) $id]
857 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
858 append tok [strrep $j]
860 if {$tok eq $oldtok} {
861 continue
863 set id [lindex $varccommits($v,$a) end]
864 foreach p $parents($v,$id) {
865 if {[info exists varcid($v,$p)]} {
866 set kidchanged($varcid($v,$p)) 1
867 } else {
868 set sortkids($p) 1
871 lset varctok($v) $a $tok
872 set b [lindex $vupptr($v) $a]
873 if {$b != $ka} {
874 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
875 modify_arc $v $ka
877 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
878 modify_arc $v $b
880 set c [lindex $vbackptr($v) $a]
881 set d [lindex $vleftptr($v) $a]
882 if {$c == 0} {
883 lset vdownptr($v) $b $d
884 } else {
885 lset vleftptr($v) $c $d
887 if {$d != 0} {
888 lset vbackptr($v) $d $c
890 if {[lindex $vlastins($v) $b] == $a} {
891 lset vlastins($v) $b $c
893 lset vupptr($v) $a $ka
894 set c [lindex $vlastins($v) $ka]
895 if {$c == 0 || \
896 [string compare $tok [lindex $varctok($v) $c]] < 0} {
897 set c $ka
898 set b [lindex $vdownptr($v) $ka]
899 } else {
900 set b [lindex $vleftptr($v) $c]
902 while {$b != 0 && \
903 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
904 set c $b
905 set b [lindex $vleftptr($v) $c]
907 if {$c == $ka} {
908 lset vdownptr($v) $ka $a
909 lset vbackptr($v) $a 0
910 } else {
911 lset vleftptr($v) $c $a
912 lset vbackptr($v) $a $c
914 lset vleftptr($v) $a $b
915 if {$b != 0} {
916 lset vbackptr($v) $b $a
918 lset vlastins($v) $ka $a
921 foreach id [array names sortkids] {
922 if {[llength $children($v,$id)] > 1} {
923 set children($v,$id) [lsort -command [list vtokcmp $v] \
924 $children($v,$id)]
927 set t2 [clock clicks -milliseconds]
928 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
931 # Fix up the graph after we have found out that in view $v,
932 # $p (a commit that we have already seen) is actually the parent
933 # of the last commit in arc $a.
934 proc fix_reversal {p a v} {
935 global varcid varcstart varctok vupptr
937 set pa $varcid($v,$p)
938 if {$p ne [lindex $varcstart($v) $pa]} {
939 splitvarc $p $v
940 set pa $varcid($v,$p)
942 # seeds always need to be renumbered
943 if {[lindex $vupptr($v) $pa] == 0 ||
944 [string compare [lindex $varctok($v) $a] \
945 [lindex $varctok($v) $pa]] > 0} {
946 renumbervarc $pa $v
950 proc insertrow {id p v} {
951 global cmitlisted children parents varcid varctok vtokmod
952 global varccommits ordertok commitidx numcommits curview
953 global targetid targetrow vshortids
955 readcommit $id
956 set vid $v,$id
957 set cmitlisted($vid) 1
958 set children($vid) {}
959 set parents($vid) [list $p]
960 set a [newvarc $v $id]
961 set varcid($vid) $a
962 lappend vshortids($v,[string range $id 0 3]) $id
963 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
964 modify_arc $v $a
966 lappend varccommits($v,$a) $id
967 set vp $v,$p
968 if {[llength [lappend children($vp) $id]] > 1} {
969 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
970 unset -nocomplain ordertok
972 fix_reversal $p $a $v
973 incr commitidx($v)
974 if {$v == $curview} {
975 set numcommits $commitidx($v)
976 setcanvscroll
977 if {[info exists targetid]} {
978 if {![comes_before $targetid $p]} {
979 incr targetrow
985 proc insertfakerow {id p} {
986 global varcid varccommits parents children cmitlisted
987 global commitidx varctok vtokmod targetid targetrow curview numcommits
989 set v $curview
990 set a $varcid($v,$p)
991 set i [lsearch -exact $varccommits($v,$a) $p]
992 if {$i < 0} {
993 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
994 return
996 set children($v,$id) {}
997 set parents($v,$id) [list $p]
998 set varcid($v,$id) $a
999 lappend children($v,$p) $id
1000 set cmitlisted($v,$id) 1
1001 set numcommits [incr commitidx($v)]
1002 # note we deliberately don't update varcstart($v) even if $i == 0
1003 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1004 modify_arc $v $a $i
1005 if {[info exists targetid]} {
1006 if {![comes_before $targetid $p]} {
1007 incr targetrow
1010 setcanvscroll
1011 drawvisible
1014 proc removefakerow {id} {
1015 global varcid varccommits parents children commitidx
1016 global varctok vtokmod cmitlisted currentid selectedline
1017 global targetid curview numcommits
1019 set v $curview
1020 if {[llength $parents($v,$id)] != 1} {
1021 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1022 return
1024 set p [lindex $parents($v,$id) 0]
1025 set a $varcid($v,$id)
1026 set i [lsearch -exact $varccommits($v,$a) $id]
1027 if {$i < 0} {
1028 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1029 return
1031 unset varcid($v,$id)
1032 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1033 unset parents($v,$id)
1034 unset children($v,$id)
1035 unset cmitlisted($v,$id)
1036 set numcommits [incr commitidx($v) -1]
1037 set j [lsearch -exact $children($v,$p) $id]
1038 if {$j >= 0} {
1039 set children($v,$p) [lreplace $children($v,$p) $j $j]
1041 modify_arc $v $a $i
1042 if {[info exist currentid] && $id eq $currentid} {
1043 unset currentid
1044 set selectedline {}
1046 if {[info exists targetid] && $targetid eq $id} {
1047 set targetid $p
1049 setcanvscroll
1050 drawvisible
1053 proc real_children {vp} {
1054 global children nullid nullid2
1056 set kids {}
1057 foreach id $children($vp) {
1058 if {$id ne $nullid && $id ne $nullid2} {
1059 lappend kids $id
1062 return $kids
1065 proc first_real_child {vp} {
1066 global children nullid nullid2
1068 foreach id $children($vp) {
1069 if {$id ne $nullid && $id ne $nullid2} {
1070 return $id
1073 return {}
1076 proc last_real_child {vp} {
1077 global children nullid nullid2
1079 set kids $children($vp)
1080 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1081 set id [lindex $kids $i]
1082 if {$id ne $nullid && $id ne $nullid2} {
1083 return $id
1086 return {}
1089 proc vtokcmp {v a b} {
1090 global varctok varcid
1092 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1093 [lindex $varctok($v) $varcid($v,$b)]]
1096 # This assumes that if lim is not given, the caller has checked that
1097 # arc a's token is less than $vtokmod($v)
1098 proc modify_arc {v a {lim {}}} {
1099 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1101 if {$lim ne {}} {
1102 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1103 if {$c > 0} return
1104 if {$c == 0} {
1105 set r [lindex $varcrow($v) $a]
1106 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1109 set vtokmod($v) [lindex $varctok($v) $a]
1110 set varcmod($v) $a
1111 if {$v == $curview} {
1112 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1113 set a [lindex $vupptr($v) $a]
1114 set lim {}
1116 set r 0
1117 if {$a != 0} {
1118 if {$lim eq {}} {
1119 set lim [llength $varccommits($v,$a)]
1121 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1123 set vrowmod($v) $r
1124 undolayout $r
1128 proc update_arcrows {v} {
1129 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1130 global varcid vrownum varcorder varcix varccommits
1131 global vupptr vdownptr vleftptr varctok
1132 global displayorder parentlist curview cached_commitrow
1134 if {$vrowmod($v) == $commitidx($v)} return
1135 if {$v == $curview} {
1136 if {[llength $displayorder] > $vrowmod($v)} {
1137 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1138 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1140 unset -nocomplain cached_commitrow
1142 set narctot [expr {[llength $varctok($v)] - 1}]
1143 set a $varcmod($v)
1144 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1145 # go up the tree until we find something that has a row number,
1146 # or we get to a seed
1147 set a [lindex $vupptr($v) $a]
1149 if {$a == 0} {
1150 set a [lindex $vdownptr($v) 0]
1151 if {$a == 0} return
1152 set vrownum($v) {0}
1153 set varcorder($v) [list $a]
1154 lset varcix($v) $a 0
1155 lset varcrow($v) $a 0
1156 set arcn 0
1157 set row 0
1158 } else {
1159 set arcn [lindex $varcix($v) $a]
1160 if {[llength $vrownum($v)] > $arcn + 1} {
1161 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1162 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1164 set row [lindex $varcrow($v) $a]
1166 while {1} {
1167 set p $a
1168 incr row [llength $varccommits($v,$a)]
1169 # go down if possible
1170 set b [lindex $vdownptr($v) $a]
1171 if {$b == 0} {
1172 # if not, go left, or go up until we can go left
1173 while {$a != 0} {
1174 set b [lindex $vleftptr($v) $a]
1175 if {$b != 0} break
1176 set a [lindex $vupptr($v) $a]
1178 if {$a == 0} break
1180 set a $b
1181 incr arcn
1182 lappend vrownum($v) $row
1183 lappend varcorder($v) $a
1184 lset varcix($v) $a $arcn
1185 lset varcrow($v) $a $row
1187 set vtokmod($v) [lindex $varctok($v) $p]
1188 set varcmod($v) $p
1189 set vrowmod($v) $row
1190 if {[info exists currentid]} {
1191 set selectedline [rowofcommit $currentid]
1195 # Test whether view $v contains commit $id
1196 proc commitinview {id v} {
1197 global varcid
1199 return [info exists varcid($v,$id)]
1202 # Return the row number for commit $id in the current view
1203 proc rowofcommit {id} {
1204 global varcid varccommits varcrow curview cached_commitrow
1205 global varctok vtokmod
1207 set v $curview
1208 if {![info exists varcid($v,$id)]} {
1209 puts "oops rowofcommit no arc for [shortids $id]"
1210 return {}
1212 set a $varcid($v,$id)
1213 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1214 update_arcrows $v
1216 if {[info exists cached_commitrow($id)]} {
1217 return $cached_commitrow($id)
1219 set i [lsearch -exact $varccommits($v,$a) $id]
1220 if {$i < 0} {
1221 puts "oops didn't find commit [shortids $id] in arc $a"
1222 return {}
1224 incr i [lindex $varcrow($v) $a]
1225 set cached_commitrow($id) $i
1226 return $i
1229 # Returns 1 if a is on an earlier row than b, otherwise 0
1230 proc comes_before {a b} {
1231 global varcid varctok curview
1233 set v $curview
1234 if {$a eq $b || ![info exists varcid($v,$a)] || \
1235 ![info exists varcid($v,$b)]} {
1236 return 0
1238 if {$varcid($v,$a) != $varcid($v,$b)} {
1239 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1240 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1242 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1245 proc bsearch {l elt} {
1246 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1247 return 0
1249 set lo 0
1250 set hi [llength $l]
1251 while {$hi - $lo > 1} {
1252 set mid [expr {int(($lo + $hi) / 2)}]
1253 set t [lindex $l $mid]
1254 if {$elt < $t} {
1255 set hi $mid
1256 } elseif {$elt > $t} {
1257 set lo $mid
1258 } else {
1259 return $mid
1262 return $lo
1265 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1266 proc make_disporder {start end} {
1267 global vrownum curview commitidx displayorder parentlist
1268 global varccommits varcorder parents vrowmod varcrow
1269 global d_valid_start d_valid_end
1271 if {$end > $vrowmod($curview)} {
1272 update_arcrows $curview
1274 set ai [bsearch $vrownum($curview) $start]
1275 set start [lindex $vrownum($curview) $ai]
1276 set narc [llength $vrownum($curview)]
1277 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1278 set a [lindex $varcorder($curview) $ai]
1279 set l [llength $displayorder]
1280 set al [llength $varccommits($curview,$a)]
1281 if {$l < $r + $al} {
1282 if {$l < $r} {
1283 set pad [ntimes [expr {$r - $l}] {}]
1284 set displayorder [concat $displayorder $pad]
1285 set parentlist [concat $parentlist $pad]
1286 } elseif {$l > $r} {
1287 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1288 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1290 foreach id $varccommits($curview,$a) {
1291 lappend displayorder $id
1292 lappend parentlist $parents($curview,$id)
1294 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1295 set i $r
1296 foreach id $varccommits($curview,$a) {
1297 lset displayorder $i $id
1298 lset parentlist $i $parents($curview,$id)
1299 incr i
1302 incr r $al
1306 proc commitonrow {row} {
1307 global displayorder
1309 set id [lindex $displayorder $row]
1310 if {$id eq {}} {
1311 make_disporder $row [expr {$row + 1}]
1312 set id [lindex $displayorder $row]
1314 return $id
1317 proc closevarcs {v} {
1318 global varctok varccommits varcid parents children
1319 global cmitlisted commitidx vtokmod curview numcommits
1321 set missing_parents 0
1322 set scripts {}
1323 set narcs [llength $varctok($v)]
1324 for {set a 1} {$a < $narcs} {incr a} {
1325 set id [lindex $varccommits($v,$a) end]
1326 foreach p $parents($v,$id) {
1327 if {[info exists varcid($v,$p)]} continue
1328 # add p as a new commit
1329 incr missing_parents
1330 set cmitlisted($v,$p) 0
1331 set parents($v,$p) {}
1332 if {[llength $children($v,$p)] == 1 &&
1333 [llength $parents($v,$id)] == 1} {
1334 set b $a
1335 } else {
1336 set b [newvarc $v $p]
1338 set varcid($v,$p) $b
1339 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1340 modify_arc $v $b
1342 lappend varccommits($v,$b) $p
1343 incr commitidx($v)
1344 if {$v == $curview} {
1345 set numcommits $commitidx($v)
1347 set scripts [check_interest $p $scripts]
1350 if {$missing_parents > 0} {
1351 foreach s $scripts {
1352 eval $s
1357 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1358 # Assumes we already have an arc for $rwid.
1359 proc rewrite_commit {v id rwid} {
1360 global children parents varcid varctok vtokmod varccommits
1362 foreach ch $children($v,$id) {
1363 # make $rwid be $ch's parent in place of $id
1364 set i [lsearch -exact $parents($v,$ch) $id]
1365 if {$i < 0} {
1366 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1368 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1369 # add $ch to $rwid's children and sort the list if necessary
1370 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1371 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1372 $children($v,$rwid)]
1374 # fix the graph after joining $id to $rwid
1375 set a $varcid($v,$ch)
1376 fix_reversal $rwid $a $v
1377 # parentlist is wrong for the last element of arc $a
1378 # even if displayorder is right, hence the 3rd arg here
1379 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1383 # Mechanism for registering a command to be executed when we come
1384 # across a particular commit. To handle the case when only the
1385 # prefix of the commit is known, the commitinterest array is now
1386 # indexed by the first 4 characters of the ID. Each element is a
1387 # list of id, cmd pairs.
1388 proc interestedin {id cmd} {
1389 global commitinterest
1391 lappend commitinterest([string range $id 0 3]) $id $cmd
1394 proc check_interest {id scripts} {
1395 global commitinterest
1397 set prefix [string range $id 0 3]
1398 if {[info exists commitinterest($prefix)]} {
1399 set newlist {}
1400 foreach {i script} $commitinterest($prefix) {
1401 if {[string match "$i*" $id]} {
1402 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1403 } else {
1404 lappend newlist $i $script
1407 if {$newlist ne {}} {
1408 set commitinterest($prefix) $newlist
1409 } else {
1410 unset commitinterest($prefix)
1413 return $scripts
1416 proc getcommitlines {fd inst view updating} {
1417 global cmitlisted leftover
1418 global commitidx commitdata vdatemode
1419 global parents children curview hlview
1420 global idpending ordertok
1421 global varccommits varcid varctok vtokmod vfilelimit vshortids
1423 set stuff [read $fd 500000]
1424 # git log doesn't terminate the last commit with a null...
1425 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1426 set stuff "\0"
1428 if {$stuff == {}} {
1429 if {![eof $fd]} {
1430 return 1
1432 global commfd viewcomplete viewactive viewname
1433 global viewinstances
1434 unset commfd($inst)
1435 set i [lsearch -exact $viewinstances($view) $inst]
1436 if {$i >= 0} {
1437 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1439 # set it blocking so we wait for the process to terminate
1440 fconfigure $fd -blocking 1
1441 if {[catch {close $fd} err]} {
1442 set fv {}
1443 if {$view != $curview} {
1444 set fv " for the \"$viewname($view)\" view"
1446 if {[string range $err 0 4] == "usage"} {
1447 set err "Gitk: error reading commits$fv:\
1448 bad arguments to git log."
1449 if {$viewname($view) eq [mc "Command line"]} {
1450 append err \
1451 " (Note: arguments to gitk are passed to git log\
1452 to allow selection of commits to be displayed.)"
1454 } else {
1455 set err "Error reading commits$fv: $err"
1457 error_popup $err
1459 if {[incr viewactive($view) -1] <= 0} {
1460 set viewcomplete($view) 1
1461 # Check if we have seen any ids listed as parents that haven't
1462 # appeared in the list
1463 closevarcs $view
1464 notbusy $view
1466 if {$view == $curview} {
1467 run chewcommits
1469 return 0
1471 set start 0
1472 set gotsome 0
1473 set scripts {}
1474 while 1 {
1475 set i [string first "\0" $stuff $start]
1476 if {$i < 0} {
1477 append leftover($inst) [string range $stuff $start end]
1478 break
1480 if {$start == 0} {
1481 set cmit $leftover($inst)
1482 append cmit [string range $stuff 0 [expr {$i - 1}]]
1483 set leftover($inst) {}
1484 } else {
1485 set cmit [string range $stuff $start [expr {$i - 1}]]
1487 set start [expr {$i + 1}]
1488 set j [string first "\n" $cmit]
1489 set ok 0
1490 set listed 1
1491 if {$j >= 0 && [string match "commit *" $cmit]} {
1492 set ids [string range $cmit 7 [expr {$j - 1}]]
1493 if {[string match {[-^<>]*} $ids]} {
1494 switch -- [string index $ids 0] {
1495 "-" {set listed 0}
1496 "^" {set listed 2}
1497 "<" {set listed 3}
1498 ">" {set listed 4}
1500 set ids [string range $ids 1 end]
1502 set ok 1
1503 foreach id $ids {
1504 if {[string length $id] != 40} {
1505 set ok 0
1506 break
1510 if {!$ok} {
1511 set shortcmit $cmit
1512 if {[string length $shortcmit] > 80} {
1513 set shortcmit "[string range $shortcmit 0 80]..."
1515 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1516 exit 1
1518 set id [lindex $ids 0]
1519 set vid $view,$id
1521 lappend vshortids($view,[string range $id 0 3]) $id
1523 if {!$listed && $updating && ![info exists varcid($vid)] &&
1524 $vfilelimit($view) ne {}} {
1525 # git log doesn't rewrite parents for unlisted commits
1526 # when doing path limiting, so work around that here
1527 # by working out the rewritten parent with git rev-list
1528 # and if we already know about it, using the rewritten
1529 # parent as a substitute parent for $id's children.
1530 if {![catch {
1531 set rwid [exec git rev-list --first-parent --max-count=1 \
1532 $id -- $vfilelimit($view)]
1533 }]} {
1534 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1535 # use $rwid in place of $id
1536 rewrite_commit $view $id $rwid
1537 continue
1542 set a 0
1543 if {[info exists varcid($vid)]} {
1544 if {$cmitlisted($vid) || !$listed} continue
1545 set a $varcid($vid)
1547 if {$listed} {
1548 set olds [lrange $ids 1 end]
1549 } else {
1550 set olds {}
1552 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1553 set cmitlisted($vid) $listed
1554 set parents($vid) $olds
1555 if {![info exists children($vid)]} {
1556 set children($vid) {}
1557 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1558 set k [lindex $children($vid) 0]
1559 if {[llength $parents($view,$k)] == 1 &&
1560 (!$vdatemode($view) ||
1561 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1562 set a $varcid($view,$k)
1565 if {$a == 0} {
1566 # new arc
1567 set a [newvarc $view $id]
1569 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1570 modify_arc $view $a
1572 if {![info exists varcid($vid)]} {
1573 set varcid($vid) $a
1574 lappend varccommits($view,$a) $id
1575 incr commitidx($view)
1578 set i 0
1579 foreach p $olds {
1580 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1581 set vp $view,$p
1582 if {[llength [lappend children($vp) $id]] > 1 &&
1583 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1584 set children($vp) [lsort -command [list vtokcmp $view] \
1585 $children($vp)]
1586 unset -nocomplain ordertok
1588 if {[info exists varcid($view,$p)]} {
1589 fix_reversal $p $a $view
1592 incr i
1595 set scripts [check_interest $id $scripts]
1596 set gotsome 1
1598 if {$gotsome} {
1599 global numcommits hlview
1601 if {$view == $curview} {
1602 set numcommits $commitidx($view)
1603 run chewcommits
1605 if {[info exists hlview] && $view == $hlview} {
1606 # we never actually get here...
1607 run vhighlightmore
1609 foreach s $scripts {
1610 eval $s
1613 return 2
1616 proc chewcommits {} {
1617 global curview hlview viewcomplete
1618 global pending_select
1620 layoutmore
1621 if {$viewcomplete($curview)} {
1622 global commitidx varctok
1623 global numcommits startmsecs
1625 if {[info exists pending_select]} {
1626 update
1627 reset_pending_select {}
1629 if {[commitinview $pending_select $curview]} {
1630 selectline [rowofcommit $pending_select] 1
1631 } else {
1632 set row [first_real_row]
1633 selectline $row 1
1636 if {$commitidx($curview) > 0} {
1637 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1638 #puts "overall $ms ms for $numcommits commits"
1639 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1640 } else {
1641 show_status [mc "No commits selected"]
1643 notbusy layout
1645 return 0
1648 proc do_readcommit {id} {
1649 global tclencoding
1651 # Invoke git-log to handle automatic encoding conversion
1652 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1653 # Read the results using i18n.logoutputencoding
1654 fconfigure $fd -translation lf -eofchar {}
1655 if {$tclencoding != {}} {
1656 fconfigure $fd -encoding $tclencoding
1658 set contents [read $fd]
1659 close $fd
1660 # Remove the heading line
1661 regsub {^commit [0-9a-f]+\n} $contents {} contents
1663 return $contents
1666 proc readcommit {id} {
1667 if {[catch {set contents [do_readcommit $id]}]} return
1668 parsecommit $id $contents 1
1671 proc parsecommit {id contents listed} {
1672 global commitinfo
1674 set inhdr 1
1675 set comment {}
1676 set headline {}
1677 set auname {}
1678 set audate {}
1679 set comname {}
1680 set comdate {}
1681 set hdrend [string first "\n\n" $contents]
1682 if {$hdrend < 0} {
1683 # should never happen...
1684 set hdrend [string length $contents]
1686 set header [string range $contents 0 [expr {$hdrend - 1}]]
1687 set comment [string range $contents [expr {$hdrend + 2}] end]
1688 foreach line [split $header "\n"] {
1689 set line [split $line " "]
1690 set tag [lindex $line 0]
1691 if {$tag == "author"} {
1692 set audate [lrange $line end-1 end]
1693 set auname [join [lrange $line 1 end-2] " "]
1694 } elseif {$tag == "committer"} {
1695 set comdate [lrange $line end-1 end]
1696 set comname [join [lrange $line 1 end-2] " "]
1699 set headline {}
1700 # take the first non-blank line of the comment as the headline
1701 set headline [string trimleft $comment]
1702 set i [string first "\n" $headline]
1703 if {$i >= 0} {
1704 set headline [string range $headline 0 $i]
1706 set headline [string trimright $headline]
1707 set i [string first "\r" $headline]
1708 if {$i >= 0} {
1709 set headline [string trimright [string range $headline 0 $i]]
1711 if {!$listed} {
1712 # git log indents the comment by 4 spaces;
1713 # if we got this via git cat-file, add the indentation
1714 set newcomment {}
1715 foreach line [split $comment "\n"] {
1716 append newcomment " "
1717 append newcomment $line
1718 append newcomment "\n"
1720 set comment $newcomment
1722 set hasnote [string first "\nNotes:\n" $contents]
1723 set diff ""
1724 # If there is diff output shown in the git-log stream, split it
1725 # out. But get rid of the empty line that always precedes the
1726 # diff.
1727 set i [string first "\n\ndiff" $comment]
1728 if {$i >= 0} {
1729 set diff [string range $comment $i+1 end]
1730 set comment [string range $comment 0 $i-1]
1732 set commitinfo($id) [list $headline $auname $audate \
1733 $comname $comdate $comment $hasnote $diff]
1736 proc getcommit {id} {
1737 global commitdata commitinfo
1739 if {[info exists commitdata($id)]} {
1740 parsecommit $id $commitdata($id) 1
1741 } else {
1742 readcommit $id
1743 if {![info exists commitinfo($id)]} {
1744 set commitinfo($id) [list [mc "No commit information available"]]
1747 return 1
1750 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1751 # and are present in the current view.
1752 # This is fairly slow...
1753 proc longid {prefix} {
1754 global varcid curview vshortids
1756 set ids {}
1757 if {[string length $prefix] >= 4} {
1758 set vshortid $curview,[string range $prefix 0 3]
1759 if {[info exists vshortids($vshortid)]} {
1760 foreach id $vshortids($vshortid) {
1761 if {[string match "$prefix*" $id]} {
1762 if {[lsearch -exact $ids $id] < 0} {
1763 lappend ids $id
1764 if {[llength $ids] >= 2} break
1769 } else {
1770 foreach match [array names varcid "$curview,$prefix*"] {
1771 lappend ids [lindex [split $match ","] 1]
1772 if {[llength $ids] >= 2} break
1775 return $ids
1778 proc readrefs {} {
1779 global tagids idtags headids idheads tagobjid
1780 global otherrefids idotherrefs mainhead mainheadid
1781 global selecthead selectheadid
1782 global hideremotes
1784 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1785 unset -nocomplain $v
1787 set refd [open [list | git show-ref -d] r]
1788 while {[gets $refd line] >= 0} {
1789 if {[string index $line 40] ne " "} continue
1790 set id [string range $line 0 39]
1791 set ref [string range $line 41 end]
1792 if {![string match "refs/*" $ref]} continue
1793 set name [string range $ref 5 end]
1794 if {[string match "remotes/*" $name]} {
1795 if {![string match "*/HEAD" $name] && !$hideremotes} {
1796 set headids($name) $id
1797 lappend idheads($id) $name
1799 } elseif {[string match "heads/*" $name]} {
1800 set name [string range $name 6 end]
1801 set headids($name) $id
1802 lappend idheads($id) $name
1803 } elseif {[string match "tags/*" $name]} {
1804 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1805 # which is what we want since the former is the commit ID
1806 set name [string range $name 5 end]
1807 if {[string match "*^{}" $name]} {
1808 set name [string range $name 0 end-3]
1809 } else {
1810 set tagobjid($name) $id
1812 set tagids($name) $id
1813 lappend idtags($id) $name
1814 } else {
1815 set otherrefids($name) $id
1816 lappend idotherrefs($id) $name
1819 catch {close $refd}
1820 set mainhead {}
1821 set mainheadid {}
1822 catch {
1823 set mainheadid [exec git rev-parse HEAD]
1824 set thehead [exec git symbolic-ref HEAD]
1825 if {[string match "refs/heads/*" $thehead]} {
1826 set mainhead [string range $thehead 11 end]
1829 set selectheadid {}
1830 if {$selecthead ne {}} {
1831 catch {
1832 set selectheadid [exec git rev-parse --verify $selecthead]
1837 # skip over fake commits
1838 proc first_real_row {} {
1839 global nullid nullid2 numcommits
1841 for {set row 0} {$row < $numcommits} {incr row} {
1842 set id [commitonrow $row]
1843 if {$id ne $nullid && $id ne $nullid2} {
1844 break
1847 return $row
1850 # update things for a head moved to a child of its previous location
1851 proc movehead {id name} {
1852 global headids idheads
1854 removehead $headids($name) $name
1855 set headids($name) $id
1856 lappend idheads($id) $name
1859 # update things when a head has been removed
1860 proc removehead {id name} {
1861 global headids idheads
1863 if {$idheads($id) eq $name} {
1864 unset idheads($id)
1865 } else {
1866 set i [lsearch -exact $idheads($id) $name]
1867 if {$i >= 0} {
1868 set idheads($id) [lreplace $idheads($id) $i $i]
1871 unset headids($name)
1874 proc ttk_toplevel {w args} {
1875 global use_ttk
1876 eval [linsert $args 0 ::toplevel $w]
1877 if {$use_ttk} {
1878 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1880 return $w
1883 proc make_transient {window origin} {
1884 global have_tk85
1886 # In MacOS Tk 8.4 transient appears to work by setting
1887 # overrideredirect, which is utterly useless, since the
1888 # windows get no border, and are not even kept above
1889 # the parent.
1890 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1892 wm transient $window $origin
1894 # Windows fails to place transient windows normally, so
1895 # schedule a callback to center them on the parent.
1896 if {[tk windowingsystem] eq {win32}} {
1897 after idle [list tk::PlaceWindow $window widget $origin]
1901 proc show_error {w top msg} {
1902 global NS
1903 if {![info exists NS]} {set NS ""}
1904 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1905 message $w.m -text $msg -justify center -aspect 400
1906 pack $w.m -side top -fill x -padx 20 -pady 20
1907 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1908 pack $w.ok -side bottom -fill x
1909 bind $top <Visibility> "grab $top; focus $top"
1910 bind $top <Key-Return> "destroy $top"
1911 bind $top <Key-space> "destroy $top"
1912 bind $top <Key-Escape> "destroy $top"
1913 tkwait window $top
1916 proc error_popup {msg {owner .}} {
1917 if {[tk windowingsystem] eq "win32"} {
1918 tk_messageBox -icon error -type ok -title [wm title .] \
1919 -parent $owner -message $msg
1920 } else {
1921 set w .error
1922 ttk_toplevel $w
1923 make_transient $w $owner
1924 show_error $w $w $msg
1928 proc confirm_popup {msg {owner .}} {
1929 global confirm_ok NS
1930 set confirm_ok 0
1931 set w .confirm
1932 ttk_toplevel $w
1933 make_transient $w $owner
1934 message $w.m -text $msg -justify center -aspect 400
1935 pack $w.m -side top -fill x -padx 20 -pady 20
1936 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1937 pack $w.ok -side left -fill x
1938 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1939 pack $w.cancel -side right -fill x
1940 bind $w <Visibility> "grab $w; focus $w"
1941 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1942 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1943 bind $w <Key-Escape> "destroy $w"
1944 tk::PlaceWindow $w widget $owner
1945 tkwait window $w
1946 return $confirm_ok
1949 proc setoptions {} {
1950 global use_ttk
1952 if {[tk windowingsystem] ne "win32"} {
1953 option add *Panedwindow.showHandle 1 startupFile
1954 option add *Panedwindow.sashRelief raised startupFile
1955 if {[tk windowingsystem] ne "aqua"} {
1956 option add *Menu.font uifont startupFile
1958 } else {
1959 option add *Menu.TearOff 0 startupFile
1961 option add *Button.font uifont startupFile
1962 option add *Checkbutton.font uifont startupFile
1963 option add *Radiobutton.font uifont startupFile
1964 option add *Menubutton.font uifont startupFile
1965 option add *Label.font uifont startupFile
1966 option add *Message.font uifont startupFile
1967 option add *Entry.font textfont startupFile
1968 option add *Text.font textfont startupFile
1969 option add *Labelframe.font uifont startupFile
1970 option add *Spinbox.font textfont startupFile
1971 option add *Listbox.font mainfont startupFile
1974 proc setttkstyle {} {
1975 eval font configure TkDefaultFont [fontflags mainfont]
1976 eval font configure TkTextFont [fontflags textfont]
1977 eval font configure TkHeadingFont [fontflags mainfont]
1978 eval font configure TkCaptionFont [fontflags mainfont] -weight bold
1979 eval font configure TkTooltipFont [fontflags uifont]
1980 eval font configure TkFixedFont [fontflags textfont]
1981 eval font configure TkIconFont [fontflags uifont]
1982 eval font configure TkMenuFont [fontflags uifont]
1983 eval font configure TkSmallCaptionFont [fontflags uifont]
1986 # Make a menu and submenus.
1987 # m is the window name for the menu, items is the list of menu items to add.
1988 # Each item is a list {mc label type description options...}
1989 # mc is ignored; it's so we can put mc there to alert xgettext
1990 # label is the string that appears in the menu
1991 # type is cascade, command or radiobutton (should add checkbutton)
1992 # description depends on type; it's the sublist for cascade, the
1993 # command to invoke for command, or {variable value} for radiobutton
1994 proc makemenu {m items} {
1995 menu $m
1996 if {[tk windowingsystem] eq {aqua}} {
1997 set Meta1 Cmd
1998 } else {
1999 set Meta1 Ctrl
2001 foreach i $items {
2002 set name [mc [lindex $i 1]]
2003 set type [lindex $i 2]
2004 set thing [lindex $i 3]
2005 set params [list $type]
2006 if {$name ne {}} {
2007 set u [string first "&" [string map {&& x} $name]]
2008 lappend params -label [string map {&& & & {}} $name]
2009 if {$u >= 0} {
2010 lappend params -underline $u
2013 switch -- $type {
2014 "cascade" {
2015 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
2016 lappend params -menu $m.$submenu
2018 "command" {
2019 lappend params -command $thing
2021 "radiobutton" {
2022 lappend params -variable [lindex $thing 0] \
2023 -value [lindex $thing 1]
2026 set tail [lrange $i 4 end]
2027 regsub -all {\yMeta1\y} $tail $Meta1 tail
2028 eval $m add $params $tail
2029 if {$type eq "cascade"} {
2030 makemenu $m.$submenu $thing
2035 # translate string and remove ampersands
2036 proc mca {str} {
2037 return [string map {&& & & {}} [mc $str]]
2040 proc cleardropsel {w} {
2041 $w selection clear
2043 proc makedroplist {w varname args} {
2044 global use_ttk
2045 if {$use_ttk} {
2046 set width 0
2047 foreach label $args {
2048 set cx [string length $label]
2049 if {$cx > $width} {set width $cx}
2051 set gm [ttk::combobox $w -width $width -state readonly\
2052 -textvariable $varname -values $args \
2053 -exportselection false]
2054 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2055 } else {
2056 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2058 return $gm
2061 proc makewindow {} {
2062 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2063 global tabstop
2064 global findtype findtypemenu findloc findstring fstring geometry
2065 global entries sha1entry sha1string sha1but
2066 global diffcontextstring diffcontext
2067 global ignorespace
2068 global maincursor textcursor curtextcursor
2069 global rowctxmenu fakerowmenu mergemax wrapcomment
2070 global highlight_files gdttype
2071 global searchstring sstring
2072 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2073 global uifgcolor uifgdisabledcolor
2074 global filesepbgcolor filesepfgcolor
2075 global mergecolors foundbgcolor currentsearchhitbgcolor
2076 global headctxmenu progresscanv progressitem progresscoords statusw
2077 global fprogitem fprogcoord lastprogupdate progupdatepending
2078 global rprogitem rprogcoord rownumsel numcommits
2079 global have_tk85 use_ttk NS
2080 global git_version
2081 global worddiff
2083 # The "mc" arguments here are purely so that xgettext
2084 # sees the following string as needing to be translated
2085 set file {
2086 mc "&File" cascade {
2087 {mc "&Update" command updatecommits -accelerator F5}
2088 {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2089 {mc "Reread re&ferences" command rereadrefs}
2090 {mc "&List references" command showrefs -accelerator F2}
2091 {xx "" separator}
2092 {mc "Start git &gui" command {exec git gui &}}
2093 {xx "" separator}
2094 {mc "&Quit" command doquit -accelerator Meta1-Q}
2096 set edit {
2097 mc "&Edit" cascade {
2098 {mc "&Preferences" command doprefs}
2100 set view {
2101 mc "&View" cascade {
2102 {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2103 {mc "&Edit view..." command editview -state disabled -accelerator F4}
2104 {mc "&Delete view" command delview -state disabled}
2105 {xx "" separator}
2106 {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2108 if {[tk windowingsystem] ne "aqua"} {
2109 set help {
2110 mc "&Help" cascade {
2111 {mc "&About gitk" command about}
2112 {mc "&Key bindings" command keys}
2114 set bar [list $file $edit $view $help]
2115 } else {
2116 proc ::tk::mac::ShowPreferences {} {doprefs}
2117 proc ::tk::mac::Quit {} {doquit}
2118 lset file end [lreplace [lindex $file end] end-1 end]
2119 set apple {
2120 xx "&Apple" cascade {
2121 {mc "&About gitk" command about}
2122 {xx "" separator}
2124 set help {
2125 mc "&Help" cascade {
2126 {mc "&Key bindings" command keys}
2128 set bar [list $apple $file $view $help]
2130 makemenu .bar $bar
2131 . configure -menu .bar
2133 if {$use_ttk} {
2134 # cover the non-themed toplevel with a themed frame.
2135 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2138 # the gui has upper and lower half, parts of a paned window.
2139 ${NS}::panedwindow .ctop -orient vertical
2141 # possibly use assumed geometry
2142 if {![info exists geometry(pwsash0)]} {
2143 set geometry(topheight) [expr {15 * $linespc}]
2144 set geometry(topwidth) [expr {80 * $charspc}]
2145 set geometry(botheight) [expr {15 * $linespc}]
2146 set geometry(botwidth) [expr {50 * $charspc}]
2147 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2148 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2151 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2152 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2153 ${NS}::frame .tf.histframe
2154 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2155 if {!$use_ttk} {
2156 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2159 # create three canvases
2160 set cscroll .tf.histframe.csb
2161 set canv .tf.histframe.pwclist.canv
2162 canvas $canv \
2163 -selectbackground $selectbgcolor \
2164 -background $bgcolor -bd 0 \
2165 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2166 .tf.histframe.pwclist add $canv
2167 set canv2 .tf.histframe.pwclist.canv2
2168 canvas $canv2 \
2169 -selectbackground $selectbgcolor \
2170 -background $bgcolor -bd 0 -yscrollincr $linespc
2171 .tf.histframe.pwclist add $canv2
2172 set canv3 .tf.histframe.pwclist.canv3
2173 canvas $canv3 \
2174 -selectbackground $selectbgcolor \
2175 -background $bgcolor -bd 0 -yscrollincr $linespc
2176 .tf.histframe.pwclist add $canv3
2177 if {$use_ttk} {
2178 bind .tf.histframe.pwclist <Map> {
2179 bind %W <Map> {}
2180 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2181 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2183 } else {
2184 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2185 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2188 # a scroll bar to rule them
2189 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2190 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2191 pack $cscroll -side right -fill y
2192 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2193 lappend bglist $canv $canv2 $canv3
2194 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2196 # we have two button bars at bottom of top frame. Bar 1
2197 ${NS}::frame .tf.bar
2198 ${NS}::frame .tf.lbar -height 15
2200 set sha1entry .tf.bar.sha1
2201 set entries $sha1entry
2202 set sha1but .tf.bar.sha1label
2203 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2204 -command gotocommit -width 8
2205 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2206 pack .tf.bar.sha1label -side left
2207 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2208 trace add variable sha1string write sha1change
2209 pack $sha1entry -side left -pady 2
2211 set bm_left_data {
2212 #define left_width 16
2213 #define left_height 16
2214 static unsigned char left_bits[] = {
2215 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2216 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2217 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2219 set bm_right_data {
2220 #define right_width 16
2221 #define right_height 16
2222 static unsigned char right_bits[] = {
2223 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2224 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2225 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2227 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2228 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2229 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2230 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2232 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2233 if {$use_ttk} {
2234 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2235 } else {
2236 .tf.bar.leftbut configure -image bm-left
2238 pack .tf.bar.leftbut -side left -fill y
2239 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2240 if {$use_ttk} {
2241 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2242 } else {
2243 .tf.bar.rightbut configure -image bm-right
2245 pack .tf.bar.rightbut -side left -fill y
2247 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2248 set rownumsel {}
2249 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2250 -relief sunken -anchor e
2251 ${NS}::label .tf.bar.rowlabel2 -text "/"
2252 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2253 -relief sunken -anchor e
2254 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2255 -side left
2256 if {!$use_ttk} {
2257 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2259 global selectedline
2260 trace add variable selectedline write selectedline_change
2262 # Status label and progress bar
2263 set statusw .tf.bar.status
2264 ${NS}::label $statusw -width 15 -relief sunken
2265 pack $statusw -side left -padx 5
2266 if {$use_ttk} {
2267 set progresscanv [ttk::progressbar .tf.bar.progress]
2268 } else {
2269 set h [expr {[font metrics uifont -linespace] + 2}]
2270 set progresscanv .tf.bar.progress
2271 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2272 set progressitem [$progresscanv create rect -1 0 0 $h -fill "#00ff00"]
2273 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2274 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2276 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2277 set progresscoords {0 0}
2278 set fprogcoord 0
2279 set rprogcoord 0
2280 bind $progresscanv <Configure> adjustprogress
2281 set lastprogupdate [clock clicks -milliseconds]
2282 set progupdatepending 0
2284 # build up the bottom bar of upper window
2285 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2287 set bm_down_data {
2288 #define down_width 16
2289 #define down_height 16
2290 static unsigned char down_bits[] = {
2291 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2292 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2293 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2294 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2296 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2297 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2298 .tf.lbar.fnext configure -image bm-down
2300 set bm_up_data {
2301 #define up_width 16
2302 #define up_height 16
2303 static unsigned char up_bits[] = {
2304 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2305 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2306 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2307 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2309 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2310 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2311 .tf.lbar.fprev configure -image bm-up
2313 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2315 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2316 -side left -fill y
2317 set gdttype [mc "containing:"]
2318 set gm [makedroplist .tf.lbar.gdttype gdttype \
2319 [mc "containing:"] \
2320 [mc "touching paths:"] \
2321 [mc "adding/removing string:"] \
2322 [mc "changing lines matching:"]]
2323 trace add variable gdttype write gdttype_change
2324 pack .tf.lbar.gdttype -side left -fill y
2326 set findstring {}
2327 set fstring .tf.lbar.findstring
2328 lappend entries $fstring
2329 ${NS}::entry $fstring -width 30 -textvariable findstring
2330 trace add variable findstring write find_change
2331 set findtype [mc "Exact"]
2332 set findtypemenu [makedroplist .tf.lbar.findtype \
2333 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2334 trace add variable findtype write findcom_change
2335 set findloc [mc "All fields"]
2336 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2337 [mc "Comments"] [mc "Author"] [mc "Committer"]
2338 trace add variable findloc write find_change
2339 pack .tf.lbar.findloc -side right
2340 pack .tf.lbar.findtype -side right
2341 pack $fstring -side left -expand 1 -fill x
2343 # Finish putting the upper half of the viewer together
2344 pack .tf.lbar -in .tf -side bottom -fill x
2345 pack .tf.bar -in .tf -side bottom -fill x
2346 pack .tf.histframe -fill both -side top -expand 1
2347 .ctop add .tf
2348 if {!$use_ttk} {
2349 .ctop paneconfigure .tf -height $geometry(topheight)
2350 .ctop paneconfigure .tf -width $geometry(topwidth)
2353 # now build up the bottom
2354 ${NS}::panedwindow .pwbottom -orient horizontal
2356 # lower left, a text box over search bar, scroll bar to the right
2357 # if we know window height, then that will set the lower text height, otherwise
2358 # we set lower text height which will drive window height
2359 if {[info exists geometry(main)]} {
2360 ${NS}::frame .bleft -width $geometry(botwidth)
2361 } else {
2362 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2364 ${NS}::frame .bleft.top
2365 ${NS}::frame .bleft.mid
2366 ${NS}::frame .bleft.bottom
2368 # gap between sub-widgets
2369 set wgap [font measure uifont "i"]
2371 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2372 pack .bleft.top.search -side left -padx 5
2373 set sstring .bleft.top.sstring
2374 set searchstring ""
2375 ${NS}::entry $sstring -width 20 -textvariable searchstring
2376 lappend entries $sstring
2377 trace add variable searchstring write incrsearch
2378 pack $sstring -side left -expand 1 -fill x
2379 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2380 -command changediffdisp -variable diffelide -value {0 0}
2381 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2382 -command changediffdisp -variable diffelide -value {0 1}
2383 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2384 -command changediffdisp -variable diffelide -value {1 0}
2386 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2387 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left -ipadx $wgap
2388 spinbox .bleft.mid.diffcontext -width 5 \
2389 -from 0 -increment 1 -to 10000000 \
2390 -validate all -validatecommand "diffcontextvalidate %P" \
2391 -textvariable diffcontextstring
2392 .bleft.mid.diffcontext set $diffcontext
2393 trace add variable diffcontextstring write diffcontextchange
2394 lappend entries .bleft.mid.diffcontext
2395 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left -ipadx $wgap
2396 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2397 -command changeignorespace -variable ignorespace
2398 pack .bleft.mid.ignspace -side left -padx 5
2400 set worddiff [mc "Line diff"]
2401 if {[package vcompare $git_version "1.7.2"] >= 0} {
2402 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2403 [mc "Markup words"] [mc "Color words"]
2404 trace add variable worddiff write changeworddiff
2405 pack .bleft.mid.worddiff -side left -padx 5
2408 set ctext .bleft.bottom.ctext
2409 text $ctext -background $bgcolor -foreground $fgcolor \
2410 -state disabled -undo 0 -font textfont \
2411 -yscrollcommand scrolltext -wrap none \
2412 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2413 if {$have_tk85} {
2414 $ctext conf -tabstyle wordprocessor
2416 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2417 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2418 pack .bleft.top -side top -fill x
2419 pack .bleft.mid -side top -fill x
2420 grid $ctext .bleft.bottom.sb -sticky nsew
2421 grid .bleft.bottom.sbhorizontal -sticky ew
2422 grid columnconfigure .bleft.bottom 0 -weight 1
2423 grid rowconfigure .bleft.bottom 0 -weight 1
2424 grid rowconfigure .bleft.bottom 1 -weight 0
2425 pack .bleft.bottom -side top -fill both -expand 1
2426 lappend bglist $ctext
2427 lappend fglist $ctext
2429 $ctext tag conf comment -wrap $wrapcomment
2430 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2431 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2432 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2433 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2434 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2435 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2436 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2437 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2438 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2439 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2440 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2441 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2442 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2443 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2444 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2445 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2446 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2447 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2448 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2449 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2450 $ctext tag conf mmax -fore darkgrey
2451 set mergemax 16
2452 $ctext tag conf mresult -font textfontbold
2453 $ctext tag conf msep -font textfontbold
2454 $ctext tag conf found -back $foundbgcolor
2455 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2456 $ctext tag conf wwrap -wrap word -lmargin2 1c
2457 $ctext tag conf bold -font textfontbold
2459 .pwbottom add .bleft
2460 if {!$use_ttk} {
2461 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2464 # lower right
2465 ${NS}::frame .bright
2466 ${NS}::frame .bright.mode
2467 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2468 -command reselectline -variable cmitmode -value "patch"
2469 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2470 -command reselectline -variable cmitmode -value "tree"
2471 grid .bright.mode.patch .bright.mode.tree -sticky ew
2472 pack .bright.mode -side top -fill x
2473 set cflist .bright.cfiles
2474 set indent [font measure mainfont "nn"]
2475 text $cflist \
2476 -selectbackground $selectbgcolor \
2477 -background $bgcolor -foreground $fgcolor \
2478 -font mainfont \
2479 -tabs [list $indent [expr {2 * $indent}]] \
2480 -yscrollcommand ".bright.sb set" \
2481 -cursor [. cget -cursor] \
2482 -spacing1 1 -spacing3 1
2483 lappend bglist $cflist
2484 lappend fglist $cflist
2485 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2486 pack .bright.sb -side right -fill y
2487 pack $cflist -side left -fill both -expand 1
2488 $cflist tag configure highlight \
2489 -background [$cflist cget -selectbackground]
2490 $cflist tag configure bold -font mainfontbold
2492 .pwbottom add .bright
2493 .ctop add .pwbottom
2495 # restore window width & height if known
2496 if {[info exists geometry(main)]} {
2497 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2498 if {$w > [winfo screenwidth .]} {
2499 set w [winfo screenwidth .]
2501 if {$h > [winfo screenheight .]} {
2502 set h [winfo screenheight .]
2504 wm geometry . "${w}x$h"
2508 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2509 wm state . $geometry(state)
2512 if {[tk windowingsystem] eq {aqua}} {
2513 set M1B M1
2514 set ::BM "3"
2515 } else {
2516 set M1B Control
2517 set ::BM "2"
2520 if {$use_ttk} {
2521 bind .ctop <Map> {
2522 bind %W <Map> {}
2523 %W sashpos 0 $::geometry(topheight)
2525 bind .pwbottom <Map> {
2526 bind %W <Map> {}
2527 %W sashpos 0 $::geometry(botwidth)
2531 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2532 pack .ctop -fill both -expand 1
2533 bindall <1> {selcanvline %W %x %y}
2534 #bindall <B1-Motion> {selcanvline %W %x %y}
2535 if {[tk windowingsystem] == "win32"} {
2536 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2537 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2538 } else {
2539 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2540 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2541 bind $ctext <Button> {
2542 if {"%b" eq 6} {
2543 $ctext xview scroll -5 units
2544 } elseif {"%b" eq 7} {
2545 $ctext xview scroll 5 units
2548 if {[tk windowingsystem] eq "aqua"} {
2549 bindall <MouseWheel> {
2550 set delta [expr {- (%D)}]
2551 allcanvs yview scroll $delta units
2553 bindall <Shift-MouseWheel> {
2554 set delta [expr {- (%D)}]
2555 $canv xview scroll $delta units
2559 bindall <$::BM> "canvscan mark %W %x %y"
2560 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2561 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2562 bind . <$M1B-Key-w> doquit
2563 bindkey <Home> selfirstline
2564 bindkey <End> sellastline
2565 bind . <Key-Up> "selnextline -1"
2566 bind . <Key-Down> "selnextline 1"
2567 bind . <Shift-Key-Up> "dofind -1 0"
2568 bind . <Shift-Key-Down> "dofind 1 0"
2569 bindkey <Key-Right> "goforw"
2570 bindkey <Key-Left> "goback"
2571 bind . <Key-Prior> "selnextpage -1"
2572 bind . <Key-Next> "selnextpage 1"
2573 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2574 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2575 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2576 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2577 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2578 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2579 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2580 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2581 bindkey <Key-space> "$ctext yview scroll 1 pages"
2582 bindkey p "selnextline -1"
2583 bindkey n "selnextline 1"
2584 bindkey z "goback"
2585 bindkey x "goforw"
2586 bindkey k "selnextline -1"
2587 bindkey j "selnextline 1"
2588 bindkey h "goback"
2589 bindkey l "goforw"
2590 bindkey b prevfile
2591 bindkey d "$ctext yview scroll 18 units"
2592 bindkey u "$ctext yview scroll -18 units"
2593 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2594 bindkey / {focus $fstring}
2595 bindkey <Key-KP_Divide> {focus $fstring}
2596 bindkey <Key-Return> {dofind 1 1}
2597 bindkey ? {dofind -1 1}
2598 bindkey f nextfile
2599 bind . <F5> updatecommits
2600 bindmodfunctionkey Shift 5 reloadcommits
2601 bind . <F2> showrefs
2602 bindmodfunctionkey Shift 4 {newview 0}
2603 bind . <F4> edit_or_newview
2604 bind . <$M1B-q> doquit
2605 bind . <$M1B-f> {dofind 1 1}
2606 bind . <$M1B-g> {dofind 1 0}
2607 bind . <$M1B-r> dosearchback
2608 bind . <$M1B-s> dosearch
2609 bind . <$M1B-equal> {incrfont 1}
2610 bind . <$M1B-plus> {incrfont 1}
2611 bind . <$M1B-KP_Add> {incrfont 1}
2612 bind . <$M1B-minus> {incrfont -1}
2613 bind . <$M1B-KP_Subtract> {incrfont -1}
2614 wm protocol . WM_DELETE_WINDOW doquit
2615 bind . <Destroy> {stop_backends}
2616 bind . <Button-1> "click %W"
2617 bind $fstring <Key-Return> {dofind 1 1}
2618 bind $sha1entry <Key-Return> {gotocommit; break}
2619 bind $sha1entry <<PasteSelection>> clearsha1
2620 bind $sha1entry <<Paste>> clearsha1
2621 bind $cflist <1> {sel_flist %W %x %y; break}
2622 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2623 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2624 global ctxbut
2625 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2626 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2627 bind $ctext <Button-1> {focus %W}
2628 bind $ctext <<Selection>> rehighlight_search_results
2629 for {set i 1} {$i < 10} {incr i} {
2630 bind . <$M1B-Key-$i> [list go_to_parent $i]
2633 set maincursor [. cget -cursor]
2634 set textcursor [$ctext cget -cursor]
2635 set curtextcursor $textcursor
2637 set rowctxmenu .rowctxmenu
2638 makemenu $rowctxmenu {
2639 {mc "Diff this -> selected" command {diffvssel 0}}
2640 {mc "Diff selected -> this" command {diffvssel 1}}
2641 {mc "Make patch" command mkpatch}
2642 {mc "Create tag" command mktag}
2643 {mc "Copy commit summary" command copysummary}
2644 {mc "Write commit to file" command writecommit}
2645 {mc "Create new branch" command mkbranch}
2646 {mc "Cherry-pick this commit" command cherrypick}
2647 {mc "Reset HEAD branch to here" command resethead}
2648 {mc "Mark this commit" command markhere}
2649 {mc "Return to mark" command gotomark}
2650 {mc "Find descendant of this and mark" command find_common_desc}
2651 {mc "Compare with marked commit" command compare_commits}
2652 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2653 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2654 {mc "Revert this commit" command revert}
2656 $rowctxmenu configure -tearoff 0
2658 set fakerowmenu .fakerowmenu
2659 makemenu $fakerowmenu {
2660 {mc "Diff this -> selected" command {diffvssel 0}}
2661 {mc "Diff selected -> this" command {diffvssel 1}}
2662 {mc "Make patch" command mkpatch}
2663 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2664 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2666 $fakerowmenu configure -tearoff 0
2668 set headctxmenu .headctxmenu
2669 makemenu $headctxmenu {
2670 {mc "Check out this branch" command cobranch}
2671 {mc "Rename this branch" command mvbranch}
2672 {mc "Remove this branch" command rmbranch}
2673 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2675 $headctxmenu configure -tearoff 0
2677 global flist_menu
2678 set flist_menu .flistctxmenu
2679 makemenu $flist_menu {
2680 {mc "Highlight this too" command {flist_hl 0}}
2681 {mc "Highlight this only" command {flist_hl 1}}
2682 {mc "External diff" command {external_diff}}
2683 {mc "Blame parent commit" command {external_blame 1}}
2684 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2686 $flist_menu configure -tearoff 0
2688 global diff_menu
2689 set diff_menu .diffctxmenu
2690 makemenu $diff_menu {
2691 {mc "Show origin of this line" command show_line_source}
2692 {mc "Run git gui blame on this line" command {external_blame_diff}}
2694 $diff_menu configure -tearoff 0
2697 # Windows sends all mouse wheel events to the current focused window, not
2698 # the one where the mouse hovers, so bind those events here and redirect
2699 # to the correct window
2700 proc windows_mousewheel_redirector {W X Y D} {
2701 global canv canv2 canv3
2702 set w [winfo containing -displayof $W $X $Y]
2703 if {$w ne ""} {
2704 set u [expr {$D < 0 ? 5 : -5}]
2705 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2706 allcanvs yview scroll $u units
2707 } else {
2708 catch {
2709 $w yview scroll $u units
2715 # Update row number label when selectedline changes
2716 proc selectedline_change {n1 n2 op} {
2717 global selectedline rownumsel
2719 if {$selectedline eq {}} {
2720 set rownumsel {}
2721 } else {
2722 set rownumsel [expr {$selectedline + 1}]
2726 # mouse-2 makes all windows scan vertically, but only the one
2727 # the cursor is in scans horizontally
2728 proc canvscan {op w x y} {
2729 global canv canv2 canv3
2730 foreach c [list $canv $canv2 $canv3] {
2731 if {$c == $w} {
2732 $c scan $op $x $y
2733 } else {
2734 $c scan $op 0 $y
2739 proc scrollcanv {cscroll f0 f1} {
2740 $cscroll set $f0 $f1
2741 drawvisible
2742 flushhighlights
2745 # when we make a key binding for the toplevel, make sure
2746 # it doesn't get triggered when that key is pressed in the
2747 # find string entry widget.
2748 proc bindkey {ev script} {
2749 global entries
2750 bind . $ev $script
2751 set escript [bind Entry $ev]
2752 if {$escript == {}} {
2753 set escript [bind Entry <Key>]
2755 foreach e $entries {
2756 bind $e $ev "$escript; break"
2760 proc bindmodfunctionkey {mod n script} {
2761 bind . <$mod-F$n> $script
2762 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2765 # set the focus back to the toplevel for any click outside
2766 # the entry widgets
2767 proc click {w} {
2768 global ctext entries
2769 foreach e [concat $entries $ctext] {
2770 if {$w == $e} return
2772 focus .
2775 # Adjust the progress bar for a change in requested extent or canvas size
2776 proc adjustprogress {} {
2777 global progresscanv progressitem progresscoords
2778 global fprogitem fprogcoord lastprogupdate progupdatepending
2779 global rprogitem rprogcoord use_ttk
2781 if {$use_ttk} {
2782 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2783 return
2786 set w [expr {[winfo width $progresscanv] - 4}]
2787 set x0 [expr {$w * [lindex $progresscoords 0]}]
2788 set x1 [expr {$w * [lindex $progresscoords 1]}]
2789 set h [winfo height $progresscanv]
2790 $progresscanv coords $progressitem $x0 0 $x1 $h
2791 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2792 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2793 set now [clock clicks -milliseconds]
2794 if {$now >= $lastprogupdate + 100} {
2795 set progupdatepending 0
2796 update
2797 } elseif {!$progupdatepending} {
2798 set progupdatepending 1
2799 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2803 proc doprogupdate {} {
2804 global lastprogupdate progupdatepending
2806 if {$progupdatepending} {
2807 set progupdatepending 0
2808 set lastprogupdate [clock clicks -milliseconds]
2809 update
2813 proc config_check_tmp_exists {tries_left} {
2814 global config_file_tmp
2816 if {[file exists $config_file_tmp]} {
2817 incr tries_left -1
2818 if {$tries_left > 0} {
2819 after 100 [list config_check_tmp_exists $tries_left]
2820 } else {
2821 error_popup "There appears to be a stale $config_file_tmp\
2822 file, which will prevent gitk from saving its configuration on exit.\
2823 Please remove it if it is not being used by any existing gitk process."
2828 proc config_init_trace {name} {
2829 global config_variable_changed config_variable_original
2831 upvar #0 $name var
2832 set config_variable_changed($name) 0
2833 set config_variable_original($name) $var
2836 proc config_variable_change_cb {name name2 op} {
2837 global config_variable_changed config_variable_original
2839 upvar #0 $name var
2840 if {$op eq "write" &&
2841 (![info exists config_variable_original($name)] ||
2842 $config_variable_original($name) ne $var)} {
2843 set config_variable_changed($name) 1
2847 proc savestuff {w} {
2848 global stuffsaved
2849 global config_file config_file_tmp
2850 global config_variables config_variable_changed
2851 global viewchanged
2853 upvar #0 viewname current_viewname
2854 upvar #0 viewfiles current_viewfiles
2855 upvar #0 viewargs current_viewargs
2856 upvar #0 viewargscmd current_viewargscmd
2857 upvar #0 viewperm current_viewperm
2858 upvar #0 nextviewnum current_nextviewnum
2859 upvar #0 use_ttk current_use_ttk
2861 if {$stuffsaved} return
2862 if {![winfo viewable .]} return
2863 set remove_tmp 0
2864 if {[catch {
2865 set try_count 0
2866 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2867 if {[incr try_count] > 50} {
2868 error "Unable to write config file: $config_file_tmp exists"
2870 after 100
2872 set remove_tmp 1
2873 if {$::tcl_platform(platform) eq {windows}} {
2874 file attributes $config_file_tmp -hidden true
2876 if {[file exists $config_file]} {
2877 source $config_file
2879 foreach var_name $config_variables {
2880 upvar #0 $var_name var
2881 upvar 0 $var_name old_var
2882 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2883 puts $f [list set $var_name $old_var]
2884 } else {
2885 puts $f [list set $var_name $var]
2889 puts $f "set geometry(main) [wm geometry .]"
2890 puts $f "set geometry(state) [wm state .]"
2891 puts $f "set geometry(topwidth) [winfo width .tf]"
2892 puts $f "set geometry(topheight) [winfo height .tf]"
2893 if {$current_use_ttk} {
2894 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2895 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2896 } else {
2897 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2898 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2900 puts $f "set geometry(botwidth) [winfo width .bleft]"
2901 puts $f "set geometry(botheight) [winfo height .bleft]"
2903 array set view_save {}
2904 array set views {}
2905 if {![info exists permviews]} { set permviews {} }
2906 foreach view $permviews {
2907 set view_save([lindex $view 0]) 1
2908 set views([lindex $view 0]) $view
2910 puts -nonewline $f "set permviews {"
2911 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2912 if {$viewchanged($v)} {
2913 if {$current_viewperm($v)} {
2914 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2915 } else {
2916 set view_save($current_viewname($v)) 0
2920 # write old and updated view to their places and append remaining to the end
2921 foreach view $permviews {
2922 set view_name [lindex $view 0]
2923 if {$view_save($view_name)} {
2924 puts $f "{$views($view_name)}"
2926 unset views($view_name)
2928 foreach view_name [array names views] {
2929 puts $f "{$views($view_name)}"
2931 puts $f "}"
2932 close $f
2933 file rename -force $config_file_tmp $config_file
2934 set remove_tmp 0
2935 } err]} {
2936 puts "Error saving config: $err"
2938 if {$remove_tmp} {
2939 file delete -force $config_file_tmp
2941 set stuffsaved 1
2944 proc resizeclistpanes {win w} {
2945 global oldwidth use_ttk
2946 if {[info exists oldwidth($win)]} {
2947 if {$use_ttk} {
2948 set s0 [$win sashpos 0]
2949 set s1 [$win sashpos 1]
2950 } else {
2951 set s0 [$win sash coord 0]
2952 set s1 [$win sash coord 1]
2954 if {$w < 60} {
2955 set sash0 [expr {int($w/2 - 2)}]
2956 set sash1 [expr {int($w*5/6 - 2)}]
2957 } else {
2958 set factor [expr {1.0 * $w / $oldwidth($win)}]
2959 set sash0 [expr {int($factor * [lindex $s0 0])}]
2960 set sash1 [expr {int($factor * [lindex $s1 0])}]
2961 if {$sash0 < 30} {
2962 set sash0 30
2964 if {$sash1 < $sash0 + 20} {
2965 set sash1 [expr {$sash0 + 20}]
2967 if {$sash1 > $w - 10} {
2968 set sash1 [expr {$w - 10}]
2969 if {$sash0 > $sash1 - 20} {
2970 set sash0 [expr {$sash1 - 20}]
2974 if {$use_ttk} {
2975 $win sashpos 0 $sash0
2976 $win sashpos 1 $sash1
2977 } else {
2978 $win sash place 0 $sash0 [lindex $s0 1]
2979 $win sash place 1 $sash1 [lindex $s1 1]
2982 set oldwidth($win) $w
2985 proc resizecdetpanes {win w} {
2986 global oldwidth use_ttk
2987 if {[info exists oldwidth($win)]} {
2988 if {$use_ttk} {
2989 set s0 [$win sashpos 0]
2990 } else {
2991 set s0 [$win sash coord 0]
2993 if {$w < 60} {
2994 set sash0 [expr {int($w*3/4 - 2)}]
2995 } else {
2996 set factor [expr {1.0 * $w / $oldwidth($win)}]
2997 set sash0 [expr {int($factor * [lindex $s0 0])}]
2998 if {$sash0 < 45} {
2999 set sash0 45
3001 if {$sash0 > $w - 15} {
3002 set sash0 [expr {$w - 15}]
3005 if {$use_ttk} {
3006 $win sashpos 0 $sash0
3007 } else {
3008 $win sash place 0 $sash0 [lindex $s0 1]
3011 set oldwidth($win) $w
3014 proc allcanvs args {
3015 global canv canv2 canv3
3016 eval $canv $args
3017 eval $canv2 $args
3018 eval $canv3 $args
3021 proc bindall {event action} {
3022 global canv canv2 canv3
3023 bind $canv $event $action
3024 bind $canv2 $event $action
3025 bind $canv3 $event $action
3028 proc about {} {
3029 global bgcolor NS
3030 set w .about
3031 if {[winfo exists $w]} {
3032 raise $w
3033 return
3035 ttk_toplevel $w
3036 wm title $w [mc "About gitk"]
3037 make_transient $w .
3038 message $w.m -text [mc "
3039 Gitk - a commit viewer for git
3041 Copyright \u00a9 2005-2016 Paul Mackerras
3043 Use and redistribute under the terms of the GNU General Public License"] \
3044 -justify center -aspect 400 -border 2 -bg $bgcolor -relief groove
3045 pack $w.m -side top -fill x -padx 2 -pady 2
3046 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3047 pack $w.ok -side bottom
3048 bind $w <Visibility> "focus $w.ok"
3049 bind $w <Key-Escape> "destroy $w"
3050 bind $w <Key-Return> "destroy $w"
3051 tk::PlaceWindow $w widget .
3054 proc keys {} {
3055 global bgcolor NS
3056 set w .keys
3057 if {[winfo exists $w]} {
3058 raise $w
3059 return
3061 if {[tk windowingsystem] eq {aqua}} {
3062 set M1T Cmd
3063 } else {
3064 set M1T Ctrl
3066 ttk_toplevel $w
3067 wm title $w [mc "Gitk key bindings"]
3068 make_transient $w .
3069 message $w.m -text "
3070 [mc "Gitk key bindings:"]
3072 [mc "<%s-Q> Quit" $M1T]
3073 [mc "<%s-W> Close window" $M1T]
3074 [mc "<Home> Move to first commit"]
3075 [mc "<End> Move to last commit"]
3076 [mc "<Up>, p, k Move up one commit"]
3077 [mc "<Down>, n, j Move down one commit"]
3078 [mc "<Left>, z, h Go back in history list"]
3079 [mc "<Right>, x, l Go forward in history list"]
3080 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3081 [mc "<PageUp> Move up one page in commit list"]
3082 [mc "<PageDown> Move down one page in commit list"]
3083 [mc "<%s-Home> Scroll to top of commit list" $M1T]
3084 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
3085 [mc "<%s-Up> Scroll commit list up one line" $M1T]
3086 [mc "<%s-Down> Scroll commit list down one line" $M1T]
3087 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3088 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3089 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3090 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3091 [mc "<Delete>, b Scroll diff view up one page"]
3092 [mc "<Backspace> Scroll diff view up one page"]
3093 [mc "<Space> Scroll diff view down one page"]
3094 [mc "u Scroll diff view up 18 lines"]
3095 [mc "d Scroll diff view down 18 lines"]
3096 [mc "<%s-F> Find" $M1T]
3097 [mc "<%s-G> Move to next find hit" $M1T]
3098 [mc "<Return> Move to next find hit"]
3099 [mc "g Go to commit"]
3100 [mc "/ Focus the search box"]
3101 [mc "? Move to previous find hit"]
3102 [mc "f Scroll diff view to next file"]
3103 [mc "<%s-S> Search for next hit in diff view" $M1T]
3104 [mc "<%s-R> Search for previous hit in diff view" $M1T]
3105 [mc "<%s-KP+> Increase font size" $M1T]
3106 [mc "<%s-plus> Increase font size" $M1T]
3107 [mc "<%s-KP-> Decrease font size" $M1T]
3108 [mc "<%s-minus> Decrease font size" $M1T]
3109 [mc "<F5> Update"]
3111 -justify left -bg $bgcolor -border 2 -relief groove
3112 pack $w.m -side top -fill both -padx 2 -pady 2
3113 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3114 bind $w <Key-Escape> [list destroy $w]
3115 pack $w.ok -side bottom
3116 bind $w <Visibility> "focus $w.ok"
3117 bind $w <Key-Escape> "destroy $w"
3118 bind $w <Key-Return> "destroy $w"
3121 # Procedures for manipulating the file list window at the
3122 # bottom right of the overall window.
3124 proc treeview {w l openlevs} {
3125 global treecontents treediropen treeheight treeparent treeindex
3127 set ix 0
3128 set treeindex() 0
3129 set lev 0
3130 set prefix {}
3131 set prefixend -1
3132 set prefendstack {}
3133 set htstack {}
3134 set ht 0
3135 set treecontents() {}
3136 $w conf -state normal
3137 foreach f $l {
3138 while {[string range $f 0 $prefixend] ne $prefix} {
3139 if {$lev <= $openlevs} {
3140 $w mark set e:$treeindex($prefix) "end -1c"
3141 $w mark gravity e:$treeindex($prefix) left
3143 set treeheight($prefix) $ht
3144 incr ht [lindex $htstack end]
3145 set htstack [lreplace $htstack end end]
3146 set prefixend [lindex $prefendstack end]
3147 set prefendstack [lreplace $prefendstack end end]
3148 set prefix [string range $prefix 0 $prefixend]
3149 incr lev -1
3151 set tail [string range $f [expr {$prefixend+1}] end]
3152 while {[set slash [string first "/" $tail]] >= 0} {
3153 lappend htstack $ht
3154 set ht 0
3155 lappend prefendstack $prefixend
3156 incr prefixend [expr {$slash + 1}]
3157 set d [string range $tail 0 $slash]
3158 lappend treecontents($prefix) $d
3159 set oldprefix $prefix
3160 append prefix $d
3161 set treecontents($prefix) {}
3162 set treeindex($prefix) [incr ix]
3163 set treeparent($prefix) $oldprefix
3164 set tail [string range $tail [expr {$slash+1}] end]
3165 if {$lev <= $openlevs} {
3166 set ht 1
3167 set treediropen($prefix) [expr {$lev < $openlevs}]
3168 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3169 $w mark set d:$ix "end -1c"
3170 $w mark gravity d:$ix left
3171 set str "\n"
3172 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3173 $w insert end $str
3174 $w image create end -align center -image $bm -padx 1 \
3175 -name a:$ix
3176 $w insert end $d [highlight_tag $prefix]
3177 $w mark set s:$ix "end -1c"
3178 $w mark gravity s:$ix left
3180 incr lev
3182 if {$tail ne {}} {
3183 if {$lev <= $openlevs} {
3184 incr ht
3185 set str "\n"
3186 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3187 $w insert end $str
3188 $w insert end $tail [highlight_tag $f]
3190 lappend treecontents($prefix) $tail
3193 while {$htstack ne {}} {
3194 set treeheight($prefix) $ht
3195 incr ht [lindex $htstack end]
3196 set htstack [lreplace $htstack end end]
3197 set prefixend [lindex $prefendstack end]
3198 set prefendstack [lreplace $prefendstack end end]
3199 set prefix [string range $prefix 0 $prefixend]
3201 $w conf -state disabled
3204 proc linetoelt {l} {
3205 global treeheight treecontents
3207 set y 2
3208 set prefix {}
3209 while {1} {
3210 foreach e $treecontents($prefix) {
3211 if {$y == $l} {
3212 return "$prefix$e"
3214 set n 1
3215 if {[string index $e end] eq "/"} {
3216 set n $treeheight($prefix$e)
3217 if {$y + $n > $l} {
3218 append prefix $e
3219 incr y
3220 break
3223 incr y $n
3228 proc highlight_tree {y prefix} {
3229 global treeheight treecontents cflist
3231 foreach e $treecontents($prefix) {
3232 set path $prefix$e
3233 if {[highlight_tag $path] ne {}} {
3234 $cflist tag add bold $y.0 "$y.0 lineend"
3236 incr y
3237 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3238 set y [highlight_tree $y $path]
3241 return $y
3244 proc treeclosedir {w dir} {
3245 global treediropen treeheight treeparent treeindex
3247 set ix $treeindex($dir)
3248 $w conf -state normal
3249 $w delete s:$ix e:$ix
3250 set treediropen($dir) 0
3251 $w image configure a:$ix -image tri-rt
3252 $w conf -state disabled
3253 set n [expr {1 - $treeheight($dir)}]
3254 while {$dir ne {}} {
3255 incr treeheight($dir) $n
3256 set dir $treeparent($dir)
3260 proc treeopendir {w dir} {
3261 global treediropen treeheight treeparent treecontents treeindex
3263 set ix $treeindex($dir)
3264 $w conf -state normal
3265 $w image configure a:$ix -image tri-dn
3266 $w mark set e:$ix s:$ix
3267 $w mark gravity e:$ix right
3268 set lev 0
3269 set str "\n"
3270 set n [llength $treecontents($dir)]
3271 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3272 incr lev
3273 append str "\t"
3274 incr treeheight($x) $n
3276 foreach e $treecontents($dir) {
3277 set de $dir$e
3278 if {[string index $e end] eq "/"} {
3279 set iy $treeindex($de)
3280 $w mark set d:$iy e:$ix
3281 $w mark gravity d:$iy left
3282 $w insert e:$ix $str
3283 set treediropen($de) 0
3284 $w image create e:$ix -align center -image tri-rt -padx 1 \
3285 -name a:$iy
3286 $w insert e:$ix $e [highlight_tag $de]
3287 $w mark set s:$iy e:$ix
3288 $w mark gravity s:$iy left
3289 set treeheight($de) 1
3290 } else {
3291 $w insert e:$ix $str
3292 $w insert e:$ix $e [highlight_tag $de]
3295 $w mark gravity e:$ix right
3296 $w conf -state disabled
3297 set treediropen($dir) 1
3298 set top [lindex [split [$w index @0,0] .] 0]
3299 set ht [$w cget -height]
3300 set l [lindex [split [$w index s:$ix] .] 0]
3301 if {$l < $top} {
3302 $w yview $l.0
3303 } elseif {$l + $n + 1 > $top + $ht} {
3304 set top [expr {$l + $n + 2 - $ht}]
3305 if {$l < $top} {
3306 set top $l
3308 $w yview $top.0
3312 proc treeclick {w x y} {
3313 global treediropen cmitmode ctext cflist cflist_top
3315 if {$cmitmode ne "tree"} return
3316 if {![info exists cflist_top]} return
3317 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3318 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3319 $cflist tag add highlight $l.0 "$l.0 lineend"
3320 set cflist_top $l
3321 if {$l == 1} {
3322 $ctext yview 1.0
3323 return
3325 set e [linetoelt $l]
3326 if {[string index $e end] ne "/"} {
3327 showfile $e
3328 } elseif {$treediropen($e)} {
3329 treeclosedir $w $e
3330 } else {
3331 treeopendir $w $e
3335 proc setfilelist {id} {
3336 global treefilelist cflist jump_to_here
3338 treeview $cflist $treefilelist($id) 0
3339 if {$jump_to_here ne {}} {
3340 set f [lindex $jump_to_here 0]
3341 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3342 showfile $f
3347 image create bitmap tri-rt -background black -foreground blue -data {
3348 #define tri-rt_width 13
3349 #define tri-rt_height 13
3350 static unsigned char tri-rt_bits[] = {
3351 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3352 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3353 0x00, 0x00};
3354 } -maskdata {
3355 #define tri-rt-mask_width 13
3356 #define tri-rt-mask_height 13
3357 static unsigned char tri-rt-mask_bits[] = {
3358 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3359 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3360 0x08, 0x00};
3362 image create bitmap tri-dn -background black -foreground blue -data {
3363 #define tri-dn_width 13
3364 #define tri-dn_height 13
3365 static unsigned char tri-dn_bits[] = {
3366 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3367 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3368 0x00, 0x00};
3369 } -maskdata {
3370 #define tri-dn-mask_width 13
3371 #define tri-dn-mask_height 13
3372 static unsigned char tri-dn-mask_bits[] = {
3373 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3374 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3375 0x00, 0x00};
3378 image create bitmap reficon-T -background black -foreground yellow -data {
3379 #define tagicon_width 13
3380 #define tagicon_height 9
3381 static unsigned char tagicon_bits[] = {
3382 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3383 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3384 } -maskdata {
3385 #define tagicon-mask_width 13
3386 #define tagicon-mask_height 9
3387 static unsigned char tagicon-mask_bits[] = {
3388 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3389 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3391 set rectdata {
3392 #define headicon_width 13
3393 #define headicon_height 9
3394 static unsigned char headicon_bits[] = {
3395 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3396 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3398 set rectmask {
3399 #define headicon-mask_width 13
3400 #define headicon-mask_height 9
3401 static unsigned char headicon-mask_bits[] = {
3402 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3403 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3405 image create bitmap reficon-H -background black -foreground "#00ff00" \
3406 -data $rectdata -maskdata $rectmask
3407 image create bitmap reficon-R -background black -foreground "#ffddaa" \
3408 -data $rectdata -maskdata $rectmask
3409 image create bitmap reficon-o -background black -foreground "#ddddff" \
3410 -data $rectdata -maskdata $rectmask
3412 proc init_flist {first} {
3413 global cflist cflist_top difffilestart
3415 $cflist conf -state normal
3416 $cflist delete 0.0 end
3417 if {$first ne {}} {
3418 $cflist insert end $first
3419 set cflist_top 1
3420 $cflist tag add highlight 1.0 "1.0 lineend"
3421 } else {
3422 unset -nocomplain cflist_top
3424 $cflist conf -state disabled
3425 set difffilestart {}
3428 proc highlight_tag {f} {
3429 global highlight_paths
3431 foreach p $highlight_paths {
3432 if {[string match $p $f]} {
3433 return "bold"
3436 return {}
3439 proc highlight_filelist {} {
3440 global cmitmode cflist
3442 $cflist conf -state normal
3443 if {$cmitmode ne "tree"} {
3444 set end [lindex [split [$cflist index end] .] 0]
3445 for {set l 2} {$l < $end} {incr l} {
3446 set line [$cflist get $l.0 "$l.0 lineend"]
3447 if {[highlight_tag $line] ne {}} {
3448 $cflist tag add bold $l.0 "$l.0 lineend"
3451 } else {
3452 highlight_tree 2 {}
3454 $cflist conf -state disabled
3457 proc unhighlight_filelist {} {
3458 global cflist
3460 $cflist conf -state normal
3461 $cflist tag remove bold 1.0 end
3462 $cflist conf -state disabled
3465 proc add_flist {fl} {
3466 global cflist
3468 $cflist conf -state normal
3469 foreach f $fl {
3470 $cflist insert end "\n"
3471 $cflist insert end $f [highlight_tag $f]
3473 $cflist conf -state disabled
3476 proc sel_flist {w x y} {
3477 global ctext difffilestart cflist cflist_top cmitmode
3479 if {$cmitmode eq "tree"} return
3480 if {![info exists cflist_top]} return
3481 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3482 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3483 $cflist tag add highlight $l.0 "$l.0 lineend"
3484 set cflist_top $l
3485 if {$l == 1} {
3486 $ctext yview 1.0
3487 } else {
3488 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3490 suppress_highlighting_file_for_current_scrollpos
3493 proc pop_flist_menu {w X Y x y} {
3494 global ctext cflist cmitmode flist_menu flist_menu_file
3495 global treediffs diffids
3497 stopfinding
3498 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3499 if {$l <= 1} return
3500 if {$cmitmode eq "tree"} {
3501 set e [linetoelt $l]
3502 if {[string index $e end] eq "/"} return
3503 } else {
3504 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3506 set flist_menu_file $e
3507 set xdiffstate "normal"
3508 if {$cmitmode eq "tree"} {
3509 set xdiffstate "disabled"
3511 # Disable "External diff" item in tree mode
3512 $flist_menu entryconf 2 -state $xdiffstate
3513 tk_popup $flist_menu $X $Y
3516 proc find_ctext_fileinfo {line} {
3517 global ctext_file_names ctext_file_lines
3519 set ok [bsearch $ctext_file_lines $line]
3520 set tline [lindex $ctext_file_lines $ok]
3522 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3523 return {}
3524 } else {
3525 return [list [lindex $ctext_file_names $ok] $tline]
3529 proc pop_diff_menu {w X Y x y} {
3530 global ctext diff_menu flist_menu_file
3531 global diff_menu_txtpos diff_menu_line
3532 global diff_menu_filebase
3534 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3535 set diff_menu_line [lindex $diff_menu_txtpos 0]
3536 # don't pop up the menu on hunk-separator or file-separator lines
3537 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3538 return
3540 stopfinding
3541 set f [find_ctext_fileinfo $diff_menu_line]
3542 if {$f eq {}} return
3543 set flist_menu_file [lindex $f 0]
3544 set diff_menu_filebase [lindex $f 1]
3545 tk_popup $diff_menu $X $Y
3548 proc flist_hl {only} {
3549 global flist_menu_file findstring gdttype
3551 set x [shellquote $flist_menu_file]
3552 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3553 set findstring $x
3554 } else {
3555 append findstring " " $x
3557 set gdttype [mc "touching paths:"]
3560 proc gitknewtmpdir {} {
3561 global diffnum gitktmpdir gitdir env
3563 if {![info exists gitktmpdir]} {
3564 if {[info exists env(GITK_TMPDIR)]} {
3565 set tmpdir $env(GITK_TMPDIR)
3566 } elseif {[info exists env(TMPDIR)]} {
3567 set tmpdir $env(TMPDIR)
3568 } else {
3569 set tmpdir $gitdir
3571 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3572 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3573 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3575 if {[catch {file mkdir $gitktmpdir} err]} {
3576 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3577 unset gitktmpdir
3578 return {}
3580 set diffnum 0
3582 incr diffnum
3583 set diffdir [file join $gitktmpdir $diffnum]
3584 if {[catch {file mkdir $diffdir} err]} {
3585 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3586 return {}
3588 return $diffdir
3591 proc save_file_from_commit {filename output what} {
3592 global nullfile
3594 if {[catch {exec git show $filename -- > $output} err]} {
3595 if {[string match "fatal: bad revision *" $err]} {
3596 return $nullfile
3598 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3599 return {}
3601 return $output
3604 proc external_diff_get_one_file {diffid filename diffdir} {
3605 global nullid nullid2 nullfile
3606 global worktree
3608 if {$diffid == $nullid} {
3609 set difffile [file join $worktree $filename]
3610 if {[file exists $difffile]} {
3611 return $difffile
3613 return $nullfile
3615 if {$diffid == $nullid2} {
3616 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3617 return [save_file_from_commit :$filename $difffile index]
3619 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3620 return [save_file_from_commit $diffid:$filename $difffile \
3621 "revision $diffid"]
3624 proc external_diff {} {
3625 global nullid nullid2
3626 global flist_menu_file
3627 global diffids
3628 global extdifftool
3630 if {[llength $diffids] == 1} {
3631 # no reference commit given
3632 set diffidto [lindex $diffids 0]
3633 if {$diffidto eq $nullid} {
3634 # diffing working copy with index
3635 set diffidfrom $nullid2
3636 } elseif {$diffidto eq $nullid2} {
3637 # diffing index with HEAD
3638 set diffidfrom "HEAD"
3639 } else {
3640 # use first parent commit
3641 global parentlist selectedline
3642 set diffidfrom [lindex $parentlist $selectedline 0]
3644 } else {
3645 set diffidfrom [lindex $diffids 0]
3646 set diffidto [lindex $diffids 1]
3649 # make sure that several diffs wont collide
3650 set diffdir [gitknewtmpdir]
3651 if {$diffdir eq {}} return
3653 # gather files to diff
3654 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3655 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3657 if {$difffromfile ne {} && $difftofile ne {}} {
3658 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3659 if {[catch {set fl [open |$cmd r]} err]} {
3660 file delete -force $diffdir
3661 error_popup "$extdifftool: [mc "command failed:"] $err"
3662 } else {
3663 fconfigure $fl -blocking 0
3664 filerun $fl [list delete_at_eof $fl $diffdir]
3669 proc find_hunk_blamespec {base line} {
3670 global ctext
3672 # Find and parse the hunk header
3673 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3674 if {$s_lix eq {}} return
3676 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3677 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3678 s_line old_specs osz osz1 new_line nsz]} {
3679 return
3682 # base lines for the parents
3683 set base_lines [list $new_line]
3684 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3685 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3686 old_spec old_line osz]} {
3687 return
3689 lappend base_lines $old_line
3692 # Now scan the lines to determine offset within the hunk
3693 set max_parent [expr {[llength $base_lines]-2}]
3694 set dline 0
3695 set s_lno [lindex [split $s_lix "."] 0]
3697 # Determine if the line is removed
3698 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3699 if {[string match {[-+ ]*} $chunk]} {
3700 set removed_idx [string first "-" $chunk]
3701 # Choose a parent index
3702 if {$removed_idx >= 0} {
3703 set parent $removed_idx
3704 } else {
3705 set unchanged_idx [string first " " $chunk]
3706 if {$unchanged_idx >= 0} {
3707 set parent $unchanged_idx
3708 } else {
3709 # blame the current commit
3710 set parent -1
3713 # then count other lines that belong to it
3714 for {set i $line} {[incr i -1] > $s_lno} {} {
3715 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3716 # Determine if the line is removed
3717 set removed_idx [string first "-" $chunk]
3718 if {$parent >= 0} {
3719 set code [string index $chunk $parent]
3720 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3721 incr dline
3723 } else {
3724 if {$removed_idx < 0} {
3725 incr dline
3729 incr parent
3730 } else {
3731 set parent 0
3734 incr dline [lindex $base_lines $parent]
3735 return [list $parent $dline]
3738 proc external_blame_diff {} {
3739 global currentid cmitmode
3740 global diff_menu_txtpos diff_menu_line
3741 global diff_menu_filebase flist_menu_file
3743 if {$cmitmode eq "tree"} {
3744 set parent_idx 0
3745 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3746 } else {
3747 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3748 if {$hinfo ne {}} {
3749 set parent_idx [lindex $hinfo 0]
3750 set line [lindex $hinfo 1]
3751 } else {
3752 set parent_idx 0
3753 set line 0
3757 external_blame $parent_idx $line
3760 # Find the SHA1 ID of the blob for file $fname in the index
3761 # at stage 0 or 2
3762 proc index_sha1 {fname} {
3763 set f [open [list | git ls-files -s $fname] r]
3764 while {[gets $f line] >= 0} {
3765 set info [lindex [split $line "\t"] 0]
3766 set stage [lindex $info 2]
3767 if {$stage eq "0" || $stage eq "2"} {
3768 close $f
3769 return [lindex $info 1]
3772 close $f
3773 return {}
3776 # Turn an absolute path into one relative to the current directory
3777 proc make_relative {f} {
3778 if {[file pathtype $f] eq "relative"} {
3779 return $f
3781 set elts [file split $f]
3782 set here [file split [pwd]]
3783 set ei 0
3784 set hi 0
3785 set res {}
3786 foreach d $here {
3787 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3788 lappend res ".."
3789 } else {
3790 incr ei
3792 incr hi
3794 set elts [concat $res [lrange $elts $ei end]]
3795 return [eval file join $elts]
3798 proc external_blame {parent_idx {line {}}} {
3799 global flist_menu_file cdup
3800 global nullid nullid2
3801 global parentlist selectedline currentid
3803 if {$parent_idx > 0} {
3804 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3805 } else {
3806 set base_commit $currentid
3809 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3810 error_popup [mc "No such commit"]
3811 return
3814 set cmdline [list git gui blame]
3815 if {$line ne {} && $line > 1} {
3816 lappend cmdline "--line=$line"
3818 set f [file join $cdup $flist_menu_file]
3819 # Unfortunately it seems git gui blame doesn't like
3820 # being given an absolute path...
3821 set f [make_relative $f]
3822 lappend cmdline $base_commit $f
3823 if {[catch {eval exec $cmdline &} err]} {
3824 error_popup "[mc "git gui blame: command failed:"] $err"
3828 proc show_line_source {} {
3829 global cmitmode currentid parents curview blamestuff blameinst
3830 global diff_menu_line diff_menu_filebase flist_menu_file
3831 global nullid nullid2 gitdir cdup
3833 set from_index {}
3834 if {$cmitmode eq "tree"} {
3835 set id $currentid
3836 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3837 } else {
3838 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3839 if {$h eq {}} return
3840 set pi [lindex $h 0]
3841 if {$pi == 0} {
3842 mark_ctext_line $diff_menu_line
3843 return
3845 incr pi -1
3846 if {$currentid eq $nullid} {
3847 if {$pi > 0} {
3848 # must be a merge in progress...
3849 if {[catch {
3850 # get the last line from .git/MERGE_HEAD
3851 set f [open [file join $gitdir MERGE_HEAD] r]
3852 set id [lindex [split [read $f] "\n"] end-1]
3853 close $f
3854 } err]} {
3855 error_popup [mc "Couldn't read merge head: %s" $err]
3856 return
3858 } elseif {$parents($curview,$currentid) eq $nullid2} {
3859 # need to do the blame from the index
3860 if {[catch {
3861 set from_index [index_sha1 $flist_menu_file]
3862 } err]} {
3863 error_popup [mc "Error reading index: %s" $err]
3864 return
3866 } else {
3867 set id $parents($curview,$currentid)
3869 } else {
3870 set id [lindex $parents($curview,$currentid) $pi]
3872 set line [lindex $h 1]
3874 set blameargs {}
3875 if {$from_index ne {}} {
3876 lappend blameargs | git cat-file blob $from_index
3878 lappend blameargs | git blame -p -L$line,+1
3879 if {$from_index ne {}} {
3880 lappend blameargs --contents -
3881 } else {
3882 lappend blameargs $id
3884 lappend blameargs -- [file join $cdup $flist_menu_file]
3885 if {[catch {
3886 set f [open $blameargs r]
3887 } err]} {
3888 error_popup [mc "Couldn't start git blame: %s" $err]
3889 return
3891 nowbusy blaming [mc "Searching"]
3892 fconfigure $f -blocking 0
3893 set i [reg_instance $f]
3894 set blamestuff($i) {}
3895 set blameinst $i
3896 filerun $f [list read_line_source $f $i]
3899 proc stopblaming {} {
3900 global blameinst
3902 if {[info exists blameinst]} {
3903 stop_instance $blameinst
3904 unset blameinst
3905 notbusy blaming
3909 proc read_line_source {fd inst} {
3910 global blamestuff curview commfd blameinst nullid nullid2
3912 while {[gets $fd line] >= 0} {
3913 lappend blamestuff($inst) $line
3915 if {![eof $fd]} {
3916 return 1
3918 unset commfd($inst)
3919 unset blameinst
3920 notbusy blaming
3921 fconfigure $fd -blocking 1
3922 if {[catch {close $fd} err]} {
3923 error_popup [mc "Error running git blame: %s" $err]
3924 return 0
3927 set fname {}
3928 set line [split [lindex $blamestuff($inst) 0] " "]
3929 set id [lindex $line 0]
3930 set lnum [lindex $line 1]
3931 if {[string length $id] == 40 && [string is xdigit $id] &&
3932 [string is digit -strict $lnum]} {
3933 # look for "filename" line
3934 foreach l $blamestuff($inst) {
3935 if {[string match "filename *" $l]} {
3936 set fname [string range $l 9 end]
3937 break
3941 if {$fname ne {}} {
3942 # all looks good, select it
3943 if {$id eq $nullid} {
3944 # blame uses all-zeroes to mean not committed,
3945 # which would mean a change in the index
3946 set id $nullid2
3948 if {[commitinview $id $curview]} {
3949 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3950 } else {
3951 error_popup [mc "That line comes from commit %s, \
3952 which is not in this view" [shortids $id]]
3954 } else {
3955 puts "oops couldn't parse git blame output"
3957 return 0
3960 # delete $dir when we see eof on $f (presumably because the child has exited)
3961 proc delete_at_eof {f dir} {
3962 while {[gets $f line] >= 0} {}
3963 if {[eof $f]} {
3964 if {[catch {close $f} err]} {
3965 error_popup "[mc "External diff viewer failed:"] $err"
3967 file delete -force $dir
3968 return 0
3970 return 1
3973 # Functions for adding and removing shell-type quoting
3975 proc shellquote {str} {
3976 if {![string match "*\['\"\\ \t]*" $str]} {
3977 return $str
3979 if {![string match "*\['\"\\]*" $str]} {
3980 return "\"$str\""
3982 if {![string match "*'*" $str]} {
3983 return "'$str'"
3985 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3988 proc shellarglist {l} {
3989 set str {}
3990 foreach a $l {
3991 if {$str ne {}} {
3992 append str " "
3994 append str [shellquote $a]
3996 return $str
3999 proc shelldequote {str} {
4000 set ret {}
4001 set used -1
4002 while {1} {
4003 incr used
4004 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
4005 append ret [string range $str $used end]
4006 set used [string length $str]
4007 break
4009 set first [lindex $first 0]
4010 set ch [string index $str $first]
4011 if {$first > $used} {
4012 append ret [string range $str $used [expr {$first - 1}]]
4013 set used $first
4015 if {$ch eq " " || $ch eq "\t"} break
4016 incr used
4017 if {$ch eq "'"} {
4018 set first [string first "'" $str $used]
4019 if {$first < 0} {
4020 error "unmatched single-quote"
4022 append ret [string range $str $used [expr {$first - 1}]]
4023 set used $first
4024 continue
4026 if {$ch eq "\\"} {
4027 if {$used >= [string length $str]} {
4028 error "trailing backslash"
4030 append ret [string index $str $used]
4031 continue
4033 # here ch == "\""
4034 while {1} {
4035 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4036 error "unmatched double-quote"
4038 set first [lindex $first 0]
4039 set ch [string index $str $first]
4040 if {$first > $used} {
4041 append ret [string range $str $used [expr {$first - 1}]]
4042 set used $first
4044 if {$ch eq "\""} break
4045 incr used
4046 append ret [string index $str $used]
4047 incr used
4050 return [list $used $ret]
4053 proc shellsplit {str} {
4054 set l {}
4055 while {1} {
4056 set str [string trimleft $str]
4057 if {$str eq {}} break
4058 set dq [shelldequote $str]
4059 set n [lindex $dq 0]
4060 set word [lindex $dq 1]
4061 set str [string range $str $n end]
4062 lappend l $word
4064 return $l
4067 proc set_window_title {} {
4068 global appname curview viewname vrevs
4069 set rev [mc "All files"]
4070 if {$curview ne 0} {
4071 if {$viewname($curview) eq [mc "Command line"]} {
4072 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4073 } else {
4074 set rev $viewname($curview)
4077 wm title . "[reponame]: $rev - $appname"
4080 # Code to implement multiple views
4082 proc newview {ishighlight} {
4083 global nextviewnum newviewname newishighlight
4084 global revtreeargs viewargscmd newviewopts curview
4086 set newishighlight $ishighlight
4087 set top .gitkview
4088 if {[winfo exists $top]} {
4089 raise $top
4090 return
4092 decode_view_opts $nextviewnum $revtreeargs
4093 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4094 set newviewopts($nextviewnum,perm) 0
4095 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4096 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4099 set known_view_options {
4100 {perm b . {} {mc "Remember this view"}}
4101 {reflabel l + {} {mc "References (space separated list):"}}
4102 {refs t15 .. {} {mc "Branches & tags:"}}
4103 {allrefs b *. "--all" {mc "All refs"}}
4104 {branches b . "--branches" {mc "All (local) branches"}}
4105 {tags b . "--tags" {mc "All tags"}}
4106 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4107 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4108 {author t15 .. "--author=*" {mc "Author:"}}
4109 {committer t15 . "--committer=*" {mc "Committer:"}}
4110 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4111 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4112 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4113 {changes_l l + {} {mc "Changes to Files:"}}
4114 {pickaxe_s r0 . {} {mc "Fixed String"}}
4115 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4116 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4117 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4118 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4119 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4120 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4121 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4122 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4123 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4124 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4125 {lright b . "--left-right" {mc "Mark branch sides"}}
4126 {first b . "--first-parent" {mc "Limit to first parent"}}
4127 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4128 {args t50 *. {} {mc "Additional arguments to git log:"}}
4129 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4130 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4133 # Convert $newviewopts($n, ...) into args for git log.
4134 proc encode_view_opts {n} {
4135 global known_view_options newviewopts
4137 set rargs [list]
4138 foreach opt $known_view_options {
4139 set patterns [lindex $opt 3]
4140 if {$patterns eq {}} continue
4141 set pattern [lindex $patterns 0]
4143 if {[lindex $opt 1] eq "b"} {
4144 set val $newviewopts($n,[lindex $opt 0])
4145 if {$val} {
4146 lappend rargs $pattern
4148 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4149 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4150 set val $newviewopts($n,$button_id)
4151 if {$val eq $value} {
4152 lappend rargs $pattern
4154 } else {
4155 set val $newviewopts($n,[lindex $opt 0])
4156 set val [string trim $val]
4157 if {$val ne {}} {
4158 set pfix [string range $pattern 0 end-1]
4159 lappend rargs $pfix$val
4163 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4164 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4167 # Fill $newviewopts($n, ...) based on args for git log.
4168 proc decode_view_opts {n view_args} {
4169 global known_view_options newviewopts
4171 foreach opt $known_view_options {
4172 set id [lindex $opt 0]
4173 if {[lindex $opt 1] eq "b"} {
4174 # Checkboxes
4175 set val 0
4176 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4177 # Radiobuttons
4178 regexp {^(.*_)} $id uselessvar id
4179 set val 0
4180 } else {
4181 # Text fields
4182 set val {}
4184 set newviewopts($n,$id) $val
4186 set oargs [list]
4187 set refargs [list]
4188 foreach arg $view_args {
4189 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4190 && ![info exists found(limit)]} {
4191 set newviewopts($n,limit) $cnt
4192 set found(limit) 1
4193 continue
4195 catch { unset val }
4196 foreach opt $known_view_options {
4197 set id [lindex $opt 0]
4198 if {[info exists found($id)]} continue
4199 foreach pattern [lindex $opt 3] {
4200 if {![string match $pattern $arg]} continue
4201 if {[lindex $opt 1] eq "b"} {
4202 # Check buttons
4203 set val 1
4204 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4205 # Radio buttons
4206 regexp {^(.*_)} $id uselessvar id
4207 set val $num
4208 } else {
4209 # Text input fields
4210 set size [string length $pattern]
4211 set val [string range $arg [expr {$size-1}] end]
4213 set newviewopts($n,$id) $val
4214 set found($id) 1
4215 break
4217 if {[info exists val]} break
4219 if {[info exists val]} continue
4220 if {[regexp {^-} $arg]} {
4221 lappend oargs $arg
4222 } else {
4223 lappend refargs $arg
4226 set newviewopts($n,refs) [shellarglist $refargs]
4227 set newviewopts($n,args) [shellarglist $oargs]
4230 proc edit_or_newview {} {
4231 global curview
4233 if {$curview > 0} {
4234 editview
4235 } else {
4236 newview 0
4240 proc editview {} {
4241 global curview
4242 global viewname viewperm newviewname newviewopts
4243 global viewargs viewargscmd
4245 set top .gitkvedit-$curview
4246 if {[winfo exists $top]} {
4247 raise $top
4248 return
4250 decode_view_opts $curview $viewargs($curview)
4251 set newviewname($curview) $viewname($curview)
4252 set newviewopts($curview,perm) $viewperm($curview)
4253 set newviewopts($curview,cmd) $viewargscmd($curview)
4254 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4257 proc vieweditor {top n title} {
4258 global newviewname newviewopts viewfiles bgcolor
4259 global known_view_options NS
4261 ttk_toplevel $top
4262 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4263 make_transient $top .
4265 # View name
4266 ${NS}::frame $top.nfr
4267 ${NS}::label $top.nl -text [mc "View Name"]
4268 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4269 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4270 pack $top.nl -in $top.nfr -side left -padx {0 5}
4271 pack $top.name -in $top.nfr -side left -padx {0 25}
4273 # View options
4274 set cframe $top.nfr
4275 set cexpand 0
4276 set cnt 0
4277 foreach opt $known_view_options {
4278 set id [lindex $opt 0]
4279 set type [lindex $opt 1]
4280 set flags [lindex $opt 2]
4281 set title [eval [lindex $opt 4]]
4282 set lxpad 0
4284 if {$flags eq "+" || $flags eq "*"} {
4285 set cframe $top.fr$cnt
4286 incr cnt
4287 ${NS}::frame $cframe
4288 pack $cframe -in $top -fill x -pady 3 -padx 3
4289 set cexpand [expr {$flags eq "*"}]
4290 } elseif {$flags eq ".." || $flags eq "*."} {
4291 set cframe $top.fr$cnt
4292 incr cnt
4293 ${NS}::frame $cframe
4294 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4295 set cexpand [expr {$flags eq "*."}]
4296 } else {
4297 set lxpad 5
4300 if {$type eq "l"} {
4301 ${NS}::label $cframe.l_$id -text $title
4302 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4303 } elseif {$type eq "b"} {
4304 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4305 pack $cframe.c_$id -in $cframe -side left \
4306 -padx [list $lxpad 0] -expand $cexpand -anchor w
4307 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4308 regexp {^(.*_)} $id uselessvar button_id
4309 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4310 pack $cframe.c_$id -in $cframe -side left \
4311 -padx [list $lxpad 0] -expand $cexpand -anchor w
4312 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4313 ${NS}::label $cframe.l_$id -text $title
4314 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4315 -textvariable newviewopts($n,$id)
4316 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4317 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4318 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4319 ${NS}::label $cframe.l_$id -text $title
4320 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4321 -textvariable newviewopts($n,$id)
4322 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4323 pack $cframe.e_$id -in $cframe -side top -fill x
4324 } elseif {$type eq "path"} {
4325 ${NS}::label $top.l -text $title
4326 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4327 text $top.t -width 40 -height 5 -background $bgcolor
4328 if {[info exists viewfiles($n)]} {
4329 foreach f $viewfiles($n) {
4330 $top.t insert end $f
4331 $top.t insert end "\n"
4333 $top.t delete {end - 1c} end
4334 $top.t mark set insert 0.0
4336 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4340 ${NS}::frame $top.buts
4341 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4342 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4343 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4344 bind $top <Control-Return> [list newviewok $top $n]
4345 bind $top <F5> [list newviewok $top $n 1]
4346 bind $top <Escape> [list destroy $top]
4347 grid $top.buts.ok $top.buts.apply $top.buts.can
4348 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4349 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4350 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4351 pack $top.buts -in $top -side top -fill x
4352 focus $top.t
4355 proc doviewmenu {m first cmd op argv} {
4356 set nmenu [$m index end]
4357 for {set i $first} {$i <= $nmenu} {incr i} {
4358 if {[$m entrycget $i -command] eq $cmd} {
4359 eval $m $op $i $argv
4360 break
4365 proc allviewmenus {n op args} {
4366 # global viewhlmenu
4368 doviewmenu .bar.view 5 [list showview $n] $op $args
4369 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4372 proc newviewok {top n {apply 0}} {
4373 global nextviewnum newviewperm newviewname newishighlight
4374 global viewname viewfiles viewperm viewchanged selectedview curview
4375 global viewargs viewargscmd newviewopts viewhlmenu
4377 if {[catch {
4378 set newargs [encode_view_opts $n]
4379 } err]} {
4380 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4381 return
4383 set files {}
4384 foreach f [split [$top.t get 0.0 end] "\n"] {
4385 set ft [string trim $f]
4386 if {$ft ne {}} {
4387 lappend files $ft
4390 if {![info exists viewfiles($n)]} {
4391 # creating a new view
4392 incr nextviewnum
4393 set viewname($n) $newviewname($n)
4394 set viewperm($n) $newviewopts($n,perm)
4395 set viewchanged($n) 1
4396 set viewfiles($n) $files
4397 set viewargs($n) $newargs
4398 set viewargscmd($n) $newviewopts($n,cmd)
4399 addviewmenu $n
4400 if {!$newishighlight} {
4401 run showview $n
4402 } else {
4403 run addvhighlight $n
4405 } else {
4406 # editing an existing view
4407 set viewperm($n) $newviewopts($n,perm)
4408 set viewchanged($n) 1
4409 if {$newviewname($n) ne $viewname($n)} {
4410 set viewname($n) $newviewname($n)
4411 doviewmenu .bar.view 5 [list showview $n] \
4412 entryconf [list -label $viewname($n)]
4413 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4414 # entryconf [list -label $viewname($n) -value $viewname($n)]
4416 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4417 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4418 set viewfiles($n) $files
4419 set viewargs($n) $newargs
4420 set viewargscmd($n) $newviewopts($n,cmd)
4421 if {$curview == $n} {
4422 run reloadcommits
4426 if {$apply} return
4427 catch {destroy $top}
4430 proc delview {} {
4431 global curview viewperm hlview selectedhlview viewchanged
4433 if {$curview == 0} return
4434 if {[info exists hlview] && $hlview == $curview} {
4435 set selectedhlview [mc "None"]
4436 unset hlview
4438 allviewmenus $curview delete
4439 set viewperm($curview) 0
4440 set viewchanged($curview) 1
4441 showview 0
4444 proc addviewmenu {n} {
4445 global viewname viewhlmenu
4447 .bar.view add radiobutton -label $viewname($n) \
4448 -command [list showview $n] -variable selectedview -value $n
4449 #$viewhlmenu add radiobutton -label $viewname($n) \
4450 # -command [list addvhighlight $n] -variable selectedhlview
4453 proc showview {n} {
4454 global curview cached_commitrow ordertok
4455 global displayorder parentlist rowidlist rowisopt rowfinal
4456 global colormap rowtextx nextcolor canvxmax
4457 global numcommits viewcomplete
4458 global selectedline currentid canv canvy0
4459 global treediffs
4460 global pending_select mainheadid
4461 global commitidx
4462 global selectedview
4463 global hlview selectedhlview commitinterest
4465 if {$n == $curview} return
4466 set selid {}
4467 set ymax [lindex [$canv cget -scrollregion] 3]
4468 set span [$canv yview]
4469 set ytop [expr {[lindex $span 0] * $ymax}]
4470 set ybot [expr {[lindex $span 1] * $ymax}]
4471 set yscreen [expr {($ybot - $ytop) / 2}]
4472 if {$selectedline ne {}} {
4473 set selid $currentid
4474 set y [yc $selectedline]
4475 if {$ytop < $y && $y < $ybot} {
4476 set yscreen [expr {$y - $ytop}]
4478 } elseif {[info exists pending_select]} {
4479 set selid $pending_select
4480 unset pending_select
4482 unselectline
4483 normalline
4484 unset -nocomplain treediffs
4485 clear_display
4486 if {[info exists hlview] && $hlview == $n} {
4487 unset hlview
4488 set selectedhlview [mc "None"]
4490 unset -nocomplain commitinterest
4491 unset -nocomplain cached_commitrow
4492 unset -nocomplain ordertok
4494 set curview $n
4495 set selectedview $n
4496 .bar.view entryconf [mca "&Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4497 .bar.view entryconf [mca "&Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4499 run refill_reflist
4500 if {![info exists viewcomplete($n)]} {
4501 getcommits $selid
4502 return
4505 set displayorder {}
4506 set parentlist {}
4507 set rowidlist {}
4508 set rowisopt {}
4509 set rowfinal {}
4510 set numcommits $commitidx($n)
4512 unset -nocomplain colormap
4513 unset -nocomplain rowtextx
4514 set nextcolor 0
4515 set canvxmax [$canv cget -width]
4516 set curview $n
4517 set row 0
4518 setcanvscroll
4519 set yf 0
4520 set row {}
4521 if {$selid ne {} && [commitinview $selid $n]} {
4522 set row [rowofcommit $selid]
4523 # try to get the selected row in the same position on the screen
4524 set ymax [lindex [$canv cget -scrollregion] 3]
4525 set ytop [expr {[yc $row] - $yscreen}]
4526 if {$ytop < 0} {
4527 set ytop 0
4529 set yf [expr {$ytop * 1.0 / $ymax}]
4531 allcanvs yview moveto $yf
4532 drawvisible
4533 if {$row ne {}} {
4534 selectline $row 0
4535 } elseif {!$viewcomplete($n)} {
4536 reset_pending_select $selid
4537 } else {
4538 reset_pending_select {}
4540 if {[commitinview $pending_select $curview]} {
4541 selectline [rowofcommit $pending_select] 1
4542 } else {
4543 set row [first_real_row]
4544 if {$row < $numcommits} {
4545 selectline $row 0
4549 if {!$viewcomplete($n)} {
4550 if {$numcommits == 0} {
4551 show_status [mc "Reading commits..."]
4553 } elseif {$numcommits == 0} {
4554 show_status [mc "No commits selected"]
4556 set_window_title
4559 # Stuff relating to the highlighting facility
4561 proc ishighlighted {id} {
4562 global vhighlights fhighlights nhighlights rhighlights
4564 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4565 return $nhighlights($id)
4567 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4568 return $vhighlights($id)
4570 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4571 return $fhighlights($id)
4573 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4574 return $rhighlights($id)
4576 return 0
4579 proc bolden {id font} {
4580 global canv linehtag currentid boldids need_redisplay markedid
4582 # need_redisplay = 1 means the display is stale and about to be redrawn
4583 if {$need_redisplay} return
4584 lappend boldids $id
4585 $canv itemconf $linehtag($id) -font $font
4586 if {[info exists currentid] && $id eq $currentid} {
4587 $canv delete secsel
4588 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4589 -outline {{}} -tags secsel \
4590 -fill [$canv cget -selectbackground]]
4591 $canv lower $t
4593 if {[info exists markedid] && $id eq $markedid} {
4594 make_idmark $id
4598 proc bolden_name {id font} {
4599 global canv2 linentag currentid boldnameids need_redisplay
4601 if {$need_redisplay} return
4602 lappend boldnameids $id
4603 $canv2 itemconf $linentag($id) -font $font
4604 if {[info exists currentid] && $id eq $currentid} {
4605 $canv2 delete secsel
4606 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4607 -outline {{}} -tags secsel \
4608 -fill [$canv2 cget -selectbackground]]
4609 $canv2 lower $t
4613 proc unbolden {} {
4614 global boldids
4616 set stillbold {}
4617 foreach id $boldids {
4618 if {![ishighlighted $id]} {
4619 bolden $id mainfont
4620 } else {
4621 lappend stillbold $id
4624 set boldids $stillbold
4627 proc addvhighlight {n} {
4628 global hlview viewcomplete curview vhl_done commitidx
4630 if {[info exists hlview]} {
4631 delvhighlight
4633 set hlview $n
4634 if {$n != $curview && ![info exists viewcomplete($n)]} {
4635 start_rev_list $n
4637 set vhl_done $commitidx($hlview)
4638 if {$vhl_done > 0} {
4639 drawvisible
4643 proc delvhighlight {} {
4644 global hlview vhighlights
4646 if {![info exists hlview]} return
4647 unset hlview
4648 unset -nocomplain vhighlights
4649 unbolden
4652 proc vhighlightmore {} {
4653 global hlview vhl_done commitidx vhighlights curview
4655 set max $commitidx($hlview)
4656 set vr [visiblerows]
4657 set r0 [lindex $vr 0]
4658 set r1 [lindex $vr 1]
4659 for {set i $vhl_done} {$i < $max} {incr i} {
4660 set id [commitonrow $i $hlview]
4661 if {[commitinview $id $curview]} {
4662 set row [rowofcommit $id]
4663 if {$r0 <= $row && $row <= $r1} {
4664 if {![highlighted $row]} {
4665 bolden $id mainfontbold
4667 set vhighlights($id) 1
4671 set vhl_done $max
4672 return 0
4675 proc askvhighlight {row id} {
4676 global hlview vhighlights iddrawn
4678 if {[commitinview $id $hlview]} {
4679 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4680 bolden $id mainfontbold
4682 set vhighlights($id) 1
4683 } else {
4684 set vhighlights($id) 0
4688 proc hfiles_change {} {
4689 global highlight_files filehighlight fhighlights fh_serial
4690 global highlight_paths
4692 if {[info exists filehighlight]} {
4693 # delete previous highlights
4694 catch {close $filehighlight}
4695 unset filehighlight
4696 unset -nocomplain fhighlights
4697 unbolden
4698 unhighlight_filelist
4700 set highlight_paths {}
4701 after cancel do_file_hl $fh_serial
4702 incr fh_serial
4703 if {$highlight_files ne {}} {
4704 after 300 do_file_hl $fh_serial
4708 proc gdttype_change {name ix op} {
4709 global gdttype highlight_files findstring findpattern
4711 stopfinding
4712 if {$findstring ne {}} {
4713 if {$gdttype eq [mc "containing:"]} {
4714 if {$highlight_files ne {}} {
4715 set highlight_files {}
4716 hfiles_change
4718 findcom_change
4719 } else {
4720 if {$findpattern ne {}} {
4721 set findpattern {}
4722 findcom_change
4724 set highlight_files $findstring
4725 hfiles_change
4727 drawvisible
4729 # enable/disable findtype/findloc menus too
4732 proc find_change {name ix op} {
4733 global gdttype findstring highlight_files
4735 stopfinding
4736 if {$gdttype eq [mc "containing:"]} {
4737 findcom_change
4738 } else {
4739 if {$highlight_files ne $findstring} {
4740 set highlight_files $findstring
4741 hfiles_change
4744 drawvisible
4747 proc findcom_change args {
4748 global nhighlights boldnameids
4749 global findpattern findtype findstring gdttype
4751 stopfinding
4752 # delete previous highlights, if any
4753 foreach id $boldnameids {
4754 bolden_name $id mainfont
4756 set boldnameids {}
4757 unset -nocomplain nhighlights
4758 unbolden
4759 unmarkmatches
4760 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4761 set findpattern {}
4762 } elseif {$findtype eq [mc "Regexp"]} {
4763 set findpattern $findstring
4764 } else {
4765 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4766 $findstring]
4767 set findpattern "*$e*"
4771 proc makepatterns {l} {
4772 set ret {}
4773 foreach e $l {
4774 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4775 if {[string index $ee end] eq "/"} {
4776 lappend ret "$ee*"
4777 } else {
4778 lappend ret $ee
4779 lappend ret "$ee/*"
4782 return $ret
4785 proc do_file_hl {serial} {
4786 global highlight_files filehighlight highlight_paths gdttype fhl_list
4787 global cdup findtype
4789 if {$gdttype eq [mc "touching paths:"]} {
4790 # If "exact" match then convert backslashes to forward slashes.
4791 # Most useful to support Windows-flavoured file paths.
4792 if {$findtype eq [mc "Exact"]} {
4793 set highlight_files [string map {"\\" "/"} $highlight_files]
4795 if {[catch {set paths [shellsplit $highlight_files]}]} return
4796 set highlight_paths [makepatterns $paths]
4797 highlight_filelist
4798 set relative_paths {}
4799 foreach path $paths {
4800 lappend relative_paths [file join $cdup $path]
4802 set gdtargs [concat -- $relative_paths]
4803 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4804 set gdtargs [list "-S$highlight_files"]
4805 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4806 set gdtargs [list "-G$highlight_files"]
4807 } else {
4808 # must be "containing:", i.e. we're searching commit info
4809 return
4811 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4812 set filehighlight [open $cmd r+]
4813 fconfigure $filehighlight -blocking 0
4814 filerun $filehighlight readfhighlight
4815 set fhl_list {}
4816 drawvisible
4817 flushhighlights
4820 proc flushhighlights {} {
4821 global filehighlight fhl_list
4823 if {[info exists filehighlight]} {
4824 lappend fhl_list {}
4825 puts $filehighlight ""
4826 flush $filehighlight
4830 proc askfilehighlight {row id} {
4831 global filehighlight fhighlights fhl_list
4833 lappend fhl_list $id
4834 set fhighlights($id) -1
4835 puts $filehighlight $id
4838 proc readfhighlight {} {
4839 global filehighlight fhighlights curview iddrawn
4840 global fhl_list find_dirn
4842 if {![info exists filehighlight]} {
4843 return 0
4845 set nr 0
4846 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4847 set line [string trim $line]
4848 set i [lsearch -exact $fhl_list $line]
4849 if {$i < 0} continue
4850 for {set j 0} {$j < $i} {incr j} {
4851 set id [lindex $fhl_list $j]
4852 set fhighlights($id) 0
4854 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4855 if {$line eq {}} continue
4856 if {![commitinview $line $curview]} continue
4857 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4858 bolden $line mainfontbold
4860 set fhighlights($line) 1
4862 if {[eof $filehighlight]} {
4863 # strange...
4864 puts "oops, git diff-tree died"
4865 catch {close $filehighlight}
4866 unset filehighlight
4867 return 0
4869 if {[info exists find_dirn]} {
4870 run findmore
4872 return 1
4875 proc doesmatch {f} {
4876 global findtype findpattern
4878 if {$findtype eq [mc "Regexp"]} {
4879 return [regexp $findpattern $f]
4880 } elseif {$findtype eq [mc "IgnCase"]} {
4881 return [string match -nocase $findpattern $f]
4882 } else {
4883 return [string match $findpattern $f]
4887 proc askfindhighlight {row id} {
4888 global nhighlights commitinfo iddrawn
4889 global findloc
4890 global markingmatches
4892 if {![info exists commitinfo($id)]} {
4893 getcommit $id
4895 set info $commitinfo($id)
4896 set isbold 0
4897 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4898 foreach f $info ty $fldtypes {
4899 if {$ty eq ""} continue
4900 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4901 [doesmatch $f]} {
4902 if {$ty eq [mc "Author"]} {
4903 set isbold 2
4904 break
4906 set isbold 1
4909 if {$isbold && [info exists iddrawn($id)]} {
4910 if {![ishighlighted $id]} {
4911 bolden $id mainfontbold
4912 if {$isbold > 1} {
4913 bolden_name $id mainfontbold
4916 if {$markingmatches} {
4917 markrowmatches $row $id
4920 set nhighlights($id) $isbold
4923 proc markrowmatches {row id} {
4924 global canv canv2 linehtag linentag commitinfo findloc
4926 set headline [lindex $commitinfo($id) 0]
4927 set author [lindex $commitinfo($id) 1]
4928 $canv delete match$row
4929 $canv2 delete match$row
4930 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4931 set m [findmatches $headline]
4932 if {$m ne {}} {
4933 markmatches $canv $row $headline $linehtag($id) $m \
4934 [$canv itemcget $linehtag($id) -font] $row
4937 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4938 set m [findmatches $author]
4939 if {$m ne {}} {
4940 markmatches $canv2 $row $author $linentag($id) $m \
4941 [$canv2 itemcget $linentag($id) -font] $row
4946 proc vrel_change {name ix op} {
4947 global highlight_related
4949 rhighlight_none
4950 if {$highlight_related ne [mc "None"]} {
4951 run drawvisible
4955 # prepare for testing whether commits are descendents or ancestors of a
4956 proc rhighlight_sel {a} {
4957 global descendent desc_todo ancestor anc_todo
4958 global highlight_related
4960 unset -nocomplain descendent
4961 set desc_todo [list $a]
4962 unset -nocomplain ancestor
4963 set anc_todo [list $a]
4964 if {$highlight_related ne [mc "None"]} {
4965 rhighlight_none
4966 run drawvisible
4970 proc rhighlight_none {} {
4971 global rhighlights
4973 unset -nocomplain rhighlights
4974 unbolden
4977 proc is_descendent {a} {
4978 global curview children descendent desc_todo
4980 set v $curview
4981 set la [rowofcommit $a]
4982 set todo $desc_todo
4983 set leftover {}
4984 set done 0
4985 for {set i 0} {$i < [llength $todo]} {incr i} {
4986 set do [lindex $todo $i]
4987 if {[rowofcommit $do] < $la} {
4988 lappend leftover $do
4989 continue
4991 foreach nk $children($v,$do) {
4992 if {![info exists descendent($nk)]} {
4993 set descendent($nk) 1
4994 lappend todo $nk
4995 if {$nk eq $a} {
4996 set done 1
5000 if {$done} {
5001 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5002 return
5005 set descendent($a) 0
5006 set desc_todo $leftover
5009 proc is_ancestor {a} {
5010 global curview parents ancestor anc_todo
5012 set v $curview
5013 set la [rowofcommit $a]
5014 set todo $anc_todo
5015 set leftover {}
5016 set done 0
5017 for {set i 0} {$i < [llength $todo]} {incr i} {
5018 set do [lindex $todo $i]
5019 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
5020 lappend leftover $do
5021 continue
5023 foreach np $parents($v,$do) {
5024 if {![info exists ancestor($np)]} {
5025 set ancestor($np) 1
5026 lappend todo $np
5027 if {$np eq $a} {
5028 set done 1
5032 if {$done} {
5033 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5034 return
5037 set ancestor($a) 0
5038 set anc_todo $leftover
5041 proc askrelhighlight {row id} {
5042 global descendent highlight_related iddrawn rhighlights
5043 global selectedline ancestor
5045 if {$selectedline eq {}} return
5046 set isbold 0
5047 if {$highlight_related eq [mc "Descendant"] ||
5048 $highlight_related eq [mc "Not descendant"]} {
5049 if {![info exists descendent($id)]} {
5050 is_descendent $id
5052 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5053 set isbold 1
5055 } elseif {$highlight_related eq [mc "Ancestor"] ||
5056 $highlight_related eq [mc "Not ancestor"]} {
5057 if {![info exists ancestor($id)]} {
5058 is_ancestor $id
5060 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5061 set isbold 1
5064 if {[info exists iddrawn($id)]} {
5065 if {$isbold && ![ishighlighted $id]} {
5066 bolden $id mainfontbold
5069 set rhighlights($id) $isbold
5072 # Graph layout functions
5074 proc shortids {ids} {
5075 set res {}
5076 foreach id $ids {
5077 if {[llength $id] > 1} {
5078 lappend res [shortids $id]
5079 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5080 lappend res [string range $id 0 7]
5081 } else {
5082 lappend res $id
5085 return $res
5088 proc ntimes {n o} {
5089 set ret {}
5090 set o [list $o]
5091 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5092 if {($n & $mask) != 0} {
5093 set ret [concat $ret $o]
5095 set o [concat $o $o]
5097 return $ret
5100 proc ordertoken {id} {
5101 global ordertok curview varcid varcstart varctok curview parents children
5102 global nullid nullid2
5104 if {[info exists ordertok($id)]} {
5105 return $ordertok($id)
5107 set origid $id
5108 set todo {}
5109 while {1} {
5110 if {[info exists varcid($curview,$id)]} {
5111 set a $varcid($curview,$id)
5112 set p [lindex $varcstart($curview) $a]
5113 } else {
5114 set p [lindex $children($curview,$id) 0]
5116 if {[info exists ordertok($p)]} {
5117 set tok $ordertok($p)
5118 break
5120 set id [first_real_child $curview,$p]
5121 if {$id eq {}} {
5122 # it's a root
5123 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5124 break
5126 if {[llength $parents($curview,$id)] == 1} {
5127 lappend todo [list $p {}]
5128 } else {
5129 set j [lsearch -exact $parents($curview,$id) $p]
5130 if {$j < 0} {
5131 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5133 lappend todo [list $p [strrep $j]]
5136 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5137 set p [lindex $todo $i 0]
5138 append tok [lindex $todo $i 1]
5139 set ordertok($p) $tok
5141 set ordertok($origid) $tok
5142 return $tok
5145 # Work out where id should go in idlist so that order-token
5146 # values increase from left to right
5147 proc idcol {idlist id {i 0}} {
5148 set t [ordertoken $id]
5149 if {$i < 0} {
5150 set i 0
5152 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5153 if {$i > [llength $idlist]} {
5154 set i [llength $idlist]
5156 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5157 incr i
5158 } else {
5159 if {$t > [ordertoken [lindex $idlist $i]]} {
5160 while {[incr i] < [llength $idlist] &&
5161 $t >= [ordertoken [lindex $idlist $i]]} {}
5164 return $i
5167 proc initlayout {} {
5168 global rowidlist rowisopt rowfinal displayorder parentlist
5169 global numcommits canvxmax canv
5170 global nextcolor
5171 global colormap rowtextx
5173 set numcommits 0
5174 set displayorder {}
5175 set parentlist {}
5176 set nextcolor 0
5177 set rowidlist {}
5178 set rowisopt {}
5179 set rowfinal {}
5180 set canvxmax [$canv cget -width]
5181 unset -nocomplain colormap
5182 unset -nocomplain rowtextx
5183 setcanvscroll
5186 proc setcanvscroll {} {
5187 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5188 global lastscrollset lastscrollrows
5190 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5191 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5192 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5193 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5194 set lastscrollset [clock clicks -milliseconds]
5195 set lastscrollrows $numcommits
5198 proc visiblerows {} {
5199 global canv numcommits linespc
5201 set ymax [lindex [$canv cget -scrollregion] 3]
5202 if {$ymax eq {} || $ymax == 0} return
5203 set f [$canv yview]
5204 set y0 [expr {int([lindex $f 0] * $ymax)}]
5205 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5206 if {$r0 < 0} {
5207 set r0 0
5209 set y1 [expr {int([lindex $f 1] * $ymax)}]
5210 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5211 if {$r1 >= $numcommits} {
5212 set r1 [expr {$numcommits - 1}]
5214 return [list $r0 $r1]
5217 proc layoutmore {} {
5218 global commitidx viewcomplete curview
5219 global numcommits pending_select curview
5220 global lastscrollset lastscrollrows
5222 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5223 [clock clicks -milliseconds] - $lastscrollset > 500} {
5224 setcanvscroll
5226 if {[info exists pending_select] &&
5227 [commitinview $pending_select $curview]} {
5228 update
5229 selectline [rowofcommit $pending_select] 1
5231 drawvisible
5234 # With path limiting, we mightn't get the actual HEAD commit,
5235 # so ask git rev-list what is the first ancestor of HEAD that
5236 # touches a file in the path limit.
5237 proc get_viewmainhead {view} {
5238 global viewmainheadid vfilelimit viewinstances mainheadid
5240 catch {
5241 set rfd [open [concat | git rev-list -1 $mainheadid \
5242 -- $vfilelimit($view)] r]
5243 set j [reg_instance $rfd]
5244 lappend viewinstances($view) $j
5245 fconfigure $rfd -blocking 0
5246 filerun $rfd [list getviewhead $rfd $j $view]
5247 set viewmainheadid($curview) {}
5251 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5252 proc getviewhead {fd inst view} {
5253 global viewmainheadid commfd curview viewinstances showlocalchanges
5255 set id {}
5256 if {[gets $fd line] < 0} {
5257 if {![eof $fd]} {
5258 return 1
5260 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5261 set id $line
5263 set viewmainheadid($view) $id
5264 close $fd
5265 unset commfd($inst)
5266 set i [lsearch -exact $viewinstances($view) $inst]
5267 if {$i >= 0} {
5268 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5270 if {$showlocalchanges && $id ne {} && $view == $curview} {
5271 doshowlocalchanges
5273 return 0
5276 proc doshowlocalchanges {} {
5277 global curview viewmainheadid
5279 if {$viewmainheadid($curview) eq {}} return
5280 if {[commitinview $viewmainheadid($curview) $curview]} {
5281 dodiffindex
5282 } else {
5283 interestedin $viewmainheadid($curview) dodiffindex
5287 proc dohidelocalchanges {} {
5288 global nullid nullid2 lserial curview
5290 if {[commitinview $nullid $curview]} {
5291 removefakerow $nullid
5293 if {[commitinview $nullid2 $curview]} {
5294 removefakerow $nullid2
5296 incr lserial
5299 # spawn off a process to do git diff-index --cached HEAD
5300 proc dodiffindex {} {
5301 global lserial showlocalchanges vfilelimit curview
5302 global hasworktree git_version
5304 if {!$showlocalchanges || !$hasworktree} return
5305 incr lserial
5306 if {[package vcompare $git_version "1.7.2"] >= 0} {
5307 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5308 } else {
5309 set cmd "|git diff-index --cached HEAD"
5311 if {$vfilelimit($curview) ne {}} {
5312 set cmd [concat $cmd -- $vfilelimit($curview)]
5314 set fd [open $cmd r]
5315 fconfigure $fd -blocking 0
5316 set i [reg_instance $fd]
5317 filerun $fd [list readdiffindex $fd $lserial $i]
5320 proc readdiffindex {fd serial inst} {
5321 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5322 global vfilelimit
5324 set isdiff 1
5325 if {[gets $fd line] < 0} {
5326 if {![eof $fd]} {
5327 return 1
5329 set isdiff 0
5331 # we only need to see one line and we don't really care what it says...
5332 stop_instance $inst
5334 if {$serial != $lserial} {
5335 return 0
5338 # now see if there are any local changes not checked in to the index
5339 set cmd "|git diff-files"
5340 if {$vfilelimit($curview) ne {}} {
5341 set cmd [concat $cmd -- $vfilelimit($curview)]
5343 set fd [open $cmd r]
5344 fconfigure $fd -blocking 0
5345 set i [reg_instance $fd]
5346 filerun $fd [list readdifffiles $fd $serial $i]
5348 if {$isdiff && ![commitinview $nullid2 $curview]} {
5349 # add the line for the changes in the index to the graph
5350 set hl [mc "Local changes checked in to index but not committed"]
5351 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5352 set commitdata($nullid2) "\n $hl\n"
5353 if {[commitinview $nullid $curview]} {
5354 removefakerow $nullid
5356 insertfakerow $nullid2 $viewmainheadid($curview)
5357 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5358 if {[commitinview $nullid $curview]} {
5359 removefakerow $nullid
5361 removefakerow $nullid2
5363 return 0
5366 proc readdifffiles {fd serial inst} {
5367 global viewmainheadid nullid nullid2 curview
5368 global commitinfo commitdata lserial
5370 set isdiff 1
5371 if {[gets $fd line] < 0} {
5372 if {![eof $fd]} {
5373 return 1
5375 set isdiff 0
5377 # we only need to see one line and we don't really care what it says...
5378 stop_instance $inst
5380 if {$serial != $lserial} {
5381 return 0
5384 if {$isdiff && ![commitinview $nullid $curview]} {
5385 # add the line for the local diff to the graph
5386 set hl [mc "Local uncommitted changes, not checked in to index"]
5387 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5388 set commitdata($nullid) "\n $hl\n"
5389 if {[commitinview $nullid2 $curview]} {
5390 set p $nullid2
5391 } else {
5392 set p $viewmainheadid($curview)
5394 insertfakerow $nullid $p
5395 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5396 removefakerow $nullid
5398 return 0
5401 proc nextuse {id row} {
5402 global curview children
5404 if {[info exists children($curview,$id)]} {
5405 foreach kid $children($curview,$id) {
5406 if {![commitinview $kid $curview]} {
5407 return -1
5409 if {[rowofcommit $kid] > $row} {
5410 return [rowofcommit $kid]
5414 if {[commitinview $id $curview]} {
5415 return [rowofcommit $id]
5417 return -1
5420 proc prevuse {id row} {
5421 global curview children
5423 set ret -1
5424 if {[info exists children($curview,$id)]} {
5425 foreach kid $children($curview,$id) {
5426 if {![commitinview $kid $curview]} break
5427 if {[rowofcommit $kid] < $row} {
5428 set ret [rowofcommit $kid]
5432 return $ret
5435 proc make_idlist {row} {
5436 global displayorder parentlist uparrowlen downarrowlen mingaplen
5437 global commitidx curview children
5439 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5440 if {$r < 0} {
5441 set r 0
5443 set ra [expr {$row - $downarrowlen}]
5444 if {$ra < 0} {
5445 set ra 0
5447 set rb [expr {$row + $uparrowlen}]
5448 if {$rb > $commitidx($curview)} {
5449 set rb $commitidx($curview)
5451 make_disporder $r [expr {$rb + 1}]
5452 set ids {}
5453 for {} {$r < $ra} {incr r} {
5454 set nextid [lindex $displayorder [expr {$r + 1}]]
5455 foreach p [lindex $parentlist $r] {
5456 if {$p eq $nextid} continue
5457 set rn [nextuse $p $r]
5458 if {$rn >= $row &&
5459 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5460 lappend ids [list [ordertoken $p] $p]
5464 for {} {$r < $row} {incr r} {
5465 set nextid [lindex $displayorder [expr {$r + 1}]]
5466 foreach p [lindex $parentlist $r] {
5467 if {$p eq $nextid} continue
5468 set rn [nextuse $p $r]
5469 if {$rn < 0 || $rn >= $row} {
5470 lappend ids [list [ordertoken $p] $p]
5474 set id [lindex $displayorder $row]
5475 lappend ids [list [ordertoken $id] $id]
5476 while {$r < $rb} {
5477 foreach p [lindex $parentlist $r] {
5478 set firstkid [lindex $children($curview,$p) 0]
5479 if {[rowofcommit $firstkid] < $row} {
5480 lappend ids [list [ordertoken $p] $p]
5483 incr r
5484 set id [lindex $displayorder $r]
5485 if {$id ne {}} {
5486 set firstkid [lindex $children($curview,$id) 0]
5487 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5488 lappend ids [list [ordertoken $id] $id]
5492 set idlist {}
5493 foreach idx [lsort -unique $ids] {
5494 lappend idlist [lindex $idx 1]
5496 return $idlist
5499 proc rowsequal {a b} {
5500 while {[set i [lsearch -exact $a {}]] >= 0} {
5501 set a [lreplace $a $i $i]
5503 while {[set i [lsearch -exact $b {}]] >= 0} {
5504 set b [lreplace $b $i $i]
5506 return [expr {$a eq $b}]
5509 proc makeupline {id row rend col} {
5510 global rowidlist uparrowlen downarrowlen mingaplen
5512 for {set r $rend} {1} {set r $rstart} {
5513 set rstart [prevuse $id $r]
5514 if {$rstart < 0} return
5515 if {$rstart < $row} break
5517 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5518 set rstart [expr {$rend - $uparrowlen - 1}]
5520 for {set r $rstart} {[incr r] <= $row} {} {
5521 set idlist [lindex $rowidlist $r]
5522 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5523 set col [idcol $idlist $id $col]
5524 lset rowidlist $r [linsert $idlist $col $id]
5525 changedrow $r
5530 proc layoutrows {row endrow} {
5531 global rowidlist rowisopt rowfinal displayorder
5532 global uparrowlen downarrowlen maxwidth mingaplen
5533 global children parentlist
5534 global commitidx viewcomplete curview
5536 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5537 set idlist {}
5538 if {$row > 0} {
5539 set rm1 [expr {$row - 1}]
5540 foreach id [lindex $rowidlist $rm1] {
5541 if {$id ne {}} {
5542 lappend idlist $id
5545 set final [lindex $rowfinal $rm1]
5547 for {} {$row < $endrow} {incr row} {
5548 set rm1 [expr {$row - 1}]
5549 if {$rm1 < 0 || $idlist eq {}} {
5550 set idlist [make_idlist $row]
5551 set final 1
5552 } else {
5553 set id [lindex $displayorder $rm1]
5554 set col [lsearch -exact $idlist $id]
5555 set idlist [lreplace $idlist $col $col]
5556 foreach p [lindex $parentlist $rm1] {
5557 if {[lsearch -exact $idlist $p] < 0} {
5558 set col [idcol $idlist $p $col]
5559 set idlist [linsert $idlist $col $p]
5560 # if not the first child, we have to insert a line going up
5561 if {$id ne [lindex $children($curview,$p) 0]} {
5562 makeupline $p $rm1 $row $col
5566 set id [lindex $displayorder $row]
5567 if {$row > $downarrowlen} {
5568 set termrow [expr {$row - $downarrowlen - 1}]
5569 foreach p [lindex $parentlist $termrow] {
5570 set i [lsearch -exact $idlist $p]
5571 if {$i < 0} continue
5572 set nr [nextuse $p $termrow]
5573 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5574 set idlist [lreplace $idlist $i $i]
5578 set col [lsearch -exact $idlist $id]
5579 if {$col < 0} {
5580 set col [idcol $idlist $id]
5581 set idlist [linsert $idlist $col $id]
5582 if {$children($curview,$id) ne {}} {
5583 makeupline $id $rm1 $row $col
5586 set r [expr {$row + $uparrowlen - 1}]
5587 if {$r < $commitidx($curview)} {
5588 set x $col
5589 foreach p [lindex $parentlist $r] {
5590 if {[lsearch -exact $idlist $p] >= 0} continue
5591 set fk [lindex $children($curview,$p) 0]
5592 if {[rowofcommit $fk] < $row} {
5593 set x [idcol $idlist $p $x]
5594 set idlist [linsert $idlist $x $p]
5597 if {[incr r] < $commitidx($curview)} {
5598 set p [lindex $displayorder $r]
5599 if {[lsearch -exact $idlist $p] < 0} {
5600 set fk [lindex $children($curview,$p) 0]
5601 if {$fk ne {} && [rowofcommit $fk] < $row} {
5602 set x [idcol $idlist $p $x]
5603 set idlist [linsert $idlist $x $p]
5609 if {$final && !$viewcomplete($curview) &&
5610 $row + $uparrowlen + $mingaplen + $downarrowlen
5611 >= $commitidx($curview)} {
5612 set final 0
5614 set l [llength $rowidlist]
5615 if {$row == $l} {
5616 lappend rowidlist $idlist
5617 lappend rowisopt 0
5618 lappend rowfinal $final
5619 } elseif {$row < $l} {
5620 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5621 lset rowidlist $row $idlist
5622 changedrow $row
5624 lset rowfinal $row $final
5625 } else {
5626 set pad [ntimes [expr {$row - $l}] {}]
5627 set rowidlist [concat $rowidlist $pad]
5628 lappend rowidlist $idlist
5629 set rowfinal [concat $rowfinal $pad]
5630 lappend rowfinal $final
5631 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5634 return $row
5637 proc changedrow {row} {
5638 global displayorder iddrawn rowisopt need_redisplay
5640 set l [llength $rowisopt]
5641 if {$row < $l} {
5642 lset rowisopt $row 0
5643 if {$row + 1 < $l} {
5644 lset rowisopt [expr {$row + 1}] 0
5645 if {$row + 2 < $l} {
5646 lset rowisopt [expr {$row + 2}] 0
5650 set id [lindex $displayorder $row]
5651 if {[info exists iddrawn($id)]} {
5652 set need_redisplay 1
5656 proc insert_pad {row col npad} {
5657 global rowidlist
5659 set pad [ntimes $npad {}]
5660 set idlist [lindex $rowidlist $row]
5661 set bef [lrange $idlist 0 [expr {$col - 1}]]
5662 set aft [lrange $idlist $col end]
5663 set i [lsearch -exact $aft {}]
5664 if {$i > 0} {
5665 set aft [lreplace $aft $i $i]
5667 lset rowidlist $row [concat $bef $pad $aft]
5668 changedrow $row
5671 proc optimize_rows {row col endrow} {
5672 global rowidlist rowisopt displayorder curview children
5674 if {$row < 1} {
5675 set row 1
5677 for {} {$row < $endrow} {incr row; set col 0} {
5678 if {[lindex $rowisopt $row]} continue
5679 set haspad 0
5680 set y0 [expr {$row - 1}]
5681 set ym [expr {$row - 2}]
5682 set idlist [lindex $rowidlist $row]
5683 set previdlist [lindex $rowidlist $y0]
5684 if {$idlist eq {} || $previdlist eq {}} continue
5685 if {$ym >= 0} {
5686 set pprevidlist [lindex $rowidlist $ym]
5687 if {$pprevidlist eq {}} continue
5688 } else {
5689 set pprevidlist {}
5691 set x0 -1
5692 set xm -1
5693 for {} {$col < [llength $idlist]} {incr col} {
5694 set id [lindex $idlist $col]
5695 if {[lindex $previdlist $col] eq $id} continue
5696 if {$id eq {}} {
5697 set haspad 1
5698 continue
5700 set x0 [lsearch -exact $previdlist $id]
5701 if {$x0 < 0} continue
5702 set z [expr {$x0 - $col}]
5703 set isarrow 0
5704 set z0 {}
5705 if {$ym >= 0} {
5706 set xm [lsearch -exact $pprevidlist $id]
5707 if {$xm >= 0} {
5708 set z0 [expr {$xm - $x0}]
5711 if {$z0 eq {}} {
5712 # if row y0 is the first child of $id then it's not an arrow
5713 if {[lindex $children($curview,$id) 0] ne
5714 [lindex $displayorder $y0]} {
5715 set isarrow 1
5718 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5719 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5720 set isarrow 1
5722 # Looking at lines from this row to the previous row,
5723 # make them go straight up if they end in an arrow on
5724 # the previous row; otherwise make them go straight up
5725 # or at 45 degrees.
5726 if {$z < -1 || ($z < 0 && $isarrow)} {
5727 # Line currently goes left too much;
5728 # insert pads in the previous row, then optimize it
5729 set npad [expr {-1 - $z + $isarrow}]
5730 insert_pad $y0 $x0 $npad
5731 if {$y0 > 0} {
5732 optimize_rows $y0 $x0 $row
5734 set previdlist [lindex $rowidlist $y0]
5735 set x0 [lsearch -exact $previdlist $id]
5736 set z [expr {$x0 - $col}]
5737 if {$z0 ne {}} {
5738 set pprevidlist [lindex $rowidlist $ym]
5739 set xm [lsearch -exact $pprevidlist $id]
5740 set z0 [expr {$xm - $x0}]
5742 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5743 # Line currently goes right too much;
5744 # insert pads in this line
5745 set npad [expr {$z - 1 + $isarrow}]
5746 insert_pad $row $col $npad
5747 set idlist [lindex $rowidlist $row]
5748 incr col $npad
5749 set z [expr {$x0 - $col}]
5750 set haspad 1
5752 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5753 # this line links to its first child on row $row-2
5754 set id [lindex $displayorder $ym]
5755 set xc [lsearch -exact $pprevidlist $id]
5756 if {$xc >= 0} {
5757 set z0 [expr {$xc - $x0}]
5760 # avoid lines jigging left then immediately right
5761 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5762 insert_pad $y0 $x0 1
5763 incr x0
5764 optimize_rows $y0 $x0 $row
5765 set previdlist [lindex $rowidlist $y0]
5768 if {!$haspad} {
5769 # Find the first column that doesn't have a line going right
5770 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5771 set id [lindex $idlist $col]
5772 if {$id eq {}} break
5773 set x0 [lsearch -exact $previdlist $id]
5774 if {$x0 < 0} {
5775 # check if this is the link to the first child
5776 set kid [lindex $displayorder $y0]
5777 if {[lindex $children($curview,$id) 0] eq $kid} {
5778 # it is, work out offset to child
5779 set x0 [lsearch -exact $previdlist $kid]
5782 if {$x0 <= $col} break
5784 # Insert a pad at that column as long as it has a line and
5785 # isn't the last column
5786 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5787 set idlist [linsert $idlist $col {}]
5788 lset rowidlist $row $idlist
5789 changedrow $row
5795 proc xc {row col} {
5796 global canvx0 linespc
5797 return [expr {$canvx0 + $col * $linespc}]
5800 proc yc {row} {
5801 global canvy0 linespc
5802 return [expr {$canvy0 + $row * $linespc}]
5805 proc linewidth {id} {
5806 global thickerline lthickness
5808 set wid $lthickness
5809 if {[info exists thickerline] && $id eq $thickerline} {
5810 set wid [expr {2 * $lthickness}]
5812 return $wid
5815 proc rowranges {id} {
5816 global curview children uparrowlen downarrowlen
5817 global rowidlist
5819 set kids $children($curview,$id)
5820 if {$kids eq {}} {
5821 return {}
5823 set ret {}
5824 lappend kids $id
5825 foreach child $kids {
5826 if {![commitinview $child $curview]} break
5827 set row [rowofcommit $child]
5828 if {![info exists prev]} {
5829 lappend ret [expr {$row + 1}]
5830 } else {
5831 if {$row <= $prevrow} {
5832 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5834 # see if the line extends the whole way from prevrow to row
5835 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5836 [lsearch -exact [lindex $rowidlist \
5837 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5838 # it doesn't, see where it ends
5839 set r [expr {$prevrow + $downarrowlen}]
5840 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5841 while {[incr r -1] > $prevrow &&
5842 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5843 } else {
5844 while {[incr r] <= $row &&
5845 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5846 incr r -1
5848 lappend ret $r
5849 # see where it starts up again
5850 set r [expr {$row - $uparrowlen}]
5851 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5852 while {[incr r] < $row &&
5853 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5854 } else {
5855 while {[incr r -1] >= $prevrow &&
5856 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5857 incr r
5859 lappend ret $r
5862 if {$child eq $id} {
5863 lappend ret $row
5865 set prev $child
5866 set prevrow $row
5868 return $ret
5871 proc drawlineseg {id row endrow arrowlow} {
5872 global rowidlist displayorder iddrawn linesegs
5873 global canv colormap linespc curview maxlinelen parentlist
5875 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5876 set le [expr {$row + 1}]
5877 set arrowhigh 1
5878 while {1} {
5879 set c [lsearch -exact [lindex $rowidlist $le] $id]
5880 if {$c < 0} {
5881 incr le -1
5882 break
5884 lappend cols $c
5885 set x [lindex $displayorder $le]
5886 if {$x eq $id} {
5887 set arrowhigh 0
5888 break
5890 if {[info exists iddrawn($x)] || $le == $endrow} {
5891 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5892 if {$c >= 0} {
5893 lappend cols $c
5894 set arrowhigh 0
5896 break
5898 incr le
5900 if {$le <= $row} {
5901 return $row
5904 set lines {}
5905 set i 0
5906 set joinhigh 0
5907 if {[info exists linesegs($id)]} {
5908 set lines $linesegs($id)
5909 foreach li $lines {
5910 set r0 [lindex $li 0]
5911 if {$r0 > $row} {
5912 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5913 set joinhigh 1
5915 break
5917 incr i
5920 set joinlow 0
5921 if {$i > 0} {
5922 set li [lindex $lines [expr {$i-1}]]
5923 set r1 [lindex $li 1]
5924 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5925 set joinlow 1
5929 set x [lindex $cols [expr {$le - $row}]]
5930 set xp [lindex $cols [expr {$le - 1 - $row}]]
5931 set dir [expr {$xp - $x}]
5932 if {$joinhigh} {
5933 set ith [lindex $lines $i 2]
5934 set coords [$canv coords $ith]
5935 set ah [$canv itemcget $ith -arrow]
5936 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5937 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5938 if {$x2 ne {} && $x - $x2 == $dir} {
5939 set coords [lrange $coords 0 end-2]
5941 } else {
5942 set coords [list [xc $le $x] [yc $le]]
5944 if {$joinlow} {
5945 set itl [lindex $lines [expr {$i-1}] 2]
5946 set al [$canv itemcget $itl -arrow]
5947 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5948 } elseif {$arrowlow} {
5949 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5950 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5951 set arrowlow 0
5954 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5955 for {set y $le} {[incr y -1] > $row} {} {
5956 set x $xp
5957 set xp [lindex $cols [expr {$y - 1 - $row}]]
5958 set ndir [expr {$xp - $x}]
5959 if {$dir != $ndir || $xp < 0} {
5960 lappend coords [xc $y $x] [yc $y]
5962 set dir $ndir
5964 if {!$joinlow} {
5965 if {$xp < 0} {
5966 # join parent line to first child
5967 set ch [lindex $displayorder $row]
5968 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5969 if {$xc < 0} {
5970 puts "oops: drawlineseg: child $ch not on row $row"
5971 } elseif {$xc != $x} {
5972 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5973 set d [expr {int(0.5 * $linespc)}]
5974 set x1 [xc $row $x]
5975 if {$xc < $x} {
5976 set x2 [expr {$x1 - $d}]
5977 } else {
5978 set x2 [expr {$x1 + $d}]
5980 set y2 [yc $row]
5981 set y1 [expr {$y2 + $d}]
5982 lappend coords $x1 $y1 $x2 $y2
5983 } elseif {$xc < $x - 1} {
5984 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5985 } elseif {$xc > $x + 1} {
5986 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5988 set x $xc
5990 lappend coords [xc $row $x] [yc $row]
5991 } else {
5992 set xn [xc $row $xp]
5993 set yn [yc $row]
5994 lappend coords $xn $yn
5996 if {!$joinhigh} {
5997 assigncolor $id
5998 set t [$canv create line $coords -width [linewidth $id] \
5999 -fill $colormap($id) -tags lines.$id -arrow $arrow]
6000 $canv lower $t
6001 bindline $t $id
6002 set lines [linsert $lines $i [list $row $le $t]]
6003 } else {
6004 $canv coords $ith $coords
6005 if {$arrow ne $ah} {
6006 $canv itemconf $ith -arrow $arrow
6008 lset lines $i 0 $row
6010 } else {
6011 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
6012 set ndir [expr {$xo - $xp}]
6013 set clow [$canv coords $itl]
6014 if {$dir == $ndir} {
6015 set clow [lrange $clow 2 end]
6017 set coords [concat $coords $clow]
6018 if {!$joinhigh} {
6019 lset lines [expr {$i-1}] 1 $le
6020 } else {
6021 # coalesce two pieces
6022 $canv delete $ith
6023 set b [lindex $lines [expr {$i-1}] 0]
6024 set e [lindex $lines $i 1]
6025 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6027 $canv coords $itl $coords
6028 if {$arrow ne $al} {
6029 $canv itemconf $itl -arrow $arrow
6033 set linesegs($id) $lines
6034 return $le
6037 proc drawparentlinks {id row} {
6038 global rowidlist canv colormap curview parentlist
6039 global idpos linespc
6041 set rowids [lindex $rowidlist $row]
6042 set col [lsearch -exact $rowids $id]
6043 if {$col < 0} return
6044 set olds [lindex $parentlist $row]
6045 set row2 [expr {$row + 1}]
6046 set x [xc $row $col]
6047 set y [yc $row]
6048 set y2 [yc $row2]
6049 set d [expr {int(0.5 * $linespc)}]
6050 set ymid [expr {$y + $d}]
6051 set ids [lindex $rowidlist $row2]
6052 # rmx = right-most X coord used
6053 set rmx 0
6054 foreach p $olds {
6055 set i [lsearch -exact $ids $p]
6056 if {$i < 0} {
6057 puts "oops, parent $p of $id not in list"
6058 continue
6060 set x2 [xc $row2 $i]
6061 if {$x2 > $rmx} {
6062 set rmx $x2
6064 set j [lsearch -exact $rowids $p]
6065 if {$j < 0} {
6066 # drawlineseg will do this one for us
6067 continue
6069 assigncolor $p
6070 # should handle duplicated parents here...
6071 set coords [list $x $y]
6072 if {$i != $col} {
6073 # if attaching to a vertical segment, draw a smaller
6074 # slant for visual distinctness
6075 if {$i == $j} {
6076 if {$i < $col} {
6077 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6078 } else {
6079 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6081 } elseif {$i < $col && $i < $j} {
6082 # segment slants towards us already
6083 lappend coords [xc $row $j] $y
6084 } else {
6085 if {$i < $col - 1} {
6086 lappend coords [expr {$x2 + $linespc}] $y
6087 } elseif {$i > $col + 1} {
6088 lappend coords [expr {$x2 - $linespc}] $y
6090 lappend coords $x2 $y2
6092 } else {
6093 lappend coords $x2 $y2
6095 set t [$canv create line $coords -width [linewidth $p] \
6096 -fill $colormap($p) -tags lines.$p]
6097 $canv lower $t
6098 bindline $t $p
6100 if {$rmx > [lindex $idpos($id) 1]} {
6101 lset idpos($id) 1 $rmx
6102 redrawtags $id
6106 proc drawlines {id} {
6107 global canv
6109 $canv itemconf lines.$id -width [linewidth $id]
6112 proc drawcmittext {id row col} {
6113 global linespc canv canv2 canv3 fgcolor curview
6114 global cmitlisted commitinfo rowidlist parentlist
6115 global rowtextx idpos idtags idheads idotherrefs
6116 global linehtag linentag linedtag selectedline
6117 global canvxmax boldids boldnameids fgcolor markedid
6118 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6119 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6120 global circleoutlinecolor
6122 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6123 set listed $cmitlisted($curview,$id)
6124 if {$id eq $nullid} {
6125 set ofill $workingfilescirclecolor
6126 } elseif {$id eq $nullid2} {
6127 set ofill $indexcirclecolor
6128 } elseif {$id eq $mainheadid} {
6129 set ofill $mainheadcirclecolor
6130 } else {
6131 set ofill [lindex $circlecolors $listed]
6133 set x [xc $row $col]
6134 set y [yc $row]
6135 set orad [expr {$linespc / 3}]
6136 if {$listed <= 2} {
6137 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6138 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6139 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6140 } elseif {$listed == 3} {
6141 # triangle pointing left for left-side commits
6142 set t [$canv create polygon \
6143 [expr {$x - $orad}] $y \
6144 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6145 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6146 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6147 } else {
6148 # triangle pointing right for right-side commits
6149 set t [$canv create polygon \
6150 [expr {$x + $orad - 1}] $y \
6151 [expr {$x - $orad}] [expr {$y - $orad}] \
6152 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6153 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6155 set circleitem($row) $t
6156 $canv raise $t
6157 $canv bind $t <1> {selcanvline {} %x %y}
6158 set rmx [llength [lindex $rowidlist $row]]
6159 set olds [lindex $parentlist $row]
6160 if {$olds ne {}} {
6161 set nextids [lindex $rowidlist [expr {$row + 1}]]
6162 foreach p $olds {
6163 set i [lsearch -exact $nextids $p]
6164 if {$i > $rmx} {
6165 set rmx $i
6169 set xt [xc $row $rmx]
6170 set rowtextx($row) $xt
6171 set idpos($id) [list $x $xt $y]
6172 if {[info exists idtags($id)] || [info exists idheads($id)]
6173 || [info exists idotherrefs($id)]} {
6174 set xt [drawtags $id $x $xt $y]
6176 if {[lindex $commitinfo($id) 6] > 0} {
6177 set xt [drawnotesign $xt $y]
6179 set headline [lindex $commitinfo($id) 0]
6180 set name [lindex $commitinfo($id) 1]
6181 set date [lindex $commitinfo($id) 2]
6182 set date [formatdate $date]
6183 set font mainfont
6184 set nfont mainfont
6185 set isbold [ishighlighted $id]
6186 if {$isbold > 0} {
6187 lappend boldids $id
6188 set font mainfontbold
6189 if {$isbold > 1} {
6190 lappend boldnameids $id
6191 set nfont mainfontbold
6194 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6195 -text $headline -font $font -tags text]
6196 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6197 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6198 -text $name -font $nfont -tags text]
6199 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6200 -text $date -font mainfont -tags text]
6201 if {$selectedline == $row} {
6202 make_secsel $id
6204 if {[info exists markedid] && $markedid eq $id} {
6205 make_idmark $id
6207 set xr [expr {$xt + [font measure $font $headline]}]
6208 if {$xr > $canvxmax} {
6209 set canvxmax $xr
6210 setcanvscroll
6214 proc drawcmitrow {row} {
6215 global displayorder rowidlist nrows_drawn
6216 global iddrawn markingmatches
6217 global commitinfo numcommits
6218 global filehighlight fhighlights findpattern nhighlights
6219 global hlview vhighlights
6220 global highlight_related rhighlights
6222 if {$row >= $numcommits} return
6224 set id [lindex $displayorder $row]
6225 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6226 askvhighlight $row $id
6228 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6229 askfilehighlight $row $id
6231 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6232 askfindhighlight $row $id
6234 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6235 askrelhighlight $row $id
6237 if {![info exists iddrawn($id)]} {
6238 set col [lsearch -exact [lindex $rowidlist $row] $id]
6239 if {$col < 0} {
6240 puts "oops, row $row id $id not in list"
6241 return
6243 if {![info exists commitinfo($id)]} {
6244 getcommit $id
6246 assigncolor $id
6247 drawcmittext $id $row $col
6248 set iddrawn($id) 1
6249 incr nrows_drawn
6251 if {$markingmatches} {
6252 markrowmatches $row $id
6256 proc drawcommits {row {endrow {}}} {
6257 global numcommits iddrawn displayorder curview need_redisplay
6258 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6260 if {$row < 0} {
6261 set row 0
6263 if {$endrow eq {}} {
6264 set endrow $row
6266 if {$endrow >= $numcommits} {
6267 set endrow [expr {$numcommits - 1}]
6270 set rl1 [expr {$row - $downarrowlen - 3}]
6271 if {$rl1 < 0} {
6272 set rl1 0
6274 set ro1 [expr {$row - 3}]
6275 if {$ro1 < 0} {
6276 set ro1 0
6278 set r2 [expr {$endrow + $uparrowlen + 3}]
6279 if {$r2 > $numcommits} {
6280 set r2 $numcommits
6282 for {set r $rl1} {$r < $r2} {incr r} {
6283 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6284 if {$rl1 < $r} {
6285 layoutrows $rl1 $r
6287 set rl1 [expr {$r + 1}]
6290 if {$rl1 < $r} {
6291 layoutrows $rl1 $r
6293 optimize_rows $ro1 0 $r2
6294 if {$need_redisplay || $nrows_drawn > 2000} {
6295 clear_display
6298 # make the lines join to already-drawn rows either side
6299 set r [expr {$row - 1}]
6300 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6301 set r $row
6303 set er [expr {$endrow + 1}]
6304 if {$er >= $numcommits ||
6305 ![info exists iddrawn([lindex $displayorder $er])]} {
6306 set er $endrow
6308 for {} {$r <= $er} {incr r} {
6309 set id [lindex $displayorder $r]
6310 set wasdrawn [info exists iddrawn($id)]
6311 drawcmitrow $r
6312 if {$r == $er} break
6313 set nextid [lindex $displayorder [expr {$r + 1}]]
6314 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6315 drawparentlinks $id $r
6317 set rowids [lindex $rowidlist $r]
6318 foreach lid $rowids {
6319 if {$lid eq {}} continue
6320 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6321 if {$lid eq $id} {
6322 # see if this is the first child of any of its parents
6323 foreach p [lindex $parentlist $r] {
6324 if {[lsearch -exact $rowids $p] < 0} {
6325 # make this line extend up to the child
6326 set lineend($p) [drawlineseg $p $r $er 0]
6329 } else {
6330 set lineend($lid) [drawlineseg $lid $r $er 1]
6336 proc undolayout {row} {
6337 global uparrowlen mingaplen downarrowlen
6338 global rowidlist rowisopt rowfinal need_redisplay
6340 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6341 if {$r < 0} {
6342 set r 0
6344 if {[llength $rowidlist] > $r} {
6345 incr r -1
6346 set rowidlist [lrange $rowidlist 0 $r]
6347 set rowfinal [lrange $rowfinal 0 $r]
6348 set rowisopt [lrange $rowisopt 0 $r]
6349 set need_redisplay 1
6350 run drawvisible
6354 proc drawvisible {} {
6355 global canv linespc curview vrowmod selectedline targetrow targetid
6356 global need_redisplay cscroll numcommits
6358 set fs [$canv yview]
6359 set ymax [lindex [$canv cget -scrollregion] 3]
6360 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6361 set f0 [lindex $fs 0]
6362 set f1 [lindex $fs 1]
6363 set y0 [expr {int($f0 * $ymax)}]
6364 set y1 [expr {int($f1 * $ymax)}]
6366 if {[info exists targetid]} {
6367 if {[commitinview $targetid $curview]} {
6368 set r [rowofcommit $targetid]
6369 if {$r != $targetrow} {
6370 # Fix up the scrollregion and change the scrolling position
6371 # now that our target row has moved.
6372 set diff [expr {($r - $targetrow) * $linespc}]
6373 set targetrow $r
6374 setcanvscroll
6375 set ymax [lindex [$canv cget -scrollregion] 3]
6376 incr y0 $diff
6377 incr y1 $diff
6378 set f0 [expr {$y0 / $ymax}]
6379 set f1 [expr {$y1 / $ymax}]
6380 allcanvs yview moveto $f0
6381 $cscroll set $f0 $f1
6382 set need_redisplay 1
6384 } else {
6385 unset targetid
6389 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6390 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6391 if {$endrow >= $vrowmod($curview)} {
6392 update_arcrows $curview
6394 if {$selectedline ne {} &&
6395 $row <= $selectedline && $selectedline <= $endrow} {
6396 set targetrow $selectedline
6397 } elseif {[info exists targetid]} {
6398 set targetrow [expr {int(($row + $endrow) / 2)}]
6400 if {[info exists targetrow]} {
6401 if {$targetrow >= $numcommits} {
6402 set targetrow [expr {$numcommits - 1}]
6404 set targetid [commitonrow $targetrow]
6406 drawcommits $row $endrow
6409 proc clear_display {} {
6410 global iddrawn linesegs need_redisplay nrows_drawn
6411 global vhighlights fhighlights nhighlights rhighlights
6412 global linehtag linentag linedtag boldids boldnameids
6414 allcanvs delete all
6415 unset -nocomplain iddrawn
6416 unset -nocomplain linesegs
6417 unset -nocomplain linehtag
6418 unset -nocomplain linentag
6419 unset -nocomplain linedtag
6420 set boldids {}
6421 set boldnameids {}
6422 unset -nocomplain vhighlights
6423 unset -nocomplain fhighlights
6424 unset -nocomplain nhighlights
6425 unset -nocomplain rhighlights
6426 set need_redisplay 0
6427 set nrows_drawn 0
6430 proc findcrossings {id} {
6431 global rowidlist parentlist numcommits displayorder
6433 set cross {}
6434 set ccross {}
6435 foreach {s e} [rowranges $id] {
6436 if {$e >= $numcommits} {
6437 set e [expr {$numcommits - 1}]
6439 if {$e <= $s} continue
6440 for {set row $e} {[incr row -1] >= $s} {} {
6441 set x [lsearch -exact [lindex $rowidlist $row] $id]
6442 if {$x < 0} break
6443 set olds [lindex $parentlist $row]
6444 set kid [lindex $displayorder $row]
6445 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6446 if {$kidx < 0} continue
6447 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6448 foreach p $olds {
6449 set px [lsearch -exact $nextrow $p]
6450 if {$px < 0} continue
6451 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6452 if {[lsearch -exact $ccross $p] >= 0} continue
6453 if {$x == $px + ($kidx < $px? -1: 1)} {
6454 lappend ccross $p
6455 } elseif {[lsearch -exact $cross $p] < 0} {
6456 lappend cross $p
6462 return [concat $ccross {{}} $cross]
6465 proc assigncolor {id} {
6466 global colormap colors nextcolor
6467 global parents children children curview
6469 if {[info exists colormap($id)]} return
6470 set ncolors [llength $colors]
6471 if {[info exists children($curview,$id)]} {
6472 set kids $children($curview,$id)
6473 } else {
6474 set kids {}
6476 if {[llength $kids] == 1} {
6477 set child [lindex $kids 0]
6478 if {[info exists colormap($child)]
6479 && [llength $parents($curview,$child)] == 1} {
6480 set colormap($id) $colormap($child)
6481 return
6484 set badcolors {}
6485 set origbad {}
6486 foreach x [findcrossings $id] {
6487 if {$x eq {}} {
6488 # delimiter between corner crossings and other crossings
6489 if {[llength $badcolors] >= $ncolors - 1} break
6490 set origbad $badcolors
6492 if {[info exists colormap($x)]
6493 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6494 lappend badcolors $colormap($x)
6497 if {[llength $badcolors] >= $ncolors} {
6498 set badcolors $origbad
6500 set origbad $badcolors
6501 if {[llength $badcolors] < $ncolors - 1} {
6502 foreach child $kids {
6503 if {[info exists colormap($child)]
6504 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6505 lappend badcolors $colormap($child)
6507 foreach p $parents($curview,$child) {
6508 if {[info exists colormap($p)]
6509 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6510 lappend badcolors $colormap($p)
6514 if {[llength $badcolors] >= $ncolors} {
6515 set badcolors $origbad
6518 for {set i 0} {$i <= $ncolors} {incr i} {
6519 set c [lindex $colors $nextcolor]
6520 if {[incr nextcolor] >= $ncolors} {
6521 set nextcolor 0
6523 if {[lsearch -exact $badcolors $c]} break
6525 set colormap($id) $c
6528 proc bindline {t id} {
6529 global canv
6531 $canv bind $t <Enter> "lineenter %x %y $id"
6532 $canv bind $t <Motion> "linemotion %x %y $id"
6533 $canv bind $t <Leave> "lineleave $id"
6534 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6537 proc graph_pane_width {} {
6538 global use_ttk
6540 if {$use_ttk} {
6541 set g [.tf.histframe.pwclist sashpos 0]
6542 } else {
6543 set g [.tf.histframe.pwclist sash coord 0]
6545 return [lindex $g 0]
6548 proc totalwidth {l font extra} {
6549 set tot 0
6550 foreach str $l {
6551 set tot [expr {$tot + [font measure $font $str] + $extra}]
6553 return $tot
6556 proc drawtags {id x xt y1} {
6557 global idtags idheads idotherrefs mainhead
6558 global linespc lthickness
6559 global canv rowtextx curview fgcolor bgcolor ctxbut
6560 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6561 global tagbgcolor tagfgcolor tagoutlinecolor
6562 global reflinecolor
6564 set marks {}
6565 set ntags 0
6566 set nheads 0
6567 set singletag 0
6568 set maxtags 3
6569 set maxtagpct 25
6570 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6571 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6572 set extra [expr {$delta + $lthickness + $linespc}]
6574 if {[info exists idtags($id)]} {
6575 set marks $idtags($id)
6576 set ntags [llength $marks]
6577 if {$ntags > $maxtags ||
6578 [totalwidth $marks mainfont $extra] > $maxwidth} {
6579 # show just a single "n tags..." tag
6580 set singletag 1
6581 if {$ntags == 1} {
6582 set marks [list "tag..."]
6583 } else {
6584 set marks [list [format "%d tags..." $ntags]]
6586 set ntags 1
6589 if {[info exists idheads($id)]} {
6590 set marks [concat $marks $idheads($id)]
6591 set nheads [llength $idheads($id)]
6593 if {[info exists idotherrefs($id)]} {
6594 set marks [concat $marks $idotherrefs($id)]
6596 if {$marks eq {}} {
6597 return $xt
6600 set yt [expr {$y1 - 0.5 * $linespc}]
6601 set yb [expr {$yt + $linespc - 1}]
6602 set xvals {}
6603 set wvals {}
6604 set i -1
6605 foreach tag $marks {
6606 incr i
6607 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6608 set wid [font measure mainfontbold $tag]
6609 } else {
6610 set wid [font measure mainfont $tag]
6612 lappend xvals $xt
6613 lappend wvals $wid
6614 set xt [expr {$xt + $wid + $extra}]
6616 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6617 -width $lthickness -fill $reflinecolor -tags tag.$id]
6618 $canv lower $t
6619 foreach tag $marks x $xvals wid $wvals {
6620 set tag_quoted [string map {% %%} $tag]
6621 set xl [expr {$x + $delta}]
6622 set xr [expr {$x + $delta + $wid + $lthickness}]
6623 set font mainfont
6624 if {[incr ntags -1] >= 0} {
6625 # draw a tag
6626 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6627 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6628 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6629 -tags tag.$id]
6630 if {$singletag} {
6631 set tagclick [list showtags $id 1]
6632 } else {
6633 set tagclick [list showtag $tag_quoted 1]
6635 $canv bind $t <1> $tagclick
6636 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6637 } else {
6638 # draw a head or other ref
6639 if {[incr nheads -1] >= 0} {
6640 set col $headbgcolor
6641 if {$tag eq $mainhead} {
6642 set font mainfontbold
6644 } else {
6645 set col "#ddddff"
6647 set xl [expr {$xl - $delta/2}]
6648 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6649 -width 1 -outline black -fill $col -tags tag.$id
6650 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6651 set rwid [font measure mainfont $remoteprefix]
6652 set xi [expr {$x + 1}]
6653 set yti [expr {$yt + 1}]
6654 set xri [expr {$x + $rwid}]
6655 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6656 -width 0 -fill $remotebgcolor -tags tag.$id
6659 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6660 -font $font -tags [list tag.$id text]]
6661 if {$ntags >= 0} {
6662 $canv bind $t <1> $tagclick
6663 } elseif {$nheads >= 0} {
6664 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6667 return $xt
6670 proc drawnotesign {xt y} {
6671 global linespc canv fgcolor
6673 set orad [expr {$linespc / 3}]
6674 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6675 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6676 -fill yellow -outline $fgcolor -width 1 -tags circle]
6677 set xt [expr {$xt + $orad * 3}]
6678 return $xt
6681 proc xcoord {i level ln} {
6682 global canvx0 xspc1 xspc2
6684 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6685 if {$i > 0 && $i == $level} {
6686 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6687 } elseif {$i > $level} {
6688 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6690 return $x
6693 proc show_status {msg} {
6694 global canv fgcolor
6696 clear_display
6697 set_window_title
6698 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6699 -tags text -fill $fgcolor
6702 # Don't change the text pane cursor if it is currently the hand cursor,
6703 # showing that we are over a sha1 ID link.
6704 proc settextcursor {c} {
6705 global ctext curtextcursor
6707 if {[$ctext cget -cursor] == $curtextcursor} {
6708 $ctext config -cursor $c
6710 set curtextcursor $c
6713 proc nowbusy {what {name {}}} {
6714 global isbusy busyname statusw
6716 if {[array names isbusy] eq {}} {
6717 . config -cursor watch
6718 settextcursor watch
6720 set isbusy($what) 1
6721 set busyname($what) $name
6722 if {$name ne {}} {
6723 $statusw conf -text $name
6727 proc notbusy {what} {
6728 global isbusy maincursor textcursor busyname statusw
6730 catch {
6731 unset isbusy($what)
6732 if {$busyname($what) ne {} &&
6733 [$statusw cget -text] eq $busyname($what)} {
6734 $statusw conf -text {}
6737 if {[array names isbusy] eq {}} {
6738 . config -cursor $maincursor
6739 settextcursor $textcursor
6743 proc findmatches {f} {
6744 global findtype findstring
6745 if {$findtype == [mc "Regexp"]} {
6746 set matches [regexp -indices -all -inline $findstring $f]
6747 } else {
6748 set fs $findstring
6749 if {$findtype == [mc "IgnCase"]} {
6750 set f [string tolower $f]
6751 set fs [string tolower $fs]
6753 set matches {}
6754 set i 0
6755 set l [string length $fs]
6756 while {[set j [string first $fs $f $i]] >= 0} {
6757 lappend matches [list $j [expr {$j+$l-1}]]
6758 set i [expr {$j + $l}]
6761 return $matches
6764 proc dofind {{dirn 1} {wrap 1}} {
6765 global findstring findstartline findcurline selectedline numcommits
6766 global gdttype filehighlight fh_serial find_dirn findallowwrap
6768 if {[info exists find_dirn]} {
6769 if {$find_dirn == $dirn} return
6770 stopfinding
6772 focus .
6773 if {$findstring eq {} || $numcommits == 0} return
6774 if {$selectedline eq {}} {
6775 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6776 } else {
6777 set findstartline $selectedline
6779 set findcurline $findstartline
6780 nowbusy finding [mc "Searching"]
6781 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6782 after cancel do_file_hl $fh_serial
6783 do_file_hl $fh_serial
6785 set find_dirn $dirn
6786 set findallowwrap $wrap
6787 run findmore
6790 proc stopfinding {} {
6791 global find_dirn findcurline fprogcoord
6793 if {[info exists find_dirn]} {
6794 unset find_dirn
6795 unset findcurline
6796 notbusy finding
6797 set fprogcoord 0
6798 adjustprogress
6800 stopblaming
6803 proc findmore {} {
6804 global commitdata commitinfo numcommits findpattern findloc
6805 global findstartline findcurline findallowwrap
6806 global find_dirn gdttype fhighlights fprogcoord
6807 global curview varcorder vrownum varccommits vrowmod
6809 if {![info exists find_dirn]} {
6810 return 0
6812 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6813 set l $findcurline
6814 set moretodo 0
6815 if {$find_dirn > 0} {
6816 incr l
6817 if {$l >= $numcommits} {
6818 set l 0
6820 if {$l <= $findstartline} {
6821 set lim [expr {$findstartline + 1}]
6822 } else {
6823 set lim $numcommits
6824 set moretodo $findallowwrap
6826 } else {
6827 if {$l == 0} {
6828 set l $numcommits
6830 incr l -1
6831 if {$l >= $findstartline} {
6832 set lim [expr {$findstartline - 1}]
6833 } else {
6834 set lim -1
6835 set moretodo $findallowwrap
6838 set n [expr {($lim - $l) * $find_dirn}]
6839 if {$n > 500} {
6840 set n 500
6841 set moretodo 1
6843 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6844 update_arcrows $curview
6846 set found 0
6847 set domore 1
6848 set ai [bsearch $vrownum($curview) $l]
6849 set a [lindex $varcorder($curview) $ai]
6850 set arow [lindex $vrownum($curview) $ai]
6851 set ids [lindex $varccommits($curview,$a)]
6852 set arowend [expr {$arow + [llength $ids]}]
6853 if {$gdttype eq [mc "containing:"]} {
6854 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6855 if {$l < $arow || $l >= $arowend} {
6856 incr ai $find_dirn
6857 set a [lindex $varcorder($curview) $ai]
6858 set arow [lindex $vrownum($curview) $ai]
6859 set ids [lindex $varccommits($curview,$a)]
6860 set arowend [expr {$arow + [llength $ids]}]
6862 set id [lindex $ids [expr {$l - $arow}]]
6863 # shouldn't happen unless git log doesn't give all the commits...
6864 if {![info exists commitdata($id)] ||
6865 ![doesmatch $commitdata($id)]} {
6866 continue
6868 if {![info exists commitinfo($id)]} {
6869 getcommit $id
6871 set info $commitinfo($id)
6872 foreach f $info ty $fldtypes {
6873 if {$ty eq ""} continue
6874 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6875 [doesmatch $f]} {
6876 set found 1
6877 break
6880 if {$found} break
6882 } else {
6883 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6884 if {$l < $arow || $l >= $arowend} {
6885 incr ai $find_dirn
6886 set a [lindex $varcorder($curview) $ai]
6887 set arow [lindex $vrownum($curview) $ai]
6888 set ids [lindex $varccommits($curview,$a)]
6889 set arowend [expr {$arow + [llength $ids]}]
6891 set id [lindex $ids [expr {$l - $arow}]]
6892 if {![info exists fhighlights($id)]} {
6893 # this sets fhighlights($id) to -1
6894 askfilehighlight $l $id
6896 if {$fhighlights($id) > 0} {
6897 set found $domore
6898 break
6900 if {$fhighlights($id) < 0} {
6901 if {$domore} {
6902 set domore 0
6903 set findcurline [expr {$l - $find_dirn}]
6908 if {$found || ($domore && !$moretodo)} {
6909 unset findcurline
6910 unset find_dirn
6911 notbusy finding
6912 set fprogcoord 0
6913 adjustprogress
6914 if {$found} {
6915 findselectline $l
6916 } else {
6917 bell
6919 return 0
6921 if {!$domore} {
6922 flushhighlights
6923 } else {
6924 set findcurline [expr {$l - $find_dirn}]
6926 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6927 if {$n < 0} {
6928 incr n $numcommits
6930 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6931 adjustprogress
6932 return $domore
6935 proc findselectline {l} {
6936 global findloc commentend ctext findcurline markingmatches gdttype
6938 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6939 set findcurline $l
6940 selectline $l 1
6941 if {$markingmatches &&
6942 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6943 # highlight the matches in the comments
6944 set f [$ctext get 1.0 $commentend]
6945 set matches [findmatches $f]
6946 foreach match $matches {
6947 set start [lindex $match 0]
6948 set end [expr {[lindex $match 1] + 1}]
6949 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6952 drawvisible
6955 # mark the bits of a headline or author that match a find string
6956 proc markmatches {canv l str tag matches font row} {
6957 global selectedline
6959 set bbox [$canv bbox $tag]
6960 set x0 [lindex $bbox 0]
6961 set y0 [lindex $bbox 1]
6962 set y1 [lindex $bbox 3]
6963 foreach match $matches {
6964 set start [lindex $match 0]
6965 set end [lindex $match 1]
6966 if {$start > $end} continue
6967 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6968 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6969 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6970 [expr {$x0+$xlen+2}] $y1 \
6971 -outline {} -tags [list match$l matches] -fill yellow]
6972 $canv lower $t
6973 if {$row == $selectedline} {
6974 $canv raise $t secsel
6979 proc unmarkmatches {} {
6980 global markingmatches
6982 allcanvs delete matches
6983 set markingmatches 0
6984 stopfinding
6987 proc selcanvline {w x y} {
6988 global canv canvy0 ctext linespc
6989 global rowtextx
6990 set ymax [lindex [$canv cget -scrollregion] 3]
6991 if {$ymax == {}} return
6992 set yfrac [lindex [$canv yview] 0]
6993 set y [expr {$y + $yfrac * $ymax}]
6994 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6995 if {$l < 0} {
6996 set l 0
6998 if {$w eq $canv} {
6999 set xmax [lindex [$canv cget -scrollregion] 2]
7000 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
7001 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
7003 unmarkmatches
7004 selectline $l 1
7007 proc commit_descriptor {p} {
7008 global commitinfo
7009 if {![info exists commitinfo($p)]} {
7010 getcommit $p
7012 set l "..."
7013 if {[llength $commitinfo($p)] > 1} {
7014 set l [lindex $commitinfo($p) 0]
7016 return "$p ($l)\n"
7019 # append some text to the ctext widget, and make any SHA1 ID
7020 # that we know about be a clickable link.
7021 # Also look for URLs of the form "http[s]://..." and make them web links.
7022 proc appendwithlinks {text tags} {
7023 global ctext linknum curview
7025 set start [$ctext index "end - 1c"]
7026 $ctext insert end $text $tags
7027 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
7028 foreach l $links {
7029 set s [lindex $l 0]
7030 set e [lindex $l 1]
7031 set linkid [string range $text $s $e]
7032 incr e
7033 $ctext tag delete link$linknum
7034 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7035 setlink $linkid link$linknum
7036 incr linknum
7038 set wlinks [regexp -indices -all -inline -line \
7039 {https?://[^[:space:]]+} $text]
7040 foreach l $wlinks {
7041 set s2 [lindex $l 0]
7042 set e2 [lindex $l 1]
7043 set url [string range $text $s2 $e2]
7044 incr e2
7045 $ctext tag delete link$linknum
7046 $ctext tag add link$linknum "$start + $s2 c" "$start + $e2 c"
7047 setwlink $url link$linknum
7048 incr linknum
7052 proc setlink {id lk} {
7053 global curview ctext pendinglinks
7054 global linkfgcolor
7056 if {[string range $id 0 1] eq "-g"} {
7057 set id [string range $id 2 end]
7060 set known 0
7061 if {[string length $id] < 40} {
7062 set matches [longid $id]
7063 if {[llength $matches] > 0} {
7064 if {[llength $matches] > 1} return
7065 set known 1
7066 set id [lindex $matches 0]
7068 } else {
7069 set known [commitinview $id $curview]
7071 if {$known} {
7072 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7073 $ctext tag bind $lk <1> [list selbyid $id]
7074 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7075 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7076 } else {
7077 lappend pendinglinks($id) $lk
7078 interestedin $id {makelink %P}
7082 proc setwlink {url lk} {
7083 global ctext
7084 global linkfgcolor
7085 global web_browser
7087 if {$web_browser eq {}} return
7088 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7089 $ctext tag bind $lk <1> [list browseweb $url]
7090 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7091 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7094 proc appendshortlink {id {pre {}} {post {}}} {
7095 global ctext linknum
7097 $ctext insert end $pre
7098 $ctext tag delete link$linknum
7099 $ctext insert end [string range $id 0 7] link$linknum
7100 $ctext insert end $post
7101 setlink $id link$linknum
7102 incr linknum
7105 proc makelink {id} {
7106 global pendinglinks
7108 if {![info exists pendinglinks($id)]} return
7109 foreach lk $pendinglinks($id) {
7110 setlink $id $lk
7112 unset pendinglinks($id)
7115 proc linkcursor {w inc} {
7116 global linkentercount curtextcursor
7118 if {[incr linkentercount $inc] > 0} {
7119 $w configure -cursor hand2
7120 } else {
7121 $w configure -cursor $curtextcursor
7122 if {$linkentercount < 0} {
7123 set linkentercount 0
7128 proc browseweb {url} {
7129 global web_browser
7131 if {$web_browser eq {}} return
7132 # Use eval here in case $web_browser is a command plus some arguments
7133 if {[catch {eval exec $web_browser [list $url] &} err]} {
7134 error_popup "[mc "Error starting web browser:"] $err"
7138 proc viewnextline {dir} {
7139 global canv linespc
7141 $canv delete hover
7142 set ymax [lindex [$canv cget -scrollregion] 3]
7143 set wnow [$canv yview]
7144 set wtop [expr {[lindex $wnow 0] * $ymax}]
7145 set newtop [expr {$wtop + $dir * $linespc}]
7146 if {$newtop < 0} {
7147 set newtop 0
7148 } elseif {$newtop > $ymax} {
7149 set newtop $ymax
7151 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7154 # add a list of tag or branch names at position pos
7155 # returns the number of names inserted
7156 proc appendrefs {pos ids var} {
7157 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7159 if {[catch {$ctext index $pos}]} {
7160 return 0
7162 $ctext conf -state normal
7163 $ctext delete $pos "$pos lineend"
7164 set tags {}
7165 foreach id $ids {
7166 foreach tag [set $var\($id\)] {
7167 lappend tags [list $tag $id]
7171 set sep {}
7172 set tags [lsort -index 0 -decreasing $tags]
7173 set nutags 0
7175 if {[llength $tags] > $maxrefs} {
7176 # If we are displaying heads, and there are too many,
7177 # see if there are some important heads to display.
7178 # Currently that are the current head and heads listed in $visiblerefs option
7179 set itags {}
7180 if {$var eq "idheads"} {
7181 set utags {}
7182 foreach ti $tags {
7183 set hname [lindex $ti 0]
7184 set id [lindex $ti 1]
7185 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7186 [llength $itags] < $maxrefs} {
7187 lappend itags $ti
7188 } else {
7189 lappend utags $ti
7192 set tags $utags
7194 if {$itags ne {}} {
7195 set str [mc "and many more"]
7196 set sep " "
7197 } else {
7198 set str [mc "many"]
7200 $ctext insert $pos "$str ([llength $tags])"
7201 set nutags [llength $tags]
7202 set tags $itags
7205 foreach ti $tags {
7206 set id [lindex $ti 1]
7207 set lk link$linknum
7208 incr linknum
7209 $ctext tag delete $lk
7210 $ctext insert $pos $sep
7211 $ctext insert $pos [lindex $ti 0] $lk
7212 setlink $id $lk
7213 set sep ", "
7215 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7216 $ctext conf -state disabled
7217 return [expr {[llength $tags] + $nutags}]
7220 # called when we have finished computing the nearby tags
7221 proc dispneartags {delay} {
7222 global selectedline currentid showneartags tagphase
7224 if {$selectedline eq {} || !$showneartags} return
7225 after cancel dispnexttag
7226 if {$delay} {
7227 after 200 dispnexttag
7228 set tagphase -1
7229 } else {
7230 after idle dispnexttag
7231 set tagphase 0
7235 proc dispnexttag {} {
7236 global selectedline currentid showneartags tagphase ctext
7238 if {$selectedline eq {} || !$showneartags} return
7239 switch -- $tagphase {
7241 set dtags [desctags $currentid]
7242 if {$dtags ne {}} {
7243 appendrefs precedes $dtags idtags
7247 set atags [anctags $currentid]
7248 if {$atags ne {}} {
7249 appendrefs follows $atags idtags
7253 set dheads [descheads $currentid]
7254 if {$dheads ne {}} {
7255 if {[appendrefs branch $dheads idheads] > 1
7256 && [$ctext get "branch -3c"] eq "h"} {
7257 # turn "Branch" into "Branches"
7258 $ctext conf -state normal
7259 $ctext insert "branch -2c" "es"
7260 $ctext conf -state disabled
7265 if {[incr tagphase] <= 2} {
7266 after idle dispnexttag
7270 proc make_secsel {id} {
7271 global linehtag linentag linedtag canv canv2 canv3
7273 if {![info exists linehtag($id)]} return
7274 $canv delete secsel
7275 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7276 -tags secsel -fill [$canv cget -selectbackground]]
7277 $canv lower $t
7278 $canv2 delete secsel
7279 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7280 -tags secsel -fill [$canv2 cget -selectbackground]]
7281 $canv2 lower $t
7282 $canv3 delete secsel
7283 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7284 -tags secsel -fill [$canv3 cget -selectbackground]]
7285 $canv3 lower $t
7288 proc make_idmark {id} {
7289 global linehtag canv fgcolor
7291 if {![info exists linehtag($id)]} return
7292 $canv delete markid
7293 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7294 -tags markid -outline $fgcolor]
7295 $canv raise $t
7298 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7299 global canv ctext commitinfo selectedline
7300 global canvy0 linespc parents children curview
7301 global currentid sha1entry
7302 global commentend idtags linknum
7303 global mergemax numcommits pending_select
7304 global cmitmode showneartags allcommits
7305 global targetrow targetid lastscrollrows
7306 global autoselect autosellen jump_to_here
7307 global vinlinediff
7309 unset -nocomplain pending_select
7310 $canv delete hover
7311 normalline
7312 unsel_reflist
7313 stopfinding
7314 if {$l < 0 || $l >= $numcommits} return
7315 set id [commitonrow $l]
7316 set targetid $id
7317 set targetrow $l
7318 set selectedline $l
7319 set currentid $id
7320 if {$lastscrollrows < $numcommits} {
7321 setcanvscroll
7324 if {$cmitmode ne "patch" && $switch_to_patch} {
7325 set cmitmode "patch"
7328 set y [expr {$canvy0 + $l * $linespc}]
7329 set ymax [lindex [$canv cget -scrollregion] 3]
7330 set ytop [expr {$y - $linespc - 1}]
7331 set ybot [expr {$y + $linespc + 1}]
7332 set wnow [$canv yview]
7333 set wtop [expr {[lindex $wnow 0] * $ymax}]
7334 set wbot [expr {[lindex $wnow 1] * $ymax}]
7335 set wh [expr {$wbot - $wtop}]
7336 set newtop $wtop
7337 if {$ytop < $wtop} {
7338 if {$ybot < $wtop} {
7339 set newtop [expr {$y - $wh / 2.0}]
7340 } else {
7341 set newtop $ytop
7342 if {$newtop > $wtop - $linespc} {
7343 set newtop [expr {$wtop - $linespc}]
7346 } elseif {$ybot > $wbot} {
7347 if {$ytop > $wbot} {
7348 set newtop [expr {$y - $wh / 2.0}]
7349 } else {
7350 set newtop [expr {$ybot - $wh}]
7351 if {$newtop < $wtop + $linespc} {
7352 set newtop [expr {$wtop + $linespc}]
7356 if {$newtop != $wtop} {
7357 if {$newtop < 0} {
7358 set newtop 0
7360 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7361 drawvisible
7364 make_secsel $id
7366 if {$isnew} {
7367 addtohistory [list selbyid $id 0] savecmitpos
7370 $sha1entry delete 0 end
7371 $sha1entry insert 0 $id
7372 if {$autoselect} {
7373 $sha1entry selection range 0 $autosellen
7375 rhighlight_sel $id
7377 $ctext conf -state normal
7378 clear_ctext
7379 set linknum 0
7380 if {![info exists commitinfo($id)]} {
7381 getcommit $id
7383 set info $commitinfo($id)
7384 set date [formatdate [lindex $info 2]]
7385 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7386 set date [formatdate [lindex $info 4]]
7387 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7388 if {[info exists idtags($id)]} {
7389 $ctext insert end [mc "Tags:"]
7390 foreach tag $idtags($id) {
7391 $ctext insert end " $tag"
7393 $ctext insert end "\n"
7396 set headers {}
7397 set olds $parents($curview,$id)
7398 if {[llength $olds] > 1} {
7399 set np 0
7400 foreach p $olds {
7401 if {$np >= $mergemax} {
7402 set tag mmax
7403 } else {
7404 set tag m$np
7406 $ctext insert end "[mc "Parent"]: " $tag
7407 appendwithlinks [commit_descriptor $p] {}
7408 incr np
7410 } else {
7411 foreach p $olds {
7412 append headers "[mc "Parent"]: [commit_descriptor $p]"
7416 foreach c $children($curview,$id) {
7417 append headers "[mc "Child"]: [commit_descriptor $c]"
7420 # make anything that looks like a SHA1 ID be a clickable link
7421 appendwithlinks $headers {}
7422 if {$showneartags} {
7423 if {![info exists allcommits]} {
7424 getallcommits
7426 $ctext insert end "[mc "Branch"]: "
7427 $ctext mark set branch "end -1c"
7428 $ctext mark gravity branch left
7429 $ctext insert end "\n[mc "Follows"]: "
7430 $ctext mark set follows "end -1c"
7431 $ctext mark gravity follows left
7432 $ctext insert end "\n[mc "Precedes"]: "
7433 $ctext mark set precedes "end -1c"
7434 $ctext mark gravity precedes left
7435 $ctext insert end "\n"
7436 dispneartags 1
7438 $ctext insert end "\n"
7439 set comment [lindex $info 5]
7440 if {[string first "\r" $comment] >= 0} {
7441 set comment [string map {"\r" "\n "} $comment]
7443 appendwithlinks $comment {comment}
7445 $ctext tag remove found 1.0 end
7446 $ctext conf -state disabled
7447 set commentend [$ctext index "end - 1c"]
7449 set jump_to_here $desired_loc
7450 init_flist [mc "Comments"]
7451 if {$cmitmode eq "tree"} {
7452 gettree $id
7453 } elseif {$vinlinediff($curview) == 1} {
7454 showinlinediff $id
7455 } elseif {[llength $olds] <= 1} {
7456 startdiff $id
7457 } else {
7458 mergediff $id
7462 proc selfirstline {} {
7463 unmarkmatches
7464 selectline 0 1
7467 proc sellastline {} {
7468 global numcommits
7469 unmarkmatches
7470 set l [expr {$numcommits - 1}]
7471 selectline $l 1
7474 proc selnextline {dir} {
7475 global selectedline
7476 focus .
7477 if {$selectedline eq {}} return
7478 set l [expr {$selectedline + $dir}]
7479 unmarkmatches
7480 selectline $l 1
7483 proc selnextpage {dir} {
7484 global canv linespc selectedline numcommits
7486 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7487 if {$lpp < 1} {
7488 set lpp 1
7490 allcanvs yview scroll [expr {$dir * $lpp}] units
7491 drawvisible
7492 if {$selectedline eq {}} return
7493 set l [expr {$selectedline + $dir * $lpp}]
7494 if {$l < 0} {
7495 set l 0
7496 } elseif {$l >= $numcommits} {
7497 set l [expr $numcommits - 1]
7499 unmarkmatches
7500 selectline $l 1
7503 proc unselectline {} {
7504 global selectedline currentid
7506 set selectedline {}
7507 unset -nocomplain currentid
7508 allcanvs delete secsel
7509 rhighlight_none
7512 proc reselectline {} {
7513 global selectedline
7515 if {$selectedline ne {}} {
7516 selectline $selectedline 0
7520 proc addtohistory {cmd {saveproc {}}} {
7521 global history historyindex curview
7523 unset_posvars
7524 save_position
7525 set elt [list $curview $cmd $saveproc {}]
7526 if {$historyindex > 0
7527 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7528 return
7531 if {$historyindex < [llength $history]} {
7532 set history [lreplace $history $historyindex end $elt]
7533 } else {
7534 lappend history $elt
7536 incr historyindex
7537 if {$historyindex > 1} {
7538 .tf.bar.leftbut conf -state normal
7539 } else {
7540 .tf.bar.leftbut conf -state disabled
7542 .tf.bar.rightbut conf -state disabled
7545 # save the scrolling position of the diff display pane
7546 proc save_position {} {
7547 global historyindex history
7549 if {$historyindex < 1} return
7550 set hi [expr {$historyindex - 1}]
7551 set fn [lindex $history $hi 2]
7552 if {$fn ne {}} {
7553 lset history $hi 3 [eval $fn]
7557 proc unset_posvars {} {
7558 global last_posvars
7560 if {[info exists last_posvars]} {
7561 foreach {var val} $last_posvars {
7562 global $var
7563 unset -nocomplain $var
7565 unset last_posvars
7569 proc godo {elt} {
7570 global curview last_posvars
7572 set view [lindex $elt 0]
7573 set cmd [lindex $elt 1]
7574 set pv [lindex $elt 3]
7575 if {$curview != $view} {
7576 showview $view
7578 unset_posvars
7579 foreach {var val} $pv {
7580 global $var
7581 set $var $val
7583 set last_posvars $pv
7584 eval $cmd
7587 proc goback {} {
7588 global history historyindex
7589 focus .
7591 if {$historyindex > 1} {
7592 save_position
7593 incr historyindex -1
7594 godo [lindex $history [expr {$historyindex - 1}]]
7595 .tf.bar.rightbut conf -state normal
7597 if {$historyindex <= 1} {
7598 .tf.bar.leftbut conf -state disabled
7602 proc goforw {} {
7603 global history historyindex
7604 focus .
7606 if {$historyindex < [llength $history]} {
7607 save_position
7608 set cmd [lindex $history $historyindex]
7609 incr historyindex
7610 godo $cmd
7611 .tf.bar.leftbut conf -state normal
7613 if {$historyindex >= [llength $history]} {
7614 .tf.bar.rightbut conf -state disabled
7618 proc go_to_parent {i} {
7619 global parents curview targetid
7620 set ps $parents($curview,$targetid)
7621 if {[llength $ps] >= $i} {
7622 selbyid [lindex $ps [expr $i - 1]]
7626 proc gettree {id} {
7627 global treefilelist treeidlist diffids diffmergeid treepending
7628 global nullid nullid2
7630 set diffids $id
7631 unset -nocomplain diffmergeid
7632 if {![info exists treefilelist($id)]} {
7633 if {![info exists treepending]} {
7634 if {$id eq $nullid} {
7635 set cmd [list | git ls-files]
7636 } elseif {$id eq $nullid2} {
7637 set cmd [list | git ls-files --stage -t]
7638 } else {
7639 set cmd [list | git ls-tree -r $id]
7641 if {[catch {set gtf [open $cmd r]}]} {
7642 return
7644 set treepending $id
7645 set treefilelist($id) {}
7646 set treeidlist($id) {}
7647 fconfigure $gtf -blocking 0 -encoding binary
7648 filerun $gtf [list gettreeline $gtf $id]
7650 } else {
7651 setfilelist $id
7655 proc gettreeline {gtf id} {
7656 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7658 set nl 0
7659 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7660 if {$diffids eq $nullid} {
7661 set fname $line
7662 } else {
7663 set i [string first "\t" $line]
7664 if {$i < 0} continue
7665 set fname [string range $line [expr {$i+1}] end]
7666 set line [string range $line 0 [expr {$i-1}]]
7667 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7668 set sha1 [lindex $line 2]
7669 lappend treeidlist($id) $sha1
7671 if {[string index $fname 0] eq "\""} {
7672 set fname [lindex $fname 0]
7674 set fname [encoding convertfrom $fname]
7675 lappend treefilelist($id) $fname
7677 if {![eof $gtf]} {
7678 return [expr {$nl >= 1000? 2: 1}]
7680 close $gtf
7681 unset treepending
7682 if {$cmitmode ne "tree"} {
7683 if {![info exists diffmergeid]} {
7684 gettreediffs $diffids
7686 } elseif {$id ne $diffids} {
7687 gettree $diffids
7688 } else {
7689 setfilelist $id
7691 return 0
7694 proc showfile {f} {
7695 global treefilelist treeidlist diffids nullid nullid2
7696 global ctext_file_names ctext_file_lines
7697 global ctext commentend
7699 set i [lsearch -exact $treefilelist($diffids) $f]
7700 if {$i < 0} {
7701 puts "oops, $f not in list for id $diffids"
7702 return
7704 if {$diffids eq $nullid} {
7705 if {[catch {set bf [open $f r]} err]} {
7706 puts "oops, can't read $f: $err"
7707 return
7709 } else {
7710 set blob [lindex $treeidlist($diffids) $i]
7711 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7712 puts "oops, error reading blob $blob: $err"
7713 return
7716 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7717 filerun $bf [list getblobline $bf $diffids]
7718 $ctext config -state normal
7719 clear_ctext $commentend
7720 lappend ctext_file_names $f
7721 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7722 $ctext insert end "\n"
7723 $ctext insert end "$f\n" filesep
7724 $ctext config -state disabled
7725 $ctext yview $commentend
7726 settabs 0
7729 proc getblobline {bf id} {
7730 global diffids cmitmode ctext
7732 if {$id ne $diffids || $cmitmode ne "tree"} {
7733 catch {close $bf}
7734 return 0
7736 $ctext config -state normal
7737 set nl 0
7738 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7739 $ctext insert end "$line\n"
7741 if {[eof $bf]} {
7742 global jump_to_here ctext_file_names commentend
7744 # delete last newline
7745 $ctext delete "end - 2c" "end - 1c"
7746 close $bf
7747 if {$jump_to_here ne {} &&
7748 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7749 set lnum [expr {[lindex $jump_to_here 1] +
7750 [lindex [split $commentend .] 0]}]
7751 mark_ctext_line $lnum
7753 $ctext config -state disabled
7754 return 0
7756 $ctext config -state disabled
7757 return [expr {$nl >= 1000? 2: 1}]
7760 proc mark_ctext_line {lnum} {
7761 global ctext markbgcolor
7763 $ctext tag delete omark
7764 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7765 $ctext tag conf omark -background $markbgcolor
7766 $ctext see $lnum.0
7769 proc mergediff {id} {
7770 global diffmergeid
7771 global diffids treediffs
7772 global parents curview
7774 set diffmergeid $id
7775 set diffids $id
7776 set treediffs($id) {}
7777 set np [llength $parents($curview,$id)]
7778 settabs $np
7779 getblobdiffs $id
7782 proc startdiff {ids} {
7783 global treediffs diffids treepending diffmergeid nullid nullid2
7785 settabs 1
7786 set diffids $ids
7787 unset -nocomplain diffmergeid
7788 if {![info exists treediffs($ids)] ||
7789 [lsearch -exact $ids $nullid] >= 0 ||
7790 [lsearch -exact $ids $nullid2] >= 0} {
7791 if {![info exists treepending]} {
7792 gettreediffs $ids
7794 } else {
7795 addtocflist $ids
7799 proc showinlinediff {ids} {
7800 global commitinfo commitdata ctext
7801 global treediffs
7803 set info $commitinfo($ids)
7804 set diff [lindex $info 7]
7805 set difflines [split $diff "\n"]
7807 initblobdiffvars
7808 set treediff {}
7810 set inhdr 0
7811 foreach line $difflines {
7812 if {![string compare -length 5 "diff " $line]} {
7813 set inhdr 1
7814 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7815 # offset also accounts for the b/ prefix
7816 lappend treediff [string range $line 6 end]
7817 set inhdr 0
7821 set treediffs($ids) $treediff
7822 add_flist $treediff
7824 $ctext conf -state normal
7825 foreach line $difflines {
7826 parseblobdiffline $ids $line
7828 maybe_scroll_ctext 1
7829 $ctext conf -state disabled
7832 # If the filename (name) is under any of the passed filter paths
7833 # then return true to include the file in the listing.
7834 proc path_filter {filter name} {
7835 set worktree [gitworktree]
7836 foreach p $filter {
7837 set fq_p [file normalize $p]
7838 set fq_n [file normalize [file join $worktree $name]]
7839 if {[string match [file normalize $fq_p]* $fq_n]} {
7840 return 1
7843 return 0
7846 proc addtocflist {ids} {
7847 global treediffs
7849 add_flist $treediffs($ids)
7850 getblobdiffs $ids
7853 proc diffcmd {ids flags} {
7854 global log_showroot nullid nullid2 git_version
7856 set i [lsearch -exact $ids $nullid]
7857 set j [lsearch -exact $ids $nullid2]
7858 if {$i >= 0} {
7859 if {[llength $ids] > 1 && $j < 0} {
7860 # comparing working directory with some specific revision
7861 set cmd [concat | git diff-index $flags]
7862 if {$i == 0} {
7863 lappend cmd -R [lindex $ids 1]
7864 } else {
7865 lappend cmd [lindex $ids 0]
7867 } else {
7868 # comparing working directory with index
7869 set cmd [concat | git diff-files $flags]
7870 if {$j == 1} {
7871 lappend cmd -R
7874 } elseif {$j >= 0} {
7875 if {[package vcompare $git_version "1.7.2"] >= 0} {
7876 set flags "$flags --ignore-submodules=dirty"
7878 set cmd [concat | git diff-index --cached $flags]
7879 if {[llength $ids] > 1} {
7880 # comparing index with specific revision
7881 if {$j == 0} {
7882 lappend cmd -R [lindex $ids 1]
7883 } else {
7884 lappend cmd [lindex $ids 0]
7886 } else {
7887 # comparing index with HEAD
7888 lappend cmd HEAD
7890 } else {
7891 if {$log_showroot} {
7892 lappend flags --root
7894 set cmd [concat | git diff-tree -r $flags $ids]
7896 return $cmd
7899 proc gettreediffs {ids} {
7900 global treediff treepending limitdiffs vfilelimit curview
7902 set cmd [diffcmd $ids {--no-commit-id}]
7903 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7904 set cmd [concat $cmd -- $vfilelimit($curview)]
7906 if {[catch {set gdtf [open $cmd r]}]} return
7908 set treepending $ids
7909 set treediff {}
7910 fconfigure $gdtf -blocking 0 -encoding binary
7911 filerun $gdtf [list gettreediffline $gdtf $ids]
7914 proc gettreediffline {gdtf ids} {
7915 global treediff treediffs treepending diffids diffmergeid
7916 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7918 set nr 0
7919 set sublist {}
7920 set max 1000
7921 if {$perfile_attrs} {
7922 # cache_gitattr is slow, and even slower on win32 where we
7923 # have to invoke it for only about 30 paths at a time
7924 set max 500
7925 if {[tk windowingsystem] == "win32"} {
7926 set max 120
7929 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7930 set i [string first "\t" $line]
7931 if {$i >= 0} {
7932 set file [string range $line [expr {$i+1}] end]
7933 if {[string index $file 0] eq "\""} {
7934 set file [lindex $file 0]
7936 set file [encoding convertfrom $file]
7937 if {$file ne [lindex $treediff end]} {
7938 lappend treediff $file
7939 lappend sublist $file
7943 if {$perfile_attrs} {
7944 cache_gitattr encoding $sublist
7946 if {![eof $gdtf]} {
7947 return [expr {$nr >= $max? 2: 1}]
7949 close $gdtf
7950 set treediffs($ids) $treediff
7951 unset treepending
7952 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7953 gettree $diffids
7954 } elseif {$ids != $diffids} {
7955 if {![info exists diffmergeid]} {
7956 gettreediffs $diffids
7958 } else {
7959 addtocflist $ids
7961 return 0
7964 # empty string or positive integer
7965 proc diffcontextvalidate {v} {
7966 return [regexp {^(|[1-9][0-9]*)$} $v]
7969 proc diffcontextchange {n1 n2 op} {
7970 global diffcontextstring diffcontext
7972 if {[string is integer -strict $diffcontextstring]} {
7973 if {$diffcontextstring >= 0} {
7974 set diffcontext $diffcontextstring
7975 reselectline
7980 proc changeignorespace {} {
7981 reselectline
7984 proc changeworddiff {name ix op} {
7985 reselectline
7988 proc initblobdiffvars {} {
7989 global diffencoding targetline diffnparents
7990 global diffinhdr currdiffsubmod diffseehere
7991 set targetline {}
7992 set diffnparents 0
7993 set diffinhdr 0
7994 set diffencoding [get_path_encoding {}]
7995 set currdiffsubmod ""
7996 set diffseehere -1
7999 proc getblobdiffs {ids} {
8000 global blobdifffd diffids env
8001 global treediffs
8002 global diffcontext
8003 global ignorespace
8004 global worddiff
8005 global limitdiffs vfilelimit curview
8006 global git_version
8008 set textconv {}
8009 if {[package vcompare $git_version "1.6.1"] >= 0} {
8010 set textconv "--textconv"
8012 set submodule {}
8013 if {[package vcompare $git_version "1.6.6"] >= 0} {
8014 set submodule "--submodule"
8016 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
8017 if {$ignorespace} {
8018 append cmd " -w"
8020 if {$worddiff ne [mc "Line diff"]} {
8021 append cmd " --word-diff=porcelain"
8023 if {$limitdiffs && $vfilelimit($curview) ne {}} {
8024 set cmd [concat $cmd -- $vfilelimit($curview)]
8026 if {[catch {set bdf [open $cmd r]} err]} {
8027 error_popup [mc "Error getting diffs: %s" $err]
8028 return
8030 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
8031 set blobdifffd($ids) $bdf
8032 initblobdiffvars
8033 filerun $bdf [list getblobdiffline $bdf $diffids]
8036 proc savecmitpos {} {
8037 global ctext cmitmode
8039 if {$cmitmode eq "tree"} {
8040 return {}
8042 return [list target_scrollpos [$ctext index @0,0]]
8045 proc savectextpos {} {
8046 global ctext
8048 return [list target_scrollpos [$ctext index @0,0]]
8051 proc maybe_scroll_ctext {ateof} {
8052 global ctext target_scrollpos
8054 if {![info exists target_scrollpos]} return
8055 if {!$ateof} {
8056 set nlines [expr {[winfo height $ctext]
8057 / [font metrics textfont -linespace]}]
8058 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
8060 $ctext yview $target_scrollpos
8061 unset target_scrollpos
8064 proc setinlist {var i val} {
8065 global $var
8067 while {[llength [set $var]] < $i} {
8068 lappend $var {}
8070 if {[llength [set $var]] == $i} {
8071 lappend $var $val
8072 } else {
8073 lset $var $i $val
8077 proc makediffhdr {fname ids} {
8078 global ctext curdiffstart treediffs diffencoding
8079 global ctext_file_names jump_to_here targetline diffline
8081 set fname [encoding convertfrom $fname]
8082 set diffencoding [get_path_encoding $fname]
8083 set i [lsearch -exact $treediffs($ids) $fname]
8084 if {$i >= 0} {
8085 setinlist difffilestart $i $curdiffstart
8087 lset ctext_file_names end $fname
8088 set l [expr {(78 - [string length $fname]) / 2}]
8089 set pad [string range "----------------------------------------" 1 $l]
8090 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8091 set targetline {}
8092 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8093 set targetline [lindex $jump_to_here 1]
8095 set diffline 0
8098 proc blobdiffmaybeseehere {ateof} {
8099 global diffseehere
8100 if {$diffseehere >= 0} {
8101 mark_ctext_line [lindex [split $diffseehere .] 0]
8103 maybe_scroll_ctext $ateof
8106 proc getblobdiffline {bdf ids} {
8107 global diffids blobdifffd
8108 global ctext
8110 set nr 0
8111 $ctext conf -state normal
8112 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8113 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8114 # Older diff read. Abort it.
8115 catch {close $bdf}
8116 if {$ids != $diffids} {
8117 array unset blobdifffd $ids
8119 return 0
8121 parseblobdiffline $ids $line
8123 $ctext conf -state disabled
8124 blobdiffmaybeseehere [eof $bdf]
8125 if {[eof $bdf]} {
8126 catch {close $bdf}
8127 array unset blobdifffd $ids
8128 return 0
8130 return [expr {$nr >= 1000? 2: 1}]
8133 proc parseblobdiffline {ids line} {
8134 global ctext curdiffstart
8135 global diffnexthead diffnextnote difffilestart
8136 global ctext_file_names ctext_file_lines
8137 global diffinhdr treediffs mergemax diffnparents
8138 global diffencoding jump_to_here targetline diffline currdiffsubmod
8139 global worddiff diffseehere
8141 if {![string compare -length 5 "diff " $line]} {
8142 if {![regexp {^diff (--cc|--git) } $line m type]} {
8143 set line [encoding convertfrom $line]
8144 $ctext insert end "$line\n" hunksep
8145 continue
8147 # start of a new file
8148 set diffinhdr 1
8149 $ctext insert end "\n"
8150 set curdiffstart [$ctext index "end - 1c"]
8151 lappend ctext_file_names ""
8152 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8153 $ctext insert end "\n" filesep
8155 if {$type eq "--cc"} {
8156 # start of a new file in a merge diff
8157 set fname [string range $line 10 end]
8158 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8159 lappend treediffs($ids) $fname
8160 add_flist [list $fname]
8163 } else {
8164 set line [string range $line 11 end]
8165 # If the name hasn't changed the length will be odd,
8166 # the middle char will be a space, and the two bits either
8167 # side will be a/name and b/name, or "a/name" and "b/name".
8168 # If the name has changed we'll get "rename from" and
8169 # "rename to" or "copy from" and "copy to" lines following
8170 # this, and we'll use them to get the filenames.
8171 # This complexity is necessary because spaces in the
8172 # filename(s) don't get escaped.
8173 set l [string length $line]
8174 set i [expr {$l / 2}]
8175 if {!(($l & 1) && [string index $line $i] eq " " &&
8176 [string range $line 2 [expr {$i - 1}]] eq \
8177 [string range $line [expr {$i + 3}] end])} {
8178 return
8180 # unescape if quoted and chop off the a/ from the front
8181 if {[string index $line 0] eq "\""} {
8182 set fname [string range [lindex $line 0] 2 end]
8183 } else {
8184 set fname [string range $line 2 [expr {$i - 1}]]
8187 makediffhdr $fname $ids
8189 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8190 set fname [encoding convertfrom [string range $line 16 end]]
8191 $ctext insert end "\n"
8192 set curdiffstart [$ctext index "end - 1c"]
8193 lappend ctext_file_names $fname
8194 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8195 $ctext insert end "$line\n" filesep
8196 set i [lsearch -exact $treediffs($ids) $fname]
8197 if {$i >= 0} {
8198 setinlist difffilestart $i $curdiffstart
8201 } elseif {![string compare -length 2 "@@" $line]} {
8202 regexp {^@@+} $line ats
8203 set line [encoding convertfrom $diffencoding $line]
8204 $ctext insert end "$line\n" hunksep
8205 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8206 set diffline $nl
8208 set diffnparents [expr {[string length $ats] - 1}]
8209 set diffinhdr 0
8211 } elseif {![string compare -length 10 "Submodule " $line]} {
8212 # start of a new submodule
8213 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8214 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8215 } else {
8216 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8218 if {$currdiffsubmod != $fname} {
8219 $ctext insert end "\n"; # Add newline after commit message
8221 set curdiffstart [$ctext index "end - 1c"]
8222 lappend ctext_file_names ""
8223 if {$currdiffsubmod != $fname} {
8224 lappend ctext_file_lines $fname
8225 makediffhdr $fname $ids
8226 set currdiffsubmod $fname
8227 $ctext insert end "\n$line\n" filesep
8228 } else {
8229 $ctext insert end "$line\n" filesep
8231 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " >" $line]} {
8232 set $currdiffsubmod ""
8233 set line [encoding convertfrom $diffencoding $line]
8234 $ctext insert end "$line\n" dresult
8235 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " <" $line]} {
8236 set $currdiffsubmod ""
8237 set line [encoding convertfrom $diffencoding $line]
8238 $ctext insert end "$line\n" d0
8239 } elseif {$diffinhdr} {
8240 if {![string compare -length 12 "rename from " $line]} {
8241 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8242 if {[string index $fname 0] eq "\""} {
8243 set fname [lindex $fname 0]
8245 set fname [encoding convertfrom $fname]
8246 set i [lsearch -exact $treediffs($ids) $fname]
8247 if {$i >= 0} {
8248 setinlist difffilestart $i $curdiffstart
8250 } elseif {![string compare -length 10 $line "rename to "] ||
8251 ![string compare -length 8 $line "copy to "]} {
8252 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8253 if {[string index $fname 0] eq "\""} {
8254 set fname [lindex $fname 0]
8256 makediffhdr $fname $ids
8257 } elseif {[string compare -length 3 $line "---"] == 0} {
8258 # do nothing
8259 return
8260 } elseif {[string compare -length 3 $line "+++"] == 0} {
8261 set diffinhdr 0
8262 return
8264 $ctext insert end "$line\n" filesep
8266 } else {
8267 set line [string map {\x1A ^Z} \
8268 [encoding convertfrom $diffencoding $line]]
8269 # parse the prefix - one ' ', '-' or '+' for each parent
8270 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8271 set tag [expr {$diffnparents > 1? "m": "d"}]
8272 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8273 set words_pre_markup ""
8274 set words_post_markup ""
8275 if {[string trim $prefix " -+"] eq {}} {
8276 # prefix only has " ", "-" and "+" in it: normal diff line
8277 set num [string first "-" $prefix]
8278 if {$dowords} {
8279 set line [string range $line 1 end]
8281 if {$num >= 0} {
8282 # removed line, first parent with line is $num
8283 if {$num >= $mergemax} {
8284 set num "max"
8286 if {$dowords && $worddiff eq [mc "Markup words"]} {
8287 $ctext insert end "\[-$line-\]" $tag$num
8288 } else {
8289 $ctext insert end "$line" $tag$num
8291 if {!$dowords} {
8292 $ctext insert end "\n" $tag$num
8294 } else {
8295 set tags {}
8296 if {[string first "+" $prefix] >= 0} {
8297 # added line
8298 lappend tags ${tag}result
8299 if {$diffnparents > 1} {
8300 set num [string first " " $prefix]
8301 if {$num >= 0} {
8302 if {$num >= $mergemax} {
8303 set num "max"
8305 lappend tags m$num
8308 set words_pre_markup "{+"
8309 set words_post_markup "+}"
8311 if {$targetline ne {}} {
8312 if {$diffline == $targetline} {
8313 set diffseehere [$ctext index "end - 1 chars"]
8314 set targetline {}
8315 } else {
8316 incr diffline
8319 if {$dowords && $worddiff eq [mc "Markup words"]} {
8320 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8321 } else {
8322 $ctext insert end "$line" $tags
8324 if {!$dowords} {
8325 $ctext insert end "\n" $tags
8328 } elseif {$dowords && $prefix eq "~"} {
8329 $ctext insert end "\n" {}
8330 } else {
8331 # "\ No newline at end of file",
8332 # or something else we don't recognize
8333 $ctext insert end "$line\n" hunksep
8338 proc changediffdisp {} {
8339 global ctext diffelide
8341 $ctext tag conf d0 -elide [lindex $diffelide 0]
8342 $ctext tag conf dresult -elide [lindex $diffelide 1]
8345 proc highlightfile {cline} {
8346 global cflist cflist_top
8348 if {![info exists cflist_top]} return
8350 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8351 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8352 $cflist see $cline.0
8353 set cflist_top $cline
8356 proc highlightfile_for_scrollpos {topidx} {
8357 global cmitmode difffilestart
8359 if {$cmitmode eq "tree"} return
8360 if {![info exists difffilestart]} return
8362 set top [lindex [split $topidx .] 0]
8363 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8364 highlightfile 0
8365 } else {
8366 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8370 proc prevfile {} {
8371 global difffilestart ctext cmitmode
8373 if {$cmitmode eq "tree"} return
8374 set prev 0.0
8375 set here [$ctext index @0,0]
8376 foreach loc $difffilestart {
8377 if {[$ctext compare $loc >= $here]} {
8378 $ctext yview $prev
8379 return
8381 set prev $loc
8383 $ctext yview $prev
8386 proc nextfile {} {
8387 global difffilestart ctext cmitmode
8389 if {$cmitmode eq "tree"} return
8390 set here [$ctext index @0,0]
8391 foreach loc $difffilestart {
8392 if {[$ctext compare $loc > $here]} {
8393 $ctext yview $loc
8394 return
8399 proc clear_ctext {{first 1.0}} {
8400 global ctext smarktop smarkbot
8401 global ctext_file_names ctext_file_lines
8402 global pendinglinks
8404 set l [lindex [split $first .] 0]
8405 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8406 set smarktop $l
8408 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8409 set smarkbot $l
8411 $ctext delete $first end
8412 if {$first eq "1.0"} {
8413 unset -nocomplain pendinglinks
8415 set ctext_file_names {}
8416 set ctext_file_lines {}
8419 proc settabs {{firstab {}}} {
8420 global firsttabstop tabstop ctext have_tk85
8422 if {$firstab ne {} && $have_tk85} {
8423 set firsttabstop $firstab
8425 set w [font measure textfont "0"]
8426 if {$firsttabstop != 0} {
8427 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8428 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8429 } elseif {$have_tk85 || $tabstop != 8} {
8430 $ctext conf -tabs [expr {$tabstop * $w}]
8431 } else {
8432 $ctext conf -tabs {}
8436 proc incrsearch {name ix op} {
8437 global ctext searchstring searchdirn
8439 if {[catch {$ctext index anchor}]} {
8440 # no anchor set, use start of selection, or of visible area
8441 set sel [$ctext tag ranges sel]
8442 if {$sel ne {}} {
8443 $ctext mark set anchor [lindex $sel 0]
8444 } elseif {$searchdirn eq "-forwards"} {
8445 $ctext mark set anchor @0,0
8446 } else {
8447 $ctext mark set anchor @0,[winfo height $ctext]
8450 if {$searchstring ne {}} {
8451 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8452 if {$here ne {}} {
8453 $ctext see $here
8454 set mend "$here + $mlen c"
8455 $ctext tag remove sel 1.0 end
8456 $ctext tag add sel $here $mend
8457 suppress_highlighting_file_for_current_scrollpos
8458 highlightfile_for_scrollpos $here
8461 rehighlight_search_results
8464 proc dosearch {} {
8465 global sstring ctext searchstring searchdirn
8467 focus $sstring
8468 $sstring icursor end
8469 set searchdirn -forwards
8470 if {$searchstring ne {}} {
8471 set sel [$ctext tag ranges sel]
8472 if {$sel ne {}} {
8473 set start "[lindex $sel 0] + 1c"
8474 } elseif {[catch {set start [$ctext index anchor]}]} {
8475 set start "@0,0"
8477 set match [$ctext search -count mlen -- $searchstring $start]
8478 $ctext tag remove sel 1.0 end
8479 if {$match eq {}} {
8480 bell
8481 return
8483 $ctext see $match
8484 suppress_highlighting_file_for_current_scrollpos
8485 highlightfile_for_scrollpos $match
8486 set mend "$match + $mlen c"
8487 $ctext tag add sel $match $mend
8488 $ctext mark unset anchor
8489 rehighlight_search_results
8493 proc dosearchback {} {
8494 global sstring ctext searchstring searchdirn
8496 focus $sstring
8497 $sstring icursor end
8498 set searchdirn -backwards
8499 if {$searchstring ne {}} {
8500 set sel [$ctext tag ranges sel]
8501 if {$sel ne {}} {
8502 set start [lindex $sel 0]
8503 } elseif {[catch {set start [$ctext index anchor]}]} {
8504 set start @0,[winfo height $ctext]
8506 set match [$ctext search -backwards -count ml -- $searchstring $start]
8507 $ctext tag remove sel 1.0 end
8508 if {$match eq {}} {
8509 bell
8510 return
8512 $ctext see $match
8513 suppress_highlighting_file_for_current_scrollpos
8514 highlightfile_for_scrollpos $match
8515 set mend "$match + $ml c"
8516 $ctext tag add sel $match $mend
8517 $ctext mark unset anchor
8518 rehighlight_search_results
8522 proc rehighlight_search_results {} {
8523 global ctext searchstring
8525 $ctext tag remove found 1.0 end
8526 $ctext tag remove currentsearchhit 1.0 end
8528 if {$searchstring ne {}} {
8529 searchmarkvisible 1
8533 proc searchmark {first last} {
8534 global ctext searchstring
8536 set sel [$ctext tag ranges sel]
8538 set mend $first.0
8539 while {1} {
8540 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8541 if {$match eq {}} break
8542 set mend "$match + $mlen c"
8543 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8544 $ctext tag add currentsearchhit $match $mend
8545 } else {
8546 $ctext tag add found $match $mend
8551 proc searchmarkvisible {doall} {
8552 global ctext smarktop smarkbot
8554 set topline [lindex [split [$ctext index @0,0] .] 0]
8555 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8556 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8557 # no overlap with previous
8558 searchmark $topline $botline
8559 set smarktop $topline
8560 set smarkbot $botline
8561 } else {
8562 if {$topline < $smarktop} {
8563 searchmark $topline [expr {$smarktop-1}]
8564 set smarktop $topline
8566 if {$botline > $smarkbot} {
8567 searchmark [expr {$smarkbot+1}] $botline
8568 set smarkbot $botline
8573 proc suppress_highlighting_file_for_current_scrollpos {} {
8574 global ctext suppress_highlighting_file_for_this_scrollpos
8576 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8579 proc scrolltext {f0 f1} {
8580 global searchstring cmitmode ctext
8581 global suppress_highlighting_file_for_this_scrollpos
8583 set topidx [$ctext index @0,0]
8584 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8585 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8586 highlightfile_for_scrollpos $topidx
8589 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8591 .bleft.bottom.sb set $f0 $f1
8592 if {$searchstring ne {}} {
8593 searchmarkvisible 0
8597 proc setcoords {} {
8598 global linespc charspc canvx0 canvy0
8599 global xspc1 xspc2 lthickness
8601 set linespc [font metrics mainfont -linespace]
8602 set charspc [font measure mainfont "m"]
8603 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8604 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8605 set lthickness [expr {int($linespc / 9) + 1}]
8606 set xspc1(0) $linespc
8607 set xspc2 $linespc
8610 proc redisplay {} {
8611 global canv
8612 global selectedline
8614 set ymax [lindex [$canv cget -scrollregion] 3]
8615 if {$ymax eq {} || $ymax == 0} return
8616 set span [$canv yview]
8617 clear_display
8618 setcanvscroll
8619 allcanvs yview moveto [lindex $span 0]
8620 drawvisible
8621 if {$selectedline ne {}} {
8622 selectline $selectedline 0
8623 allcanvs yview moveto [lindex $span 0]
8627 proc parsefont {f n} {
8628 global fontattr
8630 set fontattr($f,family) [lindex $n 0]
8631 set s [lindex $n 1]
8632 if {$s eq {} || $s == 0} {
8633 set s 10
8634 } elseif {$s < 0} {
8635 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8637 set fontattr($f,size) $s
8638 set fontattr($f,weight) normal
8639 set fontattr($f,slant) roman
8640 foreach style [lrange $n 2 end] {
8641 switch -- $style {
8642 "normal" -
8643 "bold" {set fontattr($f,weight) $style}
8644 "roman" -
8645 "italic" {set fontattr($f,slant) $style}
8650 proc fontflags {f {isbold 0}} {
8651 global fontattr
8653 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8654 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8655 -slant $fontattr($f,slant)]
8658 proc fontname {f} {
8659 global fontattr
8661 set n [list $fontattr($f,family) $fontattr($f,size)]
8662 if {$fontattr($f,weight) eq "bold"} {
8663 lappend n "bold"
8665 if {$fontattr($f,slant) eq "italic"} {
8666 lappend n "italic"
8668 return $n
8671 proc incrfont {inc} {
8672 global mainfont textfont ctext canv cflist showrefstop
8673 global stopped entries fontattr
8675 unmarkmatches
8676 set s $fontattr(mainfont,size)
8677 incr s $inc
8678 if {$s < 1} {
8679 set s 1
8681 set fontattr(mainfont,size) $s
8682 font config mainfont -size $s
8683 font config mainfontbold -size $s
8684 set mainfont [fontname mainfont]
8685 set s $fontattr(textfont,size)
8686 incr s $inc
8687 if {$s < 1} {
8688 set s 1
8690 set fontattr(textfont,size) $s
8691 font config textfont -size $s
8692 font config textfontbold -size $s
8693 set textfont [fontname textfont]
8694 setcoords
8695 settabs
8696 redisplay
8699 proc clearsha1 {} {
8700 global sha1entry sha1string
8701 if {[string length $sha1string] == 40} {
8702 $sha1entry delete 0 end
8706 proc sha1change {n1 n2 op} {
8707 global sha1string currentid sha1but
8708 if {$sha1string == {}
8709 || ([info exists currentid] && $sha1string == $currentid)} {
8710 set state disabled
8711 } else {
8712 set state normal
8714 if {[$sha1but cget -state] == $state} return
8715 if {$state == "normal"} {
8716 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8717 } else {
8718 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8722 proc gotocommit {} {
8723 global sha1string tagids headids curview varcid
8725 if {$sha1string == {}
8726 || ([info exists currentid] && $sha1string == $currentid)} return
8727 if {[info exists tagids($sha1string)]} {
8728 set id $tagids($sha1string)
8729 } elseif {[info exists headids($sha1string)]} {
8730 set id $headids($sha1string)
8731 } else {
8732 set id [string tolower $sha1string]
8733 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8734 set matches [longid $id]
8735 if {$matches ne {}} {
8736 if {[llength $matches] > 1} {
8737 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8738 return
8740 set id [lindex $matches 0]
8742 } else {
8743 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8744 error_popup [mc "Revision %s is not known" $sha1string]
8745 return
8749 if {[commitinview $id $curview]} {
8750 selectline [rowofcommit $id] 1
8751 return
8753 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8754 set msg [mc "SHA1 id %s is not known" $sha1string]
8755 } else {
8756 set msg [mc "Revision %s is not in the current view" $sha1string]
8758 error_popup $msg
8761 proc lineenter {x y id} {
8762 global hoverx hovery hoverid hovertimer
8763 global commitinfo canv
8765 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8766 set hoverx $x
8767 set hovery $y
8768 set hoverid $id
8769 if {[info exists hovertimer]} {
8770 after cancel $hovertimer
8772 set hovertimer [after 500 linehover]
8773 $canv delete hover
8776 proc linemotion {x y id} {
8777 global hoverx hovery hoverid hovertimer
8779 if {[info exists hoverid] && $id == $hoverid} {
8780 set hoverx $x
8781 set hovery $y
8782 if {[info exists hovertimer]} {
8783 after cancel $hovertimer
8785 set hovertimer [after 500 linehover]
8789 proc lineleave {id} {
8790 global hoverid hovertimer canv
8792 if {[info exists hoverid] && $id == $hoverid} {
8793 $canv delete hover
8794 if {[info exists hovertimer]} {
8795 after cancel $hovertimer
8796 unset hovertimer
8798 unset hoverid
8802 proc linehover {} {
8803 global hoverx hovery hoverid hovertimer
8804 global canv linespc lthickness
8805 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8807 global commitinfo
8809 set text [lindex $commitinfo($hoverid) 0]
8810 set ymax [lindex [$canv cget -scrollregion] 3]
8811 if {$ymax == {}} return
8812 set yfrac [lindex [$canv yview] 0]
8813 set x [expr {$hoverx + 2 * $linespc}]
8814 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8815 set x0 [expr {$x - 2 * $lthickness}]
8816 set y0 [expr {$y - 2 * $lthickness}]
8817 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8818 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8819 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8820 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8821 -width 1 -tags hover]
8822 $canv raise $t
8823 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8824 -font mainfont -fill $linehoverfgcolor]
8825 $canv raise $t
8828 proc clickisonarrow {id y} {
8829 global lthickness
8831 set ranges [rowranges $id]
8832 set thresh [expr {2 * $lthickness + 6}]
8833 set n [expr {[llength $ranges] - 1}]
8834 for {set i 1} {$i < $n} {incr i} {
8835 set row [lindex $ranges $i]
8836 if {abs([yc $row] - $y) < $thresh} {
8837 return $i
8840 return {}
8843 proc arrowjump {id n y} {
8844 global canv
8846 # 1 <-> 2, 3 <-> 4, etc...
8847 set n [expr {(($n - 1) ^ 1) + 1}]
8848 set row [lindex [rowranges $id] $n]
8849 set yt [yc $row]
8850 set ymax [lindex [$canv cget -scrollregion] 3]
8851 if {$ymax eq {} || $ymax <= 0} return
8852 set view [$canv yview]
8853 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8854 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8855 if {$yfrac < 0} {
8856 set yfrac 0
8858 allcanvs yview moveto $yfrac
8861 proc lineclick {x y id isnew} {
8862 global ctext commitinfo children canv thickerline curview
8864 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8865 unmarkmatches
8866 unselectline
8867 normalline
8868 $canv delete hover
8869 # draw this line thicker than normal
8870 set thickerline $id
8871 drawlines $id
8872 if {$isnew} {
8873 set ymax [lindex [$canv cget -scrollregion] 3]
8874 if {$ymax eq {}} return
8875 set yfrac [lindex [$canv yview] 0]
8876 set y [expr {$y + $yfrac * $ymax}]
8878 set dirn [clickisonarrow $id $y]
8879 if {$dirn ne {}} {
8880 arrowjump $id $dirn $y
8881 return
8884 if {$isnew} {
8885 addtohistory [list lineclick $x $y $id 0] savectextpos
8887 # fill the details pane with info about this line
8888 $ctext conf -state normal
8889 clear_ctext
8890 settabs 0
8891 $ctext insert end "[mc "Parent"]:\t"
8892 $ctext insert end $id link0
8893 setlink $id link0
8894 set info $commitinfo($id)
8895 $ctext insert end "\n\t[lindex $info 0]\n"
8896 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8897 set date [formatdate [lindex $info 2]]
8898 $ctext insert end "\t[mc "Date"]:\t$date\n"
8899 set kids $children($curview,$id)
8900 if {$kids ne {}} {
8901 $ctext insert end "\n[mc "Children"]:"
8902 set i 0
8903 foreach child $kids {
8904 incr i
8905 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8906 set info $commitinfo($child)
8907 $ctext insert end "\n\t"
8908 $ctext insert end $child link$i
8909 setlink $child link$i
8910 $ctext insert end "\n\t[lindex $info 0]"
8911 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8912 set date [formatdate [lindex $info 2]]
8913 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8916 maybe_scroll_ctext 1
8917 $ctext conf -state disabled
8918 init_flist {}
8921 proc normalline {} {
8922 global thickerline
8923 if {[info exists thickerline]} {
8924 set id $thickerline
8925 unset thickerline
8926 drawlines $id
8930 proc selbyid {id {isnew 1}} {
8931 global curview
8932 if {[commitinview $id $curview]} {
8933 selectline [rowofcommit $id] $isnew
8937 proc mstime {} {
8938 global startmstime
8939 if {![info exists startmstime]} {
8940 set startmstime [clock clicks -milliseconds]
8942 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8945 proc rowmenu {x y id} {
8946 global rowctxmenu selectedline rowmenuid curview
8947 global nullid nullid2 fakerowmenu mainhead markedid
8949 stopfinding
8950 set rowmenuid $id
8951 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8952 set state disabled
8953 } else {
8954 set state normal
8956 if {[info exists markedid] && $markedid ne $id} {
8957 set mstate normal
8958 } else {
8959 set mstate disabled
8961 if {$id ne $nullid && $id ne $nullid2} {
8962 set menu $rowctxmenu
8963 if {$mainhead ne {}} {
8964 $menu entryconfigure 8 -label [mc "Reset %s branch to here" $mainhead] -state normal
8965 } else {
8966 $menu entryconfigure 8 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8968 $menu entryconfigure 10 -state $mstate
8969 $menu entryconfigure 11 -state $mstate
8970 $menu entryconfigure 12 -state $mstate
8971 } else {
8972 set menu $fakerowmenu
8974 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8975 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8976 $menu entryconfigure [mca "Make patch"] -state $state
8977 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8978 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8979 tk_popup $menu $x $y
8982 proc markhere {} {
8983 global rowmenuid markedid canv
8985 set markedid $rowmenuid
8986 make_idmark $markedid
8989 proc gotomark {} {
8990 global markedid
8992 if {[info exists markedid]} {
8993 selbyid $markedid
8997 proc replace_by_kids {l r} {
8998 global curview children
9000 set id [commitonrow $r]
9001 set l [lreplace $l 0 0]
9002 foreach kid $children($curview,$id) {
9003 lappend l [rowofcommit $kid]
9005 return [lsort -integer -decreasing -unique $l]
9008 proc find_common_desc {} {
9009 global markedid rowmenuid curview children
9011 if {![info exists markedid]} return
9012 if {![commitinview $markedid $curview] ||
9013 ![commitinview $rowmenuid $curview]} return
9014 #set t1 [clock clicks -milliseconds]
9015 set l1 [list [rowofcommit $markedid]]
9016 set l2 [list [rowofcommit $rowmenuid]]
9017 while 1 {
9018 set r1 [lindex $l1 0]
9019 set r2 [lindex $l2 0]
9020 if {$r1 eq {} || $r2 eq {}} break
9021 if {$r1 == $r2} {
9022 selectline $r1 1
9023 break
9025 if {$r1 > $r2} {
9026 set l1 [replace_by_kids $l1 $r1]
9027 } else {
9028 set l2 [replace_by_kids $l2 $r2]
9031 #set t2 [clock clicks -milliseconds]
9032 #puts "took [expr {$t2-$t1}]ms"
9035 proc compare_commits {} {
9036 global markedid rowmenuid curview children
9038 if {![info exists markedid]} return
9039 if {![commitinview $markedid $curview]} return
9040 addtohistory [list do_cmp_commits $markedid $rowmenuid]
9041 do_cmp_commits $markedid $rowmenuid
9044 proc getpatchid {id} {
9045 global patchids
9047 if {![info exists patchids($id)]} {
9048 set cmd [diffcmd [list $id] {-p --root}]
9049 # trim off the initial "|"
9050 set cmd [lrange $cmd 1 end]
9051 if {[catch {
9052 set x [eval exec $cmd | git patch-id]
9053 set patchids($id) [lindex $x 0]
9054 }]} {
9055 set patchids($id) "error"
9058 return $patchids($id)
9061 proc do_cmp_commits {a b} {
9062 global ctext curview parents children patchids commitinfo
9064 $ctext conf -state normal
9065 clear_ctext
9066 init_flist {}
9067 for {set i 0} {$i < 100} {incr i} {
9068 set skipa 0
9069 set skipb 0
9070 if {[llength $parents($curview,$a)] > 1} {
9071 appendshortlink $a [mc "Skipping merge commit "] "\n"
9072 set skipa 1
9073 } else {
9074 set patcha [getpatchid $a]
9076 if {[llength $parents($curview,$b)] > 1} {
9077 appendshortlink $b [mc "Skipping merge commit "] "\n"
9078 set skipb 1
9079 } else {
9080 set patchb [getpatchid $b]
9082 if {!$skipa && !$skipb} {
9083 set heada [lindex $commitinfo($a) 0]
9084 set headb [lindex $commitinfo($b) 0]
9085 if {$patcha eq "error"} {
9086 appendshortlink $a [mc "Error getting patch ID for "] \
9087 [mc " - stopping\n"]
9088 break
9090 if {$patchb eq "error"} {
9091 appendshortlink $b [mc "Error getting patch ID for "] \
9092 [mc " - stopping\n"]
9093 break
9095 if {$patcha eq $patchb} {
9096 if {$heada eq $headb} {
9097 appendshortlink $a [mc "Commit "]
9098 appendshortlink $b " == " " $heada\n"
9099 } else {
9100 appendshortlink $a [mc "Commit "] " $heada\n"
9101 appendshortlink $b [mc " is the same patch as\n "] \
9102 " $headb\n"
9104 set skipa 1
9105 set skipb 1
9106 } else {
9107 $ctext insert end "\n"
9108 appendshortlink $a [mc "Commit "] " $heada\n"
9109 appendshortlink $b [mc " differs from\n "] \
9110 " $headb\n"
9111 $ctext insert end [mc "Diff of commits:\n\n"]
9112 $ctext conf -state disabled
9113 update
9114 diffcommits $a $b
9115 return
9118 if {$skipa} {
9119 set kids [real_children $curview,$a]
9120 if {[llength $kids] != 1} {
9121 $ctext insert end "\n"
9122 appendshortlink $a [mc "Commit "] \
9123 [mc " has %s children - stopping\n" [llength $kids]]
9124 break
9126 set a [lindex $kids 0]
9128 if {$skipb} {
9129 set kids [real_children $curview,$b]
9130 if {[llength $kids] != 1} {
9131 appendshortlink $b [mc "Commit "] \
9132 [mc " has %s children - stopping\n" [llength $kids]]
9133 break
9135 set b [lindex $kids 0]
9138 $ctext conf -state disabled
9141 proc diffcommits {a b} {
9142 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9144 set tmpdir [gitknewtmpdir]
9145 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9146 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9147 if {[catch {
9148 exec git diff-tree -p --pretty $a >$fna
9149 exec git diff-tree -p --pretty $b >$fnb
9150 } err]} {
9151 error_popup [mc "Error writing commit to file: %s" $err]
9152 return
9154 if {[catch {
9155 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9156 } err]} {
9157 error_popup [mc "Error diffing commits: %s" $err]
9158 return
9160 set diffids [list commits $a $b]
9161 set blobdifffd($diffids) $fd
9162 set diffinhdr 0
9163 set currdiffsubmod ""
9164 filerun $fd [list getblobdiffline $fd $diffids]
9167 proc diffvssel {dirn} {
9168 global rowmenuid selectedline
9170 if {$selectedline eq {}} return
9171 if {$dirn} {
9172 set oldid [commitonrow $selectedline]
9173 set newid $rowmenuid
9174 } else {
9175 set oldid $rowmenuid
9176 set newid [commitonrow $selectedline]
9178 addtohistory [list doseldiff $oldid $newid] savectextpos
9179 doseldiff $oldid $newid
9182 proc diffvsmark {dirn} {
9183 global rowmenuid markedid
9185 if {![info exists markedid]} return
9186 if {$dirn} {
9187 set oldid $markedid
9188 set newid $rowmenuid
9189 } else {
9190 set oldid $rowmenuid
9191 set newid $markedid
9193 addtohistory [list doseldiff $oldid $newid] savectextpos
9194 doseldiff $oldid $newid
9197 proc doseldiff {oldid newid} {
9198 global ctext
9199 global commitinfo
9201 $ctext conf -state normal
9202 clear_ctext
9203 init_flist [mc "Top"]
9204 $ctext insert end "[mc "From"] "
9205 $ctext insert end $oldid link0
9206 setlink $oldid link0
9207 $ctext insert end "\n "
9208 $ctext insert end [lindex $commitinfo($oldid) 0]
9209 $ctext insert end "\n\n[mc "To"] "
9210 $ctext insert end $newid link1
9211 setlink $newid link1
9212 $ctext insert end "\n "
9213 $ctext insert end [lindex $commitinfo($newid) 0]
9214 $ctext insert end "\n"
9215 $ctext conf -state disabled
9216 $ctext tag remove found 1.0 end
9217 startdiff [list $oldid $newid]
9220 proc mkpatch {} {
9221 global rowmenuid currentid commitinfo patchtop patchnum NS
9223 if {![info exists currentid]} return
9224 set oldid $currentid
9225 set oldhead [lindex $commitinfo($oldid) 0]
9226 set newid $rowmenuid
9227 set newhead [lindex $commitinfo($newid) 0]
9228 set top .patch
9229 set patchtop $top
9230 catch {destroy $top}
9231 ttk_toplevel $top
9232 make_transient $top .
9233 ${NS}::label $top.title -text [mc "Generate patch"]
9234 grid $top.title - -pady 10
9235 ${NS}::label $top.from -text [mc "From:"]
9236 ${NS}::entry $top.fromsha1 -width 40
9237 $top.fromsha1 insert 0 $oldid
9238 $top.fromsha1 conf -state readonly
9239 grid $top.from $top.fromsha1 -sticky w
9240 ${NS}::entry $top.fromhead -width 60
9241 $top.fromhead insert 0 $oldhead
9242 $top.fromhead conf -state readonly
9243 grid x $top.fromhead -sticky w
9244 ${NS}::label $top.to -text [mc "To:"]
9245 ${NS}::entry $top.tosha1 -width 40
9246 $top.tosha1 insert 0 $newid
9247 $top.tosha1 conf -state readonly
9248 grid $top.to $top.tosha1 -sticky w
9249 ${NS}::entry $top.tohead -width 60
9250 $top.tohead insert 0 $newhead
9251 $top.tohead conf -state readonly
9252 grid x $top.tohead -sticky w
9253 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9254 grid $top.rev x -pady 10 -padx 5
9255 ${NS}::label $top.flab -text [mc "Output file:"]
9256 ${NS}::entry $top.fname -width 60
9257 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9258 incr patchnum
9259 grid $top.flab $top.fname -sticky w
9260 ${NS}::frame $top.buts
9261 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9262 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9263 bind $top <Key-Return> mkpatchgo
9264 bind $top <Key-Escape> mkpatchcan
9265 grid $top.buts.gen $top.buts.can
9266 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9267 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9268 grid $top.buts - -pady 10 -sticky ew
9269 focus $top.fname
9272 proc mkpatchrev {} {
9273 global patchtop
9275 set oldid [$patchtop.fromsha1 get]
9276 set oldhead [$patchtop.fromhead get]
9277 set newid [$patchtop.tosha1 get]
9278 set newhead [$patchtop.tohead get]
9279 foreach e [list fromsha1 fromhead tosha1 tohead] \
9280 v [list $newid $newhead $oldid $oldhead] {
9281 $patchtop.$e conf -state normal
9282 $patchtop.$e delete 0 end
9283 $patchtop.$e insert 0 $v
9284 $patchtop.$e conf -state readonly
9288 proc mkpatchgo {} {
9289 global patchtop nullid nullid2
9291 set oldid [$patchtop.fromsha1 get]
9292 set newid [$patchtop.tosha1 get]
9293 set fname [$patchtop.fname get]
9294 set cmd [diffcmd [list $oldid $newid] -p]
9295 # trim off the initial "|"
9296 set cmd [lrange $cmd 1 end]
9297 lappend cmd >$fname &
9298 if {[catch {eval exec $cmd} err]} {
9299 error_popup "[mc "Error creating patch:"] $err" $patchtop
9301 catch {destroy $patchtop}
9302 unset patchtop
9305 proc mkpatchcan {} {
9306 global patchtop
9308 catch {destroy $patchtop}
9309 unset patchtop
9312 proc mktag {} {
9313 global rowmenuid mktagtop commitinfo NS
9315 set top .maketag
9316 set mktagtop $top
9317 catch {destroy $top}
9318 ttk_toplevel $top
9319 make_transient $top .
9320 ${NS}::label $top.title -text [mc "Create tag"]
9321 grid $top.title - -pady 10
9322 ${NS}::label $top.id -text [mc "ID:"]
9323 ${NS}::entry $top.sha1 -width 40
9324 $top.sha1 insert 0 $rowmenuid
9325 $top.sha1 conf -state readonly
9326 grid $top.id $top.sha1 -sticky w
9327 ${NS}::entry $top.head -width 60
9328 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9329 $top.head conf -state readonly
9330 grid x $top.head -sticky w
9331 ${NS}::label $top.tlab -text [mc "Tag name:"]
9332 ${NS}::entry $top.tag -width 60
9333 grid $top.tlab $top.tag -sticky w
9334 ${NS}::label $top.op -text [mc "Tag message is optional"]
9335 grid $top.op -columnspan 2 -sticky we
9336 ${NS}::label $top.mlab -text [mc "Tag message:"]
9337 ${NS}::entry $top.msg -width 60
9338 grid $top.mlab $top.msg -sticky w
9339 ${NS}::frame $top.buts
9340 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9341 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9342 bind $top <Key-Return> mktaggo
9343 bind $top <Key-Escape> mktagcan
9344 grid $top.buts.gen $top.buts.can
9345 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9346 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9347 grid $top.buts - -pady 10 -sticky ew
9348 focus $top.tag
9351 proc domktag {} {
9352 global mktagtop env tagids idtags
9354 set id [$mktagtop.sha1 get]
9355 set tag [$mktagtop.tag get]
9356 set msg [$mktagtop.msg get]
9357 if {$tag == {}} {
9358 error_popup [mc "No tag name specified"] $mktagtop
9359 return 0
9361 if {[info exists tagids($tag)]} {
9362 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9363 return 0
9365 if {[catch {
9366 if {$msg != {}} {
9367 exec git tag -a -m $msg $tag $id
9368 } else {
9369 exec git tag $tag $id
9371 } err]} {
9372 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9373 return 0
9376 set tagids($tag) $id
9377 lappend idtags($id) $tag
9378 redrawtags $id
9379 addedtag $id
9380 dispneartags 0
9381 run refill_reflist
9382 return 1
9385 proc redrawtags {id} {
9386 global canv linehtag idpos currentid curview cmitlisted markedid
9387 global canvxmax iddrawn circleitem mainheadid circlecolors
9388 global mainheadcirclecolor
9390 if {![commitinview $id $curview]} return
9391 if {![info exists iddrawn($id)]} return
9392 set row [rowofcommit $id]
9393 if {$id eq $mainheadid} {
9394 set ofill $mainheadcirclecolor
9395 } else {
9396 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9398 $canv itemconf $circleitem($row) -fill $ofill
9399 $canv delete tag.$id
9400 set xt [eval drawtags $id $idpos($id)]
9401 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9402 set text [$canv itemcget $linehtag($id) -text]
9403 set font [$canv itemcget $linehtag($id) -font]
9404 set xr [expr {$xt + [font measure $font $text]}]
9405 if {$xr > $canvxmax} {
9406 set canvxmax $xr
9407 setcanvscroll
9409 if {[info exists currentid] && $currentid == $id} {
9410 make_secsel $id
9412 if {[info exists markedid] && $markedid eq $id} {
9413 make_idmark $id
9417 proc mktagcan {} {
9418 global mktagtop
9420 catch {destroy $mktagtop}
9421 unset mktagtop
9424 proc mktaggo {} {
9425 if {![domktag]} return
9426 mktagcan
9429 proc copysummary {} {
9430 global rowmenuid autosellen
9432 set format "%h (\"%s\", %ad)"
9433 set cmd [list git show -s --pretty=format:$format --date=short]
9434 if {$autosellen < 40} {
9435 lappend cmd --abbrev=$autosellen
9437 set summary [eval exec $cmd $rowmenuid]
9439 clipboard clear
9440 clipboard append $summary
9443 proc writecommit {} {
9444 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9446 set top .writecommit
9447 set wrcomtop $top
9448 catch {destroy $top}
9449 ttk_toplevel $top
9450 make_transient $top .
9451 ${NS}::label $top.title -text [mc "Write commit to file"]
9452 grid $top.title - -pady 10
9453 ${NS}::label $top.id -text [mc "ID:"]
9454 ${NS}::entry $top.sha1 -width 40
9455 $top.sha1 insert 0 $rowmenuid
9456 $top.sha1 conf -state readonly
9457 grid $top.id $top.sha1 -sticky w
9458 ${NS}::entry $top.head -width 60
9459 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9460 $top.head conf -state readonly
9461 grid x $top.head -sticky w
9462 ${NS}::label $top.clab -text [mc "Command:"]
9463 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9464 grid $top.clab $top.cmd -sticky w -pady 10
9465 ${NS}::label $top.flab -text [mc "Output file:"]
9466 ${NS}::entry $top.fname -width 60
9467 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9468 grid $top.flab $top.fname -sticky w
9469 ${NS}::frame $top.buts
9470 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9471 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9472 bind $top <Key-Return> wrcomgo
9473 bind $top <Key-Escape> wrcomcan
9474 grid $top.buts.gen $top.buts.can
9475 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9476 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9477 grid $top.buts - -pady 10 -sticky ew
9478 focus $top.fname
9481 proc wrcomgo {} {
9482 global wrcomtop
9484 set id [$wrcomtop.sha1 get]
9485 set cmd "echo $id | [$wrcomtop.cmd get]"
9486 set fname [$wrcomtop.fname get]
9487 if {[catch {exec sh -c $cmd >$fname &} err]} {
9488 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9490 catch {destroy $wrcomtop}
9491 unset wrcomtop
9494 proc wrcomcan {} {
9495 global wrcomtop
9497 catch {destroy $wrcomtop}
9498 unset wrcomtop
9501 proc mkbranch {} {
9502 global NS rowmenuid
9504 set top .branchdialog
9506 set val(name) ""
9507 set val(id) $rowmenuid
9508 set val(command) [list mkbrgo $top]
9510 set ui(title) [mc "Create branch"]
9511 set ui(accept) [mc "Create"]
9513 branchdia $top val ui
9516 proc mvbranch {} {
9517 global NS
9518 global headmenuid headmenuhead
9520 set top .branchdialog
9522 set val(name) $headmenuhead
9523 set val(id) $headmenuid
9524 set val(command) [list mvbrgo $top $headmenuhead]
9526 set ui(title) [mc "Rename branch %s" $headmenuhead]
9527 set ui(accept) [mc "Rename"]
9529 branchdia $top val ui
9532 proc branchdia {top valvar uivar} {
9533 global NS commitinfo
9534 upvar $valvar val $uivar ui
9536 catch {destroy $top}
9537 ttk_toplevel $top
9538 make_transient $top .
9539 ${NS}::label $top.title -text $ui(title)
9540 grid $top.title - -pady 10
9541 ${NS}::label $top.id -text [mc "ID:"]
9542 ${NS}::entry $top.sha1 -width 40
9543 $top.sha1 insert 0 $val(id)
9544 $top.sha1 conf -state readonly
9545 grid $top.id $top.sha1 -sticky w
9546 ${NS}::entry $top.head -width 60
9547 $top.head insert 0 [lindex $commitinfo($val(id)) 0]
9548 $top.head conf -state readonly
9549 grid x $top.head -sticky ew
9550 grid columnconfigure $top 1 -weight 1
9551 ${NS}::label $top.nlab -text [mc "Name:"]
9552 ${NS}::entry $top.name -width 40
9553 $top.name insert 0 $val(name)
9554 grid $top.nlab $top.name -sticky w
9555 ${NS}::frame $top.buts
9556 ${NS}::button $top.buts.go -text $ui(accept) -command $val(command)
9557 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9558 bind $top <Key-Return> $val(command)
9559 bind $top <Key-Escape> "catch {destroy $top}"
9560 grid $top.buts.go $top.buts.can
9561 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9562 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9563 grid $top.buts - -pady 10 -sticky ew
9564 focus $top.name
9567 proc mkbrgo {top} {
9568 global headids idheads
9570 set name [$top.name get]
9571 set id [$top.sha1 get]
9572 set cmdargs {}
9573 set old_id {}
9574 if {$name eq {}} {
9575 error_popup [mc "Please specify a name for the new branch"] $top
9576 return
9578 if {[info exists headids($name)]} {
9579 if {![confirm_popup [mc \
9580 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9581 return
9583 set old_id $headids($name)
9584 lappend cmdargs -f
9586 catch {destroy $top}
9587 lappend cmdargs $name $id
9588 nowbusy newbranch
9589 update
9590 if {[catch {
9591 eval exec git branch $cmdargs
9592 } err]} {
9593 notbusy newbranch
9594 error_popup $err
9595 } else {
9596 notbusy newbranch
9597 if {$old_id ne {}} {
9598 movehead $id $name
9599 movedhead $id $name
9600 redrawtags $old_id
9601 redrawtags $id
9602 } else {
9603 set headids($name) $id
9604 lappend idheads($id) $name
9605 addedhead $id $name
9606 redrawtags $id
9608 dispneartags 0
9609 run refill_reflist
9613 proc mvbrgo {top prevname} {
9614 global headids idheads mainhead mainheadid
9616 set name [$top.name get]
9617 set id [$top.sha1 get]
9618 set cmdargs {}
9619 if {$name eq $prevname} {
9620 catch {destroy $top}
9621 return
9623 if {$name eq {}} {
9624 error_popup [mc "Please specify a new name for the branch"] $top
9625 return
9627 catch {destroy $top}
9628 lappend cmdargs -m $prevname $name
9629 nowbusy renamebranch
9630 update
9631 if {[catch {
9632 eval exec git branch $cmdargs
9633 } err]} {
9634 notbusy renamebranch
9635 error_popup $err
9636 } else {
9637 notbusy renamebranch
9638 removehead $id $prevname
9639 removedhead $id $prevname
9640 set headids($name) $id
9641 lappend idheads($id) $name
9642 addedhead $id $name
9643 if {$prevname eq $mainhead} {
9644 set mainhead $name
9645 set mainheadid $id
9647 redrawtags $id
9648 dispneartags 0
9649 run refill_reflist
9653 proc exec_citool {tool_args {baseid {}}} {
9654 global commitinfo env
9656 set save_env [array get env GIT_AUTHOR_*]
9658 if {$baseid ne {}} {
9659 if {![info exists commitinfo($baseid)]} {
9660 getcommit $baseid
9662 set author [lindex $commitinfo($baseid) 1]
9663 set date [lindex $commitinfo($baseid) 2]
9664 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9665 $author author name email]
9666 && $date ne {}} {
9667 set env(GIT_AUTHOR_NAME) $name
9668 set env(GIT_AUTHOR_EMAIL) $email
9669 set env(GIT_AUTHOR_DATE) $date
9673 eval exec git citool $tool_args &
9675 array unset env GIT_AUTHOR_*
9676 array set env $save_env
9679 proc cherrypick {} {
9680 global rowmenuid curview
9681 global mainhead mainheadid
9682 global gitdir
9684 set oldhead [exec git rev-parse HEAD]
9685 set dheads [descheads $rowmenuid]
9686 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9687 set ok [confirm_popup [mc "Commit %s is already\
9688 included in branch %s -- really re-apply it?" \
9689 [string range $rowmenuid 0 7] $mainhead]]
9690 if {!$ok} return
9692 nowbusy cherrypick [mc "Cherry-picking"]
9693 update
9694 # Unfortunately git-cherry-pick writes stuff to stderr even when
9695 # no error occurs, and exec takes that as an indication of error...
9696 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9697 notbusy cherrypick
9698 if {[regexp -line \
9699 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9700 $err msg fname]} {
9701 error_popup [mc "Cherry-pick failed because of local changes\
9702 to file '%s'.\nPlease commit, reset or stash\
9703 your changes and try again." $fname]
9704 } elseif {[regexp -line \
9705 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9706 $err]} {
9707 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9708 conflict.\nDo you wish to run git citool to\
9709 resolve it?"]]} {
9710 # Force citool to read MERGE_MSG
9711 file delete [file join $gitdir "GITGUI_MSG"]
9712 exec_citool {} $rowmenuid
9714 } else {
9715 error_popup $err
9717 run updatecommits
9718 return
9720 set newhead [exec git rev-parse HEAD]
9721 if {$newhead eq $oldhead} {
9722 notbusy cherrypick
9723 error_popup [mc "No changes committed"]
9724 return
9726 addnewchild $newhead $oldhead
9727 if {[commitinview $oldhead $curview]} {
9728 # XXX this isn't right if we have a path limit...
9729 insertrow $newhead $oldhead $curview
9730 if {$mainhead ne {}} {
9731 movehead $newhead $mainhead
9732 movedhead $newhead $mainhead
9734 set mainheadid $newhead
9735 redrawtags $oldhead
9736 redrawtags $newhead
9737 selbyid $newhead
9739 notbusy cherrypick
9742 proc revert {} {
9743 global rowmenuid curview
9744 global mainhead mainheadid
9745 global gitdir
9747 set oldhead [exec git rev-parse HEAD]
9748 set dheads [descheads $rowmenuid]
9749 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9750 set ok [confirm_popup [mc "Commit %s is not\
9751 included in branch %s -- really revert it?" \
9752 [string range $rowmenuid 0 7] $mainhead]]
9753 if {!$ok} return
9755 nowbusy revert [mc "Reverting"]
9756 update
9758 if [catch {exec git revert --no-edit $rowmenuid} err] {
9759 notbusy revert
9760 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9761 $err match files] {
9762 regsub {\n( |\t)+} $files "\n" files
9763 error_popup [mc "Revert failed because of local changes to\
9764 the following files:%s Please commit, reset or stash \
9765 your changes and try again." $files]
9766 } elseif [regexp {error: could not revert} $err] {
9767 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9768 Do you wish to run git citool to resolve it?"]] {
9769 # Force citool to read MERGE_MSG
9770 file delete [file join $gitdir "GITGUI_MSG"]
9771 exec_citool {} $rowmenuid
9773 } else { error_popup $err }
9774 run updatecommits
9775 return
9778 set newhead [exec git rev-parse HEAD]
9779 if { $newhead eq $oldhead } {
9780 notbusy revert
9781 error_popup [mc "No changes committed"]
9782 return
9785 addnewchild $newhead $oldhead
9787 if [commitinview $oldhead $curview] {
9788 # XXX this isn't right if we have a path limit...
9789 insertrow $newhead $oldhead $curview
9790 if {$mainhead ne {}} {
9791 movehead $newhead $mainhead
9792 movedhead $newhead $mainhead
9794 set mainheadid $newhead
9795 redrawtags $oldhead
9796 redrawtags $newhead
9797 selbyid $newhead
9800 notbusy revert
9803 proc resethead {} {
9804 global mainhead rowmenuid confirm_ok resettype NS
9806 set confirm_ok 0
9807 set w ".confirmreset"
9808 ttk_toplevel $w
9809 make_transient $w .
9810 wm title $w [mc "Confirm reset"]
9811 ${NS}::label $w.m -text \
9812 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9813 pack $w.m -side top -fill x -padx 20 -pady 20
9814 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9815 set resettype mixed
9816 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9817 -text [mc "Soft: Leave working tree and index untouched"]
9818 grid $w.f.soft -sticky w
9819 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9820 -text [mc "Mixed: Leave working tree untouched, reset index"]
9821 grid $w.f.mixed -sticky w
9822 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9823 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9824 grid $w.f.hard -sticky w
9825 pack $w.f -side top -fill x -padx 4
9826 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9827 pack $w.ok -side left -fill x -padx 20 -pady 20
9828 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9829 bind $w <Key-Escape> [list destroy $w]
9830 pack $w.cancel -side right -fill x -padx 20 -pady 20
9831 bind $w <Visibility> "grab $w; focus $w"
9832 tkwait window $w
9833 if {!$confirm_ok} return
9834 if {[catch {set fd [open \
9835 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9836 error_popup $err
9837 } else {
9838 dohidelocalchanges
9839 filerun $fd [list readresetstat $fd]
9840 nowbusy reset [mc "Resetting"]
9841 selbyid $rowmenuid
9845 proc readresetstat {fd} {
9846 global mainhead mainheadid showlocalchanges rprogcoord
9848 if {[gets $fd line] >= 0} {
9849 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9850 set rprogcoord [expr {1.0 * $m / $n}]
9851 adjustprogress
9853 return 1
9855 set rprogcoord 0
9856 adjustprogress
9857 notbusy reset
9858 if {[catch {close $fd} err]} {
9859 error_popup $err
9861 set oldhead $mainheadid
9862 set newhead [exec git rev-parse HEAD]
9863 if {$newhead ne $oldhead} {
9864 movehead $newhead $mainhead
9865 movedhead $newhead $mainhead
9866 set mainheadid $newhead
9867 redrawtags $oldhead
9868 redrawtags $newhead
9870 if {$showlocalchanges} {
9871 doshowlocalchanges
9873 return 0
9876 # context menu for a head
9877 proc headmenu {x y id head} {
9878 global headmenuid headmenuhead headctxmenu mainhead headids
9880 stopfinding
9881 set headmenuid $id
9882 set headmenuhead $head
9883 array set state {0 normal 1 normal 2 normal}
9884 if {[string match "remotes/*" $head]} {
9885 set localhead [string range $head [expr [string last / $head] + 1] end]
9886 if {[info exists headids($localhead)]} {
9887 set state(0) disabled
9889 array set state {1 disabled 2 disabled}
9891 if {$head eq $mainhead} {
9892 array set state {0 disabled 2 disabled}
9894 foreach i {0 1 2} {
9895 $headctxmenu entryconfigure $i -state $state($i)
9897 tk_popup $headctxmenu $x $y
9900 proc cobranch {} {
9901 global headmenuid headmenuhead headids
9902 global showlocalchanges
9904 # check the tree is clean first??
9905 set newhead $headmenuhead
9906 set command [list | git checkout]
9907 if {[string match "remotes/*" $newhead]} {
9908 set remote $newhead
9909 set newhead [string range $newhead [expr [string last / $newhead] + 1] end]
9910 # The following check is redundant - the menu option should
9911 # be disabled to begin with...
9912 if {[info exists headids($newhead)]} {
9913 error_popup [mc "A local branch named %s exists already" $newhead]
9914 return
9916 lappend command -b $newhead --track $remote
9917 } else {
9918 lappend command $newhead
9920 lappend command 2>@1
9921 nowbusy checkout [mc "Checking out"]
9922 update
9923 dohidelocalchanges
9924 if {[catch {
9925 set fd [open $command r]
9926 } err]} {
9927 notbusy checkout
9928 error_popup $err
9929 if {$showlocalchanges} {
9930 dodiffindex
9932 } else {
9933 filerun $fd [list readcheckoutstat $fd $newhead $headmenuid]
9937 proc readcheckoutstat {fd newhead newheadid} {
9938 global mainhead mainheadid headids idheads showlocalchanges progresscoords
9939 global viewmainheadid curview
9941 if {[gets $fd line] >= 0} {
9942 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9943 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9944 adjustprogress
9946 return 1
9948 set progresscoords {0 0}
9949 adjustprogress
9950 notbusy checkout
9951 if {[catch {close $fd} err]} {
9952 error_popup $err
9953 return
9955 set oldmainid $mainheadid
9956 if {! [info exists headids($newhead)]} {
9957 set headids($newhead) $newheadid
9958 lappend idheads($newheadid) $newhead
9959 addedhead $newheadid $newhead
9961 set mainhead $newhead
9962 set mainheadid $newheadid
9963 set viewmainheadid($curview) $newheadid
9964 redrawtags $oldmainid
9965 redrawtags $newheadid
9966 selbyid $newheadid
9967 if {$showlocalchanges} {
9968 dodiffindex
9972 proc rmbranch {} {
9973 global headmenuid headmenuhead mainhead
9974 global idheads
9976 set head $headmenuhead
9977 set id $headmenuid
9978 # this check shouldn't be needed any more...
9979 if {$head eq $mainhead} {
9980 error_popup [mc "Cannot delete the currently checked-out branch"]
9981 return
9983 set dheads [descheads $id]
9984 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9985 # the stuff on this branch isn't on any other branch
9986 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9987 branch.\nReally delete branch %s?" $head $head]]} return
9989 nowbusy rmbranch
9990 update
9991 if {[catch {exec git branch -D $head} err]} {
9992 notbusy rmbranch
9993 error_popup $err
9994 return
9996 removehead $id $head
9997 removedhead $id $head
9998 redrawtags $id
9999 notbusy rmbranch
10000 dispneartags 0
10001 run refill_reflist
10004 # Display a list of tags and heads
10005 proc showrefs {} {
10006 global showrefstop bgcolor fgcolor selectbgcolor NS
10007 global bglist fglist reflistfilter reflist maincursor
10009 set top .showrefs
10010 set showrefstop $top
10011 if {[winfo exists $top]} {
10012 raise $top
10013 refill_reflist
10014 return
10016 ttk_toplevel $top
10017 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
10018 make_transient $top .
10019 text $top.list -background $bgcolor -foreground $fgcolor \
10020 -selectbackground $selectbgcolor -font mainfont \
10021 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
10022 -width 30 -height 20 -cursor $maincursor \
10023 -spacing1 1 -spacing3 1 -state disabled
10024 $top.list tag configure highlight -background $selectbgcolor
10025 if {![lsearch -exact $bglist $top.list]} {
10026 lappend bglist $top.list
10027 lappend fglist $top.list
10029 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
10030 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
10031 grid $top.list $top.ysb -sticky nsew
10032 grid $top.xsb x -sticky ew
10033 ${NS}::frame $top.f
10034 ${NS}::label $top.f.l -text "[mc "Filter"]: "
10035 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
10036 set reflistfilter "*"
10037 trace add variable reflistfilter write reflistfilter_change
10038 pack $top.f.e -side right -fill x -expand 1
10039 pack $top.f.l -side left
10040 grid $top.f - -sticky ew -pady 2
10041 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
10042 bind $top <Key-Escape> [list destroy $top]
10043 grid $top.close -
10044 grid columnconfigure $top 0 -weight 1
10045 grid rowconfigure $top 0 -weight 1
10046 bind $top.list <1> {break}
10047 bind $top.list <B1-Motion> {break}
10048 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
10049 set reflist {}
10050 refill_reflist
10053 proc sel_reflist {w x y} {
10054 global showrefstop reflist headids tagids otherrefids
10056 if {![winfo exists $showrefstop]} return
10057 set l [lindex [split [$w index "@$x,$y"] "."] 0]
10058 set ref [lindex $reflist [expr {$l-1}]]
10059 set n [lindex $ref 0]
10060 switch -- [lindex $ref 1] {
10061 "H" {selbyid $headids($n)}
10062 "R" {selbyid $headids($n)}
10063 "T" {selbyid $tagids($n)}
10064 "o" {selbyid $otherrefids($n)}
10066 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
10069 proc unsel_reflist {} {
10070 global showrefstop
10072 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10073 $showrefstop.list tag remove highlight 0.0 end
10076 proc reflistfilter_change {n1 n2 op} {
10077 global reflistfilter
10079 after cancel refill_reflist
10080 after 200 refill_reflist
10083 proc refill_reflist {} {
10084 global reflist reflistfilter showrefstop headids tagids otherrefids
10085 global curview
10087 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10088 set refs {}
10089 foreach n [array names headids] {
10090 if {[string match $reflistfilter $n]} {
10091 if {[commitinview $headids($n) $curview]} {
10092 if {[string match "remotes/*" $n]} {
10093 lappend refs [list $n R]
10094 } else {
10095 lappend refs [list $n H]
10097 } else {
10098 interestedin $headids($n) {run refill_reflist}
10102 foreach n [array names tagids] {
10103 if {[string match $reflistfilter $n]} {
10104 if {[commitinview $tagids($n) $curview]} {
10105 lappend refs [list $n T]
10106 } else {
10107 interestedin $tagids($n) {run refill_reflist}
10111 foreach n [array names otherrefids] {
10112 if {[string match $reflistfilter $n]} {
10113 if {[commitinview $otherrefids($n) $curview]} {
10114 lappend refs [list $n o]
10115 } else {
10116 interestedin $otherrefids($n) {run refill_reflist}
10120 set refs [lsort -index 0 $refs]
10121 if {$refs eq $reflist} return
10123 # Update the contents of $showrefstop.list according to the
10124 # differences between $reflist (old) and $refs (new)
10125 $showrefstop.list conf -state normal
10126 $showrefstop.list insert end "\n"
10127 set i 0
10128 set j 0
10129 while {$i < [llength $reflist] || $j < [llength $refs]} {
10130 if {$i < [llength $reflist]} {
10131 if {$j < [llength $refs]} {
10132 set cmp [string compare [lindex $reflist $i 0] \
10133 [lindex $refs $j 0]]
10134 if {$cmp == 0} {
10135 set cmp [string compare [lindex $reflist $i 1] \
10136 [lindex $refs $j 1]]
10138 } else {
10139 set cmp -1
10141 } else {
10142 set cmp 1
10144 switch -- $cmp {
10145 -1 {
10146 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
10147 incr i
10150 incr i
10151 incr j
10154 set l [expr {$j + 1}]
10155 $showrefstop.list image create $l.0 -align baseline \
10156 -image reficon-[lindex $refs $j 1] -padx 2
10157 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
10158 incr j
10162 set reflist $refs
10163 # delete last newline
10164 $showrefstop.list delete end-2c end-1c
10165 $showrefstop.list conf -state disabled
10168 # Stuff for finding nearby tags
10169 proc getallcommits {} {
10170 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
10171 global idheads idtags idotherrefs allparents tagobjid
10172 global gitdir
10174 if {![info exists allcommits]} {
10175 set nextarc 0
10176 set allcommits 0
10177 set seeds {}
10178 set allcwait 0
10179 set cachedarcs 0
10180 set allccache [file join $gitdir "gitk.cache"]
10181 if {![catch {
10182 set f [open $allccache r]
10183 set allcwait 1
10184 getcache $f
10185 }]} return
10188 if {$allcwait} {
10189 return
10191 set cmd [list | git rev-list --parents]
10192 set allcupdate [expr {$seeds ne {}}]
10193 if {!$allcupdate} {
10194 set ids "--all"
10195 } else {
10196 set refs [concat [array names idheads] [array names idtags] \
10197 [array names idotherrefs]]
10198 set ids {}
10199 set tagobjs {}
10200 foreach name [array names tagobjid] {
10201 lappend tagobjs $tagobjid($name)
10203 foreach id [lsort -unique $refs] {
10204 if {![info exists allparents($id)] &&
10205 [lsearch -exact $tagobjs $id] < 0} {
10206 lappend ids $id
10209 if {$ids ne {}} {
10210 foreach id $seeds {
10211 lappend ids "^$id"
10215 if {$ids ne {}} {
10216 set fd [open [concat $cmd $ids] r]
10217 fconfigure $fd -blocking 0
10218 incr allcommits
10219 nowbusy allcommits
10220 filerun $fd [list getallclines $fd]
10221 } else {
10222 dispneartags 0
10226 # Since most commits have 1 parent and 1 child, we group strings of
10227 # such commits into "arcs" joining branch/merge points (BMPs), which
10228 # are commits that either don't have 1 parent or don't have 1 child.
10230 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10231 # arcout(id) - outgoing arcs for BMP
10232 # arcids(a) - list of IDs on arc including end but not start
10233 # arcstart(a) - BMP ID at start of arc
10234 # arcend(a) - BMP ID at end of arc
10235 # growing(a) - arc a is still growing
10236 # arctags(a) - IDs out of arcids (excluding end) that have tags
10237 # archeads(a) - IDs out of arcids (excluding end) that have heads
10238 # The start of an arc is at the descendent end, so "incoming" means
10239 # coming from descendents, and "outgoing" means going towards ancestors.
10241 proc getallclines {fd} {
10242 global allparents allchildren idtags idheads nextarc
10243 global arcnos arcids arctags arcout arcend arcstart archeads growing
10244 global seeds allcommits cachedarcs allcupdate
10246 set nid 0
10247 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10248 set id [lindex $line 0]
10249 if {[info exists allparents($id)]} {
10250 # seen it already
10251 continue
10253 set cachedarcs 0
10254 set olds [lrange $line 1 end]
10255 set allparents($id) $olds
10256 if {![info exists allchildren($id)]} {
10257 set allchildren($id) {}
10258 set arcnos($id) {}
10259 lappend seeds $id
10260 } else {
10261 set a $arcnos($id)
10262 if {[llength $olds] == 1 && [llength $a] == 1} {
10263 lappend arcids($a) $id
10264 if {[info exists idtags($id)]} {
10265 lappend arctags($a) $id
10267 if {[info exists idheads($id)]} {
10268 lappend archeads($a) $id
10270 if {[info exists allparents($olds)]} {
10271 # seen parent already
10272 if {![info exists arcout($olds)]} {
10273 splitarc $olds
10275 lappend arcids($a) $olds
10276 set arcend($a) $olds
10277 unset growing($a)
10279 lappend allchildren($olds) $id
10280 lappend arcnos($olds) $a
10281 continue
10284 foreach a $arcnos($id) {
10285 lappend arcids($a) $id
10286 set arcend($a) $id
10287 unset growing($a)
10290 set ao {}
10291 foreach p $olds {
10292 lappend allchildren($p) $id
10293 set a [incr nextarc]
10294 set arcstart($a) $id
10295 set archeads($a) {}
10296 set arctags($a) {}
10297 set archeads($a) {}
10298 set arcids($a) {}
10299 lappend ao $a
10300 set growing($a) 1
10301 if {[info exists allparents($p)]} {
10302 # seen it already, may need to make a new branch
10303 if {![info exists arcout($p)]} {
10304 splitarc $p
10306 lappend arcids($a) $p
10307 set arcend($a) $p
10308 unset growing($a)
10310 lappend arcnos($p) $a
10312 set arcout($id) $ao
10314 if {$nid > 0} {
10315 global cached_dheads cached_dtags cached_atags
10316 unset -nocomplain cached_dheads
10317 unset -nocomplain cached_dtags
10318 unset -nocomplain cached_atags
10320 if {![eof $fd]} {
10321 return [expr {$nid >= 1000? 2: 1}]
10323 set cacheok 1
10324 if {[catch {
10325 fconfigure $fd -blocking 1
10326 close $fd
10327 } err]} {
10328 # got an error reading the list of commits
10329 # if we were updating, try rereading the whole thing again
10330 if {$allcupdate} {
10331 incr allcommits -1
10332 dropcache $err
10333 return
10335 error_popup "[mc "Error reading commit topology information;\
10336 branch and preceding/following tag information\
10337 will be incomplete."]\n($err)"
10338 set cacheok 0
10340 if {[incr allcommits -1] == 0} {
10341 notbusy allcommits
10342 if {$cacheok} {
10343 run savecache
10346 dispneartags 0
10347 return 0
10350 proc recalcarc {a} {
10351 global arctags archeads arcids idtags idheads
10353 set at {}
10354 set ah {}
10355 foreach id [lrange $arcids($a) 0 end-1] {
10356 if {[info exists idtags($id)]} {
10357 lappend at $id
10359 if {[info exists idheads($id)]} {
10360 lappend ah $id
10363 set arctags($a) $at
10364 set archeads($a) $ah
10367 proc splitarc {p} {
10368 global arcnos arcids nextarc arctags archeads idtags idheads
10369 global arcstart arcend arcout allparents growing
10371 set a $arcnos($p)
10372 if {[llength $a] != 1} {
10373 puts "oops splitarc called but [llength $a] arcs already"
10374 return
10376 set a [lindex $a 0]
10377 set i [lsearch -exact $arcids($a) $p]
10378 if {$i < 0} {
10379 puts "oops splitarc $p not in arc $a"
10380 return
10382 set na [incr nextarc]
10383 if {[info exists arcend($a)]} {
10384 set arcend($na) $arcend($a)
10385 } else {
10386 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10387 set j [lsearch -exact $arcnos($l) $a]
10388 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10390 set tail [lrange $arcids($a) [expr {$i+1}] end]
10391 set arcids($a) [lrange $arcids($a) 0 $i]
10392 set arcend($a) $p
10393 set arcstart($na) $p
10394 set arcout($p) $na
10395 set arcids($na) $tail
10396 if {[info exists growing($a)]} {
10397 set growing($na) 1
10398 unset growing($a)
10401 foreach id $tail {
10402 if {[llength $arcnos($id)] == 1} {
10403 set arcnos($id) $na
10404 } else {
10405 set j [lsearch -exact $arcnos($id) $a]
10406 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10410 # reconstruct tags and heads lists
10411 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10412 recalcarc $a
10413 recalcarc $na
10414 } else {
10415 set arctags($na) {}
10416 set archeads($na) {}
10420 # Update things for a new commit added that is a child of one
10421 # existing commit. Used when cherry-picking.
10422 proc addnewchild {id p} {
10423 global allparents allchildren idtags nextarc
10424 global arcnos arcids arctags arcout arcend arcstart archeads growing
10425 global seeds allcommits
10427 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10428 set allparents($id) [list $p]
10429 set allchildren($id) {}
10430 set arcnos($id) {}
10431 lappend seeds $id
10432 lappend allchildren($p) $id
10433 set a [incr nextarc]
10434 set arcstart($a) $id
10435 set archeads($a) {}
10436 set arctags($a) {}
10437 set arcids($a) [list $p]
10438 set arcend($a) $p
10439 if {![info exists arcout($p)]} {
10440 splitarc $p
10442 lappend arcnos($p) $a
10443 set arcout($id) [list $a]
10446 # This implements a cache for the topology information.
10447 # The cache saves, for each arc, the start and end of the arc,
10448 # the ids on the arc, and the outgoing arcs from the end.
10449 proc readcache {f} {
10450 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10451 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10452 global allcwait
10454 set a $nextarc
10455 set lim $cachedarcs
10456 if {$lim - $a > 500} {
10457 set lim [expr {$a + 500}]
10459 if {[catch {
10460 if {$a == $lim} {
10461 # finish reading the cache and setting up arctags, etc.
10462 set line [gets $f]
10463 if {$line ne "1"} {error "bad final version"}
10464 close $f
10465 foreach id [array names idtags] {
10466 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10467 [llength $allparents($id)] == 1} {
10468 set a [lindex $arcnos($id) 0]
10469 if {$arctags($a) eq {}} {
10470 recalcarc $a
10474 foreach id [array names idheads] {
10475 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10476 [llength $allparents($id)] == 1} {
10477 set a [lindex $arcnos($id) 0]
10478 if {$archeads($a) eq {}} {
10479 recalcarc $a
10483 foreach id [lsort -unique $possible_seeds] {
10484 if {$arcnos($id) eq {}} {
10485 lappend seeds $id
10488 set allcwait 0
10489 } else {
10490 while {[incr a] <= $lim} {
10491 set line [gets $f]
10492 if {[llength $line] != 3} {error "bad line"}
10493 set s [lindex $line 0]
10494 set arcstart($a) $s
10495 lappend arcout($s) $a
10496 if {![info exists arcnos($s)]} {
10497 lappend possible_seeds $s
10498 set arcnos($s) {}
10500 set e [lindex $line 1]
10501 if {$e eq {}} {
10502 set growing($a) 1
10503 } else {
10504 set arcend($a) $e
10505 if {![info exists arcout($e)]} {
10506 set arcout($e) {}
10509 set arcids($a) [lindex $line 2]
10510 foreach id $arcids($a) {
10511 lappend allparents($s) $id
10512 set s $id
10513 lappend arcnos($id) $a
10515 if {![info exists allparents($s)]} {
10516 set allparents($s) {}
10518 set arctags($a) {}
10519 set archeads($a) {}
10521 set nextarc [expr {$a - 1}]
10523 } err]} {
10524 dropcache $err
10525 return 0
10527 if {!$allcwait} {
10528 getallcommits
10530 return $allcwait
10533 proc getcache {f} {
10534 global nextarc cachedarcs possible_seeds
10536 if {[catch {
10537 set line [gets $f]
10538 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10539 # make sure it's an integer
10540 set cachedarcs [expr {int([lindex $line 1])}]
10541 if {$cachedarcs < 0} {error "bad number of arcs"}
10542 set nextarc 0
10543 set possible_seeds {}
10544 run readcache $f
10545 } err]} {
10546 dropcache $err
10548 return 0
10551 proc dropcache {err} {
10552 global allcwait nextarc cachedarcs seeds
10554 #puts "dropping cache ($err)"
10555 foreach v {arcnos arcout arcids arcstart arcend growing \
10556 arctags archeads allparents allchildren} {
10557 global $v
10558 unset -nocomplain $v
10560 set allcwait 0
10561 set nextarc 0
10562 set cachedarcs 0
10563 set seeds {}
10564 getallcommits
10567 proc writecache {f} {
10568 global cachearc cachedarcs allccache
10569 global arcstart arcend arcnos arcids arcout
10571 set a $cachearc
10572 set lim $cachedarcs
10573 if {$lim - $a > 1000} {
10574 set lim [expr {$a + 1000}]
10576 if {[catch {
10577 while {[incr a] <= $lim} {
10578 if {[info exists arcend($a)]} {
10579 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10580 } else {
10581 puts $f [list $arcstart($a) {} $arcids($a)]
10584 } err]} {
10585 catch {close $f}
10586 catch {file delete $allccache}
10587 #puts "writing cache failed ($err)"
10588 return 0
10590 set cachearc [expr {$a - 1}]
10591 if {$a > $cachedarcs} {
10592 puts $f "1"
10593 close $f
10594 return 0
10596 return 1
10599 proc savecache {} {
10600 global nextarc cachedarcs cachearc allccache
10602 if {$nextarc == $cachedarcs} return
10603 set cachearc 0
10604 set cachedarcs $nextarc
10605 catch {
10606 set f [open $allccache w]
10607 puts $f [list 1 $cachedarcs]
10608 run writecache $f
10612 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10613 # or 0 if neither is true.
10614 proc anc_or_desc {a b} {
10615 global arcout arcstart arcend arcnos cached_isanc
10617 if {$arcnos($a) eq $arcnos($b)} {
10618 # Both are on the same arc(s); either both are the same BMP,
10619 # or if one is not a BMP, the other is also not a BMP or is
10620 # the BMP at end of the arc (and it only has 1 incoming arc).
10621 # Or both can be BMPs with no incoming arcs.
10622 if {$a eq $b || $arcnos($a) eq {}} {
10623 return 0
10625 # assert {[llength $arcnos($a)] == 1}
10626 set arc [lindex $arcnos($a) 0]
10627 set i [lsearch -exact $arcids($arc) $a]
10628 set j [lsearch -exact $arcids($arc) $b]
10629 if {$i < 0 || $i > $j} {
10630 return 1
10631 } else {
10632 return -1
10636 if {![info exists arcout($a)]} {
10637 set arc [lindex $arcnos($a) 0]
10638 if {[info exists arcend($arc)]} {
10639 set aend $arcend($arc)
10640 } else {
10641 set aend {}
10643 set a $arcstart($arc)
10644 } else {
10645 set aend $a
10647 if {![info exists arcout($b)]} {
10648 set arc [lindex $arcnos($b) 0]
10649 if {[info exists arcend($arc)]} {
10650 set bend $arcend($arc)
10651 } else {
10652 set bend {}
10654 set b $arcstart($arc)
10655 } else {
10656 set bend $b
10658 if {$a eq $bend} {
10659 return 1
10661 if {$b eq $aend} {
10662 return -1
10664 if {[info exists cached_isanc($a,$bend)]} {
10665 if {$cached_isanc($a,$bend)} {
10666 return 1
10669 if {[info exists cached_isanc($b,$aend)]} {
10670 if {$cached_isanc($b,$aend)} {
10671 return -1
10673 if {[info exists cached_isanc($a,$bend)]} {
10674 return 0
10678 set todo [list $a $b]
10679 set anc($a) a
10680 set anc($b) b
10681 for {set i 0} {$i < [llength $todo]} {incr i} {
10682 set x [lindex $todo $i]
10683 if {$anc($x) eq {}} {
10684 continue
10686 foreach arc $arcnos($x) {
10687 set xd $arcstart($arc)
10688 if {$xd eq $bend} {
10689 set cached_isanc($a,$bend) 1
10690 set cached_isanc($b,$aend) 0
10691 return 1
10692 } elseif {$xd eq $aend} {
10693 set cached_isanc($b,$aend) 1
10694 set cached_isanc($a,$bend) 0
10695 return -1
10697 if {![info exists anc($xd)]} {
10698 set anc($xd) $anc($x)
10699 lappend todo $xd
10700 } elseif {$anc($xd) ne $anc($x)} {
10701 set anc($xd) {}
10705 set cached_isanc($a,$bend) 0
10706 set cached_isanc($b,$aend) 0
10707 return 0
10710 # This identifies whether $desc has an ancestor that is
10711 # a growing tip of the graph and which is not an ancestor of $anc
10712 # and returns 0 if so and 1 if not.
10713 # If we subsequently discover a tag on such a growing tip, and that
10714 # turns out to be a descendent of $anc (which it could, since we
10715 # don't necessarily see children before parents), then $desc
10716 # isn't a good choice to display as a descendent tag of
10717 # $anc (since it is the descendent of another tag which is
10718 # a descendent of $anc). Similarly, $anc isn't a good choice to
10719 # display as a ancestor tag of $desc.
10721 proc is_certain {desc anc} {
10722 global arcnos arcout arcstart arcend growing problems
10724 set certain {}
10725 if {[llength $arcnos($anc)] == 1} {
10726 # tags on the same arc are certain
10727 if {$arcnos($desc) eq $arcnos($anc)} {
10728 return 1
10730 if {![info exists arcout($anc)]} {
10731 # if $anc is partway along an arc, use the start of the arc instead
10732 set a [lindex $arcnos($anc) 0]
10733 set anc $arcstart($a)
10736 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10737 set x $desc
10738 } else {
10739 set a [lindex $arcnos($desc) 0]
10740 set x $arcend($a)
10742 if {$x == $anc} {
10743 return 1
10745 set anclist [list $x]
10746 set dl($x) 1
10747 set nnh 1
10748 set ngrowanc 0
10749 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10750 set x [lindex $anclist $i]
10751 if {$dl($x)} {
10752 incr nnh -1
10754 set done($x) 1
10755 foreach a $arcout($x) {
10756 if {[info exists growing($a)]} {
10757 if {![info exists growanc($x)] && $dl($x)} {
10758 set growanc($x) 1
10759 incr ngrowanc
10761 } else {
10762 set y $arcend($a)
10763 if {[info exists dl($y)]} {
10764 if {$dl($y)} {
10765 if {!$dl($x)} {
10766 set dl($y) 0
10767 if {![info exists done($y)]} {
10768 incr nnh -1
10770 if {[info exists growanc($x)]} {
10771 incr ngrowanc -1
10773 set xl [list $y]
10774 for {set k 0} {$k < [llength $xl]} {incr k} {
10775 set z [lindex $xl $k]
10776 foreach c $arcout($z) {
10777 if {[info exists arcend($c)]} {
10778 set v $arcend($c)
10779 if {[info exists dl($v)] && $dl($v)} {
10780 set dl($v) 0
10781 if {![info exists done($v)]} {
10782 incr nnh -1
10784 if {[info exists growanc($v)]} {
10785 incr ngrowanc -1
10787 lappend xl $v
10794 } elseif {$y eq $anc || !$dl($x)} {
10795 set dl($y) 0
10796 lappend anclist $y
10797 } else {
10798 set dl($y) 1
10799 lappend anclist $y
10800 incr nnh
10805 foreach x [array names growanc] {
10806 if {$dl($x)} {
10807 return 0
10809 return 0
10811 return 1
10814 proc validate_arctags {a} {
10815 global arctags idtags
10817 set i -1
10818 set na $arctags($a)
10819 foreach id $arctags($a) {
10820 incr i
10821 if {![info exists idtags($id)]} {
10822 set na [lreplace $na $i $i]
10823 incr i -1
10826 set arctags($a) $na
10829 proc validate_archeads {a} {
10830 global archeads idheads
10832 set i -1
10833 set na $archeads($a)
10834 foreach id $archeads($a) {
10835 incr i
10836 if {![info exists idheads($id)]} {
10837 set na [lreplace $na $i $i]
10838 incr i -1
10841 set archeads($a) $na
10844 # Return the list of IDs that have tags that are descendents of id,
10845 # ignoring IDs that are descendents of IDs already reported.
10846 proc desctags {id} {
10847 global arcnos arcstart arcids arctags idtags allparents
10848 global growing cached_dtags
10850 if {![info exists allparents($id)]} {
10851 return {}
10853 set t1 [clock clicks -milliseconds]
10854 set argid $id
10855 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10856 # part-way along an arc; check that arc first
10857 set a [lindex $arcnos($id) 0]
10858 if {$arctags($a) ne {}} {
10859 validate_arctags $a
10860 set i [lsearch -exact $arcids($a) $id]
10861 set tid {}
10862 foreach t $arctags($a) {
10863 set j [lsearch -exact $arcids($a) $t]
10864 if {$j >= $i} break
10865 set tid $t
10867 if {$tid ne {}} {
10868 return $tid
10871 set id $arcstart($a)
10872 if {[info exists idtags($id)]} {
10873 return $id
10876 if {[info exists cached_dtags($id)]} {
10877 return $cached_dtags($id)
10880 set origid $id
10881 set todo [list $id]
10882 set queued($id) 1
10883 set nc 1
10884 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10885 set id [lindex $todo $i]
10886 set done($id) 1
10887 set ta [info exists hastaggedancestor($id)]
10888 if {!$ta} {
10889 incr nc -1
10891 # ignore tags on starting node
10892 if {!$ta && $i > 0} {
10893 if {[info exists idtags($id)]} {
10894 set tagloc($id) $id
10895 set ta 1
10896 } elseif {[info exists cached_dtags($id)]} {
10897 set tagloc($id) $cached_dtags($id)
10898 set ta 1
10901 foreach a $arcnos($id) {
10902 set d $arcstart($a)
10903 if {!$ta && $arctags($a) ne {}} {
10904 validate_arctags $a
10905 if {$arctags($a) ne {}} {
10906 lappend tagloc($id) [lindex $arctags($a) end]
10909 if {$ta || $arctags($a) ne {}} {
10910 set tomark [list $d]
10911 for {set j 0} {$j < [llength $tomark]} {incr j} {
10912 set dd [lindex $tomark $j]
10913 if {![info exists hastaggedancestor($dd)]} {
10914 if {[info exists done($dd)]} {
10915 foreach b $arcnos($dd) {
10916 lappend tomark $arcstart($b)
10918 if {[info exists tagloc($dd)]} {
10919 unset tagloc($dd)
10921 } elseif {[info exists queued($dd)]} {
10922 incr nc -1
10924 set hastaggedancestor($dd) 1
10928 if {![info exists queued($d)]} {
10929 lappend todo $d
10930 set queued($d) 1
10931 if {![info exists hastaggedancestor($d)]} {
10932 incr nc
10937 set tags {}
10938 foreach id [array names tagloc] {
10939 if {![info exists hastaggedancestor($id)]} {
10940 foreach t $tagloc($id) {
10941 if {[lsearch -exact $tags $t] < 0} {
10942 lappend tags $t
10947 set t2 [clock clicks -milliseconds]
10948 set loopix $i
10950 # remove tags that are descendents of other tags
10951 for {set i 0} {$i < [llength $tags]} {incr i} {
10952 set a [lindex $tags $i]
10953 for {set j 0} {$j < $i} {incr j} {
10954 set b [lindex $tags $j]
10955 set r [anc_or_desc $a $b]
10956 if {$r == 1} {
10957 set tags [lreplace $tags $j $j]
10958 incr j -1
10959 incr i -1
10960 } elseif {$r == -1} {
10961 set tags [lreplace $tags $i $i]
10962 incr i -1
10963 break
10968 if {[array names growing] ne {}} {
10969 # graph isn't finished, need to check if any tag could get
10970 # eclipsed by another tag coming later. Simply ignore any
10971 # tags that could later get eclipsed.
10972 set ctags {}
10973 foreach t $tags {
10974 if {[is_certain $t $origid]} {
10975 lappend ctags $t
10978 if {$tags eq $ctags} {
10979 set cached_dtags($origid) $tags
10980 } else {
10981 set tags $ctags
10983 } else {
10984 set cached_dtags($origid) $tags
10986 set t3 [clock clicks -milliseconds]
10987 if {0 && $t3 - $t1 >= 100} {
10988 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10989 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10991 return $tags
10994 proc anctags {id} {
10995 global arcnos arcids arcout arcend arctags idtags allparents
10996 global growing cached_atags
10998 if {![info exists allparents($id)]} {
10999 return {}
11001 set t1 [clock clicks -milliseconds]
11002 set argid $id
11003 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
11004 # part-way along an arc; check that arc first
11005 set a [lindex $arcnos($id) 0]
11006 if {$arctags($a) ne {}} {
11007 validate_arctags $a
11008 set i [lsearch -exact $arcids($a) $id]
11009 foreach t $arctags($a) {
11010 set j [lsearch -exact $arcids($a) $t]
11011 if {$j > $i} {
11012 return $t
11016 if {![info exists arcend($a)]} {
11017 return {}
11019 set id $arcend($a)
11020 if {[info exists idtags($id)]} {
11021 return $id
11024 if {[info exists cached_atags($id)]} {
11025 return $cached_atags($id)
11028 set origid $id
11029 set todo [list $id]
11030 set queued($id) 1
11031 set taglist {}
11032 set nc 1
11033 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
11034 set id [lindex $todo $i]
11035 set done($id) 1
11036 set td [info exists hastaggeddescendent($id)]
11037 if {!$td} {
11038 incr nc -1
11040 # ignore tags on starting node
11041 if {!$td && $i > 0} {
11042 if {[info exists idtags($id)]} {
11043 set tagloc($id) $id
11044 set td 1
11045 } elseif {[info exists cached_atags($id)]} {
11046 set tagloc($id) $cached_atags($id)
11047 set td 1
11050 foreach a $arcout($id) {
11051 if {!$td && $arctags($a) ne {}} {
11052 validate_arctags $a
11053 if {$arctags($a) ne {}} {
11054 lappend tagloc($id) [lindex $arctags($a) 0]
11057 if {![info exists arcend($a)]} continue
11058 set d $arcend($a)
11059 if {$td || $arctags($a) ne {}} {
11060 set tomark [list $d]
11061 for {set j 0} {$j < [llength $tomark]} {incr j} {
11062 set dd [lindex $tomark $j]
11063 if {![info exists hastaggeddescendent($dd)]} {
11064 if {[info exists done($dd)]} {
11065 foreach b $arcout($dd) {
11066 if {[info exists arcend($b)]} {
11067 lappend tomark $arcend($b)
11070 if {[info exists tagloc($dd)]} {
11071 unset tagloc($dd)
11073 } elseif {[info exists queued($dd)]} {
11074 incr nc -1
11076 set hastaggeddescendent($dd) 1
11080 if {![info exists queued($d)]} {
11081 lappend todo $d
11082 set queued($d) 1
11083 if {![info exists hastaggeddescendent($d)]} {
11084 incr nc
11089 set t2 [clock clicks -milliseconds]
11090 set loopix $i
11091 set tags {}
11092 foreach id [array names tagloc] {
11093 if {![info exists hastaggeddescendent($id)]} {
11094 foreach t $tagloc($id) {
11095 if {[lsearch -exact $tags $t] < 0} {
11096 lappend tags $t
11102 # remove tags that are ancestors of other tags
11103 for {set i 0} {$i < [llength $tags]} {incr i} {
11104 set a [lindex $tags $i]
11105 for {set j 0} {$j < $i} {incr j} {
11106 set b [lindex $tags $j]
11107 set r [anc_or_desc $a $b]
11108 if {$r == -1} {
11109 set tags [lreplace $tags $j $j]
11110 incr j -1
11111 incr i -1
11112 } elseif {$r == 1} {
11113 set tags [lreplace $tags $i $i]
11114 incr i -1
11115 break
11120 if {[array names growing] ne {}} {
11121 # graph isn't finished, need to check if any tag could get
11122 # eclipsed by another tag coming later. Simply ignore any
11123 # tags that could later get eclipsed.
11124 set ctags {}
11125 foreach t $tags {
11126 if {[is_certain $origid $t]} {
11127 lappend ctags $t
11130 if {$tags eq $ctags} {
11131 set cached_atags($origid) $tags
11132 } else {
11133 set tags $ctags
11135 } else {
11136 set cached_atags($origid) $tags
11138 set t3 [clock clicks -milliseconds]
11139 if {0 && $t3 - $t1 >= 100} {
11140 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
11141 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
11143 return $tags
11146 # Return the list of IDs that have heads that are descendents of id,
11147 # including id itself if it has a head.
11148 proc descheads {id} {
11149 global arcnos arcstart arcids archeads idheads cached_dheads
11150 global allparents arcout
11152 if {![info exists allparents($id)]} {
11153 return {}
11155 set aret {}
11156 if {![info exists arcout($id)]} {
11157 # part-way along an arc; check it first
11158 set a [lindex $arcnos($id) 0]
11159 if {$archeads($a) ne {}} {
11160 validate_archeads $a
11161 set i [lsearch -exact $arcids($a) $id]
11162 foreach t $archeads($a) {
11163 set j [lsearch -exact $arcids($a) $t]
11164 if {$j > $i} break
11165 lappend aret $t
11168 set id $arcstart($a)
11170 set origid $id
11171 set todo [list $id]
11172 set seen($id) 1
11173 set ret {}
11174 for {set i 0} {$i < [llength $todo]} {incr i} {
11175 set id [lindex $todo $i]
11176 if {[info exists cached_dheads($id)]} {
11177 set ret [concat $ret $cached_dheads($id)]
11178 } else {
11179 if {[info exists idheads($id)]} {
11180 lappend ret $id
11182 foreach a $arcnos($id) {
11183 if {$archeads($a) ne {}} {
11184 validate_archeads $a
11185 if {$archeads($a) ne {}} {
11186 set ret [concat $ret $archeads($a)]
11189 set d $arcstart($a)
11190 if {![info exists seen($d)]} {
11191 lappend todo $d
11192 set seen($d) 1
11197 set ret [lsort -unique $ret]
11198 set cached_dheads($origid) $ret
11199 return [concat $ret $aret]
11202 proc addedtag {id} {
11203 global arcnos arcout cached_dtags cached_atags
11205 if {![info exists arcnos($id)]} return
11206 if {![info exists arcout($id)]} {
11207 recalcarc [lindex $arcnos($id) 0]
11209 unset -nocomplain cached_dtags
11210 unset -nocomplain cached_atags
11213 proc addedhead {hid head} {
11214 global arcnos arcout cached_dheads
11216 if {![info exists arcnos($hid)]} return
11217 if {![info exists arcout($hid)]} {
11218 recalcarc [lindex $arcnos($hid) 0]
11220 unset -nocomplain cached_dheads
11223 proc removedhead {hid head} {
11224 global cached_dheads
11226 unset -nocomplain cached_dheads
11229 proc movedhead {hid head} {
11230 global arcnos arcout cached_dheads
11232 if {![info exists arcnos($hid)]} return
11233 if {![info exists arcout($hid)]} {
11234 recalcarc [lindex $arcnos($hid) 0]
11236 unset -nocomplain cached_dheads
11239 proc changedrefs {} {
11240 global cached_dheads cached_dtags cached_atags cached_tagcontent
11241 global arctags archeads arcnos arcout idheads idtags
11243 foreach id [concat [array names idheads] [array names idtags]] {
11244 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11245 set a [lindex $arcnos($id) 0]
11246 if {![info exists donearc($a)]} {
11247 recalcarc $a
11248 set donearc($a) 1
11252 unset -nocomplain cached_tagcontent
11253 unset -nocomplain cached_dtags
11254 unset -nocomplain cached_atags
11255 unset -nocomplain cached_dheads
11258 proc rereadrefs {} {
11259 global idtags idheads idotherrefs mainheadid
11261 set refids [concat [array names idtags] \
11262 [array names idheads] [array names idotherrefs]]
11263 foreach id $refids {
11264 if {![info exists ref($id)]} {
11265 set ref($id) [listrefs $id]
11268 set oldmainhead $mainheadid
11269 readrefs
11270 changedrefs
11271 set refids [lsort -unique [concat $refids [array names idtags] \
11272 [array names idheads] [array names idotherrefs]]]
11273 foreach id $refids {
11274 set v [listrefs $id]
11275 if {![info exists ref($id)] || $ref($id) != $v} {
11276 redrawtags $id
11279 if {$oldmainhead ne $mainheadid} {
11280 redrawtags $oldmainhead
11281 redrawtags $mainheadid
11283 run refill_reflist
11286 proc listrefs {id} {
11287 global idtags idheads idotherrefs
11289 set x {}
11290 if {[info exists idtags($id)]} {
11291 set x $idtags($id)
11293 set y {}
11294 if {[info exists idheads($id)]} {
11295 set y $idheads($id)
11297 set z {}
11298 if {[info exists idotherrefs($id)]} {
11299 set z $idotherrefs($id)
11301 return [list $x $y $z]
11304 proc add_tag_ctext {tag} {
11305 global ctext cached_tagcontent tagids
11307 if {![info exists cached_tagcontent($tag)]} {
11308 catch {
11309 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11312 $ctext insert end "[mc "Tag"]: $tag\n" bold
11313 if {[info exists cached_tagcontent($tag)]} {
11314 set text $cached_tagcontent($tag)
11315 } else {
11316 set text "[mc "Id"]: $tagids($tag)"
11318 appendwithlinks $text {}
11321 proc showtag {tag isnew} {
11322 global ctext cached_tagcontent tagids linknum tagobjid
11324 if {$isnew} {
11325 addtohistory [list showtag $tag 0] savectextpos
11327 $ctext conf -state normal
11328 clear_ctext
11329 settabs 0
11330 set linknum 0
11331 add_tag_ctext $tag
11332 maybe_scroll_ctext 1
11333 $ctext conf -state disabled
11334 init_flist {}
11337 proc showtags {id isnew} {
11338 global idtags ctext linknum
11340 if {$isnew} {
11341 addtohistory [list showtags $id 0] savectextpos
11343 $ctext conf -state normal
11344 clear_ctext
11345 settabs 0
11346 set linknum 0
11347 set sep {}
11348 foreach tag $idtags($id) {
11349 $ctext insert end $sep
11350 add_tag_ctext $tag
11351 set sep "\n\n"
11353 maybe_scroll_ctext 1
11354 $ctext conf -state disabled
11355 init_flist {}
11358 proc doquit {} {
11359 global stopped
11360 global gitktmpdir
11362 set stopped 100
11363 savestuff .
11364 destroy .
11366 if {[info exists gitktmpdir]} {
11367 catch {file delete -force $gitktmpdir}
11371 proc mkfontdisp {font top which} {
11372 global fontattr fontpref $font NS use_ttk
11374 set fontpref($font) [set $font]
11375 ${NS}::button $top.${font}but -text $which \
11376 -command [list choosefont $font $which]
11377 ${NS}::label $top.$font -relief flat -font $font \
11378 -text $fontattr($font,family) -justify left
11379 grid x $top.${font}but $top.$font -sticky w
11382 proc choosefont {font which} {
11383 global fontparam fontlist fonttop fontattr
11384 global prefstop NS
11386 set fontparam(which) $which
11387 set fontparam(font) $font
11388 set fontparam(family) [font actual $font -family]
11389 set fontparam(size) $fontattr($font,size)
11390 set fontparam(weight) $fontattr($font,weight)
11391 set fontparam(slant) $fontattr($font,slant)
11392 set top .gitkfont
11393 set fonttop $top
11394 if {![winfo exists $top]} {
11395 font create sample
11396 eval font config sample [font actual $font]
11397 ttk_toplevel $top
11398 make_transient $top $prefstop
11399 wm title $top [mc "Gitk font chooser"]
11400 ${NS}::label $top.l -textvariable fontparam(which)
11401 pack $top.l -side top
11402 set fontlist [lsort [font families]]
11403 ${NS}::frame $top.f
11404 listbox $top.f.fam -listvariable fontlist \
11405 -yscrollcommand [list $top.f.sb set]
11406 bind $top.f.fam <<ListboxSelect>> selfontfam
11407 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11408 pack $top.f.sb -side right -fill y
11409 pack $top.f.fam -side left -fill both -expand 1
11410 pack $top.f -side top -fill both -expand 1
11411 ${NS}::frame $top.g
11412 spinbox $top.g.size -from 4 -to 40 -width 4 \
11413 -textvariable fontparam(size) \
11414 -validatecommand {string is integer -strict %s}
11415 checkbutton $top.g.bold -padx 5 \
11416 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11417 -variable fontparam(weight) -onvalue bold -offvalue normal
11418 checkbutton $top.g.ital -padx 5 \
11419 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11420 -variable fontparam(slant) -onvalue italic -offvalue roman
11421 pack $top.g.size $top.g.bold $top.g.ital -side left
11422 pack $top.g -side top
11423 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11424 -background white
11425 $top.c create text 100 25 -anchor center -text $which -font sample \
11426 -fill black -tags text
11427 bind $top.c <Configure> [list centertext $top.c]
11428 pack $top.c -side top -fill x
11429 ${NS}::frame $top.buts
11430 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11431 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11432 bind $top <Key-Return> fontok
11433 bind $top <Key-Escape> fontcan
11434 grid $top.buts.ok $top.buts.can
11435 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11436 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11437 pack $top.buts -side bottom -fill x
11438 trace add variable fontparam write chg_fontparam
11439 } else {
11440 raise $top
11441 $top.c itemconf text -text $which
11443 set i [lsearch -exact $fontlist $fontparam(family)]
11444 if {$i >= 0} {
11445 $top.f.fam selection set $i
11446 $top.f.fam see $i
11450 proc centertext {w} {
11451 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11454 proc fontok {} {
11455 global fontparam fontpref prefstop
11457 set f $fontparam(font)
11458 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11459 if {$fontparam(weight) eq "bold"} {
11460 lappend fontpref($f) "bold"
11462 if {$fontparam(slant) eq "italic"} {
11463 lappend fontpref($f) "italic"
11465 set w $prefstop.notebook.fonts.$f
11466 $w conf -text $fontparam(family) -font $fontpref($f)
11468 fontcan
11471 proc fontcan {} {
11472 global fonttop fontparam
11474 if {[info exists fonttop]} {
11475 catch {destroy $fonttop}
11476 catch {font delete sample}
11477 unset fonttop
11478 unset fontparam
11482 if {[package vsatisfies [package provide Tk] 8.6]} {
11483 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11484 # function to make use of it.
11485 proc choosefont {font which} {
11486 tk fontchooser configure -title $which -font $font \
11487 -command [list on_choosefont $font $which]
11488 tk fontchooser show
11490 proc on_choosefont {font which newfont} {
11491 global fontparam
11492 puts stderr "$font $newfont"
11493 array set f [font actual $newfont]
11494 set fontparam(which) $which
11495 set fontparam(font) $font
11496 set fontparam(family) $f(-family)
11497 set fontparam(size) $f(-size)
11498 set fontparam(weight) $f(-weight)
11499 set fontparam(slant) $f(-slant)
11500 fontok
11504 proc selfontfam {} {
11505 global fonttop fontparam
11507 set i [$fonttop.f.fam curselection]
11508 if {$i ne {}} {
11509 set fontparam(family) [$fonttop.f.fam get $i]
11513 proc chg_fontparam {v sub op} {
11514 global fontparam
11516 font config sample -$sub $fontparam($sub)
11519 # Create a property sheet tab page
11520 proc create_prefs_page {w} {
11521 global NS
11522 set parent [join [lrange [split $w .] 0 end-1] .]
11523 if {[winfo class $parent] eq "TNotebook"} {
11524 ${NS}::frame $w
11525 } else {
11526 ${NS}::labelframe $w
11530 proc prefspage_general {notebook} {
11531 global NS maxwidth maxgraphpct showneartags showlocalchanges
11532 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11533 global hideremotes want_ttk have_ttk maxrefs web_browser
11535 set page [create_prefs_page $notebook.general]
11537 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11538 grid $page.ldisp - -sticky w -pady 10
11539 ${NS}::label $page.spacer -text " "
11540 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11541 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11542 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11543 #xgettext:no-tcl-format
11544 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11545 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11546 grid x $page.maxpctl $page.maxpct -sticky w
11547 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11548 -variable showlocalchanges
11549 grid x $page.showlocal -sticky w
11550 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11551 -variable autoselect
11552 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11553 grid x $page.autoselect $page.autosellen -sticky w
11554 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11555 -variable hideremotes
11556 grid x $page.hideremotes -sticky w
11558 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11559 grid $page.ddisp - -sticky w -pady 10
11560 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11561 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11562 grid x $page.tabstopl $page.tabstop -sticky w
11563 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11564 -variable showneartags
11565 grid x $page.ntag -sticky w
11566 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11567 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11568 grid x $page.maxrefsl $page.maxrefs -sticky w
11569 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11570 -variable limitdiffs
11571 grid x $page.ldiff -sticky w
11572 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11573 -variable perfile_attrs
11574 grid x $page.lattr -sticky w
11576 ${NS}::entry $page.extdifft -textvariable extdifftool
11577 ${NS}::frame $page.extdifff
11578 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11579 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11580 pack $page.extdifff.l $page.extdifff.b -side left
11581 pack configure $page.extdifff.l -padx 10
11582 grid x $page.extdifff $page.extdifft -sticky ew
11584 ${NS}::entry $page.webbrowser -textvariable web_browser
11585 ${NS}::frame $page.webbrowserf
11586 ${NS}::label $page.webbrowserf.l -text [mc "Web browser" ]
11587 pack $page.webbrowserf.l -side left
11588 pack configure $page.webbrowserf.l -padx 10
11589 grid x $page.webbrowserf $page.webbrowser -sticky ew
11591 ${NS}::label $page.lgen -text [mc "General options"]
11592 grid $page.lgen - -sticky w -pady 10
11593 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11594 -text [mc "Use themed widgets"]
11595 if {$have_ttk} {
11596 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11597 } else {
11598 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11600 grid x $page.want_ttk $page.ttk_note -sticky w
11601 return $page
11604 proc prefspage_colors {notebook} {
11605 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11607 set page [create_prefs_page $notebook.colors]
11609 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11610 grid $page.cdisp - -sticky w -pady 10
11611 label $page.ui -padx 40 -relief sunk -background $uicolor
11612 ${NS}::button $page.uibut -text [mc "Interface"] \
11613 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11614 grid x $page.uibut $page.ui -sticky w
11615 label $page.bg -padx 40 -relief sunk -background $bgcolor
11616 ${NS}::button $page.bgbut -text [mc "Background"] \
11617 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11618 grid x $page.bgbut $page.bg -sticky w
11619 label $page.fg -padx 40 -relief sunk -background $fgcolor
11620 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11621 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11622 grid x $page.fgbut $page.fg -sticky w
11623 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11624 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11625 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11626 [list $ctext tag conf d0 -foreground]]
11627 grid x $page.diffoldbut $page.diffold -sticky w
11628 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11629 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11630 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11631 [list $ctext tag conf dresult -foreground]]
11632 grid x $page.diffnewbut $page.diffnew -sticky w
11633 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11634 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11635 -command [list choosecolor diffcolors 2 $page.hunksep \
11636 [mc "diff hunk header"] \
11637 [list $ctext tag conf hunksep -foreground]]
11638 grid x $page.hunksepbut $page.hunksep -sticky w
11639 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11640 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11641 -command [list choosecolor markbgcolor {} $page.markbgsep \
11642 [mc "marked line background"] \
11643 [list $ctext tag conf omark -background]]
11644 grid x $page.markbgbut $page.markbgsep -sticky w
11645 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11646 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11647 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11648 grid x $page.selbgbut $page.selbgsep -sticky w
11649 return $page
11652 proc prefspage_fonts {notebook} {
11653 global NS
11654 set page [create_prefs_page $notebook.fonts]
11655 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11656 grid $page.cfont - -sticky w -pady 10
11657 mkfontdisp mainfont $page [mc "Main font"]
11658 mkfontdisp textfont $page [mc "Diff display font"]
11659 mkfontdisp uifont $page [mc "User interface font"]
11660 return $page
11663 proc doprefs {} {
11664 global maxwidth maxgraphpct use_ttk NS
11665 global oldprefs prefstop showneartags showlocalchanges
11666 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11667 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11668 global hideremotes want_ttk have_ttk
11670 set top .gitkprefs
11671 set prefstop $top
11672 if {[winfo exists $top]} {
11673 raise $top
11674 return
11676 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11677 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11678 set oldprefs($v) [set $v]
11680 ttk_toplevel $top
11681 wm title $top [mc "Gitk preferences"]
11682 make_transient $top .
11684 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11685 set notebook [ttk::notebook $top.notebook]
11686 } else {
11687 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11690 lappend pages [prefspage_general $notebook] [mc "General"]
11691 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11692 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11693 set col 0
11694 foreach {page title} $pages {
11695 if {$use_notebook} {
11696 $notebook add $page -text $title
11697 } else {
11698 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11699 -text $title -command [list raise $page]]
11700 $page configure -text $title
11701 grid $btn -row 0 -column [incr col] -sticky w
11702 grid $page -row 1 -column 0 -sticky news -columnspan 100
11706 if {!$use_notebook} {
11707 grid columnconfigure $notebook 0 -weight 1
11708 grid rowconfigure $notebook 1 -weight 1
11709 raise [lindex $pages 0]
11712 grid $notebook -sticky news -padx 2 -pady 2
11713 grid rowconfigure $top 0 -weight 1
11714 grid columnconfigure $top 0 -weight 1
11716 ${NS}::frame $top.buts
11717 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11718 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11719 bind $top <Key-Return> prefsok
11720 bind $top <Key-Escape> prefscan
11721 grid $top.buts.ok $top.buts.can
11722 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11723 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11724 grid $top.buts - - -pady 10 -sticky ew
11725 grid columnconfigure $top 2 -weight 1
11726 bind $top <Visibility> [list focus $top.buts.ok]
11729 proc choose_extdiff {} {
11730 global extdifftool
11732 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11733 if {$prog ne {}} {
11734 set extdifftool $prog
11738 proc choosecolor {v vi w x cmd} {
11739 global $v
11741 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11742 -title [mc "Gitk: choose color for %s" $x]]
11743 if {$c eq {}} return
11744 $w conf -background $c
11745 lset $v $vi $c
11746 eval $cmd $c
11749 proc setselbg {c} {
11750 global bglist cflist
11751 foreach w $bglist {
11752 if {[winfo exists $w]} {
11753 $w configure -selectbackground $c
11756 $cflist tag configure highlight \
11757 -background [$cflist cget -selectbackground]
11758 allcanvs itemconf secsel -fill $c
11761 # This sets the background color and the color scheme for the whole UI.
11762 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11763 # if we don't specify one ourselves, which makes the checkbuttons and
11764 # radiobuttons look bad. This chooses white for selectColor if the
11765 # background color is light, or black if it is dark.
11766 proc setui {c} {
11767 if {[tk windowingsystem] eq "win32"} { return }
11768 set bg [winfo rgb . $c]
11769 set selc black
11770 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11771 set selc white
11773 tk_setPalette background $c selectColor $selc
11776 proc setbg {c} {
11777 global bglist
11779 foreach w $bglist {
11780 if {[winfo exists $w]} {
11781 $w conf -background $c
11786 proc setfg {c} {
11787 global fglist canv
11789 foreach w $fglist {
11790 if {[winfo exists $w]} {
11791 $w conf -foreground $c
11794 allcanvs itemconf text -fill $c
11795 $canv itemconf circle -outline $c
11796 $canv itemconf markid -outline $c
11799 proc prefscan {} {
11800 global oldprefs prefstop
11802 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11803 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11804 global $v
11805 set $v $oldprefs($v)
11807 catch {destroy $prefstop}
11808 unset prefstop
11809 fontcan
11812 proc prefsok {} {
11813 global maxwidth maxgraphpct
11814 global oldprefs prefstop showneartags showlocalchanges
11815 global fontpref mainfont textfont uifont
11816 global limitdiffs treediffs perfile_attrs
11817 global hideremotes
11819 catch {destroy $prefstop}
11820 unset prefstop
11821 fontcan
11822 set fontchanged 0
11823 if {$mainfont ne $fontpref(mainfont)} {
11824 set mainfont $fontpref(mainfont)
11825 parsefont mainfont $mainfont
11826 eval font configure mainfont [fontflags mainfont]
11827 eval font configure mainfontbold [fontflags mainfont 1]
11828 setcoords
11829 set fontchanged 1
11831 if {$textfont ne $fontpref(textfont)} {
11832 set textfont $fontpref(textfont)
11833 parsefont textfont $textfont
11834 eval font configure textfont [fontflags textfont]
11835 eval font configure textfontbold [fontflags textfont 1]
11837 if {$uifont ne $fontpref(uifont)} {
11838 set uifont $fontpref(uifont)
11839 parsefont uifont $uifont
11840 eval font configure uifont [fontflags uifont]
11842 settabs
11843 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11844 if {$showlocalchanges} {
11845 doshowlocalchanges
11846 } else {
11847 dohidelocalchanges
11850 if {$limitdiffs != $oldprefs(limitdiffs) ||
11851 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11852 # treediffs elements are limited by path;
11853 # won't have encodings cached if perfile_attrs was just turned on
11854 unset -nocomplain treediffs
11856 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11857 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11858 redisplay
11859 } elseif {$showneartags != $oldprefs(showneartags) ||
11860 $limitdiffs != $oldprefs(limitdiffs)} {
11861 reselectline
11863 if {$hideremotes != $oldprefs(hideremotes)} {
11864 rereadrefs
11868 proc formatdate {d} {
11869 global datetimeformat
11870 if {$d ne {}} {
11871 # If $datetimeformat includes a timezone, display in the
11872 # timezone of the argument. Otherwise, display in local time.
11873 if {[string match {*%[zZ]*} $datetimeformat]} {
11874 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11875 # Tcl < 8.5 does not support -timezone. Emulate it by
11876 # setting TZ (e.g. TZ=<-0430>+04:30).
11877 global env
11878 if {[info exists env(TZ)]} {
11879 set savedTZ $env(TZ)
11881 set zone [lindex $d 1]
11882 set sign [string map {+ - - +} [string index $zone 0]]
11883 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11884 set d [clock format [lindex $d 0] -format $datetimeformat]
11885 if {[info exists savedTZ]} {
11886 set env(TZ) $savedTZ
11887 } else {
11888 unset env(TZ)
11891 } else {
11892 set d [clock format [lindex $d 0] -format $datetimeformat]
11895 return $d
11898 # This list of encoding names and aliases is distilled from
11899 # http://www.iana.org/assignments/character-sets.
11900 # Not all of them are supported by Tcl.
11901 set encoding_aliases {
11902 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11903 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11904 { ISO-10646-UTF-1 csISO10646UTF1 }
11905 { ISO_646.basic:1983 ref csISO646basic1983 }
11906 { INVARIANT csINVARIANT }
11907 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11908 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11909 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11910 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11911 { NATS-DANO iso-ir-9-1 csNATSDANO }
11912 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11913 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11914 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11915 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11916 { ISO-2022-KR csISO2022KR }
11917 { EUC-KR csEUCKR }
11918 { ISO-2022-JP csISO2022JP }
11919 { ISO-2022-JP-2 csISO2022JP2 }
11920 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11921 csISO13JISC6220jp }
11922 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11923 { IT iso-ir-15 ISO646-IT csISO15Italian }
11924 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11925 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11926 { greek7-old iso-ir-18 csISO18Greek7Old }
11927 { latin-greek iso-ir-19 csISO19LatinGreek }
11928 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11929 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11930 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11931 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11932 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11933 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11934 { INIS iso-ir-49 csISO49INIS }
11935 { INIS-8 iso-ir-50 csISO50INIS8 }
11936 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11937 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11938 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11939 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11940 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11941 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11942 csISO60Norwegian1 }
11943 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11944 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11945 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11946 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11947 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11948 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11949 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11950 { greek7 iso-ir-88 csISO88Greek7 }
11951 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11952 { iso-ir-90 csISO90 }
11953 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11954 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11955 csISO92JISC62991984b }
11956 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11957 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11958 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11959 csISO95JIS62291984handadd }
11960 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11961 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11962 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11963 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11964 CP819 csISOLatin1 }
11965 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11966 { T.61-7bit iso-ir-102 csISO102T617bit }
11967 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11968 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11969 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11970 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11971 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11972 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11973 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11974 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11975 arabic csISOLatinArabic }
11976 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11977 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11978 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11979 greek greek8 csISOLatinGreek }
11980 { T.101-G2 iso-ir-128 csISO128T101G2 }
11981 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11982 csISOLatinHebrew }
11983 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11984 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11985 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11986 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11987 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11988 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11989 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11990 csISOLatinCyrillic }
11991 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11992 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11993 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11994 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11995 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11996 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11997 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11998 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11999 { ISO_10367-box iso-ir-155 csISO10367Box }
12000 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
12001 { latin-lap lap iso-ir-158 csISO158Lap }
12002 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
12003 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
12004 { us-dk csUSDK }
12005 { dk-us csDKUS }
12006 { JIS_X0201 X0201 csHalfWidthKatakana }
12007 { KSC5636 ISO646-KR csKSC5636 }
12008 { ISO-10646-UCS-2 csUnicode }
12009 { ISO-10646-UCS-4 csUCS4 }
12010 { DEC-MCS dec csDECMCS }
12011 { hp-roman8 roman8 r8 csHPRoman8 }
12012 { macintosh mac csMacintosh }
12013 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
12014 csIBM037 }
12015 { IBM038 EBCDIC-INT cp038 csIBM038 }
12016 { IBM273 CP273 csIBM273 }
12017 { IBM274 EBCDIC-BE CP274 csIBM274 }
12018 { IBM275 EBCDIC-BR cp275 csIBM275 }
12019 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
12020 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
12021 { IBM280 CP280 ebcdic-cp-it csIBM280 }
12022 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
12023 { IBM284 CP284 ebcdic-cp-es csIBM284 }
12024 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
12025 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
12026 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
12027 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
12028 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
12029 { IBM424 cp424 ebcdic-cp-he csIBM424 }
12030 { IBM437 cp437 437 csPC8CodePage437 }
12031 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
12032 { IBM775 cp775 csPC775Baltic }
12033 { IBM850 cp850 850 csPC850Multilingual }
12034 { IBM851 cp851 851 csIBM851 }
12035 { IBM852 cp852 852 csPCp852 }
12036 { IBM855 cp855 855 csIBM855 }
12037 { IBM857 cp857 857 csIBM857 }
12038 { IBM860 cp860 860 csIBM860 }
12039 { IBM861 cp861 861 cp-is csIBM861 }
12040 { IBM862 cp862 862 csPC862LatinHebrew }
12041 { IBM863 cp863 863 csIBM863 }
12042 { IBM864 cp864 csIBM864 }
12043 { IBM865 cp865 865 csIBM865 }
12044 { IBM866 cp866 866 csIBM866 }
12045 { IBM868 CP868 cp-ar csIBM868 }
12046 { IBM869 cp869 869 cp-gr csIBM869 }
12047 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
12048 { IBM871 CP871 ebcdic-cp-is csIBM871 }
12049 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
12050 { IBM891 cp891 csIBM891 }
12051 { IBM903 cp903 csIBM903 }
12052 { IBM904 cp904 904 csIBBM904 }
12053 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
12054 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
12055 { IBM1026 CP1026 csIBM1026 }
12056 { EBCDIC-AT-DE csIBMEBCDICATDE }
12057 { EBCDIC-AT-DE-A csEBCDICATDEA }
12058 { EBCDIC-CA-FR csEBCDICCAFR }
12059 { EBCDIC-DK-NO csEBCDICDKNO }
12060 { EBCDIC-DK-NO-A csEBCDICDKNOA }
12061 { EBCDIC-FI-SE csEBCDICFISE }
12062 { EBCDIC-FI-SE-A csEBCDICFISEA }
12063 { EBCDIC-FR csEBCDICFR }
12064 { EBCDIC-IT csEBCDICIT }
12065 { EBCDIC-PT csEBCDICPT }
12066 { EBCDIC-ES csEBCDICES }
12067 { EBCDIC-ES-A csEBCDICESA }
12068 { EBCDIC-ES-S csEBCDICESS }
12069 { EBCDIC-UK csEBCDICUK }
12070 { EBCDIC-US csEBCDICUS }
12071 { UNKNOWN-8BIT csUnknown8BiT }
12072 { MNEMONIC csMnemonic }
12073 { MNEM csMnem }
12074 { VISCII csVISCII }
12075 { VIQR csVIQR }
12076 { KOI8-R csKOI8R }
12077 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
12078 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
12079 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
12080 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
12081 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
12082 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
12083 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
12084 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
12085 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
12086 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
12087 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
12088 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
12089 { IBM1047 IBM-1047 }
12090 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
12091 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
12092 { UNICODE-1-1 csUnicode11 }
12093 { CESU-8 csCESU-8 }
12094 { BOCU-1 csBOCU-1 }
12095 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
12096 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
12097 l8 }
12098 { ISO-8859-15 ISO_8859-15 Latin-9 }
12099 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
12100 { GBK CP936 MS936 windows-936 }
12101 { JIS_Encoding csJISEncoding }
12102 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
12103 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
12104 EUC-JP }
12105 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
12106 { ISO-10646-UCS-Basic csUnicodeASCII }
12107 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
12108 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
12109 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
12110 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
12111 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
12112 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
12113 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
12114 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
12115 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
12116 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
12117 { Adobe-Standard-Encoding csAdobeStandardEncoding }
12118 { Ventura-US csVenturaUS }
12119 { Ventura-International csVenturaInternational }
12120 { PC8-Danish-Norwegian csPC8DanishNorwegian }
12121 { PC8-Turkish csPC8Turkish }
12122 { IBM-Symbols csIBMSymbols }
12123 { IBM-Thai csIBMThai }
12124 { HP-Legal csHPLegal }
12125 { HP-Pi-font csHPPiFont }
12126 { HP-Math8 csHPMath8 }
12127 { Adobe-Symbol-Encoding csHPPSMath }
12128 { HP-DeskTop csHPDesktop }
12129 { Ventura-Math csVenturaMath }
12130 { Microsoft-Publishing csMicrosoftPublishing }
12131 { Windows-31J csWindows31J }
12132 { GB2312 csGB2312 }
12133 { Big5 csBig5 }
12136 proc tcl_encoding {enc} {
12137 global encoding_aliases tcl_encoding_cache
12138 if {[info exists tcl_encoding_cache($enc)]} {
12139 return $tcl_encoding_cache($enc)
12141 set names [encoding names]
12142 set lcnames [string tolower $names]
12143 set enc [string tolower $enc]
12144 set i [lsearch -exact $lcnames $enc]
12145 if {$i < 0} {
12146 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
12147 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
12148 set i [lsearch -exact $lcnames $encx]
12151 if {$i < 0} {
12152 foreach l $encoding_aliases {
12153 set ll [string tolower $l]
12154 if {[lsearch -exact $ll $enc] < 0} continue
12155 # look through the aliases for one that tcl knows about
12156 foreach e $ll {
12157 set i [lsearch -exact $lcnames $e]
12158 if {$i < 0} {
12159 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
12160 set i [lsearch -exact $lcnames $ex]
12163 if {$i >= 0} break
12165 break
12168 set tclenc {}
12169 if {$i >= 0} {
12170 set tclenc [lindex $names $i]
12172 set tcl_encoding_cache($enc) $tclenc
12173 return $tclenc
12176 proc gitattr {path attr default} {
12177 global path_attr_cache
12178 if {[info exists path_attr_cache($attr,$path)]} {
12179 set r $path_attr_cache($attr,$path)
12180 } else {
12181 set r "unspecified"
12182 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
12183 regexp "(.*): $attr: (.*)" $line m f r
12185 set path_attr_cache($attr,$path) $r
12187 if {$r eq "unspecified"} {
12188 return $default
12190 return $r
12193 proc cache_gitattr {attr pathlist} {
12194 global path_attr_cache
12195 set newlist {}
12196 foreach path $pathlist {
12197 if {![info exists path_attr_cache($attr,$path)]} {
12198 lappend newlist $path
12201 set lim 1000
12202 if {[tk windowingsystem] == "win32"} {
12203 # windows has a 32k limit on the arguments to a command...
12204 set lim 30
12206 while {$newlist ne {}} {
12207 set head [lrange $newlist 0 [expr {$lim - 1}]]
12208 set newlist [lrange $newlist $lim end]
12209 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
12210 foreach row [split $rlist "\n"] {
12211 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12212 if {[string index $path 0] eq "\""} {
12213 set path [encoding convertfrom [lindex $path 0]]
12215 set path_attr_cache($attr,$path) $value
12222 proc get_path_encoding {path} {
12223 global gui_encoding perfile_attrs
12224 set tcl_enc $gui_encoding
12225 if {$path ne {} && $perfile_attrs} {
12226 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12227 if {$enc2 ne {}} {
12228 set tcl_enc $enc2
12231 return $tcl_enc
12234 ## For msgcat loading, first locate the installation location.
12235 if { [info exists ::env(GITK_MSGSDIR)] } {
12236 ## Msgsdir was manually set in the environment.
12237 set gitk_msgsdir $::env(GITK_MSGSDIR)
12238 } else {
12239 ## Let's guess the prefix from argv0.
12240 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12241 set gitk_libdir [file join $gitk_prefix share gitk lib]
12242 set gitk_msgsdir [file join $gitk_libdir msgs]
12243 unset gitk_prefix
12246 ## Internationalization (i18n) through msgcat and gettext. See
12247 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12248 package require msgcat
12249 namespace import ::msgcat::mc
12250 ## And eventually load the actual message catalog
12251 ::msgcat::mcload $gitk_msgsdir
12253 # First check that Tcl/Tk is recent enough
12254 if {[catch {package require Tk 8.4} err]} {
12255 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12256 Gitk requires at least Tcl/Tk 8.4."]
12257 exit 1
12260 # on OSX bring the current Wish process window to front
12261 if {[tk windowingsystem] eq "aqua"} {
12262 exec osascript -e [format {
12263 tell application "System Events"
12264 set frontmost of processes whose unix id is %d to true
12265 end tell
12266 } [pid] ]
12269 # Unset GIT_TRACE var if set
12270 if { [info exists ::env(GIT_TRACE)] } {
12271 unset ::env(GIT_TRACE)
12274 # defaults...
12275 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12277 set gitencoding {}
12278 catch {
12279 set gitencoding [exec git config --get i18n.commitencoding]
12281 catch {
12282 set gitencoding [exec git config --get i18n.logoutputencoding]
12284 if {$gitencoding == ""} {
12285 set gitencoding "utf-8"
12287 set tclencoding [tcl_encoding $gitencoding]
12288 if {$tclencoding == {}} {
12289 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12292 set gui_encoding [encoding system]
12293 catch {
12294 set enc [exec git config --get gui.encoding]
12295 if {$enc ne {}} {
12296 set tclenc [tcl_encoding $enc]
12297 if {$tclenc ne {}} {
12298 set gui_encoding $tclenc
12299 } else {
12300 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12305 set log_showroot true
12306 catch {
12307 set log_showroot [exec git config --bool --get log.showroot]
12310 if {[tk windowingsystem] eq "aqua"} {
12311 set mainfont {{Lucida Grande} 9}
12312 set textfont {Monaco 9}
12313 set uifont {{Lucida Grande} 9 bold}
12314 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12315 # fontconfig!
12316 set mainfont {sans 9}
12317 set textfont {monospace 9}
12318 set uifont {sans 9 bold}
12319 } else {
12320 set mainfont {Helvetica 9}
12321 set textfont {Courier 9}
12322 set uifont {Helvetica 9 bold}
12324 set tabstop 8
12325 set findmergefiles 0
12326 set maxgraphpct 50
12327 set maxwidth 16
12328 set revlistorder 0
12329 set fastdate 0
12330 set uparrowlen 5
12331 set downarrowlen 5
12332 set mingaplen 100
12333 set cmitmode "patch"
12334 set wrapcomment "none"
12335 set showneartags 1
12336 set hideremotes 0
12337 set maxrefs 20
12338 set visiblerefs {"master"}
12339 set maxlinelen 200
12340 set showlocalchanges 1
12341 set limitdiffs 1
12342 set datetimeformat "%Y-%m-%d %H:%M:%S"
12343 set autoselect 1
12344 set autosellen 40
12345 set perfile_attrs 0
12346 set want_ttk 1
12348 if {[tk windowingsystem] eq "aqua"} {
12349 set extdifftool "opendiff"
12350 } else {
12351 set extdifftool "meld"
12354 set colors {"#00ff00" red blue magenta darkgrey brown orange}
12355 if {[tk windowingsystem] eq "win32"} {
12356 set uicolor SystemButtonFace
12357 set uifgcolor SystemButtonText
12358 set uifgdisabledcolor SystemDisabledText
12359 set bgcolor SystemWindow
12360 set fgcolor SystemWindowText
12361 set selectbgcolor SystemHighlight
12362 set web_browser "cmd /c start"
12363 } else {
12364 set uicolor grey85
12365 set uifgcolor black
12366 set uifgdisabledcolor "#999"
12367 set bgcolor white
12368 set fgcolor black
12369 set selectbgcolor gray85
12370 if {[tk windowingsystem] eq "aqua"} {
12371 set web_browser "open"
12372 } else {
12373 set web_browser "xdg-open"
12376 set diffcolors {red "#00a000" blue}
12377 set diffcontext 3
12378 set mergecolors {red blue "#00ff00" purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12379 set ignorespace 0
12380 set worddiff ""
12381 set markbgcolor "#e0e0ff"
12383 set headbgcolor "#00ff00"
12384 set headfgcolor black
12385 set headoutlinecolor black
12386 set remotebgcolor #ffddaa
12387 set tagbgcolor yellow
12388 set tagfgcolor black
12389 set tagoutlinecolor black
12390 set reflinecolor black
12391 set filesepbgcolor #aaaaaa
12392 set filesepfgcolor black
12393 set linehoverbgcolor #ffff80
12394 set linehoverfgcolor black
12395 set linehoveroutlinecolor black
12396 set mainheadcirclecolor yellow
12397 set workingfilescirclecolor red
12398 set indexcirclecolor "#00ff00"
12399 set circlecolors {white blue gray blue blue}
12400 set linkfgcolor blue
12401 set circleoutlinecolor $fgcolor
12402 set foundbgcolor yellow
12403 set currentsearchhitbgcolor orange
12405 # button for popping up context menus
12406 if {[tk windowingsystem] eq "aqua"} {
12407 set ctxbut <Button-2>
12408 } else {
12409 set ctxbut <Button-3>
12412 catch {
12413 # follow the XDG base directory specification by default. See
12414 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12415 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12416 # XDG_CONFIG_HOME environment variable is set
12417 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12418 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12419 } else {
12420 # default XDG_CONFIG_HOME
12421 set config_file "~/.config/git/gitk"
12422 set config_file_tmp "~/.config/git/gitk-tmp"
12424 if {![file exists $config_file]} {
12425 # for backward compatibility use the old config file if it exists
12426 if {[file exists "~/.gitk"]} {
12427 set config_file "~/.gitk"
12428 set config_file_tmp "~/.gitk-tmp"
12429 } elseif {![file exists [file dirname $config_file]]} {
12430 file mkdir [file dirname $config_file]
12433 source $config_file
12435 config_check_tmp_exists 50
12437 set config_variables {
12438 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12439 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12440 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12441 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12442 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12443 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12444 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12445 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12446 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12447 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12448 web_browser
12450 foreach var $config_variables {
12451 config_init_trace $var
12452 trace add variable $var write config_variable_change_cb
12455 parsefont mainfont $mainfont
12456 eval font create mainfont [fontflags mainfont]
12457 eval font create mainfontbold [fontflags mainfont 1]
12459 parsefont textfont $textfont
12460 eval font create textfont [fontflags textfont]
12461 eval font create textfontbold [fontflags textfont 1]
12463 parsefont uifont $uifont
12464 eval font create uifont [fontflags uifont]
12466 setui $uicolor
12468 setoptions
12470 # check that we can find a .git directory somewhere...
12471 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12472 show_error {} . [mc "Cannot find a git repository here."]
12473 exit 1
12476 set selecthead {}
12477 set selectheadid {}
12479 set revtreeargs {}
12480 set cmdline_files {}
12481 set i 0
12482 set revtreeargscmd {}
12483 foreach arg $argv {
12484 switch -glob -- $arg {
12485 "" { }
12486 "--" {
12487 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12488 break
12490 "--select-commit=*" {
12491 set selecthead [string range $arg 16 end]
12493 "--argscmd=*" {
12494 set revtreeargscmd [string range $arg 10 end]
12496 default {
12497 lappend revtreeargs $arg
12500 incr i
12503 if {$selecthead eq "HEAD"} {
12504 set selecthead {}
12507 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12508 # no -- on command line, but some arguments (other than --argscmd)
12509 if {[catch {
12510 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12511 set cmdline_files [split $f "\n"]
12512 set n [llength $cmdline_files]
12513 set revtreeargs [lrange $revtreeargs 0 end-$n]
12514 # Unfortunately git rev-parse doesn't produce an error when
12515 # something is both a revision and a filename. To be consistent
12516 # with git log and git rev-list, check revtreeargs for filenames.
12517 foreach arg $revtreeargs {
12518 if {[file exists $arg]} {
12519 show_error {} . [mc "Ambiguous argument '%s': both revision\
12520 and filename" $arg]
12521 exit 1
12524 } err]} {
12525 # unfortunately we get both stdout and stderr in $err,
12526 # so look for "fatal:".
12527 set i [string first "fatal:" $err]
12528 if {$i > 0} {
12529 set err [string range $err [expr {$i + 6}] end]
12531 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12532 exit 1
12536 set nullid "0000000000000000000000000000000000000000"
12537 set nullid2 "0000000000000000000000000000000000000001"
12538 set nullfile "/dev/null"
12540 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12541 if {![info exists have_ttk]} {
12542 set have_ttk [llength [info commands ::ttk::style]]
12544 set use_ttk [expr {$have_ttk && $want_ttk}]
12545 set NS [expr {$use_ttk ? "ttk" : ""}]
12547 if {$use_ttk} {
12548 setttkstyle
12551 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12553 set show_notes {}
12554 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12555 set show_notes "--show-notes"
12558 set appname "gitk"
12560 set runq {}
12561 set history {}
12562 set historyindex 0
12563 set fh_serial 0
12564 set nhl_names {}
12565 set highlight_paths {}
12566 set findpattern {}
12567 set searchdirn -forwards
12568 set boldids {}
12569 set boldnameids {}
12570 set diffelide {0 0}
12571 set markingmatches 0
12572 set linkentercount 0
12573 set need_redisplay 0
12574 set nrows_drawn 0
12575 set firsttabstop 0
12577 set nextviewnum 1
12578 set curview 0
12579 set selectedview 0
12580 set selectedhlview [mc "None"]
12581 set highlight_related [mc "None"]
12582 set highlight_files {}
12583 set viewfiles(0) {}
12584 set viewperm(0) 0
12585 set viewchanged(0) 0
12586 set viewargs(0) {}
12587 set viewargscmd(0) {}
12589 set selectedline {}
12590 set numcommits 0
12591 set loginstance 0
12592 set cmdlineok 0
12593 set stopped 0
12594 set stuffsaved 0
12595 set patchnum 0
12596 set lserial 0
12597 set hasworktree [hasworktree]
12598 set cdup {}
12599 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12600 set cdup [exec git rev-parse --show-cdup]
12602 set worktree [exec git rev-parse --show-toplevel]
12603 setcoords
12604 makewindow
12605 catch {
12606 image create photo gitlogo -width 16 -height 16
12608 image create photo gitlogominus -width 4 -height 2
12609 gitlogominus put #C00000 -to 0 0 4 2
12610 gitlogo copy gitlogominus -to 1 5
12611 gitlogo copy gitlogominus -to 6 5
12612 gitlogo copy gitlogominus -to 11 5
12613 image delete gitlogominus
12615 image create photo gitlogoplus -width 4 -height 4
12616 gitlogoplus put #008000 -to 1 0 3 4
12617 gitlogoplus put #008000 -to 0 1 4 3
12618 gitlogo copy gitlogoplus -to 1 9
12619 gitlogo copy gitlogoplus -to 6 9
12620 gitlogo copy gitlogoplus -to 11 9
12621 image delete gitlogoplus
12623 image create photo gitlogo32 -width 32 -height 32
12624 gitlogo32 copy gitlogo -zoom 2 2
12626 wm iconphoto . -default gitlogo gitlogo32
12628 # wait for the window to become visible
12629 tkwait visibility .
12630 set_window_title
12631 update
12632 readrefs
12634 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12635 # create a view for the files/dirs specified on the command line
12636 set curview 1
12637 set selectedview 1
12638 set nextviewnum 2
12639 set viewname(1) [mc "Command line"]
12640 set viewfiles(1) $cmdline_files
12641 set viewargs(1) $revtreeargs
12642 set viewargscmd(1) $revtreeargscmd
12643 set viewperm(1) 0
12644 set viewchanged(1) 0
12645 set vdatemode(1) 0
12646 addviewmenu 1
12647 .bar.view entryconf [mca "&Edit view..."] -state normal
12648 .bar.view entryconf [mca "&Delete view"] -state normal
12651 if {[info exists permviews]} {
12652 foreach v $permviews {
12653 set n $nextviewnum
12654 incr nextviewnum
12655 set viewname($n) [lindex $v 0]
12656 set viewfiles($n) [lindex $v 1]
12657 set viewargs($n) [lindex $v 2]
12658 set viewargscmd($n) [lindex $v 3]
12659 set viewperm($n) 1
12660 set viewchanged($n) 0
12661 addviewmenu $n
12665 if {[tk windowingsystem] eq "win32"} {
12666 focus -force .
12669 getcommits {}
12671 # Local variables:
12672 # mode: tcl
12673 # indent-tabs-mode: t
12674 # tab-width: 8
12675 # End: