gitk: Synchronize config file writes
[git/gitster.git] / gitk
blob0325ab0ca2b60876db2b5fc3209e3fdcc77fe5a0
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2014 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 package require Tk
12 proc hasworktree {} {
13 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
14 [exec git rev-parse --is-inside-git-dir] == "false"}]
17 proc reponame {} {
18 global gitdir
19 set n [file normalize $gitdir]
20 if {[string match "*/.git" $n]} {
21 set n [string range $n 0 end-5]
23 return [file tail $n]
26 proc gitworktree {} {
27 variable _gitworktree
28 if {[info exists _gitworktree]} {
29 return $_gitworktree
31 # v1.7.0 introduced --show-toplevel to return the canonical work-tree
32 if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
33 # try to set work tree from environment, core.worktree or use
34 # cdup to obtain a relative path to the top of the worktree. If
35 # run from the top, the ./ prefix ensures normalize expands pwd.
36 if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
37 catch {set _gitworktree [exec git config --get core.worktree]}
38 if {$_gitworktree eq ""} {
39 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
43 return $_gitworktree
46 # A simple scheduler for compute-intensive stuff.
47 # The aim is to make sure that event handlers for GUI actions can
48 # run at least every 50-100 ms. Unfortunately fileevent handlers are
49 # run before X event handlers, so reading from a fast source can
50 # make the GUI completely unresponsive.
51 proc run args {
52 global isonrunq runq currunq
54 set script $args
55 if {[info exists isonrunq($script)]} return
56 if {$runq eq {} && ![info exists currunq]} {
57 after idle dorunq
59 lappend runq [list {} $script]
60 set isonrunq($script) 1
63 proc filerun {fd script} {
64 fileevent $fd readable [list filereadable $fd $script]
67 proc filereadable {fd script} {
68 global runq currunq
70 fileevent $fd readable {}
71 if {$runq eq {} && ![info exists currunq]} {
72 after idle dorunq
74 lappend runq [list $fd $script]
77 proc nukefile {fd} {
78 global runq
80 for {set i 0} {$i < [llength $runq]} {} {
81 if {[lindex $runq $i 0] eq $fd} {
82 set runq [lreplace $runq $i $i]
83 } else {
84 incr i
89 proc dorunq {} {
90 global isonrunq runq currunq
92 set tstart [clock clicks -milliseconds]
93 set t0 $tstart
94 while {[llength $runq] > 0} {
95 set fd [lindex $runq 0 0]
96 set script [lindex $runq 0 1]
97 set currunq [lindex $runq 0]
98 set runq [lrange $runq 1 end]
99 set repeat [eval $script]
100 unset currunq
101 set t1 [clock clicks -milliseconds]
102 set t [expr {$t1 - $t0}]
103 if {$repeat ne {} && $repeat} {
104 if {$fd eq {} || $repeat == 2} {
105 # script returns 1 if it wants to be readded
106 # file readers return 2 if they could do more straight away
107 lappend runq [list $fd $script]
108 } else {
109 fileevent $fd readable [list filereadable $fd $script]
111 } elseif {$fd eq {}} {
112 unset isonrunq($script)
114 set t0 $t1
115 if {$t1 - $tstart >= 80} break
117 if {$runq ne {}} {
118 after idle dorunq
122 proc reg_instance {fd} {
123 global commfd leftover loginstance
125 set i [incr loginstance]
126 set commfd($i) $fd
127 set leftover($i) {}
128 return $i
131 proc unmerged_files {files} {
132 global nr_unmerged
134 # find the list of unmerged files
135 set mlist {}
136 set nr_unmerged 0
137 if {[catch {
138 set fd [open "| git ls-files -u" r]
139 } err]} {
140 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
141 exit 1
143 while {[gets $fd line] >= 0} {
144 set i [string first "\t" $line]
145 if {$i < 0} continue
146 set fname [string range $line [expr {$i+1}] end]
147 if {[lsearch -exact $mlist $fname] >= 0} continue
148 incr nr_unmerged
149 if {$files eq {} || [path_filter $files $fname]} {
150 lappend mlist $fname
153 catch {close $fd}
154 return $mlist
157 proc parseviewargs {n arglist} {
158 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
159 global vinlinediff
160 global worddiff git_version
162 set vdatemode($n) 0
163 set vmergeonly($n) 0
164 set vinlinediff($n) 0
165 set glflags {}
166 set diffargs {}
167 set nextisval 0
168 set revargs {}
169 set origargs $arglist
170 set allknown 1
171 set filtered 0
172 set i -1
173 foreach arg $arglist {
174 incr i
175 if {$nextisval} {
176 lappend glflags $arg
177 set nextisval 0
178 continue
180 switch -glob -- $arg {
181 "-d" -
182 "--date-order" {
183 set vdatemode($n) 1
184 # remove from origargs in case we hit an unknown option
185 set origargs [lreplace $origargs $i $i]
186 incr i -1
188 "-[puabwcrRBMC]" -
189 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
190 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
191 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
192 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
193 "--ignore-space-change" - "-U*" - "--unified=*" {
194 # These request or affect diff output, which we don't want.
195 # Some could be used to set our defaults for diff display.
196 lappend diffargs $arg
198 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
199 "--name-only" - "--name-status" - "--color" -
200 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
201 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
202 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
203 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
204 "--objects" - "--objects-edge" - "--reverse" {
205 # These cause our parsing of git log's output to fail, or else
206 # they're options we want to set ourselves, so ignore them.
208 "--color-words*" - "--word-diff=color" {
209 # These trigger a word diff in the console interface,
210 # so help the user by enabling our own support
211 if {[package vcompare $git_version "1.7.2"] >= 0} {
212 set worddiff [mc "Color words"]
215 "--word-diff*" {
216 if {[package vcompare $git_version "1.7.2"] >= 0} {
217 set worddiff [mc "Markup words"]
220 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
221 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
222 "--full-history" - "--dense" - "--sparse" -
223 "--follow" - "--left-right" - "--encoding=*" {
224 # These are harmless, and some are even useful
225 lappend glflags $arg
227 "--diff-filter=*" - "--no-merges" - "--unpacked" -
228 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
229 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
230 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
231 "--remove-empty" - "--first-parent" - "--cherry-pick" -
232 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
233 "--simplify-by-decoration" {
234 # These mean that we get a subset of the commits
235 set filtered 1
236 lappend glflags $arg
238 "-L*" {
239 # Line-log with 'stuck' argument (unstuck form is
240 # not supported)
241 set filtered 1
242 set vinlinediff($n) 1
243 set allknown 0
244 lappend glflags $arg
246 "-n" {
247 # This appears to be the only one that has a value as a
248 # separate word following it
249 set filtered 1
250 set nextisval 1
251 lappend glflags $arg
253 "--not" - "--all" {
254 lappend revargs $arg
256 "--merge" {
257 set vmergeonly($n) 1
258 # git rev-parse doesn't understand --merge
259 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
261 "--no-replace-objects" {
262 set env(GIT_NO_REPLACE_OBJECTS) "1"
264 "-*" {
265 # Other flag arguments including -<n>
266 if {[string is digit -strict [string range $arg 1 end]]} {
267 set filtered 1
268 } else {
269 # a flag argument that we don't recognize;
270 # that means we can't optimize
271 set allknown 0
273 lappend glflags $arg
275 default {
276 # Non-flag arguments specify commits or ranges of commits
277 if {[string match "*...*" $arg]} {
278 lappend revargs --gitk-symmetric-diff-marker
280 lappend revargs $arg
284 set vdflags($n) $diffargs
285 set vflags($n) $glflags
286 set vrevs($n) $revargs
287 set vfiltered($n) $filtered
288 set vorigargs($n) $origargs
289 return $allknown
292 proc parseviewrevs {view revs} {
293 global vposids vnegids
295 if {$revs eq {}} {
296 set revs HEAD
297 } elseif {[lsearch -exact $revs --all] >= 0} {
298 lappend revs HEAD
300 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
301 # we get stdout followed by stderr in $err
302 # for an unknown rev, git rev-parse echoes it and then errors out
303 set errlines [split $err "\n"]
304 set badrev {}
305 for {set l 0} {$l < [llength $errlines]} {incr l} {
306 set line [lindex $errlines $l]
307 if {!([string length $line] == 40 && [string is xdigit $line])} {
308 if {[string match "fatal:*" $line]} {
309 if {[string match "fatal: ambiguous argument*" $line]
310 && $badrev ne {}} {
311 if {[llength $badrev] == 1} {
312 set err "unknown revision $badrev"
313 } else {
314 set err "unknown revisions: [join $badrev ", "]"
316 } else {
317 set err [join [lrange $errlines $l end] "\n"]
319 break
321 lappend badrev $line
324 error_popup "[mc "Error parsing revisions:"] $err"
325 return {}
327 set ret {}
328 set pos {}
329 set neg {}
330 set sdm 0
331 foreach id [split $ids "\n"] {
332 if {$id eq "--gitk-symmetric-diff-marker"} {
333 set sdm 4
334 } elseif {[string match "^*" $id]} {
335 if {$sdm != 1} {
336 lappend ret $id
337 if {$sdm == 3} {
338 set sdm 0
341 lappend neg [string range $id 1 end]
342 } else {
343 if {$sdm != 2} {
344 lappend ret $id
345 } else {
346 lset ret end $id...[lindex $ret end]
348 lappend pos $id
350 incr sdm -1
352 set vposids($view) $pos
353 set vnegids($view) $neg
354 return $ret
357 # Start off a git log process and arrange to read its output
358 proc start_rev_list {view} {
359 global startmsecs commitidx viewcomplete curview
360 global tclencoding
361 global viewargs viewargscmd viewfiles vfilelimit
362 global showlocalchanges
363 global viewactive viewinstances vmergeonly
364 global mainheadid viewmainheadid viewmainheadid_orig
365 global vcanopt vflags vrevs vorigargs
366 global show_notes
368 set startmsecs [clock clicks -milliseconds]
369 set commitidx($view) 0
370 # these are set this way for the error exits
371 set viewcomplete($view) 1
372 set viewactive($view) 0
373 varcinit $view
375 set args $viewargs($view)
376 if {$viewargscmd($view) ne {}} {
377 if {[catch {
378 set str [exec sh -c $viewargscmd($view)]
379 } err]} {
380 error_popup "[mc "Error executing --argscmd command:"] $err"
381 return 0
383 set args [concat $args [split $str "\n"]]
385 set vcanopt($view) [parseviewargs $view $args]
387 set files $viewfiles($view)
388 if {$vmergeonly($view)} {
389 set files [unmerged_files $files]
390 if {$files eq {}} {
391 global nr_unmerged
392 if {$nr_unmerged == 0} {
393 error_popup [mc "No files selected: --merge specified but\
394 no files are unmerged."]
395 } else {
396 error_popup [mc "No files selected: --merge specified but\
397 no unmerged files are within file limit."]
399 return 0
402 set vfilelimit($view) $files
404 if {$vcanopt($view)} {
405 set revs [parseviewrevs $view $vrevs($view)]
406 if {$revs eq {}} {
407 return 0
409 set args [concat $vflags($view) $revs]
410 } else {
411 set args $vorigargs($view)
414 if {[catch {
415 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
416 --parents --boundary $args "--" $files] r]
417 } err]} {
418 error_popup "[mc "Error executing git log:"] $err"
419 return 0
421 set i [reg_instance $fd]
422 set viewinstances($view) [list $i]
423 set viewmainheadid($view) $mainheadid
424 set viewmainheadid_orig($view) $mainheadid
425 if {$files ne {} && $mainheadid ne {}} {
426 get_viewmainhead $view
428 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
429 interestedin $viewmainheadid($view) dodiffindex
431 fconfigure $fd -blocking 0 -translation lf -eofchar {}
432 if {$tclencoding != {}} {
433 fconfigure $fd -encoding $tclencoding
435 filerun $fd [list getcommitlines $fd $i $view 0]
436 nowbusy $view [mc "Reading"]
437 set viewcomplete($view) 0
438 set viewactive($view) 1
439 return 1
442 proc stop_instance {inst} {
443 global commfd leftover
445 set fd $commfd($inst)
446 catch {
447 set pid [pid $fd]
449 if {$::tcl_platform(platform) eq {windows}} {
450 exec taskkill /pid $pid
451 } else {
452 exec kill $pid
455 catch {close $fd}
456 nukefile $fd
457 unset commfd($inst)
458 unset leftover($inst)
461 proc stop_backends {} {
462 global commfd
464 foreach inst [array names commfd] {
465 stop_instance $inst
469 proc stop_rev_list {view} {
470 global viewinstances
472 foreach inst $viewinstances($view) {
473 stop_instance $inst
475 set viewinstances($view) {}
478 proc reset_pending_select {selid} {
479 global pending_select mainheadid selectheadid
481 if {$selid ne {}} {
482 set pending_select $selid
483 } elseif {$selectheadid ne {}} {
484 set pending_select $selectheadid
485 } else {
486 set pending_select $mainheadid
490 proc getcommits {selid} {
491 global canv curview need_redisplay viewactive
493 initlayout
494 if {[start_rev_list $curview]} {
495 reset_pending_select $selid
496 show_status [mc "Reading commits..."]
497 set need_redisplay 1
498 } else {
499 show_status [mc "No commits selected"]
503 proc updatecommits {} {
504 global curview vcanopt vorigargs vfilelimit viewinstances
505 global viewactive viewcomplete tclencoding
506 global startmsecs showneartags showlocalchanges
507 global mainheadid viewmainheadid viewmainheadid_orig pending_select
508 global hasworktree
509 global varcid vposids vnegids vflags vrevs
510 global show_notes
512 set hasworktree [hasworktree]
513 rereadrefs
514 set view $curview
515 if {$mainheadid ne $viewmainheadid_orig($view)} {
516 if {$showlocalchanges} {
517 dohidelocalchanges
519 set viewmainheadid($view) $mainheadid
520 set viewmainheadid_orig($view) $mainheadid
521 if {$vfilelimit($view) ne {}} {
522 get_viewmainhead $view
525 if {$showlocalchanges} {
526 doshowlocalchanges
528 if {$vcanopt($view)} {
529 set oldpos $vposids($view)
530 set oldneg $vnegids($view)
531 set revs [parseviewrevs $view $vrevs($view)]
532 if {$revs eq {}} {
533 return
535 # note: getting the delta when negative refs change is hard,
536 # and could require multiple git log invocations, so in that
537 # case we ask git log for all the commits (not just the delta)
538 if {$oldneg eq $vnegids($view)} {
539 set newrevs {}
540 set npos 0
541 # take out positive refs that we asked for before or
542 # that we have already seen
543 foreach rev $revs {
544 if {[string length $rev] == 40} {
545 if {[lsearch -exact $oldpos $rev] < 0
546 && ![info exists varcid($view,$rev)]} {
547 lappend newrevs $rev
548 incr npos
550 } else {
551 lappend $newrevs $rev
554 if {$npos == 0} return
555 set revs $newrevs
556 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
558 set args [concat $vflags($view) $revs --not $oldpos]
559 } else {
560 set args $vorigargs($view)
562 if {[catch {
563 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
564 --parents --boundary $args "--" $vfilelimit($view)] r]
565 } err]} {
566 error_popup "[mc "Error executing git log:"] $err"
567 return
569 if {$viewactive($view) == 0} {
570 set startmsecs [clock clicks -milliseconds]
572 set i [reg_instance $fd]
573 lappend viewinstances($view) $i
574 fconfigure $fd -blocking 0 -translation lf -eofchar {}
575 if {$tclencoding != {}} {
576 fconfigure $fd -encoding $tclencoding
578 filerun $fd [list getcommitlines $fd $i $view 1]
579 incr viewactive($view)
580 set viewcomplete($view) 0
581 reset_pending_select {}
582 nowbusy $view [mc "Reading"]
583 if {$showneartags} {
584 getallcommits
588 proc reloadcommits {} {
589 global curview viewcomplete selectedline currentid thickerline
590 global showneartags treediffs commitinterest cached_commitrow
591 global targetid
593 set selid {}
594 if {$selectedline ne {}} {
595 set selid $currentid
598 if {!$viewcomplete($curview)} {
599 stop_rev_list $curview
601 resetvarcs $curview
602 set selectedline {}
603 catch {unset currentid}
604 catch {unset thickerline}
605 catch {unset treediffs}
606 readrefs
607 changedrefs
608 if {$showneartags} {
609 getallcommits
611 clear_display
612 catch {unset commitinterest}
613 catch {unset cached_commitrow}
614 catch {unset targetid}
615 setcanvscroll
616 getcommits $selid
617 return 0
620 # This makes a string representation of a positive integer which
621 # sorts as a string in numerical order
622 proc strrep {n} {
623 if {$n < 16} {
624 return [format "%x" $n]
625 } elseif {$n < 256} {
626 return [format "x%.2x" $n]
627 } elseif {$n < 65536} {
628 return [format "y%.4x" $n]
630 return [format "z%.8x" $n]
633 # Procedures used in reordering commits from git log (without
634 # --topo-order) into the order for display.
636 proc varcinit {view} {
637 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
638 global vtokmod varcmod vrowmod varcix vlastins
640 set varcstart($view) {{}}
641 set vupptr($view) {0}
642 set vdownptr($view) {0}
643 set vleftptr($view) {0}
644 set vbackptr($view) {0}
645 set varctok($view) {{}}
646 set varcrow($view) {{}}
647 set vtokmod($view) {}
648 set varcmod($view) 0
649 set vrowmod($view) 0
650 set varcix($view) {{}}
651 set vlastins($view) {0}
654 proc resetvarcs {view} {
655 global varcid varccommits parents children vseedcount ordertok
656 global vshortids
658 foreach vid [array names varcid $view,*] {
659 unset varcid($vid)
660 unset children($vid)
661 unset parents($vid)
663 foreach vid [array names vshortids $view,*] {
664 unset vshortids($vid)
666 # some commits might have children but haven't been seen yet
667 foreach vid [array names children $view,*] {
668 unset children($vid)
670 foreach va [array names varccommits $view,*] {
671 unset varccommits($va)
673 foreach vd [array names vseedcount $view,*] {
674 unset vseedcount($vd)
676 catch {unset ordertok}
679 # returns a list of the commits with no children
680 proc seeds {v} {
681 global vdownptr vleftptr varcstart
683 set ret {}
684 set a [lindex $vdownptr($v) 0]
685 while {$a != 0} {
686 lappend ret [lindex $varcstart($v) $a]
687 set a [lindex $vleftptr($v) $a]
689 return $ret
692 proc newvarc {view id} {
693 global varcid varctok parents children vdatemode
694 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
695 global commitdata commitinfo vseedcount varccommits vlastins
697 set a [llength $varctok($view)]
698 set vid $view,$id
699 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
700 if {![info exists commitinfo($id)]} {
701 parsecommit $id $commitdata($id) 1
703 set cdate [lindex [lindex $commitinfo($id) 4] 0]
704 if {![string is integer -strict $cdate]} {
705 set cdate 0
707 if {![info exists vseedcount($view,$cdate)]} {
708 set vseedcount($view,$cdate) -1
710 set c [incr vseedcount($view,$cdate)]
711 set cdate [expr {$cdate ^ 0xffffffff}]
712 set tok "s[strrep $cdate][strrep $c]"
713 } else {
714 set tok {}
716 set ka 0
717 if {[llength $children($vid)] > 0} {
718 set kid [lindex $children($vid) end]
719 set k $varcid($view,$kid)
720 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
721 set ki $kid
722 set ka $k
723 set tok [lindex $varctok($view) $k]
726 if {$ka != 0} {
727 set i [lsearch -exact $parents($view,$ki) $id]
728 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
729 append tok [strrep $j]
731 set c [lindex $vlastins($view) $ka]
732 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
733 set c $ka
734 set b [lindex $vdownptr($view) $ka]
735 } else {
736 set b [lindex $vleftptr($view) $c]
738 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
739 set c $b
740 set b [lindex $vleftptr($view) $c]
742 if {$c == $ka} {
743 lset vdownptr($view) $ka $a
744 lappend vbackptr($view) 0
745 } else {
746 lset vleftptr($view) $c $a
747 lappend vbackptr($view) $c
749 lset vlastins($view) $ka $a
750 lappend vupptr($view) $ka
751 lappend vleftptr($view) $b
752 if {$b != 0} {
753 lset vbackptr($view) $b $a
755 lappend varctok($view) $tok
756 lappend varcstart($view) $id
757 lappend vdownptr($view) 0
758 lappend varcrow($view) {}
759 lappend varcix($view) {}
760 set varccommits($view,$a) {}
761 lappend vlastins($view) 0
762 return $a
765 proc splitvarc {p v} {
766 global varcid varcstart varccommits varctok vtokmod
767 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
769 set oa $varcid($v,$p)
770 set otok [lindex $varctok($v) $oa]
771 set ac $varccommits($v,$oa)
772 set i [lsearch -exact $varccommits($v,$oa) $p]
773 if {$i <= 0} return
774 set na [llength $varctok($v)]
775 # "%" sorts before "0"...
776 set tok "$otok%[strrep $i]"
777 lappend varctok($v) $tok
778 lappend varcrow($v) {}
779 lappend varcix($v) {}
780 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
781 set varccommits($v,$na) [lrange $ac $i end]
782 lappend varcstart($v) $p
783 foreach id $varccommits($v,$na) {
784 set varcid($v,$id) $na
786 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
787 lappend vlastins($v) [lindex $vlastins($v) $oa]
788 lset vdownptr($v) $oa $na
789 lset vlastins($v) $oa 0
790 lappend vupptr($v) $oa
791 lappend vleftptr($v) 0
792 lappend vbackptr($v) 0
793 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
794 lset vupptr($v) $b $na
796 if {[string compare $otok $vtokmod($v)] <= 0} {
797 modify_arc $v $oa
801 proc renumbervarc {a v} {
802 global parents children varctok varcstart varccommits
803 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
805 set t1 [clock clicks -milliseconds]
806 set todo {}
807 set isrelated($a) 1
808 set kidchanged($a) 1
809 set ntot 0
810 while {$a != 0} {
811 if {[info exists isrelated($a)]} {
812 lappend todo $a
813 set id [lindex $varccommits($v,$a) end]
814 foreach p $parents($v,$id) {
815 if {[info exists varcid($v,$p)]} {
816 set isrelated($varcid($v,$p)) 1
820 incr ntot
821 set b [lindex $vdownptr($v) $a]
822 if {$b == 0} {
823 while {$a != 0} {
824 set b [lindex $vleftptr($v) $a]
825 if {$b != 0} break
826 set a [lindex $vupptr($v) $a]
829 set a $b
831 foreach a $todo {
832 if {![info exists kidchanged($a)]} continue
833 set id [lindex $varcstart($v) $a]
834 if {[llength $children($v,$id)] > 1} {
835 set children($v,$id) [lsort -command [list vtokcmp $v] \
836 $children($v,$id)]
838 set oldtok [lindex $varctok($v) $a]
839 if {!$vdatemode($v)} {
840 set tok {}
841 } else {
842 set tok $oldtok
844 set ka 0
845 set kid [last_real_child $v,$id]
846 if {$kid ne {}} {
847 set k $varcid($v,$kid)
848 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
849 set ki $kid
850 set ka $k
851 set tok [lindex $varctok($v) $k]
854 if {$ka != 0} {
855 set i [lsearch -exact $parents($v,$ki) $id]
856 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
857 append tok [strrep $j]
859 if {$tok eq $oldtok} {
860 continue
862 set id [lindex $varccommits($v,$a) end]
863 foreach p $parents($v,$id) {
864 if {[info exists varcid($v,$p)]} {
865 set kidchanged($varcid($v,$p)) 1
866 } else {
867 set sortkids($p) 1
870 lset varctok($v) $a $tok
871 set b [lindex $vupptr($v) $a]
872 if {$b != $ka} {
873 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
874 modify_arc $v $ka
876 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
877 modify_arc $v $b
879 set c [lindex $vbackptr($v) $a]
880 set d [lindex $vleftptr($v) $a]
881 if {$c == 0} {
882 lset vdownptr($v) $b $d
883 } else {
884 lset vleftptr($v) $c $d
886 if {$d != 0} {
887 lset vbackptr($v) $d $c
889 if {[lindex $vlastins($v) $b] == $a} {
890 lset vlastins($v) $b $c
892 lset vupptr($v) $a $ka
893 set c [lindex $vlastins($v) $ka]
894 if {$c == 0 || \
895 [string compare $tok [lindex $varctok($v) $c]] < 0} {
896 set c $ka
897 set b [lindex $vdownptr($v) $ka]
898 } else {
899 set b [lindex $vleftptr($v) $c]
901 while {$b != 0 && \
902 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
903 set c $b
904 set b [lindex $vleftptr($v) $c]
906 if {$c == $ka} {
907 lset vdownptr($v) $ka $a
908 lset vbackptr($v) $a 0
909 } else {
910 lset vleftptr($v) $c $a
911 lset vbackptr($v) $a $c
913 lset vleftptr($v) $a $b
914 if {$b != 0} {
915 lset vbackptr($v) $b $a
917 lset vlastins($v) $ka $a
920 foreach id [array names sortkids] {
921 if {[llength $children($v,$id)] > 1} {
922 set children($v,$id) [lsort -command [list vtokcmp $v] \
923 $children($v,$id)]
926 set t2 [clock clicks -milliseconds]
927 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
930 # Fix up the graph after we have found out that in view $v,
931 # $p (a commit that we have already seen) is actually the parent
932 # of the last commit in arc $a.
933 proc fix_reversal {p a v} {
934 global varcid varcstart varctok vupptr
936 set pa $varcid($v,$p)
937 if {$p ne [lindex $varcstart($v) $pa]} {
938 splitvarc $p $v
939 set pa $varcid($v,$p)
941 # seeds always need to be renumbered
942 if {[lindex $vupptr($v) $pa] == 0 ||
943 [string compare [lindex $varctok($v) $a] \
944 [lindex $varctok($v) $pa]] > 0} {
945 renumbervarc $pa $v
949 proc insertrow {id p v} {
950 global cmitlisted children parents varcid varctok vtokmod
951 global varccommits ordertok commitidx numcommits curview
952 global targetid targetrow vshortids
954 readcommit $id
955 set vid $v,$id
956 set cmitlisted($vid) 1
957 set children($vid) {}
958 set parents($vid) [list $p]
959 set a [newvarc $v $id]
960 set varcid($vid) $a
961 lappend vshortids($v,[string range $id 0 3]) $id
962 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
963 modify_arc $v $a
965 lappend varccommits($v,$a) $id
966 set vp $v,$p
967 if {[llength [lappend children($vp) $id]] > 1} {
968 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
969 catch {unset ordertok}
971 fix_reversal $p $a $v
972 incr commitidx($v)
973 if {$v == $curview} {
974 set numcommits $commitidx($v)
975 setcanvscroll
976 if {[info exists targetid]} {
977 if {![comes_before $targetid $p]} {
978 incr targetrow
984 proc insertfakerow {id p} {
985 global varcid varccommits parents children cmitlisted
986 global commitidx varctok vtokmod targetid targetrow curview numcommits
988 set v $curview
989 set a $varcid($v,$p)
990 set i [lsearch -exact $varccommits($v,$a) $p]
991 if {$i < 0} {
992 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
993 return
995 set children($v,$id) {}
996 set parents($v,$id) [list $p]
997 set varcid($v,$id) $a
998 lappend children($v,$p) $id
999 set cmitlisted($v,$id) 1
1000 set numcommits [incr commitidx($v)]
1001 # note we deliberately don't update varcstart($v) even if $i == 0
1002 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1003 modify_arc $v $a $i
1004 if {[info exists targetid]} {
1005 if {![comes_before $targetid $p]} {
1006 incr targetrow
1009 setcanvscroll
1010 drawvisible
1013 proc removefakerow {id} {
1014 global varcid varccommits parents children commitidx
1015 global varctok vtokmod cmitlisted currentid selectedline
1016 global targetid curview numcommits
1018 set v $curview
1019 if {[llength $parents($v,$id)] != 1} {
1020 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1021 return
1023 set p [lindex $parents($v,$id) 0]
1024 set a $varcid($v,$id)
1025 set i [lsearch -exact $varccommits($v,$a) $id]
1026 if {$i < 0} {
1027 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1028 return
1030 unset varcid($v,$id)
1031 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1032 unset parents($v,$id)
1033 unset children($v,$id)
1034 unset cmitlisted($v,$id)
1035 set numcommits [incr commitidx($v) -1]
1036 set j [lsearch -exact $children($v,$p) $id]
1037 if {$j >= 0} {
1038 set children($v,$p) [lreplace $children($v,$p) $j $j]
1040 modify_arc $v $a $i
1041 if {[info exist currentid] && $id eq $currentid} {
1042 unset currentid
1043 set selectedline {}
1045 if {[info exists targetid] && $targetid eq $id} {
1046 set targetid $p
1048 setcanvscroll
1049 drawvisible
1052 proc real_children {vp} {
1053 global children nullid nullid2
1055 set kids {}
1056 foreach id $children($vp) {
1057 if {$id ne $nullid && $id ne $nullid2} {
1058 lappend kids $id
1061 return $kids
1064 proc first_real_child {vp} {
1065 global children nullid nullid2
1067 foreach id $children($vp) {
1068 if {$id ne $nullid && $id ne $nullid2} {
1069 return $id
1072 return {}
1075 proc last_real_child {vp} {
1076 global children nullid nullid2
1078 set kids $children($vp)
1079 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1080 set id [lindex $kids $i]
1081 if {$id ne $nullid && $id ne $nullid2} {
1082 return $id
1085 return {}
1088 proc vtokcmp {v a b} {
1089 global varctok varcid
1091 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1092 [lindex $varctok($v) $varcid($v,$b)]]
1095 # This assumes that if lim is not given, the caller has checked that
1096 # arc a's token is less than $vtokmod($v)
1097 proc modify_arc {v a {lim {}}} {
1098 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1100 if {$lim ne {}} {
1101 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1102 if {$c > 0} return
1103 if {$c == 0} {
1104 set r [lindex $varcrow($v) $a]
1105 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1108 set vtokmod($v) [lindex $varctok($v) $a]
1109 set varcmod($v) $a
1110 if {$v == $curview} {
1111 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1112 set a [lindex $vupptr($v) $a]
1113 set lim {}
1115 set r 0
1116 if {$a != 0} {
1117 if {$lim eq {}} {
1118 set lim [llength $varccommits($v,$a)]
1120 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1122 set vrowmod($v) $r
1123 undolayout $r
1127 proc update_arcrows {v} {
1128 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1129 global varcid vrownum varcorder varcix varccommits
1130 global vupptr vdownptr vleftptr varctok
1131 global displayorder parentlist curview cached_commitrow
1133 if {$vrowmod($v) == $commitidx($v)} return
1134 if {$v == $curview} {
1135 if {[llength $displayorder] > $vrowmod($v)} {
1136 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1137 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1139 catch {unset cached_commitrow}
1141 set narctot [expr {[llength $varctok($v)] - 1}]
1142 set a $varcmod($v)
1143 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1144 # go up the tree until we find something that has a row number,
1145 # or we get to a seed
1146 set a [lindex $vupptr($v) $a]
1148 if {$a == 0} {
1149 set a [lindex $vdownptr($v) 0]
1150 if {$a == 0} return
1151 set vrownum($v) {0}
1152 set varcorder($v) [list $a]
1153 lset varcix($v) $a 0
1154 lset varcrow($v) $a 0
1155 set arcn 0
1156 set row 0
1157 } else {
1158 set arcn [lindex $varcix($v) $a]
1159 if {[llength $vrownum($v)] > $arcn + 1} {
1160 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1161 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1163 set row [lindex $varcrow($v) $a]
1165 while {1} {
1166 set p $a
1167 incr row [llength $varccommits($v,$a)]
1168 # go down if possible
1169 set b [lindex $vdownptr($v) $a]
1170 if {$b == 0} {
1171 # if not, go left, or go up until we can go left
1172 while {$a != 0} {
1173 set b [lindex $vleftptr($v) $a]
1174 if {$b != 0} break
1175 set a [lindex $vupptr($v) $a]
1177 if {$a == 0} break
1179 set a $b
1180 incr arcn
1181 lappend vrownum($v) $row
1182 lappend varcorder($v) $a
1183 lset varcix($v) $a $arcn
1184 lset varcrow($v) $a $row
1186 set vtokmod($v) [lindex $varctok($v) $p]
1187 set varcmod($v) $p
1188 set vrowmod($v) $row
1189 if {[info exists currentid]} {
1190 set selectedline [rowofcommit $currentid]
1194 # Test whether view $v contains commit $id
1195 proc commitinview {id v} {
1196 global varcid
1198 return [info exists varcid($v,$id)]
1201 # Return the row number for commit $id in the current view
1202 proc rowofcommit {id} {
1203 global varcid varccommits varcrow curview cached_commitrow
1204 global varctok vtokmod
1206 set v $curview
1207 if {![info exists varcid($v,$id)]} {
1208 puts "oops rowofcommit no arc for [shortids $id]"
1209 return {}
1211 set a $varcid($v,$id)
1212 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1213 update_arcrows $v
1215 if {[info exists cached_commitrow($id)]} {
1216 return $cached_commitrow($id)
1218 set i [lsearch -exact $varccommits($v,$a) $id]
1219 if {$i < 0} {
1220 puts "oops didn't find commit [shortids $id] in arc $a"
1221 return {}
1223 incr i [lindex $varcrow($v) $a]
1224 set cached_commitrow($id) $i
1225 return $i
1228 # Returns 1 if a is on an earlier row than b, otherwise 0
1229 proc comes_before {a b} {
1230 global varcid varctok curview
1232 set v $curview
1233 if {$a eq $b || ![info exists varcid($v,$a)] || \
1234 ![info exists varcid($v,$b)]} {
1235 return 0
1237 if {$varcid($v,$a) != $varcid($v,$b)} {
1238 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1239 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1241 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1244 proc bsearch {l elt} {
1245 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1246 return 0
1248 set lo 0
1249 set hi [llength $l]
1250 while {$hi - $lo > 1} {
1251 set mid [expr {int(($lo + $hi) / 2)}]
1252 set t [lindex $l $mid]
1253 if {$elt < $t} {
1254 set hi $mid
1255 } elseif {$elt > $t} {
1256 set lo $mid
1257 } else {
1258 return $mid
1261 return $lo
1264 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1265 proc make_disporder {start end} {
1266 global vrownum curview commitidx displayorder parentlist
1267 global varccommits varcorder parents vrowmod varcrow
1268 global d_valid_start d_valid_end
1270 if {$end > $vrowmod($curview)} {
1271 update_arcrows $curview
1273 set ai [bsearch $vrownum($curview) $start]
1274 set start [lindex $vrownum($curview) $ai]
1275 set narc [llength $vrownum($curview)]
1276 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1277 set a [lindex $varcorder($curview) $ai]
1278 set l [llength $displayorder]
1279 set al [llength $varccommits($curview,$a)]
1280 if {$l < $r + $al} {
1281 if {$l < $r} {
1282 set pad [ntimes [expr {$r - $l}] {}]
1283 set displayorder [concat $displayorder $pad]
1284 set parentlist [concat $parentlist $pad]
1285 } elseif {$l > $r} {
1286 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1287 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1289 foreach id $varccommits($curview,$a) {
1290 lappend displayorder $id
1291 lappend parentlist $parents($curview,$id)
1293 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1294 set i $r
1295 foreach id $varccommits($curview,$a) {
1296 lset displayorder $i $id
1297 lset parentlist $i $parents($curview,$id)
1298 incr i
1301 incr r $al
1305 proc commitonrow {row} {
1306 global displayorder
1308 set id [lindex $displayorder $row]
1309 if {$id eq {}} {
1310 make_disporder $row [expr {$row + 1}]
1311 set id [lindex $displayorder $row]
1313 return $id
1316 proc closevarcs {v} {
1317 global varctok varccommits varcid parents children
1318 global cmitlisted commitidx vtokmod
1320 set missing_parents 0
1321 set scripts {}
1322 set narcs [llength $varctok($v)]
1323 for {set a 1} {$a < $narcs} {incr a} {
1324 set id [lindex $varccommits($v,$a) end]
1325 foreach p $parents($v,$id) {
1326 if {[info exists varcid($v,$p)]} continue
1327 # add p as a new commit
1328 incr missing_parents
1329 set cmitlisted($v,$p) 0
1330 set parents($v,$p) {}
1331 if {[llength $children($v,$p)] == 1 &&
1332 [llength $parents($v,$id)] == 1} {
1333 set b $a
1334 } else {
1335 set b [newvarc $v $p]
1337 set varcid($v,$p) $b
1338 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1339 modify_arc $v $b
1341 lappend varccommits($v,$b) $p
1342 incr commitidx($v)
1343 set scripts [check_interest $p $scripts]
1346 if {$missing_parents > 0} {
1347 foreach s $scripts {
1348 eval $s
1353 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1354 # Assumes we already have an arc for $rwid.
1355 proc rewrite_commit {v id rwid} {
1356 global children parents varcid varctok vtokmod varccommits
1358 foreach ch $children($v,$id) {
1359 # make $rwid be $ch's parent in place of $id
1360 set i [lsearch -exact $parents($v,$ch) $id]
1361 if {$i < 0} {
1362 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1364 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1365 # add $ch to $rwid's children and sort the list if necessary
1366 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1367 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1368 $children($v,$rwid)]
1370 # fix the graph after joining $id to $rwid
1371 set a $varcid($v,$ch)
1372 fix_reversal $rwid $a $v
1373 # parentlist is wrong for the last element of arc $a
1374 # even if displayorder is right, hence the 3rd arg here
1375 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1379 # Mechanism for registering a command to be executed when we come
1380 # across a particular commit. To handle the case when only the
1381 # prefix of the commit is known, the commitinterest array is now
1382 # indexed by the first 4 characters of the ID. Each element is a
1383 # list of id, cmd pairs.
1384 proc interestedin {id cmd} {
1385 global commitinterest
1387 lappend commitinterest([string range $id 0 3]) $id $cmd
1390 proc check_interest {id scripts} {
1391 global commitinterest
1393 set prefix [string range $id 0 3]
1394 if {[info exists commitinterest($prefix)]} {
1395 set newlist {}
1396 foreach {i script} $commitinterest($prefix) {
1397 if {[string match "$i*" $id]} {
1398 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1399 } else {
1400 lappend newlist $i $script
1403 if {$newlist ne {}} {
1404 set commitinterest($prefix) $newlist
1405 } else {
1406 unset commitinterest($prefix)
1409 return $scripts
1412 proc getcommitlines {fd inst view updating} {
1413 global cmitlisted leftover
1414 global commitidx commitdata vdatemode
1415 global parents children curview hlview
1416 global idpending ordertok
1417 global varccommits varcid varctok vtokmod vfilelimit vshortids
1419 set stuff [read $fd 500000]
1420 # git log doesn't terminate the last commit with a null...
1421 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1422 set stuff "\0"
1424 if {$stuff == {}} {
1425 if {![eof $fd]} {
1426 return 1
1428 global commfd viewcomplete viewactive viewname
1429 global viewinstances
1430 unset commfd($inst)
1431 set i [lsearch -exact $viewinstances($view) $inst]
1432 if {$i >= 0} {
1433 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1435 # set it blocking so we wait for the process to terminate
1436 fconfigure $fd -blocking 1
1437 if {[catch {close $fd} err]} {
1438 set fv {}
1439 if {$view != $curview} {
1440 set fv " for the \"$viewname($view)\" view"
1442 if {[string range $err 0 4] == "usage"} {
1443 set err "Gitk: error reading commits$fv:\
1444 bad arguments to git log."
1445 if {$viewname($view) eq "Command line"} {
1446 append err \
1447 " (Note: arguments to gitk are passed to git log\
1448 to allow selection of commits to be displayed.)"
1450 } else {
1451 set err "Error reading commits$fv: $err"
1453 error_popup $err
1455 if {[incr viewactive($view) -1] <= 0} {
1456 set viewcomplete($view) 1
1457 # Check if we have seen any ids listed as parents that haven't
1458 # appeared in the list
1459 closevarcs $view
1460 notbusy $view
1462 if {$view == $curview} {
1463 run chewcommits
1465 return 0
1467 set start 0
1468 set gotsome 0
1469 set scripts {}
1470 while 1 {
1471 set i [string first "\0" $stuff $start]
1472 if {$i < 0} {
1473 append leftover($inst) [string range $stuff $start end]
1474 break
1476 if {$start == 0} {
1477 set cmit $leftover($inst)
1478 append cmit [string range $stuff 0 [expr {$i - 1}]]
1479 set leftover($inst) {}
1480 } else {
1481 set cmit [string range $stuff $start [expr {$i - 1}]]
1483 set start [expr {$i + 1}]
1484 set j [string first "\n" $cmit]
1485 set ok 0
1486 set listed 1
1487 if {$j >= 0 && [string match "commit *" $cmit]} {
1488 set ids [string range $cmit 7 [expr {$j - 1}]]
1489 if {[string match {[-^<>]*} $ids]} {
1490 switch -- [string index $ids 0] {
1491 "-" {set listed 0}
1492 "^" {set listed 2}
1493 "<" {set listed 3}
1494 ">" {set listed 4}
1496 set ids [string range $ids 1 end]
1498 set ok 1
1499 foreach id $ids {
1500 if {[string length $id] != 40} {
1501 set ok 0
1502 break
1506 if {!$ok} {
1507 set shortcmit $cmit
1508 if {[string length $shortcmit] > 80} {
1509 set shortcmit "[string range $shortcmit 0 80]..."
1511 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1512 exit 1
1514 set id [lindex $ids 0]
1515 set vid $view,$id
1517 lappend vshortids($view,[string range $id 0 3]) $id
1519 if {!$listed && $updating && ![info exists varcid($vid)] &&
1520 $vfilelimit($view) ne {}} {
1521 # git log doesn't rewrite parents for unlisted commits
1522 # when doing path limiting, so work around that here
1523 # by working out the rewritten parent with git rev-list
1524 # and if we already know about it, using the rewritten
1525 # parent as a substitute parent for $id's children.
1526 if {![catch {
1527 set rwid [exec git rev-list --first-parent --max-count=1 \
1528 $id -- $vfilelimit($view)]
1529 }]} {
1530 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1531 # use $rwid in place of $id
1532 rewrite_commit $view $id $rwid
1533 continue
1538 set a 0
1539 if {[info exists varcid($vid)]} {
1540 if {$cmitlisted($vid) || !$listed} continue
1541 set a $varcid($vid)
1543 if {$listed} {
1544 set olds [lrange $ids 1 end]
1545 } else {
1546 set olds {}
1548 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1549 set cmitlisted($vid) $listed
1550 set parents($vid) $olds
1551 if {![info exists children($vid)]} {
1552 set children($vid) {}
1553 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1554 set k [lindex $children($vid) 0]
1555 if {[llength $parents($view,$k)] == 1 &&
1556 (!$vdatemode($view) ||
1557 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1558 set a $varcid($view,$k)
1561 if {$a == 0} {
1562 # new arc
1563 set a [newvarc $view $id]
1565 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1566 modify_arc $view $a
1568 if {![info exists varcid($vid)]} {
1569 set varcid($vid) $a
1570 lappend varccommits($view,$a) $id
1571 incr commitidx($view)
1574 set i 0
1575 foreach p $olds {
1576 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1577 set vp $view,$p
1578 if {[llength [lappend children($vp) $id]] > 1 &&
1579 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1580 set children($vp) [lsort -command [list vtokcmp $view] \
1581 $children($vp)]
1582 catch {unset ordertok}
1584 if {[info exists varcid($view,$p)]} {
1585 fix_reversal $p $a $view
1588 incr i
1591 set scripts [check_interest $id $scripts]
1592 set gotsome 1
1594 if {$gotsome} {
1595 global numcommits hlview
1597 if {$view == $curview} {
1598 set numcommits $commitidx($view)
1599 run chewcommits
1601 if {[info exists hlview] && $view == $hlview} {
1602 # we never actually get here...
1603 run vhighlightmore
1605 foreach s $scripts {
1606 eval $s
1609 return 2
1612 proc chewcommits {} {
1613 global curview hlview viewcomplete
1614 global pending_select
1616 layoutmore
1617 if {$viewcomplete($curview)} {
1618 global commitidx varctok
1619 global numcommits startmsecs
1621 if {[info exists pending_select]} {
1622 update
1623 reset_pending_select {}
1625 if {[commitinview $pending_select $curview]} {
1626 selectline [rowofcommit $pending_select] 1
1627 } else {
1628 set row [first_real_row]
1629 selectline $row 1
1632 if {$commitidx($curview) > 0} {
1633 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1634 #puts "overall $ms ms for $numcommits commits"
1635 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1636 } else {
1637 show_status [mc "No commits selected"]
1639 notbusy layout
1641 return 0
1644 proc do_readcommit {id} {
1645 global tclencoding
1647 # Invoke git-log to handle automatic encoding conversion
1648 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1649 # Read the results using i18n.logoutputencoding
1650 fconfigure $fd -translation lf -eofchar {}
1651 if {$tclencoding != {}} {
1652 fconfigure $fd -encoding $tclencoding
1654 set contents [read $fd]
1655 close $fd
1656 # Remove the heading line
1657 regsub {^commit [0-9a-f]+\n} $contents {} contents
1659 return $contents
1662 proc readcommit {id} {
1663 if {[catch {set contents [do_readcommit $id]}]} return
1664 parsecommit $id $contents 1
1667 proc parsecommit {id contents listed} {
1668 global commitinfo
1670 set inhdr 1
1671 set comment {}
1672 set headline {}
1673 set auname {}
1674 set audate {}
1675 set comname {}
1676 set comdate {}
1677 set hdrend [string first "\n\n" $contents]
1678 if {$hdrend < 0} {
1679 # should never happen...
1680 set hdrend [string length $contents]
1682 set header [string range $contents 0 [expr {$hdrend - 1}]]
1683 set comment [string range $contents [expr {$hdrend + 2}] end]
1684 foreach line [split $header "\n"] {
1685 set line [split $line " "]
1686 set tag [lindex $line 0]
1687 if {$tag == "author"} {
1688 set audate [lrange $line end-1 end]
1689 set auname [join [lrange $line 1 end-2] " "]
1690 } elseif {$tag == "committer"} {
1691 set comdate [lrange $line end-1 end]
1692 set comname [join [lrange $line 1 end-2] " "]
1695 set headline {}
1696 # take the first non-blank line of the comment as the headline
1697 set headline [string trimleft $comment]
1698 set i [string first "\n" $headline]
1699 if {$i >= 0} {
1700 set headline [string range $headline 0 $i]
1702 set headline [string trimright $headline]
1703 set i [string first "\r" $headline]
1704 if {$i >= 0} {
1705 set headline [string trimright [string range $headline 0 $i]]
1707 if {!$listed} {
1708 # git log indents the comment by 4 spaces;
1709 # if we got this via git cat-file, add the indentation
1710 set newcomment {}
1711 foreach line [split $comment "\n"] {
1712 append newcomment " "
1713 append newcomment $line
1714 append newcomment "\n"
1716 set comment $newcomment
1718 set hasnote [string first "\nNotes:\n" $contents]
1719 set diff ""
1720 # If there is diff output shown in the git-log stream, split it
1721 # out. But get rid of the empty line that always precedes the
1722 # diff.
1723 set i [string first "\n\ndiff" $comment]
1724 if {$i >= 0} {
1725 set diff [string range $comment $i+1 end]
1726 set comment [string range $comment 0 $i-1]
1728 set commitinfo($id) [list $headline $auname $audate \
1729 $comname $comdate $comment $hasnote $diff]
1732 proc getcommit {id} {
1733 global commitdata commitinfo
1735 if {[info exists commitdata($id)]} {
1736 parsecommit $id $commitdata($id) 1
1737 } else {
1738 readcommit $id
1739 if {![info exists commitinfo($id)]} {
1740 set commitinfo($id) [list [mc "No commit information available"]]
1743 return 1
1746 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1747 # and are present in the current view.
1748 # This is fairly slow...
1749 proc longid {prefix} {
1750 global varcid curview vshortids
1752 set ids {}
1753 if {[string length $prefix] >= 4} {
1754 set vshortid $curview,[string range $prefix 0 3]
1755 if {[info exists vshortids($vshortid)]} {
1756 foreach id $vshortids($vshortid) {
1757 if {[string match "$prefix*" $id]} {
1758 if {[lsearch -exact $ids $id] < 0} {
1759 lappend ids $id
1760 if {[llength $ids] >= 2} break
1765 } else {
1766 foreach match [array names varcid "$curview,$prefix*"] {
1767 lappend ids [lindex [split $match ","] 1]
1768 if {[llength $ids] >= 2} break
1771 return $ids
1774 proc readrefs {} {
1775 global tagids idtags headids idheads tagobjid
1776 global otherrefids idotherrefs mainhead mainheadid
1777 global selecthead selectheadid
1778 global hideremotes
1780 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1781 catch {unset $v}
1783 set refd [open [list | git show-ref -d] r]
1784 while {[gets $refd line] >= 0} {
1785 if {[string index $line 40] ne " "} continue
1786 set id [string range $line 0 39]
1787 set ref [string range $line 41 end]
1788 if {![string match "refs/*" $ref]} continue
1789 set name [string range $ref 5 end]
1790 if {[string match "remotes/*" $name]} {
1791 if {![string match "*/HEAD" $name] && !$hideremotes} {
1792 set headids($name) $id
1793 lappend idheads($id) $name
1795 } elseif {[string match "heads/*" $name]} {
1796 set name [string range $name 6 end]
1797 set headids($name) $id
1798 lappend idheads($id) $name
1799 } elseif {[string match "tags/*" $name]} {
1800 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1801 # which is what we want since the former is the commit ID
1802 set name [string range $name 5 end]
1803 if {[string match "*^{}" $name]} {
1804 set name [string range $name 0 end-3]
1805 } else {
1806 set tagobjid($name) $id
1808 set tagids($name) $id
1809 lappend idtags($id) $name
1810 } else {
1811 set otherrefids($name) $id
1812 lappend idotherrefs($id) $name
1815 catch {close $refd}
1816 set mainhead {}
1817 set mainheadid {}
1818 catch {
1819 set mainheadid [exec git rev-parse HEAD]
1820 set thehead [exec git symbolic-ref HEAD]
1821 if {[string match "refs/heads/*" $thehead]} {
1822 set mainhead [string range $thehead 11 end]
1825 set selectheadid {}
1826 if {$selecthead ne {}} {
1827 catch {
1828 set selectheadid [exec git rev-parse --verify $selecthead]
1833 # skip over fake commits
1834 proc first_real_row {} {
1835 global nullid nullid2 numcommits
1837 for {set row 0} {$row < $numcommits} {incr row} {
1838 set id [commitonrow $row]
1839 if {$id ne $nullid && $id ne $nullid2} {
1840 break
1843 return $row
1846 # update things for a head moved to a child of its previous location
1847 proc movehead {id name} {
1848 global headids idheads
1850 removehead $headids($name) $name
1851 set headids($name) $id
1852 lappend idheads($id) $name
1855 # update things when a head has been removed
1856 proc removehead {id name} {
1857 global headids idheads
1859 if {$idheads($id) eq $name} {
1860 unset idheads($id)
1861 } else {
1862 set i [lsearch -exact $idheads($id) $name]
1863 if {$i >= 0} {
1864 set idheads($id) [lreplace $idheads($id) $i $i]
1867 unset headids($name)
1870 proc ttk_toplevel {w args} {
1871 global use_ttk
1872 eval [linsert $args 0 ::toplevel $w]
1873 if {$use_ttk} {
1874 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1876 return $w
1879 proc make_transient {window origin} {
1880 global have_tk85
1882 # In MacOS Tk 8.4 transient appears to work by setting
1883 # overrideredirect, which is utterly useless, since the
1884 # windows get no border, and are not even kept above
1885 # the parent.
1886 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1888 wm transient $window $origin
1890 # Windows fails to place transient windows normally, so
1891 # schedule a callback to center them on the parent.
1892 if {[tk windowingsystem] eq {win32}} {
1893 after idle [list tk::PlaceWindow $window widget $origin]
1897 proc show_error {w top msg {mc mc}} {
1898 global NS
1899 if {![info exists NS]} {set NS ""}
1900 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1901 message $w.m -text $msg -justify center -aspect 400
1902 pack $w.m -side top -fill x -padx 20 -pady 20
1903 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1904 pack $w.ok -side bottom -fill x
1905 bind $top <Visibility> "grab $top; focus $top"
1906 bind $top <Key-Return> "destroy $top"
1907 bind $top <Key-space> "destroy $top"
1908 bind $top <Key-Escape> "destroy $top"
1909 tkwait window $top
1912 proc error_popup {msg {owner .}} {
1913 if {[tk windowingsystem] eq "win32"} {
1914 tk_messageBox -icon error -type ok -title [wm title .] \
1915 -parent $owner -message $msg
1916 } else {
1917 set w .error
1918 ttk_toplevel $w
1919 make_transient $w $owner
1920 show_error $w $w $msg
1924 proc confirm_popup {msg {owner .}} {
1925 global confirm_ok NS
1926 set confirm_ok 0
1927 set w .confirm
1928 ttk_toplevel $w
1929 make_transient $w $owner
1930 message $w.m -text $msg -justify center -aspect 400
1931 pack $w.m -side top -fill x -padx 20 -pady 20
1932 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1933 pack $w.ok -side left -fill x
1934 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1935 pack $w.cancel -side right -fill x
1936 bind $w <Visibility> "grab $w; focus $w"
1937 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1938 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1939 bind $w <Key-Escape> "destroy $w"
1940 tk::PlaceWindow $w widget $owner
1941 tkwait window $w
1942 return $confirm_ok
1945 proc setoptions {} {
1946 if {[tk windowingsystem] ne "win32"} {
1947 option add *Panedwindow.showHandle 1 startupFile
1948 option add *Panedwindow.sashRelief raised startupFile
1949 if {[tk windowingsystem] ne "aqua"} {
1950 option add *Menu.font uifont startupFile
1952 } else {
1953 option add *Menu.TearOff 0 startupFile
1955 option add *Button.font uifont startupFile
1956 option add *Checkbutton.font uifont startupFile
1957 option add *Radiobutton.font uifont startupFile
1958 option add *Menubutton.font uifont startupFile
1959 option add *Label.font uifont startupFile
1960 option add *Message.font uifont startupFile
1961 option add *Entry.font textfont startupFile
1962 option add *Text.font textfont startupFile
1963 option add *Labelframe.font uifont startupFile
1964 option add *Spinbox.font textfont startupFile
1965 option add *Listbox.font mainfont startupFile
1968 # Make a menu and submenus.
1969 # m is the window name for the menu, items is the list of menu items to add.
1970 # Each item is a list {mc label type description options...}
1971 # mc is ignored; it's so we can put mc there to alert xgettext
1972 # label is the string that appears in the menu
1973 # type is cascade, command or radiobutton (should add checkbutton)
1974 # description depends on type; it's the sublist for cascade, the
1975 # command to invoke for command, or {variable value} for radiobutton
1976 proc makemenu {m items} {
1977 menu $m
1978 if {[tk windowingsystem] eq {aqua}} {
1979 set Meta1 Cmd
1980 } else {
1981 set Meta1 Ctrl
1983 foreach i $items {
1984 set name [mc [lindex $i 1]]
1985 set type [lindex $i 2]
1986 set thing [lindex $i 3]
1987 set params [list $type]
1988 if {$name ne {}} {
1989 set u [string first "&" [string map {&& x} $name]]
1990 lappend params -label [string map {&& & & {}} $name]
1991 if {$u >= 0} {
1992 lappend params -underline $u
1995 switch -- $type {
1996 "cascade" {
1997 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1998 lappend params -menu $m.$submenu
2000 "command" {
2001 lappend params -command $thing
2003 "radiobutton" {
2004 lappend params -variable [lindex $thing 0] \
2005 -value [lindex $thing 1]
2008 set tail [lrange $i 4 end]
2009 regsub -all {\yMeta1\y} $tail $Meta1 tail
2010 eval $m add $params $tail
2011 if {$type eq "cascade"} {
2012 makemenu $m.$submenu $thing
2017 # translate string and remove ampersands
2018 proc mca {str} {
2019 return [string map {&& & & {}} [mc $str]]
2022 proc cleardropsel {w} {
2023 $w selection clear
2025 proc makedroplist {w varname args} {
2026 global use_ttk
2027 if {$use_ttk} {
2028 set width 0
2029 foreach label $args {
2030 set cx [string length $label]
2031 if {$cx > $width} {set width $cx}
2033 set gm [ttk::combobox $w -width $width -state readonly\
2034 -textvariable $varname -values $args \
2035 -exportselection false]
2036 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2037 } else {
2038 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2040 return $gm
2043 proc makewindow {} {
2044 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2045 global tabstop
2046 global findtype findtypemenu findloc findstring fstring geometry
2047 global entries sha1entry sha1string sha1but
2048 global diffcontextstring diffcontext
2049 global ignorespace
2050 global maincursor textcursor curtextcursor
2051 global rowctxmenu fakerowmenu mergemax wrapcomment
2052 global highlight_files gdttype
2053 global searchstring sstring
2054 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2055 global uifgcolor uifgdisabledcolor
2056 global filesepbgcolor filesepfgcolor
2057 global mergecolors foundbgcolor currentsearchhitbgcolor
2058 global headctxmenu progresscanv progressitem progresscoords statusw
2059 global fprogitem fprogcoord lastprogupdate progupdatepending
2060 global rprogitem rprogcoord rownumsel numcommits
2061 global have_tk85 use_ttk NS
2062 global git_version
2063 global worddiff
2065 # The "mc" arguments here are purely so that xgettext
2066 # sees the following string as needing to be translated
2067 set file {
2068 mc "File" cascade {
2069 {mc "Update" command updatecommits -accelerator F5}
2070 {mc "Reload" command reloadcommits -accelerator Shift-F5}
2071 {mc "Reread references" command rereadrefs}
2072 {mc "List references" command showrefs -accelerator F2}
2073 {xx "" separator}
2074 {mc "Start git gui" command {exec git gui &}}
2075 {xx "" separator}
2076 {mc "Quit" command doquit -accelerator Meta1-Q}
2078 set edit {
2079 mc "Edit" cascade {
2080 {mc "Preferences" command doprefs}
2082 set view {
2083 mc "View" cascade {
2084 {mc "New view..." command {newview 0} -accelerator Shift-F4}
2085 {mc "Edit view..." command editview -state disabled -accelerator F4}
2086 {mc "Delete view" command delview -state disabled}
2087 {xx "" separator}
2088 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2090 if {[tk windowingsystem] ne "aqua"} {
2091 set help {
2092 mc "Help" cascade {
2093 {mc "About gitk" command about}
2094 {mc "Key bindings" command keys}
2096 set bar [list $file $edit $view $help]
2097 } else {
2098 proc ::tk::mac::ShowPreferences {} {doprefs}
2099 proc ::tk::mac::Quit {} {doquit}
2100 lset file end [lreplace [lindex $file end] end-1 end]
2101 set apple {
2102 xx "Apple" cascade {
2103 {mc "About gitk" command about}
2104 {xx "" separator}
2106 set help {
2107 mc "Help" cascade {
2108 {mc "Key bindings" command keys}
2110 set bar [list $apple $file $view $help]
2112 makemenu .bar $bar
2113 . configure -menu .bar
2115 if {$use_ttk} {
2116 # cover the non-themed toplevel with a themed frame.
2117 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2120 # the gui has upper and lower half, parts of a paned window.
2121 ${NS}::panedwindow .ctop -orient vertical
2123 # possibly use assumed geometry
2124 if {![info exists geometry(pwsash0)]} {
2125 set geometry(topheight) [expr {15 * $linespc}]
2126 set geometry(topwidth) [expr {80 * $charspc}]
2127 set geometry(botheight) [expr {15 * $linespc}]
2128 set geometry(botwidth) [expr {50 * $charspc}]
2129 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2130 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2133 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2134 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2135 ${NS}::frame .tf.histframe
2136 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2137 if {!$use_ttk} {
2138 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2141 # create three canvases
2142 set cscroll .tf.histframe.csb
2143 set canv .tf.histframe.pwclist.canv
2144 canvas $canv \
2145 -selectbackground $selectbgcolor \
2146 -background $bgcolor -bd 0 \
2147 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2148 .tf.histframe.pwclist add $canv
2149 set canv2 .tf.histframe.pwclist.canv2
2150 canvas $canv2 \
2151 -selectbackground $selectbgcolor \
2152 -background $bgcolor -bd 0 -yscrollincr $linespc
2153 .tf.histframe.pwclist add $canv2
2154 set canv3 .tf.histframe.pwclist.canv3
2155 canvas $canv3 \
2156 -selectbackground $selectbgcolor \
2157 -background $bgcolor -bd 0 -yscrollincr $linespc
2158 .tf.histframe.pwclist add $canv3
2159 if {$use_ttk} {
2160 bind .tf.histframe.pwclist <Map> {
2161 bind %W <Map> {}
2162 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2163 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2165 } else {
2166 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2167 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2170 # a scroll bar to rule them
2171 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2172 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2173 pack $cscroll -side right -fill y
2174 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2175 lappend bglist $canv $canv2 $canv3
2176 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2178 # we have two button bars at bottom of top frame. Bar 1
2179 ${NS}::frame .tf.bar
2180 ${NS}::frame .tf.lbar -height 15
2182 set sha1entry .tf.bar.sha1
2183 set entries $sha1entry
2184 set sha1but .tf.bar.sha1label
2185 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2186 -command gotocommit -width 8
2187 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2188 pack .tf.bar.sha1label -side left
2189 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2190 trace add variable sha1string write sha1change
2191 pack $sha1entry -side left -pady 2
2193 set bm_left_data {
2194 #define left_width 16
2195 #define left_height 16
2196 static unsigned char left_bits[] = {
2197 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2198 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2199 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2201 set bm_right_data {
2202 #define right_width 16
2203 #define right_height 16
2204 static unsigned char right_bits[] = {
2205 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2206 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2207 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2209 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2210 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2211 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2212 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2214 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2215 if {$use_ttk} {
2216 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2217 } else {
2218 .tf.bar.leftbut configure -image bm-left
2220 pack .tf.bar.leftbut -side left -fill y
2221 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2222 if {$use_ttk} {
2223 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2224 } else {
2225 .tf.bar.rightbut configure -image bm-right
2227 pack .tf.bar.rightbut -side left -fill y
2229 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2230 set rownumsel {}
2231 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2232 -relief sunken -anchor e
2233 ${NS}::label .tf.bar.rowlabel2 -text "/"
2234 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2235 -relief sunken -anchor e
2236 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2237 -side left
2238 if {!$use_ttk} {
2239 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2241 global selectedline
2242 trace add variable selectedline write selectedline_change
2244 # Status label and progress bar
2245 set statusw .tf.bar.status
2246 ${NS}::label $statusw -width 15 -relief sunken
2247 pack $statusw -side left -padx 5
2248 if {$use_ttk} {
2249 set progresscanv [ttk::progressbar .tf.bar.progress]
2250 } else {
2251 set h [expr {[font metrics uifont -linespace] + 2}]
2252 set progresscanv .tf.bar.progress
2253 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2254 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2255 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2256 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2258 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2259 set progresscoords {0 0}
2260 set fprogcoord 0
2261 set rprogcoord 0
2262 bind $progresscanv <Configure> adjustprogress
2263 set lastprogupdate [clock clicks -milliseconds]
2264 set progupdatepending 0
2266 # build up the bottom bar of upper window
2267 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2269 set bm_down_data {
2270 #define down_width 16
2271 #define down_height 16
2272 static unsigned char down_bits[] = {
2273 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2274 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2275 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2276 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2278 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2279 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2280 .tf.lbar.fnext configure -image bm-down
2282 set bm_up_data {
2283 #define up_width 16
2284 #define up_height 16
2285 static unsigned char up_bits[] = {
2286 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2287 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2288 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2289 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2291 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2292 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2293 .tf.lbar.fprev configure -image bm-up
2295 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2297 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2298 -side left -fill y
2299 set gdttype [mc "containing:"]
2300 set gm [makedroplist .tf.lbar.gdttype gdttype \
2301 [mc "containing:"] \
2302 [mc "touching paths:"] \
2303 [mc "adding/removing string:"] \
2304 [mc "changing lines matching:"]]
2305 trace add variable gdttype write gdttype_change
2306 pack .tf.lbar.gdttype -side left -fill y
2308 set findstring {}
2309 set fstring .tf.lbar.findstring
2310 lappend entries $fstring
2311 ${NS}::entry $fstring -width 30 -textvariable findstring
2312 trace add variable findstring write find_change
2313 set findtype [mc "Exact"]
2314 set findtypemenu [makedroplist .tf.lbar.findtype \
2315 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2316 trace add variable findtype write findcom_change
2317 set findloc [mc "All fields"]
2318 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2319 [mc "Comments"] [mc "Author"] [mc "Committer"]
2320 trace add variable findloc write find_change
2321 pack .tf.lbar.findloc -side right
2322 pack .tf.lbar.findtype -side right
2323 pack $fstring -side left -expand 1 -fill x
2325 # Finish putting the upper half of the viewer together
2326 pack .tf.lbar -in .tf -side bottom -fill x
2327 pack .tf.bar -in .tf -side bottom -fill x
2328 pack .tf.histframe -fill both -side top -expand 1
2329 .ctop add .tf
2330 if {!$use_ttk} {
2331 .ctop paneconfigure .tf -height $geometry(topheight)
2332 .ctop paneconfigure .tf -width $geometry(topwidth)
2335 # now build up the bottom
2336 ${NS}::panedwindow .pwbottom -orient horizontal
2338 # lower left, a text box over search bar, scroll bar to the right
2339 # if we know window height, then that will set the lower text height, otherwise
2340 # we set lower text height which will drive window height
2341 if {[info exists geometry(main)]} {
2342 ${NS}::frame .bleft -width $geometry(botwidth)
2343 } else {
2344 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2346 ${NS}::frame .bleft.top
2347 ${NS}::frame .bleft.mid
2348 ${NS}::frame .bleft.bottom
2350 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2351 pack .bleft.top.search -side left -padx 5
2352 set sstring .bleft.top.sstring
2353 set searchstring ""
2354 ${NS}::entry $sstring -width 20 -textvariable searchstring
2355 lappend entries $sstring
2356 trace add variable searchstring write incrsearch
2357 pack $sstring -side left -expand 1 -fill x
2358 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2359 -command changediffdisp -variable diffelide -value {0 0}
2360 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2361 -command changediffdisp -variable diffelide -value {0 1}
2362 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2363 -command changediffdisp -variable diffelide -value {1 0}
2364 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2365 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2366 spinbox .bleft.mid.diffcontext -width 5 \
2367 -from 0 -increment 1 -to 10000000 \
2368 -validate all -validatecommand "diffcontextvalidate %P" \
2369 -textvariable diffcontextstring
2370 .bleft.mid.diffcontext set $diffcontext
2371 trace add variable diffcontextstring write diffcontextchange
2372 lappend entries .bleft.mid.diffcontext
2373 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2374 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2375 -command changeignorespace -variable ignorespace
2376 pack .bleft.mid.ignspace -side left -padx 5
2378 set worddiff [mc "Line diff"]
2379 if {[package vcompare $git_version "1.7.2"] >= 0} {
2380 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2381 [mc "Markup words"] [mc "Color words"]
2382 trace add variable worddiff write changeworddiff
2383 pack .bleft.mid.worddiff -side left -padx 5
2386 set ctext .bleft.bottom.ctext
2387 text $ctext -background $bgcolor -foreground $fgcolor \
2388 -state disabled -font textfont \
2389 -yscrollcommand scrolltext -wrap none \
2390 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2391 if {$have_tk85} {
2392 $ctext conf -tabstyle wordprocessor
2394 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2395 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2396 pack .bleft.top -side top -fill x
2397 pack .bleft.mid -side top -fill x
2398 grid $ctext .bleft.bottom.sb -sticky nsew
2399 grid .bleft.bottom.sbhorizontal -sticky ew
2400 grid columnconfigure .bleft.bottom 0 -weight 1
2401 grid rowconfigure .bleft.bottom 0 -weight 1
2402 grid rowconfigure .bleft.bottom 1 -weight 0
2403 pack .bleft.bottom -side top -fill both -expand 1
2404 lappend bglist $ctext
2405 lappend fglist $ctext
2407 $ctext tag conf comment -wrap $wrapcomment
2408 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2409 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2410 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2411 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2412 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2413 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2414 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2415 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2416 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2417 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2418 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2419 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2420 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2421 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2422 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2423 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2424 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2425 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2426 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2427 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2428 $ctext tag conf mmax -fore darkgrey
2429 set mergemax 16
2430 $ctext tag conf mresult -font textfontbold
2431 $ctext tag conf msep -font textfontbold
2432 $ctext tag conf found -back $foundbgcolor
2433 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2434 $ctext tag conf wwrap -wrap word -lmargin2 1c
2435 $ctext tag conf bold -font textfontbold
2437 .pwbottom add .bleft
2438 if {!$use_ttk} {
2439 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2442 # lower right
2443 ${NS}::frame .bright
2444 ${NS}::frame .bright.mode
2445 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2446 -command reselectline -variable cmitmode -value "patch"
2447 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2448 -command reselectline -variable cmitmode -value "tree"
2449 grid .bright.mode.patch .bright.mode.tree -sticky ew
2450 pack .bright.mode -side top -fill x
2451 set cflist .bright.cfiles
2452 set indent [font measure mainfont "nn"]
2453 text $cflist \
2454 -selectbackground $selectbgcolor \
2455 -background $bgcolor -foreground $fgcolor \
2456 -font mainfont \
2457 -tabs [list $indent [expr {2 * $indent}]] \
2458 -yscrollcommand ".bright.sb set" \
2459 -cursor [. cget -cursor] \
2460 -spacing1 1 -spacing3 1
2461 lappend bglist $cflist
2462 lappend fglist $cflist
2463 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2464 pack .bright.sb -side right -fill y
2465 pack $cflist -side left -fill both -expand 1
2466 $cflist tag configure highlight \
2467 -background [$cflist cget -selectbackground]
2468 $cflist tag configure bold -font mainfontbold
2470 .pwbottom add .bright
2471 .ctop add .pwbottom
2473 # restore window width & height if known
2474 if {[info exists geometry(main)]} {
2475 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2476 if {$w > [winfo screenwidth .]} {
2477 set w [winfo screenwidth .]
2479 if {$h > [winfo screenheight .]} {
2480 set h [winfo screenheight .]
2482 wm geometry . "${w}x$h"
2486 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2487 wm state . $geometry(state)
2490 if {[tk windowingsystem] eq {aqua}} {
2491 set M1B M1
2492 set ::BM "3"
2493 } else {
2494 set M1B Control
2495 set ::BM "2"
2498 if {$use_ttk} {
2499 bind .ctop <Map> {
2500 bind %W <Map> {}
2501 %W sashpos 0 $::geometry(topheight)
2503 bind .pwbottom <Map> {
2504 bind %W <Map> {}
2505 %W sashpos 0 $::geometry(botwidth)
2509 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2510 pack .ctop -fill both -expand 1
2511 bindall <1> {selcanvline %W %x %y}
2512 #bindall <B1-Motion> {selcanvline %W %x %y}
2513 if {[tk windowingsystem] == "win32"} {
2514 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2515 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2516 } else {
2517 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2518 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2519 bind $ctext <Button> {
2520 if {"%b" eq 6} {
2521 $ctext xview scroll -5 units
2522 } elseif {"%b" eq 7} {
2523 $ctext xview scroll 5 units
2526 if {[tk windowingsystem] eq "aqua"} {
2527 bindall <MouseWheel> {
2528 set delta [expr {- (%D)}]
2529 allcanvs yview scroll $delta units
2531 bindall <Shift-MouseWheel> {
2532 set delta [expr {- (%D)}]
2533 $canv xview scroll $delta units
2537 bindall <$::BM> "canvscan mark %W %x %y"
2538 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2539 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2540 bind . <$M1B-Key-w> doquit
2541 bindkey <Home> selfirstline
2542 bindkey <End> sellastline
2543 bind . <Key-Up> "selnextline -1"
2544 bind . <Key-Down> "selnextline 1"
2545 bind . <Shift-Key-Up> "dofind -1 0"
2546 bind . <Shift-Key-Down> "dofind 1 0"
2547 bindkey <Key-Right> "goforw"
2548 bindkey <Key-Left> "goback"
2549 bind . <Key-Prior> "selnextpage -1"
2550 bind . <Key-Next> "selnextpage 1"
2551 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2552 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2553 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2554 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2555 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2556 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2557 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2558 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2559 bindkey <Key-space> "$ctext yview scroll 1 pages"
2560 bindkey p "selnextline -1"
2561 bindkey n "selnextline 1"
2562 bindkey z "goback"
2563 bindkey x "goforw"
2564 bindkey k "selnextline -1"
2565 bindkey j "selnextline 1"
2566 bindkey h "goback"
2567 bindkey l "goforw"
2568 bindkey b prevfile
2569 bindkey d "$ctext yview scroll 18 units"
2570 bindkey u "$ctext yview scroll -18 units"
2571 bindkey / {focus $fstring}
2572 bindkey <Key-KP_Divide> {focus $fstring}
2573 bindkey <Key-Return> {dofind 1 1}
2574 bindkey ? {dofind -1 1}
2575 bindkey f nextfile
2576 bind . <F5> updatecommits
2577 bindmodfunctionkey Shift 5 reloadcommits
2578 bind . <F2> showrefs
2579 bindmodfunctionkey Shift 4 {newview 0}
2580 bind . <F4> edit_or_newview
2581 bind . <$M1B-q> doquit
2582 bind . <$M1B-f> {dofind 1 1}
2583 bind . <$M1B-g> {dofind 1 0}
2584 bind . <$M1B-r> dosearchback
2585 bind . <$M1B-s> dosearch
2586 bind . <$M1B-equal> {incrfont 1}
2587 bind . <$M1B-plus> {incrfont 1}
2588 bind . <$M1B-KP_Add> {incrfont 1}
2589 bind . <$M1B-minus> {incrfont -1}
2590 bind . <$M1B-KP_Subtract> {incrfont -1}
2591 wm protocol . WM_DELETE_WINDOW doquit
2592 bind . <Destroy> {stop_backends}
2593 bind . <Button-1> "click %W"
2594 bind $fstring <Key-Return> {dofind 1 1}
2595 bind $sha1entry <Key-Return> {gotocommit; break}
2596 bind $sha1entry <<PasteSelection>> clearsha1
2597 bind $sha1entry <<Paste>> clearsha1
2598 bind $cflist <1> {sel_flist %W %x %y; break}
2599 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2600 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2601 global ctxbut
2602 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2603 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2604 bind $ctext <Button-1> {focus %W}
2605 bind $ctext <<Selection>> rehighlight_search_results
2606 for {set i 1} {$i < 10} {incr i} {
2607 bind . <$M1B-Key-$i> [list go_to_parent $i]
2610 set maincursor [. cget -cursor]
2611 set textcursor [$ctext cget -cursor]
2612 set curtextcursor $textcursor
2614 set rowctxmenu .rowctxmenu
2615 makemenu $rowctxmenu {
2616 {mc "Diff this -> selected" command {diffvssel 0}}
2617 {mc "Diff selected -> this" command {diffvssel 1}}
2618 {mc "Make patch" command mkpatch}
2619 {mc "Create tag" command mktag}
2620 {mc "Write commit to file" command writecommit}
2621 {mc "Create new branch" command mkbranch}
2622 {mc "Cherry-pick this commit" command cherrypick}
2623 {mc "Reset HEAD branch to here" command resethead}
2624 {mc "Mark this commit" command markhere}
2625 {mc "Return to mark" command gotomark}
2626 {mc "Find descendant of this and mark" command find_common_desc}
2627 {mc "Compare with marked commit" command compare_commits}
2628 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2629 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2630 {mc "Revert this commit" command revert}
2632 $rowctxmenu configure -tearoff 0
2634 set fakerowmenu .fakerowmenu
2635 makemenu $fakerowmenu {
2636 {mc "Diff this -> selected" command {diffvssel 0}}
2637 {mc "Diff selected -> this" command {diffvssel 1}}
2638 {mc "Make patch" command mkpatch}
2639 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2640 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2642 $fakerowmenu configure -tearoff 0
2644 set headctxmenu .headctxmenu
2645 makemenu $headctxmenu {
2646 {mc "Check out this branch" command cobranch}
2647 {mc "Remove this branch" command rmbranch}
2649 $headctxmenu configure -tearoff 0
2651 global flist_menu
2652 set flist_menu .flistctxmenu
2653 makemenu $flist_menu {
2654 {mc "Highlight this too" command {flist_hl 0}}
2655 {mc "Highlight this only" command {flist_hl 1}}
2656 {mc "External diff" command {external_diff}}
2657 {mc "Blame parent commit" command {external_blame 1}}
2659 $flist_menu configure -tearoff 0
2661 global diff_menu
2662 set diff_menu .diffctxmenu
2663 makemenu $diff_menu {
2664 {mc "Show origin of this line" command show_line_source}
2665 {mc "Run git gui blame on this line" command {external_blame_diff}}
2667 $diff_menu configure -tearoff 0
2670 # Windows sends all mouse wheel events to the current focused window, not
2671 # the one where the mouse hovers, so bind those events here and redirect
2672 # to the correct window
2673 proc windows_mousewheel_redirector {W X Y D} {
2674 global canv canv2 canv3
2675 set w [winfo containing -displayof $W $X $Y]
2676 if {$w ne ""} {
2677 set u [expr {$D < 0 ? 5 : -5}]
2678 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2679 allcanvs yview scroll $u units
2680 } else {
2681 catch {
2682 $w yview scroll $u units
2688 # Update row number label when selectedline changes
2689 proc selectedline_change {n1 n2 op} {
2690 global selectedline rownumsel
2692 if {$selectedline eq {}} {
2693 set rownumsel {}
2694 } else {
2695 set rownumsel [expr {$selectedline + 1}]
2699 # mouse-2 makes all windows scan vertically, but only the one
2700 # the cursor is in scans horizontally
2701 proc canvscan {op w x y} {
2702 global canv canv2 canv3
2703 foreach c [list $canv $canv2 $canv3] {
2704 if {$c == $w} {
2705 $c scan $op $x $y
2706 } else {
2707 $c scan $op 0 $y
2712 proc scrollcanv {cscroll f0 f1} {
2713 $cscroll set $f0 $f1
2714 drawvisible
2715 flushhighlights
2718 # when we make a key binding for the toplevel, make sure
2719 # it doesn't get triggered when that key is pressed in the
2720 # find string entry widget.
2721 proc bindkey {ev script} {
2722 global entries
2723 bind . $ev $script
2724 set escript [bind Entry $ev]
2725 if {$escript == {}} {
2726 set escript [bind Entry <Key>]
2728 foreach e $entries {
2729 bind $e $ev "$escript; break"
2733 proc bindmodfunctionkey {mod n script} {
2734 bind . <$mod-F$n> $script
2735 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2738 # set the focus back to the toplevel for any click outside
2739 # the entry widgets
2740 proc click {w} {
2741 global ctext entries
2742 foreach e [concat $entries $ctext] {
2743 if {$w == $e} return
2745 focus .
2748 # Adjust the progress bar for a change in requested extent or canvas size
2749 proc adjustprogress {} {
2750 global progresscanv progressitem progresscoords
2751 global fprogitem fprogcoord lastprogupdate progupdatepending
2752 global rprogitem rprogcoord use_ttk
2754 if {$use_ttk} {
2755 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2756 return
2759 set w [expr {[winfo width $progresscanv] - 4}]
2760 set x0 [expr {$w * [lindex $progresscoords 0]}]
2761 set x1 [expr {$w * [lindex $progresscoords 1]}]
2762 set h [winfo height $progresscanv]
2763 $progresscanv coords $progressitem $x0 0 $x1 $h
2764 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2765 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2766 set now [clock clicks -milliseconds]
2767 if {$now >= $lastprogupdate + 100} {
2768 set progupdatepending 0
2769 update
2770 } elseif {!$progupdatepending} {
2771 set progupdatepending 1
2772 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2776 proc doprogupdate {} {
2777 global lastprogupdate progupdatepending
2779 if {$progupdatepending} {
2780 set progupdatepending 0
2781 set lastprogupdate [clock clicks -milliseconds]
2782 update
2786 proc config_check_tmp_exists {tries_left} {
2787 global config_file_tmp
2789 if {[file exists $config_file_tmp]} {
2790 incr tries_left -1
2791 if {$tries_left > 0} {
2792 after 100 [list config_check_tmp_exists $tries_left]
2793 } else {
2794 error_popup "There appears to be a stale $config_file_tmp\
2795 file, which will prevent gitk from saving its configuration on exit.\
2796 Please remove it if it is not being used by any existing gitk process."
2801 proc config_init_trace {name} {
2802 global config_variable_changed config_variable_original
2804 upvar #0 $name var
2805 set config_variable_changed($name) 0
2806 set config_variable_original($name) $var
2809 proc config_variable_change_cb {name name2 op} {
2810 global config_variable_changed config_variable_original
2812 upvar #0 $name var
2813 if {$op eq "write" &&
2814 (![info exists config_variable_original($name)] ||
2815 $config_variable_original($name) ne $var)} {
2816 set config_variable_changed($name) 1
2820 proc savestuff {w} {
2821 global stuffsaved
2822 global config_file config_file_tmp
2823 global config_variables config_variable_changed
2824 global viewchanged
2826 upvar #0 viewname current_viewname
2827 upvar #0 viewfiles current_viewfiles
2828 upvar #0 viewargs current_viewargs
2829 upvar #0 viewargscmd current_viewargscmd
2830 upvar #0 viewperm current_viewperm
2831 upvar #0 nextviewnum current_nextviewnum
2832 upvar #0 use_ttk current_use_ttk
2834 if {$stuffsaved} return
2835 if {![winfo viewable .]} return
2836 set remove_tmp 0
2837 if {[catch {
2838 set try_count 0
2839 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2840 if {[incr try_count] > 50} {
2841 error "Unable to write config file: $config_file_tmp exists"
2843 after 100
2845 set remove_tmp 1
2846 if {$::tcl_platform(platform) eq {windows}} {
2847 file attributes $config_file_tmp -hidden true
2849 if {[file exists $config_file]} {
2850 source $config_file
2852 foreach var_name $config_variables {
2853 upvar #0 $var_name var
2854 upvar 0 $var_name old_var
2855 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2856 puts $f [list set $var_name $old_var]
2857 } else {
2858 puts $f [list set $var_name $var]
2862 puts $f "set geometry(main) [wm geometry .]"
2863 puts $f "set geometry(state) [wm state .]"
2864 puts $f "set geometry(topwidth) [winfo width .tf]"
2865 puts $f "set geometry(topheight) [winfo height .tf]"
2866 if {$current_use_ttk} {
2867 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2868 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2869 } else {
2870 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2871 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2873 puts $f "set geometry(botwidth) [winfo width .bleft]"
2874 puts $f "set geometry(botheight) [winfo height .bleft]"
2876 array set view_save {}
2877 array set views {}
2878 if {![info exists permviews]} { set permviews {} }
2879 foreach view $permviews {
2880 set view_save([lindex $view 0]) 1
2881 set views([lindex $view 0]) $view
2883 puts -nonewline $f "set permviews {"
2884 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2885 if {$viewchanged($v)} {
2886 if {$current_viewperm($v)} {
2887 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2888 } else {
2889 set view_save($current_viewname($v)) 0
2893 # write old and updated view to their places and append remaining to the end
2894 foreach view $permviews {
2895 set view_name [lindex $view 0]
2896 if {$view_save($view_name)} {
2897 puts $f "{$views($view_name)}"
2899 unset views($view_name)
2901 foreach view_name [array names views] {
2902 puts $f "{$views($view_name)}"
2904 puts $f "}"
2905 close $f
2906 file rename -force $config_file_tmp $config_file
2907 set remove_tmp 0
2908 } err]} {
2909 puts "Error saving config: $err"
2911 if {$remove_tmp} {
2912 file delete -force $config_file_tmp
2914 set stuffsaved 1
2917 proc resizeclistpanes {win w} {
2918 global oldwidth use_ttk
2919 if {[info exists oldwidth($win)]} {
2920 if {$use_ttk} {
2921 set s0 [$win sashpos 0]
2922 set s1 [$win sashpos 1]
2923 } else {
2924 set s0 [$win sash coord 0]
2925 set s1 [$win sash coord 1]
2927 if {$w < 60} {
2928 set sash0 [expr {int($w/2 - 2)}]
2929 set sash1 [expr {int($w*5/6 - 2)}]
2930 } else {
2931 set factor [expr {1.0 * $w / $oldwidth($win)}]
2932 set sash0 [expr {int($factor * [lindex $s0 0])}]
2933 set sash1 [expr {int($factor * [lindex $s1 0])}]
2934 if {$sash0 < 30} {
2935 set sash0 30
2937 if {$sash1 < $sash0 + 20} {
2938 set sash1 [expr {$sash0 + 20}]
2940 if {$sash1 > $w - 10} {
2941 set sash1 [expr {$w - 10}]
2942 if {$sash0 > $sash1 - 20} {
2943 set sash0 [expr {$sash1 - 20}]
2947 if {$use_ttk} {
2948 $win sashpos 0 $sash0
2949 $win sashpos 1 $sash1
2950 } else {
2951 $win sash place 0 $sash0 [lindex $s0 1]
2952 $win sash place 1 $sash1 [lindex $s1 1]
2955 set oldwidth($win) $w
2958 proc resizecdetpanes {win w} {
2959 global oldwidth use_ttk
2960 if {[info exists oldwidth($win)]} {
2961 if {$use_ttk} {
2962 set s0 [$win sashpos 0]
2963 } else {
2964 set s0 [$win sash coord 0]
2966 if {$w < 60} {
2967 set sash0 [expr {int($w*3/4 - 2)}]
2968 } else {
2969 set factor [expr {1.0 * $w / $oldwidth($win)}]
2970 set sash0 [expr {int($factor * [lindex $s0 0])}]
2971 if {$sash0 < 45} {
2972 set sash0 45
2974 if {$sash0 > $w - 15} {
2975 set sash0 [expr {$w - 15}]
2978 if {$use_ttk} {
2979 $win sashpos 0 $sash0
2980 } else {
2981 $win sash place 0 $sash0 [lindex $s0 1]
2984 set oldwidth($win) $w
2987 proc allcanvs args {
2988 global canv canv2 canv3
2989 eval $canv $args
2990 eval $canv2 $args
2991 eval $canv3 $args
2994 proc bindall {event action} {
2995 global canv canv2 canv3
2996 bind $canv $event $action
2997 bind $canv2 $event $action
2998 bind $canv3 $event $action
3001 proc about {} {
3002 global uifont NS
3003 set w .about
3004 if {[winfo exists $w]} {
3005 raise $w
3006 return
3008 ttk_toplevel $w
3009 wm title $w [mc "About gitk"]
3010 make_transient $w .
3011 message $w.m -text [mc "
3012 Gitk - a commit viewer for git
3014 Copyright \u00a9 2005-2014 Paul Mackerras
3016 Use and redistribute under the terms of the GNU General Public License"] \
3017 -justify center -aspect 400 -border 2 -bg white -relief groove
3018 pack $w.m -side top -fill x -padx 2 -pady 2
3019 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3020 pack $w.ok -side bottom
3021 bind $w <Visibility> "focus $w.ok"
3022 bind $w <Key-Escape> "destroy $w"
3023 bind $w <Key-Return> "destroy $w"
3024 tk::PlaceWindow $w widget .
3027 proc keys {} {
3028 global NS
3029 set w .keys
3030 if {[winfo exists $w]} {
3031 raise $w
3032 return
3034 if {[tk windowingsystem] eq {aqua}} {
3035 set M1T Cmd
3036 } else {
3037 set M1T Ctrl
3039 ttk_toplevel $w
3040 wm title $w [mc "Gitk key bindings"]
3041 make_transient $w .
3042 message $w.m -text "
3043 [mc "Gitk key bindings:"]
3045 [mc "<%s-Q> Quit" $M1T]
3046 [mc "<%s-W> Close window" $M1T]
3047 [mc "<Home> Move to first commit"]
3048 [mc "<End> Move to last commit"]
3049 [mc "<Up>, p, k Move up one commit"]
3050 [mc "<Down>, n, j Move down one commit"]
3051 [mc "<Left>, z, h Go back in history list"]
3052 [mc "<Right>, x, l Go forward in history list"]
3053 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3054 [mc "<PageUp> Move up one page in commit list"]
3055 [mc "<PageDown> Move down one page in commit list"]
3056 [mc "<%s-Home> Scroll to top of commit list" $M1T]
3057 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
3058 [mc "<%s-Up> Scroll commit list up one line" $M1T]
3059 [mc "<%s-Down> Scroll commit list down one line" $M1T]
3060 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3061 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3062 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3063 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3064 [mc "<Delete>, b Scroll diff view up one page"]
3065 [mc "<Backspace> Scroll diff view up one page"]
3066 [mc "<Space> Scroll diff view down one page"]
3067 [mc "u Scroll diff view up 18 lines"]
3068 [mc "d Scroll diff view down 18 lines"]
3069 [mc "<%s-F> Find" $M1T]
3070 [mc "<%s-G> Move to next find hit" $M1T]
3071 [mc "<Return> Move to next find hit"]
3072 [mc "/ Focus the search box"]
3073 [mc "? Move to previous find hit"]
3074 [mc "f Scroll diff view to next file"]
3075 [mc "<%s-S> Search for next hit in diff view" $M1T]
3076 [mc "<%s-R> Search for previous hit in diff view" $M1T]
3077 [mc "<%s-KP+> Increase font size" $M1T]
3078 [mc "<%s-plus> Increase font size" $M1T]
3079 [mc "<%s-KP-> Decrease font size" $M1T]
3080 [mc "<%s-minus> Decrease font size" $M1T]
3081 [mc "<F5> Update"]
3083 -justify left -bg white -border 2 -relief groove
3084 pack $w.m -side top -fill both -padx 2 -pady 2
3085 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3086 bind $w <Key-Escape> [list destroy $w]
3087 pack $w.ok -side bottom
3088 bind $w <Visibility> "focus $w.ok"
3089 bind $w <Key-Escape> "destroy $w"
3090 bind $w <Key-Return> "destroy $w"
3093 # Procedures for manipulating the file list window at the
3094 # bottom right of the overall window.
3096 proc treeview {w l openlevs} {
3097 global treecontents treediropen treeheight treeparent treeindex
3099 set ix 0
3100 set treeindex() 0
3101 set lev 0
3102 set prefix {}
3103 set prefixend -1
3104 set prefendstack {}
3105 set htstack {}
3106 set ht 0
3107 set treecontents() {}
3108 $w conf -state normal
3109 foreach f $l {
3110 while {[string range $f 0 $prefixend] ne $prefix} {
3111 if {$lev <= $openlevs} {
3112 $w mark set e:$treeindex($prefix) "end -1c"
3113 $w mark gravity e:$treeindex($prefix) left
3115 set treeheight($prefix) $ht
3116 incr ht [lindex $htstack end]
3117 set htstack [lreplace $htstack end end]
3118 set prefixend [lindex $prefendstack end]
3119 set prefendstack [lreplace $prefendstack end end]
3120 set prefix [string range $prefix 0 $prefixend]
3121 incr lev -1
3123 set tail [string range $f [expr {$prefixend+1}] end]
3124 while {[set slash [string first "/" $tail]] >= 0} {
3125 lappend htstack $ht
3126 set ht 0
3127 lappend prefendstack $prefixend
3128 incr prefixend [expr {$slash + 1}]
3129 set d [string range $tail 0 $slash]
3130 lappend treecontents($prefix) $d
3131 set oldprefix $prefix
3132 append prefix $d
3133 set treecontents($prefix) {}
3134 set treeindex($prefix) [incr ix]
3135 set treeparent($prefix) $oldprefix
3136 set tail [string range $tail [expr {$slash+1}] end]
3137 if {$lev <= $openlevs} {
3138 set ht 1
3139 set treediropen($prefix) [expr {$lev < $openlevs}]
3140 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3141 $w mark set d:$ix "end -1c"
3142 $w mark gravity d:$ix left
3143 set str "\n"
3144 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3145 $w insert end $str
3146 $w image create end -align center -image $bm -padx 1 \
3147 -name a:$ix
3148 $w insert end $d [highlight_tag $prefix]
3149 $w mark set s:$ix "end -1c"
3150 $w mark gravity s:$ix left
3152 incr lev
3154 if {$tail ne {}} {
3155 if {$lev <= $openlevs} {
3156 incr ht
3157 set str "\n"
3158 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3159 $w insert end $str
3160 $w insert end $tail [highlight_tag $f]
3162 lappend treecontents($prefix) $tail
3165 while {$htstack ne {}} {
3166 set treeheight($prefix) $ht
3167 incr ht [lindex $htstack end]
3168 set htstack [lreplace $htstack end end]
3169 set prefixend [lindex $prefendstack end]
3170 set prefendstack [lreplace $prefendstack end end]
3171 set prefix [string range $prefix 0 $prefixend]
3173 $w conf -state disabled
3176 proc linetoelt {l} {
3177 global treeheight treecontents
3179 set y 2
3180 set prefix {}
3181 while {1} {
3182 foreach e $treecontents($prefix) {
3183 if {$y == $l} {
3184 return "$prefix$e"
3186 set n 1
3187 if {[string index $e end] eq "/"} {
3188 set n $treeheight($prefix$e)
3189 if {$y + $n > $l} {
3190 append prefix $e
3191 incr y
3192 break
3195 incr y $n
3200 proc highlight_tree {y prefix} {
3201 global treeheight treecontents cflist
3203 foreach e $treecontents($prefix) {
3204 set path $prefix$e
3205 if {[highlight_tag $path] ne {}} {
3206 $cflist tag add bold $y.0 "$y.0 lineend"
3208 incr y
3209 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3210 set y [highlight_tree $y $path]
3213 return $y
3216 proc treeclosedir {w dir} {
3217 global treediropen treeheight treeparent treeindex
3219 set ix $treeindex($dir)
3220 $w conf -state normal
3221 $w delete s:$ix e:$ix
3222 set treediropen($dir) 0
3223 $w image configure a:$ix -image tri-rt
3224 $w conf -state disabled
3225 set n [expr {1 - $treeheight($dir)}]
3226 while {$dir ne {}} {
3227 incr treeheight($dir) $n
3228 set dir $treeparent($dir)
3232 proc treeopendir {w dir} {
3233 global treediropen treeheight treeparent treecontents treeindex
3235 set ix $treeindex($dir)
3236 $w conf -state normal
3237 $w image configure a:$ix -image tri-dn
3238 $w mark set e:$ix s:$ix
3239 $w mark gravity e:$ix right
3240 set lev 0
3241 set str "\n"
3242 set n [llength $treecontents($dir)]
3243 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3244 incr lev
3245 append str "\t"
3246 incr treeheight($x) $n
3248 foreach e $treecontents($dir) {
3249 set de $dir$e
3250 if {[string index $e end] eq "/"} {
3251 set iy $treeindex($de)
3252 $w mark set d:$iy e:$ix
3253 $w mark gravity d:$iy left
3254 $w insert e:$ix $str
3255 set treediropen($de) 0
3256 $w image create e:$ix -align center -image tri-rt -padx 1 \
3257 -name a:$iy
3258 $w insert e:$ix $e [highlight_tag $de]
3259 $w mark set s:$iy e:$ix
3260 $w mark gravity s:$iy left
3261 set treeheight($de) 1
3262 } else {
3263 $w insert e:$ix $str
3264 $w insert e:$ix $e [highlight_tag $de]
3267 $w mark gravity e:$ix right
3268 $w conf -state disabled
3269 set treediropen($dir) 1
3270 set top [lindex [split [$w index @0,0] .] 0]
3271 set ht [$w cget -height]
3272 set l [lindex [split [$w index s:$ix] .] 0]
3273 if {$l < $top} {
3274 $w yview $l.0
3275 } elseif {$l + $n + 1 > $top + $ht} {
3276 set top [expr {$l + $n + 2 - $ht}]
3277 if {$l < $top} {
3278 set top $l
3280 $w yview $top.0
3284 proc treeclick {w x y} {
3285 global treediropen cmitmode ctext cflist cflist_top
3287 if {$cmitmode ne "tree"} return
3288 if {![info exists cflist_top]} return
3289 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3290 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3291 $cflist tag add highlight $l.0 "$l.0 lineend"
3292 set cflist_top $l
3293 if {$l == 1} {
3294 $ctext yview 1.0
3295 return
3297 set e [linetoelt $l]
3298 if {[string index $e end] ne "/"} {
3299 showfile $e
3300 } elseif {$treediropen($e)} {
3301 treeclosedir $w $e
3302 } else {
3303 treeopendir $w $e
3307 proc setfilelist {id} {
3308 global treefilelist cflist jump_to_here
3310 treeview $cflist $treefilelist($id) 0
3311 if {$jump_to_here ne {}} {
3312 set f [lindex $jump_to_here 0]
3313 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3314 showfile $f
3319 image create bitmap tri-rt -background black -foreground blue -data {
3320 #define tri-rt_width 13
3321 #define tri-rt_height 13
3322 static unsigned char tri-rt_bits[] = {
3323 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3324 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3325 0x00, 0x00};
3326 } -maskdata {
3327 #define tri-rt-mask_width 13
3328 #define tri-rt-mask_height 13
3329 static unsigned char tri-rt-mask_bits[] = {
3330 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3331 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3332 0x08, 0x00};
3334 image create bitmap tri-dn -background black -foreground blue -data {
3335 #define tri-dn_width 13
3336 #define tri-dn_height 13
3337 static unsigned char tri-dn_bits[] = {
3338 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3339 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3340 0x00, 0x00};
3341 } -maskdata {
3342 #define tri-dn-mask_width 13
3343 #define tri-dn-mask_height 13
3344 static unsigned char tri-dn-mask_bits[] = {
3345 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3346 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3347 0x00, 0x00};
3350 image create bitmap reficon-T -background black -foreground yellow -data {
3351 #define tagicon_width 13
3352 #define tagicon_height 9
3353 static unsigned char tagicon_bits[] = {
3354 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3355 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3356 } -maskdata {
3357 #define tagicon-mask_width 13
3358 #define tagicon-mask_height 9
3359 static unsigned char tagicon-mask_bits[] = {
3360 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3361 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3363 set rectdata {
3364 #define headicon_width 13
3365 #define headicon_height 9
3366 static unsigned char headicon_bits[] = {
3367 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3368 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3370 set rectmask {
3371 #define headicon-mask_width 13
3372 #define headicon-mask_height 9
3373 static unsigned char headicon-mask_bits[] = {
3374 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3375 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3377 image create bitmap reficon-H -background black -foreground green \
3378 -data $rectdata -maskdata $rectmask
3379 image create bitmap reficon-o -background black -foreground "#ddddff" \
3380 -data $rectdata -maskdata $rectmask
3382 proc init_flist {first} {
3383 global cflist cflist_top difffilestart
3385 $cflist conf -state normal
3386 $cflist delete 0.0 end
3387 if {$first ne {}} {
3388 $cflist insert end $first
3389 set cflist_top 1
3390 $cflist tag add highlight 1.0 "1.0 lineend"
3391 } else {
3392 catch {unset cflist_top}
3394 $cflist conf -state disabled
3395 set difffilestart {}
3398 proc highlight_tag {f} {
3399 global highlight_paths
3401 foreach p $highlight_paths {
3402 if {[string match $p $f]} {
3403 return "bold"
3406 return {}
3409 proc highlight_filelist {} {
3410 global cmitmode cflist
3412 $cflist conf -state normal
3413 if {$cmitmode ne "tree"} {
3414 set end [lindex [split [$cflist index end] .] 0]
3415 for {set l 2} {$l < $end} {incr l} {
3416 set line [$cflist get $l.0 "$l.0 lineend"]
3417 if {[highlight_tag $line] ne {}} {
3418 $cflist tag add bold $l.0 "$l.0 lineend"
3421 } else {
3422 highlight_tree 2 {}
3424 $cflist conf -state disabled
3427 proc unhighlight_filelist {} {
3428 global cflist
3430 $cflist conf -state normal
3431 $cflist tag remove bold 1.0 end
3432 $cflist conf -state disabled
3435 proc add_flist {fl} {
3436 global cflist
3438 $cflist conf -state normal
3439 foreach f $fl {
3440 $cflist insert end "\n"
3441 $cflist insert end $f [highlight_tag $f]
3443 $cflist conf -state disabled
3446 proc sel_flist {w x y} {
3447 global ctext difffilestart cflist cflist_top cmitmode
3449 if {$cmitmode eq "tree"} return
3450 if {![info exists cflist_top]} return
3451 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3452 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3453 $cflist tag add highlight $l.0 "$l.0 lineend"
3454 set cflist_top $l
3455 if {$l == 1} {
3456 $ctext yview 1.0
3457 } else {
3458 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3460 suppress_highlighting_file_for_current_scrollpos
3463 proc pop_flist_menu {w X Y x y} {
3464 global ctext cflist cmitmode flist_menu flist_menu_file
3465 global treediffs diffids
3467 stopfinding
3468 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3469 if {$l <= 1} return
3470 if {$cmitmode eq "tree"} {
3471 set e [linetoelt $l]
3472 if {[string index $e end] eq "/"} return
3473 } else {
3474 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3476 set flist_menu_file $e
3477 set xdiffstate "normal"
3478 if {$cmitmode eq "tree"} {
3479 set xdiffstate "disabled"
3481 # Disable "External diff" item in tree mode
3482 $flist_menu entryconf 2 -state $xdiffstate
3483 tk_popup $flist_menu $X $Y
3486 proc find_ctext_fileinfo {line} {
3487 global ctext_file_names ctext_file_lines
3489 set ok [bsearch $ctext_file_lines $line]
3490 set tline [lindex $ctext_file_lines $ok]
3492 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3493 return {}
3494 } else {
3495 return [list [lindex $ctext_file_names $ok] $tline]
3499 proc pop_diff_menu {w X Y x y} {
3500 global ctext diff_menu flist_menu_file
3501 global diff_menu_txtpos diff_menu_line
3502 global diff_menu_filebase
3504 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3505 set diff_menu_line [lindex $diff_menu_txtpos 0]
3506 # don't pop up the menu on hunk-separator or file-separator lines
3507 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3508 return
3510 stopfinding
3511 set f [find_ctext_fileinfo $diff_menu_line]
3512 if {$f eq {}} return
3513 set flist_menu_file [lindex $f 0]
3514 set diff_menu_filebase [lindex $f 1]
3515 tk_popup $diff_menu $X $Y
3518 proc flist_hl {only} {
3519 global flist_menu_file findstring gdttype
3521 set x [shellquote $flist_menu_file]
3522 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3523 set findstring $x
3524 } else {
3525 append findstring " " $x
3527 set gdttype [mc "touching paths:"]
3530 proc gitknewtmpdir {} {
3531 global diffnum gitktmpdir gitdir env
3533 if {![info exists gitktmpdir]} {
3534 if {[info exists env(GITK_TMPDIR)]} {
3535 set tmpdir $env(GITK_TMPDIR)
3536 } elseif {[info exists env(TMPDIR)]} {
3537 set tmpdir $env(TMPDIR)
3538 } else {
3539 set tmpdir $gitdir
3541 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3542 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3543 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3545 if {[catch {file mkdir $gitktmpdir} err]} {
3546 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3547 unset gitktmpdir
3548 return {}
3550 set diffnum 0
3552 incr diffnum
3553 set diffdir [file join $gitktmpdir $diffnum]
3554 if {[catch {file mkdir $diffdir} err]} {
3555 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3556 return {}
3558 return $diffdir
3561 proc save_file_from_commit {filename output what} {
3562 global nullfile
3564 if {[catch {exec git show $filename -- > $output} err]} {
3565 if {[string match "fatal: bad revision *" $err]} {
3566 return $nullfile
3568 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3569 return {}
3571 return $output
3574 proc external_diff_get_one_file {diffid filename diffdir} {
3575 global nullid nullid2 nullfile
3576 global worktree
3578 if {$diffid == $nullid} {
3579 set difffile [file join $worktree $filename]
3580 if {[file exists $difffile]} {
3581 return $difffile
3583 return $nullfile
3585 if {$diffid == $nullid2} {
3586 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3587 return [save_file_from_commit :$filename $difffile index]
3589 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3590 return [save_file_from_commit $diffid:$filename $difffile \
3591 "revision $diffid"]
3594 proc external_diff {} {
3595 global nullid nullid2
3596 global flist_menu_file
3597 global diffids
3598 global extdifftool
3600 if {[llength $diffids] == 1} {
3601 # no reference commit given
3602 set diffidto [lindex $diffids 0]
3603 if {$diffidto eq $nullid} {
3604 # diffing working copy with index
3605 set diffidfrom $nullid2
3606 } elseif {$diffidto eq $nullid2} {
3607 # diffing index with HEAD
3608 set diffidfrom "HEAD"
3609 } else {
3610 # use first parent commit
3611 global parentlist selectedline
3612 set diffidfrom [lindex $parentlist $selectedline 0]
3614 } else {
3615 set diffidfrom [lindex $diffids 0]
3616 set diffidto [lindex $diffids 1]
3619 # make sure that several diffs wont collide
3620 set diffdir [gitknewtmpdir]
3621 if {$diffdir eq {}} return
3623 # gather files to diff
3624 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3625 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3627 if {$difffromfile ne {} && $difftofile ne {}} {
3628 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3629 if {[catch {set fl [open |$cmd r]} err]} {
3630 file delete -force $diffdir
3631 error_popup "$extdifftool: [mc "command failed:"] $err"
3632 } else {
3633 fconfigure $fl -blocking 0
3634 filerun $fl [list delete_at_eof $fl $diffdir]
3639 proc find_hunk_blamespec {base line} {
3640 global ctext
3642 # Find and parse the hunk header
3643 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3644 if {$s_lix eq {}} return
3646 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3647 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3648 s_line old_specs osz osz1 new_line nsz]} {
3649 return
3652 # base lines for the parents
3653 set base_lines [list $new_line]
3654 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3655 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3656 old_spec old_line osz]} {
3657 return
3659 lappend base_lines $old_line
3662 # Now scan the lines to determine offset within the hunk
3663 set max_parent [expr {[llength $base_lines]-2}]
3664 set dline 0
3665 set s_lno [lindex [split $s_lix "."] 0]
3667 # Determine if the line is removed
3668 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3669 if {[string match {[-+ ]*} $chunk]} {
3670 set removed_idx [string first "-" $chunk]
3671 # Choose a parent index
3672 if {$removed_idx >= 0} {
3673 set parent $removed_idx
3674 } else {
3675 set unchanged_idx [string first " " $chunk]
3676 if {$unchanged_idx >= 0} {
3677 set parent $unchanged_idx
3678 } else {
3679 # blame the current commit
3680 set parent -1
3683 # then count other lines that belong to it
3684 for {set i $line} {[incr i -1] > $s_lno} {} {
3685 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3686 # Determine if the line is removed
3687 set removed_idx [string first "-" $chunk]
3688 if {$parent >= 0} {
3689 set code [string index $chunk $parent]
3690 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3691 incr dline
3693 } else {
3694 if {$removed_idx < 0} {
3695 incr dline
3699 incr parent
3700 } else {
3701 set parent 0
3704 incr dline [lindex $base_lines $parent]
3705 return [list $parent $dline]
3708 proc external_blame_diff {} {
3709 global currentid cmitmode
3710 global diff_menu_txtpos diff_menu_line
3711 global diff_menu_filebase flist_menu_file
3713 if {$cmitmode eq "tree"} {
3714 set parent_idx 0
3715 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3716 } else {
3717 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3718 if {$hinfo ne {}} {
3719 set parent_idx [lindex $hinfo 0]
3720 set line [lindex $hinfo 1]
3721 } else {
3722 set parent_idx 0
3723 set line 0
3727 external_blame $parent_idx $line
3730 # Find the SHA1 ID of the blob for file $fname in the index
3731 # at stage 0 or 2
3732 proc index_sha1 {fname} {
3733 set f [open [list | git ls-files -s $fname] r]
3734 while {[gets $f line] >= 0} {
3735 set info [lindex [split $line "\t"] 0]
3736 set stage [lindex $info 2]
3737 if {$stage eq "0" || $stage eq "2"} {
3738 close $f
3739 return [lindex $info 1]
3742 close $f
3743 return {}
3746 # Turn an absolute path into one relative to the current directory
3747 proc make_relative {f} {
3748 if {[file pathtype $f] eq "relative"} {
3749 return $f
3751 set elts [file split $f]
3752 set here [file split [pwd]]
3753 set ei 0
3754 set hi 0
3755 set res {}
3756 foreach d $here {
3757 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3758 lappend res ".."
3759 } else {
3760 incr ei
3762 incr hi
3764 set elts [concat $res [lrange $elts $ei end]]
3765 return [eval file join $elts]
3768 proc external_blame {parent_idx {line {}}} {
3769 global flist_menu_file cdup
3770 global nullid nullid2
3771 global parentlist selectedline currentid
3773 if {$parent_idx > 0} {
3774 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3775 } else {
3776 set base_commit $currentid
3779 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3780 error_popup [mc "No such commit"]
3781 return
3784 set cmdline [list git gui blame]
3785 if {$line ne {} && $line > 1} {
3786 lappend cmdline "--line=$line"
3788 set f [file join $cdup $flist_menu_file]
3789 # Unfortunately it seems git gui blame doesn't like
3790 # being given an absolute path...
3791 set f [make_relative $f]
3792 lappend cmdline $base_commit $f
3793 if {[catch {eval exec $cmdline &} err]} {
3794 error_popup "[mc "git gui blame: command failed:"] $err"
3798 proc show_line_source {} {
3799 global cmitmode currentid parents curview blamestuff blameinst
3800 global diff_menu_line diff_menu_filebase flist_menu_file
3801 global nullid nullid2 gitdir cdup
3803 set from_index {}
3804 if {$cmitmode eq "tree"} {
3805 set id $currentid
3806 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3807 } else {
3808 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3809 if {$h eq {}} return
3810 set pi [lindex $h 0]
3811 if {$pi == 0} {
3812 mark_ctext_line $diff_menu_line
3813 return
3815 incr pi -1
3816 if {$currentid eq $nullid} {
3817 if {$pi > 0} {
3818 # must be a merge in progress...
3819 if {[catch {
3820 # get the last line from .git/MERGE_HEAD
3821 set f [open [file join $gitdir MERGE_HEAD] r]
3822 set id [lindex [split [read $f] "\n"] end-1]
3823 close $f
3824 } err]} {
3825 error_popup [mc "Couldn't read merge head: %s" $err]
3826 return
3828 } elseif {$parents($curview,$currentid) eq $nullid2} {
3829 # need to do the blame from the index
3830 if {[catch {
3831 set from_index [index_sha1 $flist_menu_file]
3832 } err]} {
3833 error_popup [mc "Error reading index: %s" $err]
3834 return
3836 } else {
3837 set id $parents($curview,$currentid)
3839 } else {
3840 set id [lindex $parents($curview,$currentid) $pi]
3842 set line [lindex $h 1]
3844 set blameargs {}
3845 if {$from_index ne {}} {
3846 lappend blameargs | git cat-file blob $from_index
3848 lappend blameargs | git blame -p -L$line,+1
3849 if {$from_index ne {}} {
3850 lappend blameargs --contents -
3851 } else {
3852 lappend blameargs $id
3854 lappend blameargs -- [file join $cdup $flist_menu_file]
3855 if {[catch {
3856 set f [open $blameargs r]
3857 } err]} {
3858 error_popup [mc "Couldn't start git blame: %s" $err]
3859 return
3861 nowbusy blaming [mc "Searching"]
3862 fconfigure $f -blocking 0
3863 set i [reg_instance $f]
3864 set blamestuff($i) {}
3865 set blameinst $i
3866 filerun $f [list read_line_source $f $i]
3869 proc stopblaming {} {
3870 global blameinst
3872 if {[info exists blameinst]} {
3873 stop_instance $blameinst
3874 unset blameinst
3875 notbusy blaming
3879 proc read_line_source {fd inst} {
3880 global blamestuff curview commfd blameinst nullid nullid2
3882 while {[gets $fd line] >= 0} {
3883 lappend blamestuff($inst) $line
3885 if {![eof $fd]} {
3886 return 1
3888 unset commfd($inst)
3889 unset blameinst
3890 notbusy blaming
3891 fconfigure $fd -blocking 1
3892 if {[catch {close $fd} err]} {
3893 error_popup [mc "Error running git blame: %s" $err]
3894 return 0
3897 set fname {}
3898 set line [split [lindex $blamestuff($inst) 0] " "]
3899 set id [lindex $line 0]
3900 set lnum [lindex $line 1]
3901 if {[string length $id] == 40 && [string is xdigit $id] &&
3902 [string is digit -strict $lnum]} {
3903 # look for "filename" line
3904 foreach l $blamestuff($inst) {
3905 if {[string match "filename *" $l]} {
3906 set fname [string range $l 9 end]
3907 break
3911 if {$fname ne {}} {
3912 # all looks good, select it
3913 if {$id eq $nullid} {
3914 # blame uses all-zeroes to mean not committed,
3915 # which would mean a change in the index
3916 set id $nullid2
3918 if {[commitinview $id $curview]} {
3919 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3920 } else {
3921 error_popup [mc "That line comes from commit %s, \
3922 which is not in this view" [shortids $id]]
3924 } else {
3925 puts "oops couldn't parse git blame output"
3927 return 0
3930 # delete $dir when we see eof on $f (presumably because the child has exited)
3931 proc delete_at_eof {f dir} {
3932 while {[gets $f line] >= 0} {}
3933 if {[eof $f]} {
3934 if {[catch {close $f} err]} {
3935 error_popup "[mc "External diff viewer failed:"] $err"
3937 file delete -force $dir
3938 return 0
3940 return 1
3943 # Functions for adding and removing shell-type quoting
3945 proc shellquote {str} {
3946 if {![string match "*\['\"\\ \t]*" $str]} {
3947 return $str
3949 if {![string match "*\['\"\\]*" $str]} {
3950 return "\"$str\""
3952 if {![string match "*'*" $str]} {
3953 return "'$str'"
3955 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3958 proc shellarglist {l} {
3959 set str {}
3960 foreach a $l {
3961 if {$str ne {}} {
3962 append str " "
3964 append str [shellquote $a]
3966 return $str
3969 proc shelldequote {str} {
3970 set ret {}
3971 set used -1
3972 while {1} {
3973 incr used
3974 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3975 append ret [string range $str $used end]
3976 set used [string length $str]
3977 break
3979 set first [lindex $first 0]
3980 set ch [string index $str $first]
3981 if {$first > $used} {
3982 append ret [string range $str $used [expr {$first - 1}]]
3983 set used $first
3985 if {$ch eq " " || $ch eq "\t"} break
3986 incr used
3987 if {$ch eq "'"} {
3988 set first [string first "'" $str $used]
3989 if {$first < 0} {
3990 error "unmatched single-quote"
3992 append ret [string range $str $used [expr {$first - 1}]]
3993 set used $first
3994 continue
3996 if {$ch eq "\\"} {
3997 if {$used >= [string length $str]} {
3998 error "trailing backslash"
4000 append ret [string index $str $used]
4001 continue
4003 # here ch == "\""
4004 while {1} {
4005 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4006 error "unmatched double-quote"
4008 set first [lindex $first 0]
4009 set ch [string index $str $first]
4010 if {$first > $used} {
4011 append ret [string range $str $used [expr {$first - 1}]]
4012 set used $first
4014 if {$ch eq "\""} break
4015 incr used
4016 append ret [string index $str $used]
4017 incr used
4020 return [list $used $ret]
4023 proc shellsplit {str} {
4024 set l {}
4025 while {1} {
4026 set str [string trimleft $str]
4027 if {$str eq {}} break
4028 set dq [shelldequote $str]
4029 set n [lindex $dq 0]
4030 set word [lindex $dq 1]
4031 set str [string range $str $n end]
4032 lappend l $word
4034 return $l
4037 # Code to implement multiple views
4039 proc newview {ishighlight} {
4040 global nextviewnum newviewname newishighlight
4041 global revtreeargs viewargscmd newviewopts curview
4043 set newishighlight $ishighlight
4044 set top .gitkview
4045 if {[winfo exists $top]} {
4046 raise $top
4047 return
4049 decode_view_opts $nextviewnum $revtreeargs
4050 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4051 set newviewopts($nextviewnum,perm) 0
4052 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4053 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4056 set known_view_options {
4057 {perm b . {} {mc "Remember this view"}}
4058 {reflabel l + {} {mc "References (space separated list):"}}
4059 {refs t15 .. {} {mc "Branches & tags:"}}
4060 {allrefs b *. "--all" {mc "All refs"}}
4061 {branches b . "--branches" {mc "All (local) branches"}}
4062 {tags b . "--tags" {mc "All tags"}}
4063 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4064 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4065 {author t15 .. "--author=*" {mc "Author:"}}
4066 {committer t15 . "--committer=*" {mc "Committer:"}}
4067 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4068 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4069 {changes_l l + {} {mc "Changes to Files:"}}
4070 {pickaxe_s r0 . {} {mc "Fixed String"}}
4071 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4072 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4073 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4074 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4075 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4076 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4077 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4078 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4079 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4080 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4081 {lright b . "--left-right" {mc "Mark branch sides"}}
4082 {first b . "--first-parent" {mc "Limit to first parent"}}
4083 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4084 {args t50 *. {} {mc "Additional arguments to git log:"}}
4085 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4086 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4089 # Convert $newviewopts($n, ...) into args for git log.
4090 proc encode_view_opts {n} {
4091 global known_view_options newviewopts
4093 set rargs [list]
4094 foreach opt $known_view_options {
4095 set patterns [lindex $opt 3]
4096 if {$patterns eq {}} continue
4097 set pattern [lindex $patterns 0]
4099 if {[lindex $opt 1] eq "b"} {
4100 set val $newviewopts($n,[lindex $opt 0])
4101 if {$val} {
4102 lappend rargs $pattern
4104 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4105 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4106 set val $newviewopts($n,$button_id)
4107 if {$val eq $value} {
4108 lappend rargs $pattern
4110 } else {
4111 set val $newviewopts($n,[lindex $opt 0])
4112 set val [string trim $val]
4113 if {$val ne {}} {
4114 set pfix [string range $pattern 0 end-1]
4115 lappend rargs $pfix$val
4119 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4120 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4123 # Fill $newviewopts($n, ...) based on args for git log.
4124 proc decode_view_opts {n view_args} {
4125 global known_view_options newviewopts
4127 foreach opt $known_view_options {
4128 set id [lindex $opt 0]
4129 if {[lindex $opt 1] eq "b"} {
4130 # Checkboxes
4131 set val 0
4132 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4133 # Radiobuttons
4134 regexp {^(.*_)} $id uselessvar id
4135 set val 0
4136 } else {
4137 # Text fields
4138 set val {}
4140 set newviewopts($n,$id) $val
4142 set oargs [list]
4143 set refargs [list]
4144 foreach arg $view_args {
4145 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4146 && ![info exists found(limit)]} {
4147 set newviewopts($n,limit) $cnt
4148 set found(limit) 1
4149 continue
4151 catch { unset val }
4152 foreach opt $known_view_options {
4153 set id [lindex $opt 0]
4154 if {[info exists found($id)]} continue
4155 foreach pattern [lindex $opt 3] {
4156 if {![string match $pattern $arg]} continue
4157 if {[lindex $opt 1] eq "b"} {
4158 # Check buttons
4159 set val 1
4160 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4161 # Radio buttons
4162 regexp {^(.*_)} $id uselessvar id
4163 set val $num
4164 } else {
4165 # Text input fields
4166 set size [string length $pattern]
4167 set val [string range $arg [expr {$size-1}] end]
4169 set newviewopts($n,$id) $val
4170 set found($id) 1
4171 break
4173 if {[info exists val]} break
4175 if {[info exists val]} continue
4176 if {[regexp {^-} $arg]} {
4177 lappend oargs $arg
4178 } else {
4179 lappend refargs $arg
4182 set newviewopts($n,refs) [shellarglist $refargs]
4183 set newviewopts($n,args) [shellarglist $oargs]
4186 proc edit_or_newview {} {
4187 global curview
4189 if {$curview > 0} {
4190 editview
4191 } else {
4192 newview 0
4196 proc editview {} {
4197 global curview
4198 global viewname viewperm newviewname newviewopts
4199 global viewargs viewargscmd
4201 set top .gitkvedit-$curview
4202 if {[winfo exists $top]} {
4203 raise $top
4204 return
4206 decode_view_opts $curview $viewargs($curview)
4207 set newviewname($curview) $viewname($curview)
4208 set newviewopts($curview,perm) $viewperm($curview)
4209 set newviewopts($curview,cmd) $viewargscmd($curview)
4210 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4213 proc vieweditor {top n title} {
4214 global newviewname newviewopts viewfiles bgcolor
4215 global known_view_options NS
4217 ttk_toplevel $top
4218 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4219 make_transient $top .
4221 # View name
4222 ${NS}::frame $top.nfr
4223 ${NS}::label $top.nl -text [mc "View Name"]
4224 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4225 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4226 pack $top.nl -in $top.nfr -side left -padx {0 5}
4227 pack $top.name -in $top.nfr -side left -padx {0 25}
4229 # View options
4230 set cframe $top.nfr
4231 set cexpand 0
4232 set cnt 0
4233 foreach opt $known_view_options {
4234 set id [lindex $opt 0]
4235 set type [lindex $opt 1]
4236 set flags [lindex $opt 2]
4237 set title [eval [lindex $opt 4]]
4238 set lxpad 0
4240 if {$flags eq "+" || $flags eq "*"} {
4241 set cframe $top.fr$cnt
4242 incr cnt
4243 ${NS}::frame $cframe
4244 pack $cframe -in $top -fill x -pady 3 -padx 3
4245 set cexpand [expr {$flags eq "*"}]
4246 } elseif {$flags eq ".." || $flags eq "*."} {
4247 set cframe $top.fr$cnt
4248 incr cnt
4249 ${NS}::frame $cframe
4250 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4251 set cexpand [expr {$flags eq "*."}]
4252 } else {
4253 set lxpad 5
4256 if {$type eq "l"} {
4257 ${NS}::label $cframe.l_$id -text $title
4258 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4259 } elseif {$type eq "b"} {
4260 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4261 pack $cframe.c_$id -in $cframe -side left \
4262 -padx [list $lxpad 0] -expand $cexpand -anchor w
4263 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4264 regexp {^(.*_)} $id uselessvar button_id
4265 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4266 pack $cframe.c_$id -in $cframe -side left \
4267 -padx [list $lxpad 0] -expand $cexpand -anchor w
4268 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4269 ${NS}::label $cframe.l_$id -text $title
4270 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4271 -textvariable newviewopts($n,$id)
4272 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4273 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4274 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4275 ${NS}::label $cframe.l_$id -text $title
4276 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4277 -textvariable newviewopts($n,$id)
4278 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4279 pack $cframe.e_$id -in $cframe -side top -fill x
4280 } elseif {$type eq "path"} {
4281 ${NS}::label $top.l -text $title
4282 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4283 text $top.t -width 40 -height 5 -background $bgcolor
4284 if {[info exists viewfiles($n)]} {
4285 foreach f $viewfiles($n) {
4286 $top.t insert end $f
4287 $top.t insert end "\n"
4289 $top.t delete {end - 1c} end
4290 $top.t mark set insert 0.0
4292 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4296 ${NS}::frame $top.buts
4297 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4298 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4299 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4300 bind $top <Control-Return> [list newviewok $top $n]
4301 bind $top <F5> [list newviewok $top $n 1]
4302 bind $top <Escape> [list destroy $top]
4303 grid $top.buts.ok $top.buts.apply $top.buts.can
4304 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4305 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4306 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4307 pack $top.buts -in $top -side top -fill x
4308 focus $top.t
4311 proc doviewmenu {m first cmd op argv} {
4312 set nmenu [$m index end]
4313 for {set i $first} {$i <= $nmenu} {incr i} {
4314 if {[$m entrycget $i -command] eq $cmd} {
4315 eval $m $op $i $argv
4316 break
4321 proc allviewmenus {n op args} {
4322 # global viewhlmenu
4324 doviewmenu .bar.view 5 [list showview $n] $op $args
4325 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4328 proc newviewok {top n {apply 0}} {
4329 global nextviewnum newviewperm newviewname newishighlight
4330 global viewname viewfiles viewperm viewchanged selectedview curview
4331 global viewargs viewargscmd newviewopts viewhlmenu
4333 if {[catch {
4334 set newargs [encode_view_opts $n]
4335 } err]} {
4336 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4337 return
4339 set files {}
4340 foreach f [split [$top.t get 0.0 end] "\n"] {
4341 set ft [string trim $f]
4342 if {$ft ne {}} {
4343 lappend files $ft
4346 if {![info exists viewfiles($n)]} {
4347 # creating a new view
4348 incr nextviewnum
4349 set viewname($n) $newviewname($n)
4350 set viewperm($n) $newviewopts($n,perm)
4351 set viewchanged($n) 1
4352 set viewfiles($n) $files
4353 set viewargs($n) $newargs
4354 set viewargscmd($n) $newviewopts($n,cmd)
4355 addviewmenu $n
4356 if {!$newishighlight} {
4357 run showview $n
4358 } else {
4359 run addvhighlight $n
4361 } else {
4362 # editing an existing view
4363 set viewperm($n) $newviewopts($n,perm)
4364 set viewchanged($n) 1
4365 if {$newviewname($n) ne $viewname($n)} {
4366 set viewname($n) $newviewname($n)
4367 doviewmenu .bar.view 5 [list showview $n] \
4368 entryconf [list -label $viewname($n)]
4369 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4370 # entryconf [list -label $viewname($n) -value $viewname($n)]
4372 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4373 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4374 set viewfiles($n) $files
4375 set viewargs($n) $newargs
4376 set viewargscmd($n) $newviewopts($n,cmd)
4377 if {$curview == $n} {
4378 run reloadcommits
4382 if {$apply} return
4383 catch {destroy $top}
4386 proc delview {} {
4387 global curview viewperm hlview selectedhlview viewchanged
4389 if {$curview == 0} return
4390 if {[info exists hlview] && $hlview == $curview} {
4391 set selectedhlview [mc "None"]
4392 unset hlview
4394 allviewmenus $curview delete
4395 set viewperm($curview) 0
4396 set viewchanged($curview) 1
4397 showview 0
4400 proc addviewmenu {n} {
4401 global viewname viewhlmenu
4403 .bar.view add radiobutton -label $viewname($n) \
4404 -command [list showview $n] -variable selectedview -value $n
4405 #$viewhlmenu add radiobutton -label $viewname($n) \
4406 # -command [list addvhighlight $n] -variable selectedhlview
4409 proc showview {n} {
4410 global curview cached_commitrow ordertok
4411 global displayorder parentlist rowidlist rowisopt rowfinal
4412 global colormap rowtextx nextcolor canvxmax
4413 global numcommits viewcomplete
4414 global selectedline currentid canv canvy0
4415 global treediffs
4416 global pending_select mainheadid
4417 global commitidx
4418 global selectedview
4419 global hlview selectedhlview commitinterest
4421 if {$n == $curview} return
4422 set selid {}
4423 set ymax [lindex [$canv cget -scrollregion] 3]
4424 set span [$canv yview]
4425 set ytop [expr {[lindex $span 0] * $ymax}]
4426 set ybot [expr {[lindex $span 1] * $ymax}]
4427 set yscreen [expr {($ybot - $ytop) / 2}]
4428 if {$selectedline ne {}} {
4429 set selid $currentid
4430 set y [yc $selectedline]
4431 if {$ytop < $y && $y < $ybot} {
4432 set yscreen [expr {$y - $ytop}]
4434 } elseif {[info exists pending_select]} {
4435 set selid $pending_select
4436 unset pending_select
4438 unselectline
4439 normalline
4440 catch {unset treediffs}
4441 clear_display
4442 if {[info exists hlview] && $hlview == $n} {
4443 unset hlview
4444 set selectedhlview [mc "None"]
4446 catch {unset commitinterest}
4447 catch {unset cached_commitrow}
4448 catch {unset ordertok}
4450 set curview $n
4451 set selectedview $n
4452 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4453 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4455 run refill_reflist
4456 if {![info exists viewcomplete($n)]} {
4457 getcommits $selid
4458 return
4461 set displayorder {}
4462 set parentlist {}
4463 set rowidlist {}
4464 set rowisopt {}
4465 set rowfinal {}
4466 set numcommits $commitidx($n)
4468 catch {unset colormap}
4469 catch {unset rowtextx}
4470 set nextcolor 0
4471 set canvxmax [$canv cget -width]
4472 set curview $n
4473 set row 0
4474 setcanvscroll
4475 set yf 0
4476 set row {}
4477 if {$selid ne {} && [commitinview $selid $n]} {
4478 set row [rowofcommit $selid]
4479 # try to get the selected row in the same position on the screen
4480 set ymax [lindex [$canv cget -scrollregion] 3]
4481 set ytop [expr {[yc $row] - $yscreen}]
4482 if {$ytop < 0} {
4483 set ytop 0
4485 set yf [expr {$ytop * 1.0 / $ymax}]
4487 allcanvs yview moveto $yf
4488 drawvisible
4489 if {$row ne {}} {
4490 selectline $row 0
4491 } elseif {!$viewcomplete($n)} {
4492 reset_pending_select $selid
4493 } else {
4494 reset_pending_select {}
4496 if {[commitinview $pending_select $curview]} {
4497 selectline [rowofcommit $pending_select] 1
4498 } else {
4499 set row [first_real_row]
4500 if {$row < $numcommits} {
4501 selectline $row 0
4505 if {!$viewcomplete($n)} {
4506 if {$numcommits == 0} {
4507 show_status [mc "Reading commits..."]
4509 } elseif {$numcommits == 0} {
4510 show_status [mc "No commits selected"]
4514 # Stuff relating to the highlighting facility
4516 proc ishighlighted {id} {
4517 global vhighlights fhighlights nhighlights rhighlights
4519 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4520 return $nhighlights($id)
4522 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4523 return $vhighlights($id)
4525 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4526 return $fhighlights($id)
4528 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4529 return $rhighlights($id)
4531 return 0
4534 proc bolden {id font} {
4535 global canv linehtag currentid boldids need_redisplay markedid
4537 # need_redisplay = 1 means the display is stale and about to be redrawn
4538 if {$need_redisplay} return
4539 lappend boldids $id
4540 $canv itemconf $linehtag($id) -font $font
4541 if {[info exists currentid] && $id eq $currentid} {
4542 $canv delete secsel
4543 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4544 -outline {{}} -tags secsel \
4545 -fill [$canv cget -selectbackground]]
4546 $canv lower $t
4548 if {[info exists markedid] && $id eq $markedid} {
4549 make_idmark $id
4553 proc bolden_name {id font} {
4554 global canv2 linentag currentid boldnameids need_redisplay
4556 if {$need_redisplay} return
4557 lappend boldnameids $id
4558 $canv2 itemconf $linentag($id) -font $font
4559 if {[info exists currentid] && $id eq $currentid} {
4560 $canv2 delete secsel
4561 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4562 -outline {{}} -tags secsel \
4563 -fill [$canv2 cget -selectbackground]]
4564 $canv2 lower $t
4568 proc unbolden {} {
4569 global boldids
4571 set stillbold {}
4572 foreach id $boldids {
4573 if {![ishighlighted $id]} {
4574 bolden $id mainfont
4575 } else {
4576 lappend stillbold $id
4579 set boldids $stillbold
4582 proc addvhighlight {n} {
4583 global hlview viewcomplete curview vhl_done commitidx
4585 if {[info exists hlview]} {
4586 delvhighlight
4588 set hlview $n
4589 if {$n != $curview && ![info exists viewcomplete($n)]} {
4590 start_rev_list $n
4592 set vhl_done $commitidx($hlview)
4593 if {$vhl_done > 0} {
4594 drawvisible
4598 proc delvhighlight {} {
4599 global hlview vhighlights
4601 if {![info exists hlview]} return
4602 unset hlview
4603 catch {unset vhighlights}
4604 unbolden
4607 proc vhighlightmore {} {
4608 global hlview vhl_done commitidx vhighlights curview
4610 set max $commitidx($hlview)
4611 set vr [visiblerows]
4612 set r0 [lindex $vr 0]
4613 set r1 [lindex $vr 1]
4614 for {set i $vhl_done} {$i < $max} {incr i} {
4615 set id [commitonrow $i $hlview]
4616 if {[commitinview $id $curview]} {
4617 set row [rowofcommit $id]
4618 if {$r0 <= $row && $row <= $r1} {
4619 if {![highlighted $row]} {
4620 bolden $id mainfontbold
4622 set vhighlights($id) 1
4626 set vhl_done $max
4627 return 0
4630 proc askvhighlight {row id} {
4631 global hlview vhighlights iddrawn
4633 if {[commitinview $id $hlview]} {
4634 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4635 bolden $id mainfontbold
4637 set vhighlights($id) 1
4638 } else {
4639 set vhighlights($id) 0
4643 proc hfiles_change {} {
4644 global highlight_files filehighlight fhighlights fh_serial
4645 global highlight_paths
4647 if {[info exists filehighlight]} {
4648 # delete previous highlights
4649 catch {close $filehighlight}
4650 unset filehighlight
4651 catch {unset fhighlights}
4652 unbolden
4653 unhighlight_filelist
4655 set highlight_paths {}
4656 after cancel do_file_hl $fh_serial
4657 incr fh_serial
4658 if {$highlight_files ne {}} {
4659 after 300 do_file_hl $fh_serial
4663 proc gdttype_change {name ix op} {
4664 global gdttype highlight_files findstring findpattern
4666 stopfinding
4667 if {$findstring ne {}} {
4668 if {$gdttype eq [mc "containing:"]} {
4669 if {$highlight_files ne {}} {
4670 set highlight_files {}
4671 hfiles_change
4673 findcom_change
4674 } else {
4675 if {$findpattern ne {}} {
4676 set findpattern {}
4677 findcom_change
4679 set highlight_files $findstring
4680 hfiles_change
4682 drawvisible
4684 # enable/disable findtype/findloc menus too
4687 proc find_change {name ix op} {
4688 global gdttype findstring highlight_files
4690 stopfinding
4691 if {$gdttype eq [mc "containing:"]} {
4692 findcom_change
4693 } else {
4694 if {$highlight_files ne $findstring} {
4695 set highlight_files $findstring
4696 hfiles_change
4699 drawvisible
4702 proc findcom_change args {
4703 global nhighlights boldnameids
4704 global findpattern findtype findstring gdttype
4706 stopfinding
4707 # delete previous highlights, if any
4708 foreach id $boldnameids {
4709 bolden_name $id mainfont
4711 set boldnameids {}
4712 catch {unset nhighlights}
4713 unbolden
4714 unmarkmatches
4715 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4716 set findpattern {}
4717 } elseif {$findtype eq [mc "Regexp"]} {
4718 set findpattern $findstring
4719 } else {
4720 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4721 $findstring]
4722 set findpattern "*$e*"
4726 proc makepatterns {l} {
4727 set ret {}
4728 foreach e $l {
4729 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4730 if {[string index $ee end] eq "/"} {
4731 lappend ret "$ee*"
4732 } else {
4733 lappend ret $ee
4734 lappend ret "$ee/*"
4737 return $ret
4740 proc do_file_hl {serial} {
4741 global highlight_files filehighlight highlight_paths gdttype fhl_list
4742 global cdup findtype
4744 if {$gdttype eq [mc "touching paths:"]} {
4745 # If "exact" match then convert backslashes to forward slashes.
4746 # Most useful to support Windows-flavoured file paths.
4747 if {$findtype eq [mc "Exact"]} {
4748 set highlight_files [string map {"\\" "/"} $highlight_files]
4750 if {[catch {set paths [shellsplit $highlight_files]}]} return
4751 set highlight_paths [makepatterns $paths]
4752 highlight_filelist
4753 set relative_paths {}
4754 foreach path $paths {
4755 lappend relative_paths [file join $cdup $path]
4757 set gdtargs [concat -- $relative_paths]
4758 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4759 set gdtargs [list "-S$highlight_files"]
4760 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4761 set gdtargs [list "-G$highlight_files"]
4762 } else {
4763 # must be "containing:", i.e. we're searching commit info
4764 return
4766 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4767 set filehighlight [open $cmd r+]
4768 fconfigure $filehighlight -blocking 0
4769 filerun $filehighlight readfhighlight
4770 set fhl_list {}
4771 drawvisible
4772 flushhighlights
4775 proc flushhighlights {} {
4776 global filehighlight fhl_list
4778 if {[info exists filehighlight]} {
4779 lappend fhl_list {}
4780 puts $filehighlight ""
4781 flush $filehighlight
4785 proc askfilehighlight {row id} {
4786 global filehighlight fhighlights fhl_list
4788 lappend fhl_list $id
4789 set fhighlights($id) -1
4790 puts $filehighlight $id
4793 proc readfhighlight {} {
4794 global filehighlight fhighlights curview iddrawn
4795 global fhl_list find_dirn
4797 if {![info exists filehighlight]} {
4798 return 0
4800 set nr 0
4801 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4802 set line [string trim $line]
4803 set i [lsearch -exact $fhl_list $line]
4804 if {$i < 0} continue
4805 for {set j 0} {$j < $i} {incr j} {
4806 set id [lindex $fhl_list $j]
4807 set fhighlights($id) 0
4809 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4810 if {$line eq {}} continue
4811 if {![commitinview $line $curview]} continue
4812 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4813 bolden $line mainfontbold
4815 set fhighlights($line) 1
4817 if {[eof $filehighlight]} {
4818 # strange...
4819 puts "oops, git diff-tree died"
4820 catch {close $filehighlight}
4821 unset filehighlight
4822 return 0
4824 if {[info exists find_dirn]} {
4825 run findmore
4827 return 1
4830 proc doesmatch {f} {
4831 global findtype findpattern
4833 if {$findtype eq [mc "Regexp"]} {
4834 return [regexp $findpattern $f]
4835 } elseif {$findtype eq [mc "IgnCase"]} {
4836 return [string match -nocase $findpattern $f]
4837 } else {
4838 return [string match $findpattern $f]
4842 proc askfindhighlight {row id} {
4843 global nhighlights commitinfo iddrawn
4844 global findloc
4845 global markingmatches
4847 if {![info exists commitinfo($id)]} {
4848 getcommit $id
4850 set info $commitinfo($id)
4851 set isbold 0
4852 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4853 foreach f $info ty $fldtypes {
4854 if {$ty eq ""} continue
4855 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4856 [doesmatch $f]} {
4857 if {$ty eq [mc "Author"]} {
4858 set isbold 2
4859 break
4861 set isbold 1
4864 if {$isbold && [info exists iddrawn($id)]} {
4865 if {![ishighlighted $id]} {
4866 bolden $id mainfontbold
4867 if {$isbold > 1} {
4868 bolden_name $id mainfontbold
4871 if {$markingmatches} {
4872 markrowmatches $row $id
4875 set nhighlights($id) $isbold
4878 proc markrowmatches {row id} {
4879 global canv canv2 linehtag linentag commitinfo findloc
4881 set headline [lindex $commitinfo($id) 0]
4882 set author [lindex $commitinfo($id) 1]
4883 $canv delete match$row
4884 $canv2 delete match$row
4885 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4886 set m [findmatches $headline]
4887 if {$m ne {}} {
4888 markmatches $canv $row $headline $linehtag($id) $m \
4889 [$canv itemcget $linehtag($id) -font] $row
4892 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4893 set m [findmatches $author]
4894 if {$m ne {}} {
4895 markmatches $canv2 $row $author $linentag($id) $m \
4896 [$canv2 itemcget $linentag($id) -font] $row
4901 proc vrel_change {name ix op} {
4902 global highlight_related
4904 rhighlight_none
4905 if {$highlight_related ne [mc "None"]} {
4906 run drawvisible
4910 # prepare for testing whether commits are descendents or ancestors of a
4911 proc rhighlight_sel {a} {
4912 global descendent desc_todo ancestor anc_todo
4913 global highlight_related
4915 catch {unset descendent}
4916 set desc_todo [list $a]
4917 catch {unset ancestor}
4918 set anc_todo [list $a]
4919 if {$highlight_related ne [mc "None"]} {
4920 rhighlight_none
4921 run drawvisible
4925 proc rhighlight_none {} {
4926 global rhighlights
4928 catch {unset rhighlights}
4929 unbolden
4932 proc is_descendent {a} {
4933 global curview children descendent desc_todo
4935 set v $curview
4936 set la [rowofcommit $a]
4937 set todo $desc_todo
4938 set leftover {}
4939 set done 0
4940 for {set i 0} {$i < [llength $todo]} {incr i} {
4941 set do [lindex $todo $i]
4942 if {[rowofcommit $do] < $la} {
4943 lappend leftover $do
4944 continue
4946 foreach nk $children($v,$do) {
4947 if {![info exists descendent($nk)]} {
4948 set descendent($nk) 1
4949 lappend todo $nk
4950 if {$nk eq $a} {
4951 set done 1
4955 if {$done} {
4956 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4957 return
4960 set descendent($a) 0
4961 set desc_todo $leftover
4964 proc is_ancestor {a} {
4965 global curview parents ancestor anc_todo
4967 set v $curview
4968 set la [rowofcommit $a]
4969 set todo $anc_todo
4970 set leftover {}
4971 set done 0
4972 for {set i 0} {$i < [llength $todo]} {incr i} {
4973 set do [lindex $todo $i]
4974 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4975 lappend leftover $do
4976 continue
4978 foreach np $parents($v,$do) {
4979 if {![info exists ancestor($np)]} {
4980 set ancestor($np) 1
4981 lappend todo $np
4982 if {$np eq $a} {
4983 set done 1
4987 if {$done} {
4988 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4989 return
4992 set ancestor($a) 0
4993 set anc_todo $leftover
4996 proc askrelhighlight {row id} {
4997 global descendent highlight_related iddrawn rhighlights
4998 global selectedline ancestor
5000 if {$selectedline eq {}} return
5001 set isbold 0
5002 if {$highlight_related eq [mc "Descendant"] ||
5003 $highlight_related eq [mc "Not descendant"]} {
5004 if {![info exists descendent($id)]} {
5005 is_descendent $id
5007 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5008 set isbold 1
5010 } elseif {$highlight_related eq [mc "Ancestor"] ||
5011 $highlight_related eq [mc "Not ancestor"]} {
5012 if {![info exists ancestor($id)]} {
5013 is_ancestor $id
5015 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5016 set isbold 1
5019 if {[info exists iddrawn($id)]} {
5020 if {$isbold && ![ishighlighted $id]} {
5021 bolden $id mainfontbold
5024 set rhighlights($id) $isbold
5027 # Graph layout functions
5029 proc shortids {ids} {
5030 set res {}
5031 foreach id $ids {
5032 if {[llength $id] > 1} {
5033 lappend res [shortids $id]
5034 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5035 lappend res [string range $id 0 7]
5036 } else {
5037 lappend res $id
5040 return $res
5043 proc ntimes {n o} {
5044 set ret {}
5045 set o [list $o]
5046 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5047 if {($n & $mask) != 0} {
5048 set ret [concat $ret $o]
5050 set o [concat $o $o]
5052 return $ret
5055 proc ordertoken {id} {
5056 global ordertok curview varcid varcstart varctok curview parents children
5057 global nullid nullid2
5059 if {[info exists ordertok($id)]} {
5060 return $ordertok($id)
5062 set origid $id
5063 set todo {}
5064 while {1} {
5065 if {[info exists varcid($curview,$id)]} {
5066 set a $varcid($curview,$id)
5067 set p [lindex $varcstart($curview) $a]
5068 } else {
5069 set p [lindex $children($curview,$id) 0]
5071 if {[info exists ordertok($p)]} {
5072 set tok $ordertok($p)
5073 break
5075 set id [first_real_child $curview,$p]
5076 if {$id eq {}} {
5077 # it's a root
5078 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5079 break
5081 if {[llength $parents($curview,$id)] == 1} {
5082 lappend todo [list $p {}]
5083 } else {
5084 set j [lsearch -exact $parents($curview,$id) $p]
5085 if {$j < 0} {
5086 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5088 lappend todo [list $p [strrep $j]]
5091 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5092 set p [lindex $todo $i 0]
5093 append tok [lindex $todo $i 1]
5094 set ordertok($p) $tok
5096 set ordertok($origid) $tok
5097 return $tok
5100 # Work out where id should go in idlist so that order-token
5101 # values increase from left to right
5102 proc idcol {idlist id {i 0}} {
5103 set t [ordertoken $id]
5104 if {$i < 0} {
5105 set i 0
5107 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5108 if {$i > [llength $idlist]} {
5109 set i [llength $idlist]
5111 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5112 incr i
5113 } else {
5114 if {$t > [ordertoken [lindex $idlist $i]]} {
5115 while {[incr i] < [llength $idlist] &&
5116 $t >= [ordertoken [lindex $idlist $i]]} {}
5119 return $i
5122 proc initlayout {} {
5123 global rowidlist rowisopt rowfinal displayorder parentlist
5124 global numcommits canvxmax canv
5125 global nextcolor
5126 global colormap rowtextx
5128 set numcommits 0
5129 set displayorder {}
5130 set parentlist {}
5131 set nextcolor 0
5132 set rowidlist {}
5133 set rowisopt {}
5134 set rowfinal {}
5135 set canvxmax [$canv cget -width]
5136 catch {unset colormap}
5137 catch {unset rowtextx}
5138 setcanvscroll
5141 proc setcanvscroll {} {
5142 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5143 global lastscrollset lastscrollrows
5145 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5146 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5147 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5148 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5149 set lastscrollset [clock clicks -milliseconds]
5150 set lastscrollrows $numcommits
5153 proc visiblerows {} {
5154 global canv numcommits linespc
5156 set ymax [lindex [$canv cget -scrollregion] 3]
5157 if {$ymax eq {} || $ymax == 0} return
5158 set f [$canv yview]
5159 set y0 [expr {int([lindex $f 0] * $ymax)}]
5160 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5161 if {$r0 < 0} {
5162 set r0 0
5164 set y1 [expr {int([lindex $f 1] * $ymax)}]
5165 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5166 if {$r1 >= $numcommits} {
5167 set r1 [expr {$numcommits - 1}]
5169 return [list $r0 $r1]
5172 proc layoutmore {} {
5173 global commitidx viewcomplete curview
5174 global numcommits pending_select curview
5175 global lastscrollset lastscrollrows
5177 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5178 [clock clicks -milliseconds] - $lastscrollset > 500} {
5179 setcanvscroll
5181 if {[info exists pending_select] &&
5182 [commitinview $pending_select $curview]} {
5183 update
5184 selectline [rowofcommit $pending_select] 1
5186 drawvisible
5189 # With path limiting, we mightn't get the actual HEAD commit,
5190 # so ask git rev-list what is the first ancestor of HEAD that
5191 # touches a file in the path limit.
5192 proc get_viewmainhead {view} {
5193 global viewmainheadid vfilelimit viewinstances mainheadid
5195 catch {
5196 set rfd [open [concat | git rev-list -1 $mainheadid \
5197 -- $vfilelimit($view)] r]
5198 set j [reg_instance $rfd]
5199 lappend viewinstances($view) $j
5200 fconfigure $rfd -blocking 0
5201 filerun $rfd [list getviewhead $rfd $j $view]
5202 set viewmainheadid($curview) {}
5206 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5207 proc getviewhead {fd inst view} {
5208 global viewmainheadid commfd curview viewinstances showlocalchanges
5210 set id {}
5211 if {[gets $fd line] < 0} {
5212 if {![eof $fd]} {
5213 return 1
5215 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5216 set id $line
5218 set viewmainheadid($view) $id
5219 close $fd
5220 unset commfd($inst)
5221 set i [lsearch -exact $viewinstances($view) $inst]
5222 if {$i >= 0} {
5223 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5225 if {$showlocalchanges && $id ne {} && $view == $curview} {
5226 doshowlocalchanges
5228 return 0
5231 proc doshowlocalchanges {} {
5232 global curview viewmainheadid
5234 if {$viewmainheadid($curview) eq {}} return
5235 if {[commitinview $viewmainheadid($curview) $curview]} {
5236 dodiffindex
5237 } else {
5238 interestedin $viewmainheadid($curview) dodiffindex
5242 proc dohidelocalchanges {} {
5243 global nullid nullid2 lserial curview
5245 if {[commitinview $nullid $curview]} {
5246 removefakerow $nullid
5248 if {[commitinview $nullid2 $curview]} {
5249 removefakerow $nullid2
5251 incr lserial
5254 # spawn off a process to do git diff-index --cached HEAD
5255 proc dodiffindex {} {
5256 global lserial showlocalchanges vfilelimit curview
5257 global hasworktree git_version
5259 if {!$showlocalchanges || !$hasworktree} return
5260 incr lserial
5261 if {[package vcompare $git_version "1.7.2"] >= 0} {
5262 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5263 } else {
5264 set cmd "|git diff-index --cached HEAD"
5266 if {$vfilelimit($curview) ne {}} {
5267 set cmd [concat $cmd -- $vfilelimit($curview)]
5269 set fd [open $cmd r]
5270 fconfigure $fd -blocking 0
5271 set i [reg_instance $fd]
5272 filerun $fd [list readdiffindex $fd $lserial $i]
5275 proc readdiffindex {fd serial inst} {
5276 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5277 global vfilelimit
5279 set isdiff 1
5280 if {[gets $fd line] < 0} {
5281 if {![eof $fd]} {
5282 return 1
5284 set isdiff 0
5286 # we only need to see one line and we don't really care what it says...
5287 stop_instance $inst
5289 if {$serial != $lserial} {
5290 return 0
5293 # now see if there are any local changes not checked in to the index
5294 set cmd "|git diff-files"
5295 if {$vfilelimit($curview) ne {}} {
5296 set cmd [concat $cmd -- $vfilelimit($curview)]
5298 set fd [open $cmd r]
5299 fconfigure $fd -blocking 0
5300 set i [reg_instance $fd]
5301 filerun $fd [list readdifffiles $fd $serial $i]
5303 if {$isdiff && ![commitinview $nullid2 $curview]} {
5304 # add the line for the changes in the index to the graph
5305 set hl [mc "Local changes checked in to index but not committed"]
5306 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5307 set commitdata($nullid2) "\n $hl\n"
5308 if {[commitinview $nullid $curview]} {
5309 removefakerow $nullid
5311 insertfakerow $nullid2 $viewmainheadid($curview)
5312 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5313 if {[commitinview $nullid $curview]} {
5314 removefakerow $nullid
5316 removefakerow $nullid2
5318 return 0
5321 proc readdifffiles {fd serial inst} {
5322 global viewmainheadid nullid nullid2 curview
5323 global commitinfo commitdata lserial
5325 set isdiff 1
5326 if {[gets $fd line] < 0} {
5327 if {![eof $fd]} {
5328 return 1
5330 set isdiff 0
5332 # we only need to see one line and we don't really care what it says...
5333 stop_instance $inst
5335 if {$serial != $lserial} {
5336 return 0
5339 if {$isdiff && ![commitinview $nullid $curview]} {
5340 # add the line for the local diff to the graph
5341 set hl [mc "Local uncommitted changes, not checked in to index"]
5342 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5343 set commitdata($nullid) "\n $hl\n"
5344 if {[commitinview $nullid2 $curview]} {
5345 set p $nullid2
5346 } else {
5347 set p $viewmainheadid($curview)
5349 insertfakerow $nullid $p
5350 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5351 removefakerow $nullid
5353 return 0
5356 proc nextuse {id row} {
5357 global curview children
5359 if {[info exists children($curview,$id)]} {
5360 foreach kid $children($curview,$id) {
5361 if {![commitinview $kid $curview]} {
5362 return -1
5364 if {[rowofcommit $kid] > $row} {
5365 return [rowofcommit $kid]
5369 if {[commitinview $id $curview]} {
5370 return [rowofcommit $id]
5372 return -1
5375 proc prevuse {id row} {
5376 global curview children
5378 set ret -1
5379 if {[info exists children($curview,$id)]} {
5380 foreach kid $children($curview,$id) {
5381 if {![commitinview $kid $curview]} break
5382 if {[rowofcommit $kid] < $row} {
5383 set ret [rowofcommit $kid]
5387 return $ret
5390 proc make_idlist {row} {
5391 global displayorder parentlist uparrowlen downarrowlen mingaplen
5392 global commitidx curview children
5394 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5395 if {$r < 0} {
5396 set r 0
5398 set ra [expr {$row - $downarrowlen}]
5399 if {$ra < 0} {
5400 set ra 0
5402 set rb [expr {$row + $uparrowlen}]
5403 if {$rb > $commitidx($curview)} {
5404 set rb $commitidx($curview)
5406 make_disporder $r [expr {$rb + 1}]
5407 set ids {}
5408 for {} {$r < $ra} {incr r} {
5409 set nextid [lindex $displayorder [expr {$r + 1}]]
5410 foreach p [lindex $parentlist $r] {
5411 if {$p eq $nextid} continue
5412 set rn [nextuse $p $r]
5413 if {$rn >= $row &&
5414 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5415 lappend ids [list [ordertoken $p] $p]
5419 for {} {$r < $row} {incr r} {
5420 set nextid [lindex $displayorder [expr {$r + 1}]]
5421 foreach p [lindex $parentlist $r] {
5422 if {$p eq $nextid} continue
5423 set rn [nextuse $p $r]
5424 if {$rn < 0 || $rn >= $row} {
5425 lappend ids [list [ordertoken $p] $p]
5429 set id [lindex $displayorder $row]
5430 lappend ids [list [ordertoken $id] $id]
5431 while {$r < $rb} {
5432 foreach p [lindex $parentlist $r] {
5433 set firstkid [lindex $children($curview,$p) 0]
5434 if {[rowofcommit $firstkid] < $row} {
5435 lappend ids [list [ordertoken $p] $p]
5438 incr r
5439 set id [lindex $displayorder $r]
5440 if {$id ne {}} {
5441 set firstkid [lindex $children($curview,$id) 0]
5442 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5443 lappend ids [list [ordertoken $id] $id]
5447 set idlist {}
5448 foreach idx [lsort -unique $ids] {
5449 lappend idlist [lindex $idx 1]
5451 return $idlist
5454 proc rowsequal {a b} {
5455 while {[set i [lsearch -exact $a {}]] >= 0} {
5456 set a [lreplace $a $i $i]
5458 while {[set i [lsearch -exact $b {}]] >= 0} {
5459 set b [lreplace $b $i $i]
5461 return [expr {$a eq $b}]
5464 proc makeupline {id row rend col} {
5465 global rowidlist uparrowlen downarrowlen mingaplen
5467 for {set r $rend} {1} {set r $rstart} {
5468 set rstart [prevuse $id $r]
5469 if {$rstart < 0} return
5470 if {$rstart < $row} break
5472 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5473 set rstart [expr {$rend - $uparrowlen - 1}]
5475 for {set r $rstart} {[incr r] <= $row} {} {
5476 set idlist [lindex $rowidlist $r]
5477 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5478 set col [idcol $idlist $id $col]
5479 lset rowidlist $r [linsert $idlist $col $id]
5480 changedrow $r
5485 proc layoutrows {row endrow} {
5486 global rowidlist rowisopt rowfinal displayorder
5487 global uparrowlen downarrowlen maxwidth mingaplen
5488 global children parentlist
5489 global commitidx viewcomplete curview
5491 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5492 set idlist {}
5493 if {$row > 0} {
5494 set rm1 [expr {$row - 1}]
5495 foreach id [lindex $rowidlist $rm1] {
5496 if {$id ne {}} {
5497 lappend idlist $id
5500 set final [lindex $rowfinal $rm1]
5502 for {} {$row < $endrow} {incr row} {
5503 set rm1 [expr {$row - 1}]
5504 if {$rm1 < 0 || $idlist eq {}} {
5505 set idlist [make_idlist $row]
5506 set final 1
5507 } else {
5508 set id [lindex $displayorder $rm1]
5509 set col [lsearch -exact $idlist $id]
5510 set idlist [lreplace $idlist $col $col]
5511 foreach p [lindex $parentlist $rm1] {
5512 if {[lsearch -exact $idlist $p] < 0} {
5513 set col [idcol $idlist $p $col]
5514 set idlist [linsert $idlist $col $p]
5515 # if not the first child, we have to insert a line going up
5516 if {$id ne [lindex $children($curview,$p) 0]} {
5517 makeupline $p $rm1 $row $col
5521 set id [lindex $displayorder $row]
5522 if {$row > $downarrowlen} {
5523 set termrow [expr {$row - $downarrowlen - 1}]
5524 foreach p [lindex $parentlist $termrow] {
5525 set i [lsearch -exact $idlist $p]
5526 if {$i < 0} continue
5527 set nr [nextuse $p $termrow]
5528 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5529 set idlist [lreplace $idlist $i $i]
5533 set col [lsearch -exact $idlist $id]
5534 if {$col < 0} {
5535 set col [idcol $idlist $id]
5536 set idlist [linsert $idlist $col $id]
5537 if {$children($curview,$id) ne {}} {
5538 makeupline $id $rm1 $row $col
5541 set r [expr {$row + $uparrowlen - 1}]
5542 if {$r < $commitidx($curview)} {
5543 set x $col
5544 foreach p [lindex $parentlist $r] {
5545 if {[lsearch -exact $idlist $p] >= 0} continue
5546 set fk [lindex $children($curview,$p) 0]
5547 if {[rowofcommit $fk] < $row} {
5548 set x [idcol $idlist $p $x]
5549 set idlist [linsert $idlist $x $p]
5552 if {[incr r] < $commitidx($curview)} {
5553 set p [lindex $displayorder $r]
5554 if {[lsearch -exact $idlist $p] < 0} {
5555 set fk [lindex $children($curview,$p) 0]
5556 if {$fk ne {} && [rowofcommit $fk] < $row} {
5557 set x [idcol $idlist $p $x]
5558 set idlist [linsert $idlist $x $p]
5564 if {$final && !$viewcomplete($curview) &&
5565 $row + $uparrowlen + $mingaplen + $downarrowlen
5566 >= $commitidx($curview)} {
5567 set final 0
5569 set l [llength $rowidlist]
5570 if {$row == $l} {
5571 lappend rowidlist $idlist
5572 lappend rowisopt 0
5573 lappend rowfinal $final
5574 } elseif {$row < $l} {
5575 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5576 lset rowidlist $row $idlist
5577 changedrow $row
5579 lset rowfinal $row $final
5580 } else {
5581 set pad [ntimes [expr {$row - $l}] {}]
5582 set rowidlist [concat $rowidlist $pad]
5583 lappend rowidlist $idlist
5584 set rowfinal [concat $rowfinal $pad]
5585 lappend rowfinal $final
5586 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5589 return $row
5592 proc changedrow {row} {
5593 global displayorder iddrawn rowisopt need_redisplay
5595 set l [llength $rowisopt]
5596 if {$row < $l} {
5597 lset rowisopt $row 0
5598 if {$row + 1 < $l} {
5599 lset rowisopt [expr {$row + 1}] 0
5600 if {$row + 2 < $l} {
5601 lset rowisopt [expr {$row + 2}] 0
5605 set id [lindex $displayorder $row]
5606 if {[info exists iddrawn($id)]} {
5607 set need_redisplay 1
5611 proc insert_pad {row col npad} {
5612 global rowidlist
5614 set pad [ntimes $npad {}]
5615 set idlist [lindex $rowidlist $row]
5616 set bef [lrange $idlist 0 [expr {$col - 1}]]
5617 set aft [lrange $idlist $col end]
5618 set i [lsearch -exact $aft {}]
5619 if {$i > 0} {
5620 set aft [lreplace $aft $i $i]
5622 lset rowidlist $row [concat $bef $pad $aft]
5623 changedrow $row
5626 proc optimize_rows {row col endrow} {
5627 global rowidlist rowisopt displayorder curview children
5629 if {$row < 1} {
5630 set row 1
5632 for {} {$row < $endrow} {incr row; set col 0} {
5633 if {[lindex $rowisopt $row]} continue
5634 set haspad 0
5635 set y0 [expr {$row - 1}]
5636 set ym [expr {$row - 2}]
5637 set idlist [lindex $rowidlist $row]
5638 set previdlist [lindex $rowidlist $y0]
5639 if {$idlist eq {} || $previdlist eq {}} continue
5640 if {$ym >= 0} {
5641 set pprevidlist [lindex $rowidlist $ym]
5642 if {$pprevidlist eq {}} continue
5643 } else {
5644 set pprevidlist {}
5646 set x0 -1
5647 set xm -1
5648 for {} {$col < [llength $idlist]} {incr col} {
5649 set id [lindex $idlist $col]
5650 if {[lindex $previdlist $col] eq $id} continue
5651 if {$id eq {}} {
5652 set haspad 1
5653 continue
5655 set x0 [lsearch -exact $previdlist $id]
5656 if {$x0 < 0} continue
5657 set z [expr {$x0 - $col}]
5658 set isarrow 0
5659 set z0 {}
5660 if {$ym >= 0} {
5661 set xm [lsearch -exact $pprevidlist $id]
5662 if {$xm >= 0} {
5663 set z0 [expr {$xm - $x0}]
5666 if {$z0 eq {}} {
5667 # if row y0 is the first child of $id then it's not an arrow
5668 if {[lindex $children($curview,$id) 0] ne
5669 [lindex $displayorder $y0]} {
5670 set isarrow 1
5673 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5674 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5675 set isarrow 1
5677 # Looking at lines from this row to the previous row,
5678 # make them go straight up if they end in an arrow on
5679 # the previous row; otherwise make them go straight up
5680 # or at 45 degrees.
5681 if {$z < -1 || ($z < 0 && $isarrow)} {
5682 # Line currently goes left too much;
5683 # insert pads in the previous row, then optimize it
5684 set npad [expr {-1 - $z + $isarrow}]
5685 insert_pad $y0 $x0 $npad
5686 if {$y0 > 0} {
5687 optimize_rows $y0 $x0 $row
5689 set previdlist [lindex $rowidlist $y0]
5690 set x0 [lsearch -exact $previdlist $id]
5691 set z [expr {$x0 - $col}]
5692 if {$z0 ne {}} {
5693 set pprevidlist [lindex $rowidlist $ym]
5694 set xm [lsearch -exact $pprevidlist $id]
5695 set z0 [expr {$xm - $x0}]
5697 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5698 # Line currently goes right too much;
5699 # insert pads in this line
5700 set npad [expr {$z - 1 + $isarrow}]
5701 insert_pad $row $col $npad
5702 set idlist [lindex $rowidlist $row]
5703 incr col $npad
5704 set z [expr {$x0 - $col}]
5705 set haspad 1
5707 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5708 # this line links to its first child on row $row-2
5709 set id [lindex $displayorder $ym]
5710 set xc [lsearch -exact $pprevidlist $id]
5711 if {$xc >= 0} {
5712 set z0 [expr {$xc - $x0}]
5715 # avoid lines jigging left then immediately right
5716 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5717 insert_pad $y0 $x0 1
5718 incr x0
5719 optimize_rows $y0 $x0 $row
5720 set previdlist [lindex $rowidlist $y0]
5723 if {!$haspad} {
5724 # Find the first column that doesn't have a line going right
5725 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5726 set id [lindex $idlist $col]
5727 if {$id eq {}} break
5728 set x0 [lsearch -exact $previdlist $id]
5729 if {$x0 < 0} {
5730 # check if this is the link to the first child
5731 set kid [lindex $displayorder $y0]
5732 if {[lindex $children($curview,$id) 0] eq $kid} {
5733 # it is, work out offset to child
5734 set x0 [lsearch -exact $previdlist $kid]
5737 if {$x0 <= $col} break
5739 # Insert a pad at that column as long as it has a line and
5740 # isn't the last column
5741 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5742 set idlist [linsert $idlist $col {}]
5743 lset rowidlist $row $idlist
5744 changedrow $row
5750 proc xc {row col} {
5751 global canvx0 linespc
5752 return [expr {$canvx0 + $col * $linespc}]
5755 proc yc {row} {
5756 global canvy0 linespc
5757 return [expr {$canvy0 + $row * $linespc}]
5760 proc linewidth {id} {
5761 global thickerline lthickness
5763 set wid $lthickness
5764 if {[info exists thickerline] && $id eq $thickerline} {
5765 set wid [expr {2 * $lthickness}]
5767 return $wid
5770 proc rowranges {id} {
5771 global curview children uparrowlen downarrowlen
5772 global rowidlist
5774 set kids $children($curview,$id)
5775 if {$kids eq {}} {
5776 return {}
5778 set ret {}
5779 lappend kids $id
5780 foreach child $kids {
5781 if {![commitinview $child $curview]} break
5782 set row [rowofcommit $child]
5783 if {![info exists prev]} {
5784 lappend ret [expr {$row + 1}]
5785 } else {
5786 if {$row <= $prevrow} {
5787 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5789 # see if the line extends the whole way from prevrow to row
5790 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5791 [lsearch -exact [lindex $rowidlist \
5792 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5793 # it doesn't, see where it ends
5794 set r [expr {$prevrow + $downarrowlen}]
5795 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5796 while {[incr r -1] > $prevrow &&
5797 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5798 } else {
5799 while {[incr r] <= $row &&
5800 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5801 incr r -1
5803 lappend ret $r
5804 # see where it starts up again
5805 set r [expr {$row - $uparrowlen}]
5806 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5807 while {[incr r] < $row &&
5808 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5809 } else {
5810 while {[incr r -1] >= $prevrow &&
5811 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5812 incr r
5814 lappend ret $r
5817 if {$child eq $id} {
5818 lappend ret $row
5820 set prev $child
5821 set prevrow $row
5823 return $ret
5826 proc drawlineseg {id row endrow arrowlow} {
5827 global rowidlist displayorder iddrawn linesegs
5828 global canv colormap linespc curview maxlinelen parentlist
5830 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5831 set le [expr {$row + 1}]
5832 set arrowhigh 1
5833 while {1} {
5834 set c [lsearch -exact [lindex $rowidlist $le] $id]
5835 if {$c < 0} {
5836 incr le -1
5837 break
5839 lappend cols $c
5840 set x [lindex $displayorder $le]
5841 if {$x eq $id} {
5842 set arrowhigh 0
5843 break
5845 if {[info exists iddrawn($x)] || $le == $endrow} {
5846 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5847 if {$c >= 0} {
5848 lappend cols $c
5849 set arrowhigh 0
5851 break
5853 incr le
5855 if {$le <= $row} {
5856 return $row
5859 set lines {}
5860 set i 0
5861 set joinhigh 0
5862 if {[info exists linesegs($id)]} {
5863 set lines $linesegs($id)
5864 foreach li $lines {
5865 set r0 [lindex $li 0]
5866 if {$r0 > $row} {
5867 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5868 set joinhigh 1
5870 break
5872 incr i
5875 set joinlow 0
5876 if {$i > 0} {
5877 set li [lindex $lines [expr {$i-1}]]
5878 set r1 [lindex $li 1]
5879 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5880 set joinlow 1
5884 set x [lindex $cols [expr {$le - $row}]]
5885 set xp [lindex $cols [expr {$le - 1 - $row}]]
5886 set dir [expr {$xp - $x}]
5887 if {$joinhigh} {
5888 set ith [lindex $lines $i 2]
5889 set coords [$canv coords $ith]
5890 set ah [$canv itemcget $ith -arrow]
5891 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5892 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5893 if {$x2 ne {} && $x - $x2 == $dir} {
5894 set coords [lrange $coords 0 end-2]
5896 } else {
5897 set coords [list [xc $le $x] [yc $le]]
5899 if {$joinlow} {
5900 set itl [lindex $lines [expr {$i-1}] 2]
5901 set al [$canv itemcget $itl -arrow]
5902 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5903 } elseif {$arrowlow} {
5904 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5905 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5906 set arrowlow 0
5909 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5910 for {set y $le} {[incr y -1] > $row} {} {
5911 set x $xp
5912 set xp [lindex $cols [expr {$y - 1 - $row}]]
5913 set ndir [expr {$xp - $x}]
5914 if {$dir != $ndir || $xp < 0} {
5915 lappend coords [xc $y $x] [yc $y]
5917 set dir $ndir
5919 if {!$joinlow} {
5920 if {$xp < 0} {
5921 # join parent line to first child
5922 set ch [lindex $displayorder $row]
5923 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5924 if {$xc < 0} {
5925 puts "oops: drawlineseg: child $ch not on row $row"
5926 } elseif {$xc != $x} {
5927 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5928 set d [expr {int(0.5 * $linespc)}]
5929 set x1 [xc $row $x]
5930 if {$xc < $x} {
5931 set x2 [expr {$x1 - $d}]
5932 } else {
5933 set x2 [expr {$x1 + $d}]
5935 set y2 [yc $row]
5936 set y1 [expr {$y2 + $d}]
5937 lappend coords $x1 $y1 $x2 $y2
5938 } elseif {$xc < $x - 1} {
5939 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5940 } elseif {$xc > $x + 1} {
5941 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5943 set x $xc
5945 lappend coords [xc $row $x] [yc $row]
5946 } else {
5947 set xn [xc $row $xp]
5948 set yn [yc $row]
5949 lappend coords $xn $yn
5951 if {!$joinhigh} {
5952 assigncolor $id
5953 set t [$canv create line $coords -width [linewidth $id] \
5954 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5955 $canv lower $t
5956 bindline $t $id
5957 set lines [linsert $lines $i [list $row $le $t]]
5958 } else {
5959 $canv coords $ith $coords
5960 if {$arrow ne $ah} {
5961 $canv itemconf $ith -arrow $arrow
5963 lset lines $i 0 $row
5965 } else {
5966 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5967 set ndir [expr {$xo - $xp}]
5968 set clow [$canv coords $itl]
5969 if {$dir == $ndir} {
5970 set clow [lrange $clow 2 end]
5972 set coords [concat $coords $clow]
5973 if {!$joinhigh} {
5974 lset lines [expr {$i-1}] 1 $le
5975 } else {
5976 # coalesce two pieces
5977 $canv delete $ith
5978 set b [lindex $lines [expr {$i-1}] 0]
5979 set e [lindex $lines $i 1]
5980 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5982 $canv coords $itl $coords
5983 if {$arrow ne $al} {
5984 $canv itemconf $itl -arrow $arrow
5988 set linesegs($id) $lines
5989 return $le
5992 proc drawparentlinks {id row} {
5993 global rowidlist canv colormap curview parentlist
5994 global idpos linespc
5996 set rowids [lindex $rowidlist $row]
5997 set col [lsearch -exact $rowids $id]
5998 if {$col < 0} return
5999 set olds [lindex $parentlist $row]
6000 set row2 [expr {$row + 1}]
6001 set x [xc $row $col]
6002 set y [yc $row]
6003 set y2 [yc $row2]
6004 set d [expr {int(0.5 * $linespc)}]
6005 set ymid [expr {$y + $d}]
6006 set ids [lindex $rowidlist $row2]
6007 # rmx = right-most X coord used
6008 set rmx 0
6009 foreach p $olds {
6010 set i [lsearch -exact $ids $p]
6011 if {$i < 0} {
6012 puts "oops, parent $p of $id not in list"
6013 continue
6015 set x2 [xc $row2 $i]
6016 if {$x2 > $rmx} {
6017 set rmx $x2
6019 set j [lsearch -exact $rowids $p]
6020 if {$j < 0} {
6021 # drawlineseg will do this one for us
6022 continue
6024 assigncolor $p
6025 # should handle duplicated parents here...
6026 set coords [list $x $y]
6027 if {$i != $col} {
6028 # if attaching to a vertical segment, draw a smaller
6029 # slant for visual distinctness
6030 if {$i == $j} {
6031 if {$i < $col} {
6032 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6033 } else {
6034 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6036 } elseif {$i < $col && $i < $j} {
6037 # segment slants towards us already
6038 lappend coords [xc $row $j] $y
6039 } else {
6040 if {$i < $col - 1} {
6041 lappend coords [expr {$x2 + $linespc}] $y
6042 } elseif {$i > $col + 1} {
6043 lappend coords [expr {$x2 - $linespc}] $y
6045 lappend coords $x2 $y2
6047 } else {
6048 lappend coords $x2 $y2
6050 set t [$canv create line $coords -width [linewidth $p] \
6051 -fill $colormap($p) -tags lines.$p]
6052 $canv lower $t
6053 bindline $t $p
6055 if {$rmx > [lindex $idpos($id) 1]} {
6056 lset idpos($id) 1 $rmx
6057 redrawtags $id
6061 proc drawlines {id} {
6062 global canv
6064 $canv itemconf lines.$id -width [linewidth $id]
6067 proc drawcmittext {id row col} {
6068 global linespc canv canv2 canv3 fgcolor curview
6069 global cmitlisted commitinfo rowidlist parentlist
6070 global rowtextx idpos idtags idheads idotherrefs
6071 global linehtag linentag linedtag selectedline
6072 global canvxmax boldids boldnameids fgcolor markedid
6073 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6074 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6075 global circleoutlinecolor
6077 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6078 set listed $cmitlisted($curview,$id)
6079 if {$id eq $nullid} {
6080 set ofill $workingfilescirclecolor
6081 } elseif {$id eq $nullid2} {
6082 set ofill $indexcirclecolor
6083 } elseif {$id eq $mainheadid} {
6084 set ofill $mainheadcirclecolor
6085 } else {
6086 set ofill [lindex $circlecolors $listed]
6088 set x [xc $row $col]
6089 set y [yc $row]
6090 set orad [expr {$linespc / 3}]
6091 if {$listed <= 2} {
6092 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6093 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6094 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6095 } elseif {$listed == 3} {
6096 # triangle pointing left for left-side commits
6097 set t [$canv create polygon \
6098 [expr {$x - $orad}] $y \
6099 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6100 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6101 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6102 } else {
6103 # triangle pointing right for right-side commits
6104 set t [$canv create polygon \
6105 [expr {$x + $orad - 1}] $y \
6106 [expr {$x - $orad}] [expr {$y - $orad}] \
6107 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6108 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6110 set circleitem($row) $t
6111 $canv raise $t
6112 $canv bind $t <1> {selcanvline {} %x %y}
6113 set rmx [llength [lindex $rowidlist $row]]
6114 set olds [lindex $parentlist $row]
6115 if {$olds ne {}} {
6116 set nextids [lindex $rowidlist [expr {$row + 1}]]
6117 foreach p $olds {
6118 set i [lsearch -exact $nextids $p]
6119 if {$i > $rmx} {
6120 set rmx $i
6124 set xt [xc $row $rmx]
6125 set rowtextx($row) $xt
6126 set idpos($id) [list $x $xt $y]
6127 if {[info exists idtags($id)] || [info exists idheads($id)]
6128 || [info exists idotherrefs($id)]} {
6129 set xt [drawtags $id $x $xt $y]
6131 if {[lindex $commitinfo($id) 6] > 0} {
6132 set xt [drawnotesign $xt $y]
6134 set headline [lindex $commitinfo($id) 0]
6135 set name [lindex $commitinfo($id) 1]
6136 set date [lindex $commitinfo($id) 2]
6137 set date [formatdate $date]
6138 set font mainfont
6139 set nfont mainfont
6140 set isbold [ishighlighted $id]
6141 if {$isbold > 0} {
6142 lappend boldids $id
6143 set font mainfontbold
6144 if {$isbold > 1} {
6145 lappend boldnameids $id
6146 set nfont mainfontbold
6149 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6150 -text $headline -font $font -tags text]
6151 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6152 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6153 -text $name -font $nfont -tags text]
6154 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6155 -text $date -font mainfont -tags text]
6156 if {$selectedline == $row} {
6157 make_secsel $id
6159 if {[info exists markedid] && $markedid eq $id} {
6160 make_idmark $id
6162 set xr [expr {$xt + [font measure $font $headline]}]
6163 if {$xr > $canvxmax} {
6164 set canvxmax $xr
6165 setcanvscroll
6169 proc drawcmitrow {row} {
6170 global displayorder rowidlist nrows_drawn
6171 global iddrawn markingmatches
6172 global commitinfo numcommits
6173 global filehighlight fhighlights findpattern nhighlights
6174 global hlview vhighlights
6175 global highlight_related rhighlights
6177 if {$row >= $numcommits} return
6179 set id [lindex $displayorder $row]
6180 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6181 askvhighlight $row $id
6183 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6184 askfilehighlight $row $id
6186 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6187 askfindhighlight $row $id
6189 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6190 askrelhighlight $row $id
6192 if {![info exists iddrawn($id)]} {
6193 set col [lsearch -exact [lindex $rowidlist $row] $id]
6194 if {$col < 0} {
6195 puts "oops, row $row id $id not in list"
6196 return
6198 if {![info exists commitinfo($id)]} {
6199 getcommit $id
6201 assigncolor $id
6202 drawcmittext $id $row $col
6203 set iddrawn($id) 1
6204 incr nrows_drawn
6206 if {$markingmatches} {
6207 markrowmatches $row $id
6211 proc drawcommits {row {endrow {}}} {
6212 global numcommits iddrawn displayorder curview need_redisplay
6213 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6215 if {$row < 0} {
6216 set row 0
6218 if {$endrow eq {}} {
6219 set endrow $row
6221 if {$endrow >= $numcommits} {
6222 set endrow [expr {$numcommits - 1}]
6225 set rl1 [expr {$row - $downarrowlen - 3}]
6226 if {$rl1 < 0} {
6227 set rl1 0
6229 set ro1 [expr {$row - 3}]
6230 if {$ro1 < 0} {
6231 set ro1 0
6233 set r2 [expr {$endrow + $uparrowlen + 3}]
6234 if {$r2 > $numcommits} {
6235 set r2 $numcommits
6237 for {set r $rl1} {$r < $r2} {incr r} {
6238 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6239 if {$rl1 < $r} {
6240 layoutrows $rl1 $r
6242 set rl1 [expr {$r + 1}]
6245 if {$rl1 < $r} {
6246 layoutrows $rl1 $r
6248 optimize_rows $ro1 0 $r2
6249 if {$need_redisplay || $nrows_drawn > 2000} {
6250 clear_display
6253 # make the lines join to already-drawn rows either side
6254 set r [expr {$row - 1}]
6255 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6256 set r $row
6258 set er [expr {$endrow + 1}]
6259 if {$er >= $numcommits ||
6260 ![info exists iddrawn([lindex $displayorder $er])]} {
6261 set er $endrow
6263 for {} {$r <= $er} {incr r} {
6264 set id [lindex $displayorder $r]
6265 set wasdrawn [info exists iddrawn($id)]
6266 drawcmitrow $r
6267 if {$r == $er} break
6268 set nextid [lindex $displayorder [expr {$r + 1}]]
6269 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6270 drawparentlinks $id $r
6272 set rowids [lindex $rowidlist $r]
6273 foreach lid $rowids {
6274 if {$lid eq {}} continue
6275 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6276 if {$lid eq $id} {
6277 # see if this is the first child of any of its parents
6278 foreach p [lindex $parentlist $r] {
6279 if {[lsearch -exact $rowids $p] < 0} {
6280 # make this line extend up to the child
6281 set lineend($p) [drawlineseg $p $r $er 0]
6284 } else {
6285 set lineend($lid) [drawlineseg $lid $r $er 1]
6291 proc undolayout {row} {
6292 global uparrowlen mingaplen downarrowlen
6293 global rowidlist rowisopt rowfinal need_redisplay
6295 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6296 if {$r < 0} {
6297 set r 0
6299 if {[llength $rowidlist] > $r} {
6300 incr r -1
6301 set rowidlist [lrange $rowidlist 0 $r]
6302 set rowfinal [lrange $rowfinal 0 $r]
6303 set rowisopt [lrange $rowisopt 0 $r]
6304 set need_redisplay 1
6305 run drawvisible
6309 proc drawvisible {} {
6310 global canv linespc curview vrowmod selectedline targetrow targetid
6311 global need_redisplay cscroll numcommits
6313 set fs [$canv yview]
6314 set ymax [lindex [$canv cget -scrollregion] 3]
6315 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6316 set f0 [lindex $fs 0]
6317 set f1 [lindex $fs 1]
6318 set y0 [expr {int($f0 * $ymax)}]
6319 set y1 [expr {int($f1 * $ymax)}]
6321 if {[info exists targetid]} {
6322 if {[commitinview $targetid $curview]} {
6323 set r [rowofcommit $targetid]
6324 if {$r != $targetrow} {
6325 # Fix up the scrollregion and change the scrolling position
6326 # now that our target row has moved.
6327 set diff [expr {($r - $targetrow) * $linespc}]
6328 set targetrow $r
6329 setcanvscroll
6330 set ymax [lindex [$canv cget -scrollregion] 3]
6331 incr y0 $diff
6332 incr y1 $diff
6333 set f0 [expr {$y0 / $ymax}]
6334 set f1 [expr {$y1 / $ymax}]
6335 allcanvs yview moveto $f0
6336 $cscroll set $f0 $f1
6337 set need_redisplay 1
6339 } else {
6340 unset targetid
6344 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6345 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6346 if {$endrow >= $vrowmod($curview)} {
6347 update_arcrows $curview
6349 if {$selectedline ne {} &&
6350 $row <= $selectedline && $selectedline <= $endrow} {
6351 set targetrow $selectedline
6352 } elseif {[info exists targetid]} {
6353 set targetrow [expr {int(($row + $endrow) / 2)}]
6355 if {[info exists targetrow]} {
6356 if {$targetrow >= $numcommits} {
6357 set targetrow [expr {$numcommits - 1}]
6359 set targetid [commitonrow $targetrow]
6361 drawcommits $row $endrow
6364 proc clear_display {} {
6365 global iddrawn linesegs need_redisplay nrows_drawn
6366 global vhighlights fhighlights nhighlights rhighlights
6367 global linehtag linentag linedtag boldids boldnameids
6369 allcanvs delete all
6370 catch {unset iddrawn}
6371 catch {unset linesegs}
6372 catch {unset linehtag}
6373 catch {unset linentag}
6374 catch {unset linedtag}
6375 set boldids {}
6376 set boldnameids {}
6377 catch {unset vhighlights}
6378 catch {unset fhighlights}
6379 catch {unset nhighlights}
6380 catch {unset rhighlights}
6381 set need_redisplay 0
6382 set nrows_drawn 0
6385 proc findcrossings {id} {
6386 global rowidlist parentlist numcommits displayorder
6388 set cross {}
6389 set ccross {}
6390 foreach {s e} [rowranges $id] {
6391 if {$e >= $numcommits} {
6392 set e [expr {$numcommits - 1}]
6394 if {$e <= $s} continue
6395 for {set row $e} {[incr row -1] >= $s} {} {
6396 set x [lsearch -exact [lindex $rowidlist $row] $id]
6397 if {$x < 0} break
6398 set olds [lindex $parentlist $row]
6399 set kid [lindex $displayorder $row]
6400 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6401 if {$kidx < 0} continue
6402 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6403 foreach p $olds {
6404 set px [lsearch -exact $nextrow $p]
6405 if {$px < 0} continue
6406 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6407 if {[lsearch -exact $ccross $p] >= 0} continue
6408 if {$x == $px + ($kidx < $px? -1: 1)} {
6409 lappend ccross $p
6410 } elseif {[lsearch -exact $cross $p] < 0} {
6411 lappend cross $p
6417 return [concat $ccross {{}} $cross]
6420 proc assigncolor {id} {
6421 global colormap colors nextcolor
6422 global parents children children curview
6424 if {[info exists colormap($id)]} return
6425 set ncolors [llength $colors]
6426 if {[info exists children($curview,$id)]} {
6427 set kids $children($curview,$id)
6428 } else {
6429 set kids {}
6431 if {[llength $kids] == 1} {
6432 set child [lindex $kids 0]
6433 if {[info exists colormap($child)]
6434 && [llength $parents($curview,$child)] == 1} {
6435 set colormap($id) $colormap($child)
6436 return
6439 set badcolors {}
6440 set origbad {}
6441 foreach x [findcrossings $id] {
6442 if {$x eq {}} {
6443 # delimiter between corner crossings and other crossings
6444 if {[llength $badcolors] >= $ncolors - 1} break
6445 set origbad $badcolors
6447 if {[info exists colormap($x)]
6448 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6449 lappend badcolors $colormap($x)
6452 if {[llength $badcolors] >= $ncolors} {
6453 set badcolors $origbad
6455 set origbad $badcolors
6456 if {[llength $badcolors] < $ncolors - 1} {
6457 foreach child $kids {
6458 if {[info exists colormap($child)]
6459 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6460 lappend badcolors $colormap($child)
6462 foreach p $parents($curview,$child) {
6463 if {[info exists colormap($p)]
6464 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6465 lappend badcolors $colormap($p)
6469 if {[llength $badcolors] >= $ncolors} {
6470 set badcolors $origbad
6473 for {set i 0} {$i <= $ncolors} {incr i} {
6474 set c [lindex $colors $nextcolor]
6475 if {[incr nextcolor] >= $ncolors} {
6476 set nextcolor 0
6478 if {[lsearch -exact $badcolors $c]} break
6480 set colormap($id) $c
6483 proc bindline {t id} {
6484 global canv
6486 $canv bind $t <Enter> "lineenter %x %y $id"
6487 $canv bind $t <Motion> "linemotion %x %y $id"
6488 $canv bind $t <Leave> "lineleave $id"
6489 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6492 proc graph_pane_width {} {
6493 global use_ttk
6495 if {$use_ttk} {
6496 set g [.tf.histframe.pwclist sashpos 0]
6497 } else {
6498 set g [.tf.histframe.pwclist sash coord 0]
6500 return [lindex $g 0]
6503 proc totalwidth {l font extra} {
6504 set tot 0
6505 foreach str $l {
6506 set tot [expr {$tot + [font measure $font $str] + $extra}]
6508 return $tot
6511 proc drawtags {id x xt y1} {
6512 global idtags idheads idotherrefs mainhead
6513 global linespc lthickness
6514 global canv rowtextx curview fgcolor bgcolor ctxbut
6515 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6516 global tagbgcolor tagfgcolor tagoutlinecolor
6517 global reflinecolor
6519 set marks {}
6520 set ntags 0
6521 set nheads 0
6522 set singletag 0
6523 set maxtags 3
6524 set maxtagpct 25
6525 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6526 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6527 set extra [expr {$delta + $lthickness + $linespc}]
6529 if {[info exists idtags($id)]} {
6530 set marks $idtags($id)
6531 set ntags [llength $marks]
6532 if {$ntags > $maxtags ||
6533 [totalwidth $marks mainfont $extra] > $maxwidth} {
6534 # show just a single "n tags..." tag
6535 set singletag 1
6536 if {$ntags == 1} {
6537 set marks [list "tag..."]
6538 } else {
6539 set marks [list [format "%d tags..." $ntags]]
6541 set ntags 1
6544 if {[info exists idheads($id)]} {
6545 set marks [concat $marks $idheads($id)]
6546 set nheads [llength $idheads($id)]
6548 if {[info exists idotherrefs($id)]} {
6549 set marks [concat $marks $idotherrefs($id)]
6551 if {$marks eq {}} {
6552 return $xt
6555 set yt [expr {$y1 - 0.5 * $linespc}]
6556 set yb [expr {$yt + $linespc - 1}]
6557 set xvals {}
6558 set wvals {}
6559 set i -1
6560 foreach tag $marks {
6561 incr i
6562 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6563 set wid [font measure mainfontbold $tag]
6564 } else {
6565 set wid [font measure mainfont $tag]
6567 lappend xvals $xt
6568 lappend wvals $wid
6569 set xt [expr {$xt + $wid + $extra}]
6571 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6572 -width $lthickness -fill $reflinecolor -tags tag.$id]
6573 $canv lower $t
6574 foreach tag $marks x $xvals wid $wvals {
6575 set tag_quoted [string map {% %%} $tag]
6576 set xl [expr {$x + $delta}]
6577 set xr [expr {$x + $delta + $wid + $lthickness}]
6578 set font mainfont
6579 if {[incr ntags -1] >= 0} {
6580 # draw a tag
6581 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6582 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6583 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6584 -tags tag.$id]
6585 if {$singletag} {
6586 set tagclick [list showtags $id 1]
6587 } else {
6588 set tagclick [list showtag $tag_quoted 1]
6590 $canv bind $t <1> $tagclick
6591 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6592 } else {
6593 # draw a head or other ref
6594 if {[incr nheads -1] >= 0} {
6595 set col $headbgcolor
6596 if {$tag eq $mainhead} {
6597 set font mainfontbold
6599 } else {
6600 set col "#ddddff"
6602 set xl [expr {$xl - $delta/2}]
6603 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6604 -width 1 -outline black -fill $col -tags tag.$id
6605 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6606 set rwid [font measure mainfont $remoteprefix]
6607 set xi [expr {$x + 1}]
6608 set yti [expr {$yt + 1}]
6609 set xri [expr {$x + $rwid}]
6610 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6611 -width 0 -fill $remotebgcolor -tags tag.$id
6614 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6615 -font $font -tags [list tag.$id text]]
6616 if {$ntags >= 0} {
6617 $canv bind $t <1> $tagclick
6618 } elseif {$nheads >= 0} {
6619 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6622 return $xt
6625 proc drawnotesign {xt y} {
6626 global linespc canv fgcolor
6628 set orad [expr {$linespc / 3}]
6629 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6630 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6631 -fill yellow -outline $fgcolor -width 1 -tags circle]
6632 set xt [expr {$xt + $orad * 3}]
6633 return $xt
6636 proc xcoord {i level ln} {
6637 global canvx0 xspc1 xspc2
6639 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6640 if {$i > 0 && $i == $level} {
6641 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6642 } elseif {$i > $level} {
6643 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6645 return $x
6648 proc show_status {msg} {
6649 global canv fgcolor
6651 clear_display
6652 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6653 -tags text -fill $fgcolor
6656 # Don't change the text pane cursor if it is currently the hand cursor,
6657 # showing that we are over a sha1 ID link.
6658 proc settextcursor {c} {
6659 global ctext curtextcursor
6661 if {[$ctext cget -cursor] == $curtextcursor} {
6662 $ctext config -cursor $c
6664 set curtextcursor $c
6667 proc nowbusy {what {name {}}} {
6668 global isbusy busyname statusw
6670 if {[array names isbusy] eq {}} {
6671 . config -cursor watch
6672 settextcursor watch
6674 set isbusy($what) 1
6675 set busyname($what) $name
6676 if {$name ne {}} {
6677 $statusw conf -text $name
6681 proc notbusy {what} {
6682 global isbusy maincursor textcursor busyname statusw
6684 catch {
6685 unset isbusy($what)
6686 if {$busyname($what) ne {} &&
6687 [$statusw cget -text] eq $busyname($what)} {
6688 $statusw conf -text {}
6691 if {[array names isbusy] eq {}} {
6692 . config -cursor $maincursor
6693 settextcursor $textcursor
6697 proc findmatches {f} {
6698 global findtype findstring
6699 if {$findtype == [mc "Regexp"]} {
6700 set matches [regexp -indices -all -inline $findstring $f]
6701 } else {
6702 set fs $findstring
6703 if {$findtype == [mc "IgnCase"]} {
6704 set f [string tolower $f]
6705 set fs [string tolower $fs]
6707 set matches {}
6708 set i 0
6709 set l [string length $fs]
6710 while {[set j [string first $fs $f $i]] >= 0} {
6711 lappend matches [list $j [expr {$j+$l-1}]]
6712 set i [expr {$j + $l}]
6715 return $matches
6718 proc dofind {{dirn 1} {wrap 1}} {
6719 global findstring findstartline findcurline selectedline numcommits
6720 global gdttype filehighlight fh_serial find_dirn findallowwrap
6722 if {[info exists find_dirn]} {
6723 if {$find_dirn == $dirn} return
6724 stopfinding
6726 focus .
6727 if {$findstring eq {} || $numcommits == 0} return
6728 if {$selectedline eq {}} {
6729 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6730 } else {
6731 set findstartline $selectedline
6733 set findcurline $findstartline
6734 nowbusy finding [mc "Searching"]
6735 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6736 after cancel do_file_hl $fh_serial
6737 do_file_hl $fh_serial
6739 set find_dirn $dirn
6740 set findallowwrap $wrap
6741 run findmore
6744 proc stopfinding {} {
6745 global find_dirn findcurline fprogcoord
6747 if {[info exists find_dirn]} {
6748 unset find_dirn
6749 unset findcurline
6750 notbusy finding
6751 set fprogcoord 0
6752 adjustprogress
6754 stopblaming
6757 proc findmore {} {
6758 global commitdata commitinfo numcommits findpattern findloc
6759 global findstartline findcurline findallowwrap
6760 global find_dirn gdttype fhighlights fprogcoord
6761 global curview varcorder vrownum varccommits vrowmod
6763 if {![info exists find_dirn]} {
6764 return 0
6766 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6767 set l $findcurline
6768 set moretodo 0
6769 if {$find_dirn > 0} {
6770 incr l
6771 if {$l >= $numcommits} {
6772 set l 0
6774 if {$l <= $findstartline} {
6775 set lim [expr {$findstartline + 1}]
6776 } else {
6777 set lim $numcommits
6778 set moretodo $findallowwrap
6780 } else {
6781 if {$l == 0} {
6782 set l $numcommits
6784 incr l -1
6785 if {$l >= $findstartline} {
6786 set lim [expr {$findstartline - 1}]
6787 } else {
6788 set lim -1
6789 set moretodo $findallowwrap
6792 set n [expr {($lim - $l) * $find_dirn}]
6793 if {$n > 500} {
6794 set n 500
6795 set moretodo 1
6797 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6798 update_arcrows $curview
6800 set found 0
6801 set domore 1
6802 set ai [bsearch $vrownum($curview) $l]
6803 set a [lindex $varcorder($curview) $ai]
6804 set arow [lindex $vrownum($curview) $ai]
6805 set ids [lindex $varccommits($curview,$a)]
6806 set arowend [expr {$arow + [llength $ids]}]
6807 if {$gdttype eq [mc "containing:"]} {
6808 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6809 if {$l < $arow || $l >= $arowend} {
6810 incr ai $find_dirn
6811 set a [lindex $varcorder($curview) $ai]
6812 set arow [lindex $vrownum($curview) $ai]
6813 set ids [lindex $varccommits($curview,$a)]
6814 set arowend [expr {$arow + [llength $ids]}]
6816 set id [lindex $ids [expr {$l - $arow}]]
6817 # shouldn't happen unless git log doesn't give all the commits...
6818 if {![info exists commitdata($id)] ||
6819 ![doesmatch $commitdata($id)]} {
6820 continue
6822 if {![info exists commitinfo($id)]} {
6823 getcommit $id
6825 set info $commitinfo($id)
6826 foreach f $info ty $fldtypes {
6827 if {$ty eq ""} continue
6828 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6829 [doesmatch $f]} {
6830 set found 1
6831 break
6834 if {$found} break
6836 } else {
6837 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6838 if {$l < $arow || $l >= $arowend} {
6839 incr ai $find_dirn
6840 set a [lindex $varcorder($curview) $ai]
6841 set arow [lindex $vrownum($curview) $ai]
6842 set ids [lindex $varccommits($curview,$a)]
6843 set arowend [expr {$arow + [llength $ids]}]
6845 set id [lindex $ids [expr {$l - $arow}]]
6846 if {![info exists fhighlights($id)]} {
6847 # this sets fhighlights($id) to -1
6848 askfilehighlight $l $id
6850 if {$fhighlights($id) > 0} {
6851 set found $domore
6852 break
6854 if {$fhighlights($id) < 0} {
6855 if {$domore} {
6856 set domore 0
6857 set findcurline [expr {$l - $find_dirn}]
6862 if {$found || ($domore && !$moretodo)} {
6863 unset findcurline
6864 unset find_dirn
6865 notbusy finding
6866 set fprogcoord 0
6867 adjustprogress
6868 if {$found} {
6869 findselectline $l
6870 } else {
6871 bell
6873 return 0
6875 if {!$domore} {
6876 flushhighlights
6877 } else {
6878 set findcurline [expr {$l - $find_dirn}]
6880 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6881 if {$n < 0} {
6882 incr n $numcommits
6884 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6885 adjustprogress
6886 return $domore
6889 proc findselectline {l} {
6890 global findloc commentend ctext findcurline markingmatches gdttype
6892 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6893 set findcurline $l
6894 selectline $l 1
6895 if {$markingmatches &&
6896 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6897 # highlight the matches in the comments
6898 set f [$ctext get 1.0 $commentend]
6899 set matches [findmatches $f]
6900 foreach match $matches {
6901 set start [lindex $match 0]
6902 set end [expr {[lindex $match 1] + 1}]
6903 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6906 drawvisible
6909 # mark the bits of a headline or author that match a find string
6910 proc markmatches {canv l str tag matches font row} {
6911 global selectedline
6913 set bbox [$canv bbox $tag]
6914 set x0 [lindex $bbox 0]
6915 set y0 [lindex $bbox 1]
6916 set y1 [lindex $bbox 3]
6917 foreach match $matches {
6918 set start [lindex $match 0]
6919 set end [lindex $match 1]
6920 if {$start > $end} continue
6921 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6922 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6923 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6924 [expr {$x0+$xlen+2}] $y1 \
6925 -outline {} -tags [list match$l matches] -fill yellow]
6926 $canv lower $t
6927 if {$row == $selectedline} {
6928 $canv raise $t secsel
6933 proc unmarkmatches {} {
6934 global markingmatches
6936 allcanvs delete matches
6937 set markingmatches 0
6938 stopfinding
6941 proc selcanvline {w x y} {
6942 global canv canvy0 ctext linespc
6943 global rowtextx
6944 set ymax [lindex [$canv cget -scrollregion] 3]
6945 if {$ymax == {}} return
6946 set yfrac [lindex [$canv yview] 0]
6947 set y [expr {$y + $yfrac * $ymax}]
6948 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6949 if {$l < 0} {
6950 set l 0
6952 if {$w eq $canv} {
6953 set xmax [lindex [$canv cget -scrollregion] 2]
6954 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6955 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6957 unmarkmatches
6958 selectline $l 1
6961 proc commit_descriptor {p} {
6962 global commitinfo
6963 if {![info exists commitinfo($p)]} {
6964 getcommit $p
6966 set l "..."
6967 if {[llength $commitinfo($p)] > 1} {
6968 set l [lindex $commitinfo($p) 0]
6970 return "$p ($l)\n"
6973 # append some text to the ctext widget, and make any SHA1 ID
6974 # that we know about be a clickable link.
6975 proc appendwithlinks {text tags} {
6976 global ctext linknum curview
6978 set start [$ctext index "end - 1c"]
6979 $ctext insert end $text $tags
6980 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6981 foreach l $links {
6982 set s [lindex $l 0]
6983 set e [lindex $l 1]
6984 set linkid [string range $text $s $e]
6985 incr e
6986 $ctext tag delete link$linknum
6987 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6988 setlink $linkid link$linknum
6989 incr linknum
6993 proc setlink {id lk} {
6994 global curview ctext pendinglinks
6995 global linkfgcolor
6997 if {[string range $id 0 1] eq "-g"} {
6998 set id [string range $id 2 end]
7001 set known 0
7002 if {[string length $id] < 40} {
7003 set matches [longid $id]
7004 if {[llength $matches] > 0} {
7005 if {[llength $matches] > 1} return
7006 set known 1
7007 set id [lindex $matches 0]
7009 } else {
7010 set known [commitinview $id $curview]
7012 if {$known} {
7013 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7014 $ctext tag bind $lk <1> [list selbyid $id]
7015 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7016 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7017 } else {
7018 lappend pendinglinks($id) $lk
7019 interestedin $id {makelink %P}
7023 proc appendshortlink {id {pre {}} {post {}}} {
7024 global ctext linknum
7026 $ctext insert end $pre
7027 $ctext tag delete link$linknum
7028 $ctext insert end [string range $id 0 7] link$linknum
7029 $ctext insert end $post
7030 setlink $id link$linknum
7031 incr linknum
7034 proc makelink {id} {
7035 global pendinglinks
7037 if {![info exists pendinglinks($id)]} return
7038 foreach lk $pendinglinks($id) {
7039 setlink $id $lk
7041 unset pendinglinks($id)
7044 proc linkcursor {w inc} {
7045 global linkentercount curtextcursor
7047 if {[incr linkentercount $inc] > 0} {
7048 $w configure -cursor hand2
7049 } else {
7050 $w configure -cursor $curtextcursor
7051 if {$linkentercount < 0} {
7052 set linkentercount 0
7057 proc viewnextline {dir} {
7058 global canv linespc
7060 $canv delete hover
7061 set ymax [lindex [$canv cget -scrollregion] 3]
7062 set wnow [$canv yview]
7063 set wtop [expr {[lindex $wnow 0] * $ymax}]
7064 set newtop [expr {$wtop + $dir * $linespc}]
7065 if {$newtop < 0} {
7066 set newtop 0
7067 } elseif {$newtop > $ymax} {
7068 set newtop $ymax
7070 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7073 # add a list of tag or branch names at position pos
7074 # returns the number of names inserted
7075 proc appendrefs {pos ids var} {
7076 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7078 if {[catch {$ctext index $pos}]} {
7079 return 0
7081 $ctext conf -state normal
7082 $ctext delete $pos "$pos lineend"
7083 set tags {}
7084 foreach id $ids {
7085 foreach tag [set $var\($id\)] {
7086 lappend tags [list $tag $id]
7090 set sep {}
7091 set tags [lsort -index 0 -decreasing $tags]
7092 set nutags 0
7094 if {[llength $tags] > $maxrefs} {
7095 # If we are displaying heads, and there are too many,
7096 # see if there are some important heads to display.
7097 # Currently that are the current head and heads listed in $visiblerefs option
7098 set itags {}
7099 if {$var eq "idheads"} {
7100 set utags {}
7101 foreach ti $tags {
7102 set hname [lindex $ti 0]
7103 set id [lindex $ti 1]
7104 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7105 [llength $itags] < $maxrefs} {
7106 lappend itags $ti
7107 } else {
7108 lappend utags $ti
7111 set tags $utags
7113 if {$itags ne {}} {
7114 set str [mc "and many more"]
7115 set sep " "
7116 } else {
7117 set str [mc "many"]
7119 $ctext insert $pos "$str ([llength $tags])"
7120 set nutags [llength $tags]
7121 set tags $itags
7124 foreach ti $tags {
7125 set id [lindex $ti 1]
7126 set lk link$linknum
7127 incr linknum
7128 $ctext tag delete $lk
7129 $ctext insert $pos $sep
7130 $ctext insert $pos [lindex $ti 0] $lk
7131 setlink $id $lk
7132 set sep ", "
7134 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7135 $ctext conf -state disabled
7136 return [expr {[llength $tags] + $nutags}]
7139 # called when we have finished computing the nearby tags
7140 proc dispneartags {delay} {
7141 global selectedline currentid showneartags tagphase
7143 if {$selectedline eq {} || !$showneartags} return
7144 after cancel dispnexttag
7145 if {$delay} {
7146 after 200 dispnexttag
7147 set tagphase -1
7148 } else {
7149 after idle dispnexttag
7150 set tagphase 0
7154 proc dispnexttag {} {
7155 global selectedline currentid showneartags tagphase ctext
7157 if {$selectedline eq {} || !$showneartags} return
7158 switch -- $tagphase {
7160 set dtags [desctags $currentid]
7161 if {$dtags ne {}} {
7162 appendrefs precedes $dtags idtags
7166 set atags [anctags $currentid]
7167 if {$atags ne {}} {
7168 appendrefs follows $atags idtags
7172 set dheads [descheads $currentid]
7173 if {$dheads ne {}} {
7174 if {[appendrefs branch $dheads idheads] > 1
7175 && [$ctext get "branch -3c"] eq "h"} {
7176 # turn "Branch" into "Branches"
7177 $ctext conf -state normal
7178 $ctext insert "branch -2c" "es"
7179 $ctext conf -state disabled
7184 if {[incr tagphase] <= 2} {
7185 after idle dispnexttag
7189 proc make_secsel {id} {
7190 global linehtag linentag linedtag canv canv2 canv3
7192 if {![info exists linehtag($id)]} return
7193 $canv delete secsel
7194 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7195 -tags secsel -fill [$canv cget -selectbackground]]
7196 $canv lower $t
7197 $canv2 delete secsel
7198 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7199 -tags secsel -fill [$canv2 cget -selectbackground]]
7200 $canv2 lower $t
7201 $canv3 delete secsel
7202 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7203 -tags secsel -fill [$canv3 cget -selectbackground]]
7204 $canv3 lower $t
7207 proc make_idmark {id} {
7208 global linehtag canv fgcolor
7210 if {![info exists linehtag($id)]} return
7211 $canv delete markid
7212 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7213 -tags markid -outline $fgcolor]
7214 $canv raise $t
7217 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7218 global canv ctext commitinfo selectedline
7219 global canvy0 linespc parents children curview
7220 global currentid sha1entry
7221 global commentend idtags linknum
7222 global mergemax numcommits pending_select
7223 global cmitmode showneartags allcommits
7224 global targetrow targetid lastscrollrows
7225 global autoselect autosellen jump_to_here
7226 global vinlinediff
7228 catch {unset pending_select}
7229 $canv delete hover
7230 normalline
7231 unsel_reflist
7232 stopfinding
7233 if {$l < 0 || $l >= $numcommits} return
7234 set id [commitonrow $l]
7235 set targetid $id
7236 set targetrow $l
7237 set selectedline $l
7238 set currentid $id
7239 if {$lastscrollrows < $numcommits} {
7240 setcanvscroll
7243 if {$cmitmode ne "patch" && $switch_to_patch} {
7244 set cmitmode "patch"
7247 set y [expr {$canvy0 + $l * $linespc}]
7248 set ymax [lindex [$canv cget -scrollregion] 3]
7249 set ytop [expr {$y - $linespc - 1}]
7250 set ybot [expr {$y + $linespc + 1}]
7251 set wnow [$canv yview]
7252 set wtop [expr {[lindex $wnow 0] * $ymax}]
7253 set wbot [expr {[lindex $wnow 1] * $ymax}]
7254 set wh [expr {$wbot - $wtop}]
7255 set newtop $wtop
7256 if {$ytop < $wtop} {
7257 if {$ybot < $wtop} {
7258 set newtop [expr {$y - $wh / 2.0}]
7259 } else {
7260 set newtop $ytop
7261 if {$newtop > $wtop - $linespc} {
7262 set newtop [expr {$wtop - $linespc}]
7265 } elseif {$ybot > $wbot} {
7266 if {$ytop > $wbot} {
7267 set newtop [expr {$y - $wh / 2.0}]
7268 } else {
7269 set newtop [expr {$ybot - $wh}]
7270 if {$newtop < $wtop + $linespc} {
7271 set newtop [expr {$wtop + $linespc}]
7275 if {$newtop != $wtop} {
7276 if {$newtop < 0} {
7277 set newtop 0
7279 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7280 drawvisible
7283 make_secsel $id
7285 if {$isnew} {
7286 addtohistory [list selbyid $id 0] savecmitpos
7289 $sha1entry delete 0 end
7290 $sha1entry insert 0 $id
7291 if {$autoselect} {
7292 $sha1entry selection range 0 $autosellen
7294 rhighlight_sel $id
7296 $ctext conf -state normal
7297 clear_ctext
7298 set linknum 0
7299 if {![info exists commitinfo($id)]} {
7300 getcommit $id
7302 set info $commitinfo($id)
7303 set date [formatdate [lindex $info 2]]
7304 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7305 set date [formatdate [lindex $info 4]]
7306 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7307 if {[info exists idtags($id)]} {
7308 $ctext insert end [mc "Tags:"]
7309 foreach tag $idtags($id) {
7310 $ctext insert end " $tag"
7312 $ctext insert end "\n"
7315 set headers {}
7316 set olds $parents($curview,$id)
7317 if {[llength $olds] > 1} {
7318 set np 0
7319 foreach p $olds {
7320 if {$np >= $mergemax} {
7321 set tag mmax
7322 } else {
7323 set tag m$np
7325 $ctext insert end "[mc "Parent"]: " $tag
7326 appendwithlinks [commit_descriptor $p] {}
7327 incr np
7329 } else {
7330 foreach p $olds {
7331 append headers "[mc "Parent"]: [commit_descriptor $p]"
7335 foreach c $children($curview,$id) {
7336 append headers "[mc "Child"]: [commit_descriptor $c]"
7339 # make anything that looks like a SHA1 ID be a clickable link
7340 appendwithlinks $headers {}
7341 if {$showneartags} {
7342 if {![info exists allcommits]} {
7343 getallcommits
7345 $ctext insert end "[mc "Branch"]: "
7346 $ctext mark set branch "end -1c"
7347 $ctext mark gravity branch left
7348 $ctext insert end "\n[mc "Follows"]: "
7349 $ctext mark set follows "end -1c"
7350 $ctext mark gravity follows left
7351 $ctext insert end "\n[mc "Precedes"]: "
7352 $ctext mark set precedes "end -1c"
7353 $ctext mark gravity precedes left
7354 $ctext insert end "\n"
7355 dispneartags 1
7357 $ctext insert end "\n"
7358 set comment [lindex $info 5]
7359 if {[string first "\r" $comment] >= 0} {
7360 set comment [string map {"\r" "\n "} $comment]
7362 appendwithlinks $comment {comment}
7364 $ctext tag remove found 1.0 end
7365 $ctext conf -state disabled
7366 set commentend [$ctext index "end - 1c"]
7368 set jump_to_here $desired_loc
7369 init_flist [mc "Comments"]
7370 if {$cmitmode eq "tree"} {
7371 gettree $id
7372 } elseif {$vinlinediff($curview) == 1} {
7373 showinlinediff $id
7374 } elseif {[llength $olds] <= 1} {
7375 startdiff $id
7376 } else {
7377 mergediff $id
7381 proc selfirstline {} {
7382 unmarkmatches
7383 selectline 0 1
7386 proc sellastline {} {
7387 global numcommits
7388 unmarkmatches
7389 set l [expr {$numcommits - 1}]
7390 selectline $l 1
7393 proc selnextline {dir} {
7394 global selectedline
7395 focus .
7396 if {$selectedline eq {}} return
7397 set l [expr {$selectedline + $dir}]
7398 unmarkmatches
7399 selectline $l 1
7402 proc selnextpage {dir} {
7403 global canv linespc selectedline numcommits
7405 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7406 if {$lpp < 1} {
7407 set lpp 1
7409 allcanvs yview scroll [expr {$dir * $lpp}] units
7410 drawvisible
7411 if {$selectedline eq {}} return
7412 set l [expr {$selectedline + $dir * $lpp}]
7413 if {$l < 0} {
7414 set l 0
7415 } elseif {$l >= $numcommits} {
7416 set l [expr $numcommits - 1]
7418 unmarkmatches
7419 selectline $l 1
7422 proc unselectline {} {
7423 global selectedline currentid
7425 set selectedline {}
7426 catch {unset currentid}
7427 allcanvs delete secsel
7428 rhighlight_none
7431 proc reselectline {} {
7432 global selectedline
7434 if {$selectedline ne {}} {
7435 selectline $selectedline 0
7439 proc addtohistory {cmd {saveproc {}}} {
7440 global history historyindex curview
7442 unset_posvars
7443 save_position
7444 set elt [list $curview $cmd $saveproc {}]
7445 if {$historyindex > 0
7446 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7447 return
7450 if {$historyindex < [llength $history]} {
7451 set history [lreplace $history $historyindex end $elt]
7452 } else {
7453 lappend history $elt
7455 incr historyindex
7456 if {$historyindex > 1} {
7457 .tf.bar.leftbut conf -state normal
7458 } else {
7459 .tf.bar.leftbut conf -state disabled
7461 .tf.bar.rightbut conf -state disabled
7464 # save the scrolling position of the diff display pane
7465 proc save_position {} {
7466 global historyindex history
7468 if {$historyindex < 1} return
7469 set hi [expr {$historyindex - 1}]
7470 set fn [lindex $history $hi 2]
7471 if {$fn ne {}} {
7472 lset history $hi 3 [eval $fn]
7476 proc unset_posvars {} {
7477 global last_posvars
7479 if {[info exists last_posvars]} {
7480 foreach {var val} $last_posvars {
7481 global $var
7482 catch {unset $var}
7484 unset last_posvars
7488 proc godo {elt} {
7489 global curview last_posvars
7491 set view [lindex $elt 0]
7492 set cmd [lindex $elt 1]
7493 set pv [lindex $elt 3]
7494 if {$curview != $view} {
7495 showview $view
7497 unset_posvars
7498 foreach {var val} $pv {
7499 global $var
7500 set $var $val
7502 set last_posvars $pv
7503 eval $cmd
7506 proc goback {} {
7507 global history historyindex
7508 focus .
7510 if {$historyindex > 1} {
7511 save_position
7512 incr historyindex -1
7513 godo [lindex $history [expr {$historyindex - 1}]]
7514 .tf.bar.rightbut conf -state normal
7516 if {$historyindex <= 1} {
7517 .tf.bar.leftbut conf -state disabled
7521 proc goforw {} {
7522 global history historyindex
7523 focus .
7525 if {$historyindex < [llength $history]} {
7526 save_position
7527 set cmd [lindex $history $historyindex]
7528 incr historyindex
7529 godo $cmd
7530 .tf.bar.leftbut conf -state normal
7532 if {$historyindex >= [llength $history]} {
7533 .tf.bar.rightbut conf -state disabled
7537 proc go_to_parent {i} {
7538 global parents curview targetid
7539 set ps $parents($curview,$targetid)
7540 if {[llength $ps] >= $i} {
7541 selbyid [lindex $ps [expr $i - 1]]
7545 proc gettree {id} {
7546 global treefilelist treeidlist diffids diffmergeid treepending
7547 global nullid nullid2
7549 set diffids $id
7550 catch {unset diffmergeid}
7551 if {![info exists treefilelist($id)]} {
7552 if {![info exists treepending]} {
7553 if {$id eq $nullid} {
7554 set cmd [list | git ls-files]
7555 } elseif {$id eq $nullid2} {
7556 set cmd [list | git ls-files --stage -t]
7557 } else {
7558 set cmd [list | git ls-tree -r $id]
7560 if {[catch {set gtf [open $cmd r]}]} {
7561 return
7563 set treepending $id
7564 set treefilelist($id) {}
7565 set treeidlist($id) {}
7566 fconfigure $gtf -blocking 0 -encoding binary
7567 filerun $gtf [list gettreeline $gtf $id]
7569 } else {
7570 setfilelist $id
7574 proc gettreeline {gtf id} {
7575 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7577 set nl 0
7578 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7579 if {$diffids eq $nullid} {
7580 set fname $line
7581 } else {
7582 set i [string first "\t" $line]
7583 if {$i < 0} continue
7584 set fname [string range $line [expr {$i+1}] end]
7585 set line [string range $line 0 [expr {$i-1}]]
7586 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7587 set sha1 [lindex $line 2]
7588 lappend treeidlist($id) $sha1
7590 if {[string index $fname 0] eq "\""} {
7591 set fname [lindex $fname 0]
7593 set fname [encoding convertfrom $fname]
7594 lappend treefilelist($id) $fname
7596 if {![eof $gtf]} {
7597 return [expr {$nl >= 1000? 2: 1}]
7599 close $gtf
7600 unset treepending
7601 if {$cmitmode ne "tree"} {
7602 if {![info exists diffmergeid]} {
7603 gettreediffs $diffids
7605 } elseif {$id ne $diffids} {
7606 gettree $diffids
7607 } else {
7608 setfilelist $id
7610 return 0
7613 proc showfile {f} {
7614 global treefilelist treeidlist diffids nullid nullid2
7615 global ctext_file_names ctext_file_lines
7616 global ctext commentend
7618 set i [lsearch -exact $treefilelist($diffids) $f]
7619 if {$i < 0} {
7620 puts "oops, $f not in list for id $diffids"
7621 return
7623 if {$diffids eq $nullid} {
7624 if {[catch {set bf [open $f r]} err]} {
7625 puts "oops, can't read $f: $err"
7626 return
7628 } else {
7629 set blob [lindex $treeidlist($diffids) $i]
7630 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7631 puts "oops, error reading blob $blob: $err"
7632 return
7635 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7636 filerun $bf [list getblobline $bf $diffids]
7637 $ctext config -state normal
7638 clear_ctext $commentend
7639 lappend ctext_file_names $f
7640 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7641 $ctext insert end "\n"
7642 $ctext insert end "$f\n" filesep
7643 $ctext config -state disabled
7644 $ctext yview $commentend
7645 settabs 0
7648 proc getblobline {bf id} {
7649 global diffids cmitmode ctext
7651 if {$id ne $diffids || $cmitmode ne "tree"} {
7652 catch {close $bf}
7653 return 0
7655 $ctext config -state normal
7656 set nl 0
7657 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7658 $ctext insert end "$line\n"
7660 if {[eof $bf]} {
7661 global jump_to_here ctext_file_names commentend
7663 # delete last newline
7664 $ctext delete "end - 2c" "end - 1c"
7665 close $bf
7666 if {$jump_to_here ne {} &&
7667 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7668 set lnum [expr {[lindex $jump_to_here 1] +
7669 [lindex [split $commentend .] 0]}]
7670 mark_ctext_line $lnum
7672 $ctext config -state disabled
7673 return 0
7675 $ctext config -state disabled
7676 return [expr {$nl >= 1000? 2: 1}]
7679 proc mark_ctext_line {lnum} {
7680 global ctext markbgcolor
7682 $ctext tag delete omark
7683 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7684 $ctext tag conf omark -background $markbgcolor
7685 $ctext see $lnum.0
7688 proc mergediff {id} {
7689 global diffmergeid
7690 global diffids treediffs
7691 global parents curview
7693 set diffmergeid $id
7694 set diffids $id
7695 set treediffs($id) {}
7696 set np [llength $parents($curview,$id)]
7697 settabs $np
7698 getblobdiffs $id
7701 proc startdiff {ids} {
7702 global treediffs diffids treepending diffmergeid nullid nullid2
7704 settabs 1
7705 set diffids $ids
7706 catch {unset diffmergeid}
7707 if {![info exists treediffs($ids)] ||
7708 [lsearch -exact $ids $nullid] >= 0 ||
7709 [lsearch -exact $ids $nullid2] >= 0} {
7710 if {![info exists treepending]} {
7711 gettreediffs $ids
7713 } else {
7714 addtocflist $ids
7718 proc showinlinediff {ids} {
7719 global commitinfo commitdata ctext
7720 global treediffs
7722 set info $commitinfo($ids)
7723 set diff [lindex $info 7]
7724 set difflines [split $diff "\n"]
7726 initblobdiffvars
7727 set treediff {}
7729 set inhdr 0
7730 foreach line $difflines {
7731 if {![string compare -length 5 "diff " $line]} {
7732 set inhdr 1
7733 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7734 # offset also accounts for the b/ prefix
7735 lappend treediff [string range $line 6 end]
7736 set inhdr 0
7740 set treediffs($ids) $treediff
7741 add_flist $treediff
7743 $ctext conf -state normal
7744 foreach line $difflines {
7745 parseblobdiffline $ids $line
7747 maybe_scroll_ctext 1
7748 $ctext conf -state disabled
7751 # If the filename (name) is under any of the passed filter paths
7752 # then return true to include the file in the listing.
7753 proc path_filter {filter name} {
7754 set worktree [gitworktree]
7755 foreach p $filter {
7756 set fq_p [file normalize $p]
7757 set fq_n [file normalize [file join $worktree $name]]
7758 if {[string match [file normalize $fq_p]* $fq_n]} {
7759 return 1
7762 return 0
7765 proc addtocflist {ids} {
7766 global treediffs
7768 add_flist $treediffs($ids)
7769 getblobdiffs $ids
7772 proc diffcmd {ids flags} {
7773 global log_showroot nullid nullid2 git_version
7775 set i [lsearch -exact $ids $nullid]
7776 set j [lsearch -exact $ids $nullid2]
7777 if {$i >= 0} {
7778 if {[llength $ids] > 1 && $j < 0} {
7779 # comparing working directory with some specific revision
7780 set cmd [concat | git diff-index $flags]
7781 if {$i == 0} {
7782 lappend cmd -R [lindex $ids 1]
7783 } else {
7784 lappend cmd [lindex $ids 0]
7786 } else {
7787 # comparing working directory with index
7788 set cmd [concat | git diff-files $flags]
7789 if {$j == 1} {
7790 lappend cmd -R
7793 } elseif {$j >= 0} {
7794 if {[package vcompare $git_version "1.7.2"] >= 0} {
7795 set flags "$flags --ignore-submodules=dirty"
7797 set cmd [concat | git diff-index --cached $flags]
7798 if {[llength $ids] > 1} {
7799 # comparing index with specific revision
7800 if {$j == 0} {
7801 lappend cmd -R [lindex $ids 1]
7802 } else {
7803 lappend cmd [lindex $ids 0]
7805 } else {
7806 # comparing index with HEAD
7807 lappend cmd HEAD
7809 } else {
7810 if {$log_showroot} {
7811 lappend flags --root
7813 set cmd [concat | git diff-tree -r $flags $ids]
7815 return $cmd
7818 proc gettreediffs {ids} {
7819 global treediff treepending limitdiffs vfilelimit curview
7821 set cmd [diffcmd $ids {--no-commit-id}]
7822 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7823 set cmd [concat $cmd -- $vfilelimit($curview)]
7825 if {[catch {set gdtf [open $cmd r]}]} return
7827 set treepending $ids
7828 set treediff {}
7829 fconfigure $gdtf -blocking 0 -encoding binary
7830 filerun $gdtf [list gettreediffline $gdtf $ids]
7833 proc gettreediffline {gdtf ids} {
7834 global treediff treediffs treepending diffids diffmergeid
7835 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7837 set nr 0
7838 set sublist {}
7839 set max 1000
7840 if {$perfile_attrs} {
7841 # cache_gitattr is slow, and even slower on win32 where we
7842 # have to invoke it for only about 30 paths at a time
7843 set max 500
7844 if {[tk windowingsystem] == "win32"} {
7845 set max 120
7848 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7849 set i [string first "\t" $line]
7850 if {$i >= 0} {
7851 set file [string range $line [expr {$i+1}] end]
7852 if {[string index $file 0] eq "\""} {
7853 set file [lindex $file 0]
7855 set file [encoding convertfrom $file]
7856 if {$file ne [lindex $treediff end]} {
7857 lappend treediff $file
7858 lappend sublist $file
7862 if {$perfile_attrs} {
7863 cache_gitattr encoding $sublist
7865 if {![eof $gdtf]} {
7866 return [expr {$nr >= $max? 2: 1}]
7868 close $gdtf
7869 set treediffs($ids) $treediff
7870 unset treepending
7871 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7872 gettree $diffids
7873 } elseif {$ids != $diffids} {
7874 if {![info exists diffmergeid]} {
7875 gettreediffs $diffids
7877 } else {
7878 addtocflist $ids
7880 return 0
7883 # empty string or positive integer
7884 proc diffcontextvalidate {v} {
7885 return [regexp {^(|[1-9][0-9]*)$} $v]
7888 proc diffcontextchange {n1 n2 op} {
7889 global diffcontextstring diffcontext
7891 if {[string is integer -strict $diffcontextstring]} {
7892 if {$diffcontextstring >= 0} {
7893 set diffcontext $diffcontextstring
7894 reselectline
7899 proc changeignorespace {} {
7900 reselectline
7903 proc changeworddiff {name ix op} {
7904 reselectline
7907 proc initblobdiffvars {} {
7908 global diffencoding targetline diffnparents
7909 global diffinhdr currdiffsubmod diffseehere
7910 set targetline {}
7911 set diffnparents 0
7912 set diffinhdr 0
7913 set diffencoding [get_path_encoding {}]
7914 set currdiffsubmod ""
7915 set diffseehere -1
7918 proc getblobdiffs {ids} {
7919 global blobdifffd diffids env
7920 global treediffs
7921 global diffcontext
7922 global ignorespace
7923 global worddiff
7924 global limitdiffs vfilelimit curview
7925 global git_version
7927 set textconv {}
7928 if {[package vcompare $git_version "1.6.1"] >= 0} {
7929 set textconv "--textconv"
7931 set submodule {}
7932 if {[package vcompare $git_version "1.6.6"] >= 0} {
7933 set submodule "--submodule"
7935 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7936 if {$ignorespace} {
7937 append cmd " -w"
7939 if {$worddiff ne [mc "Line diff"]} {
7940 append cmd " --word-diff=porcelain"
7942 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7943 set cmd [concat $cmd -- $vfilelimit($curview)]
7945 if {[catch {set bdf [open $cmd r]} err]} {
7946 error_popup [mc "Error getting diffs: %s" $err]
7947 return
7949 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7950 set blobdifffd($ids) $bdf
7951 initblobdiffvars
7952 filerun $bdf [list getblobdiffline $bdf $diffids]
7955 proc savecmitpos {} {
7956 global ctext cmitmode
7958 if {$cmitmode eq "tree"} {
7959 return {}
7961 return [list target_scrollpos [$ctext index @0,0]]
7964 proc savectextpos {} {
7965 global ctext
7967 return [list target_scrollpos [$ctext index @0,0]]
7970 proc maybe_scroll_ctext {ateof} {
7971 global ctext target_scrollpos
7973 if {![info exists target_scrollpos]} return
7974 if {!$ateof} {
7975 set nlines [expr {[winfo height $ctext]
7976 / [font metrics textfont -linespace]}]
7977 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7979 $ctext yview $target_scrollpos
7980 unset target_scrollpos
7983 proc setinlist {var i val} {
7984 global $var
7986 while {[llength [set $var]] < $i} {
7987 lappend $var {}
7989 if {[llength [set $var]] == $i} {
7990 lappend $var $val
7991 } else {
7992 lset $var $i $val
7996 proc makediffhdr {fname ids} {
7997 global ctext curdiffstart treediffs diffencoding
7998 global ctext_file_names jump_to_here targetline diffline
8000 set fname [encoding convertfrom $fname]
8001 set diffencoding [get_path_encoding $fname]
8002 set i [lsearch -exact $treediffs($ids) $fname]
8003 if {$i >= 0} {
8004 setinlist difffilestart $i $curdiffstart
8006 lset ctext_file_names end $fname
8007 set l [expr {(78 - [string length $fname]) / 2}]
8008 set pad [string range "----------------------------------------" 1 $l]
8009 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8010 set targetline {}
8011 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8012 set targetline [lindex $jump_to_here 1]
8014 set diffline 0
8017 proc blobdiffmaybeseehere {ateof} {
8018 global diffseehere
8019 if {$diffseehere >= 0} {
8020 mark_ctext_line [lindex [split $diffseehere .] 0]
8022 maybe_scroll_ctext $ateof
8025 proc getblobdiffline {bdf ids} {
8026 global diffids blobdifffd
8027 global ctext
8029 set nr 0
8030 $ctext conf -state normal
8031 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8032 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8033 catch {close $bdf}
8034 return 0
8036 parseblobdiffline $ids $line
8038 $ctext conf -state disabled
8039 blobdiffmaybeseehere [eof $bdf]
8040 if {[eof $bdf]} {
8041 catch {close $bdf}
8042 return 0
8044 return [expr {$nr >= 1000? 2: 1}]
8047 proc parseblobdiffline {ids line} {
8048 global ctext curdiffstart
8049 global diffnexthead diffnextnote difffilestart
8050 global ctext_file_names ctext_file_lines
8051 global diffinhdr treediffs mergemax diffnparents
8052 global diffencoding jump_to_here targetline diffline currdiffsubmod
8053 global worddiff diffseehere
8055 if {![string compare -length 5 "diff " $line]} {
8056 if {![regexp {^diff (--cc|--git) } $line m type]} {
8057 set line [encoding convertfrom $line]
8058 $ctext insert end "$line\n" hunksep
8059 continue
8061 # start of a new file
8062 set diffinhdr 1
8063 $ctext insert end "\n"
8064 set curdiffstart [$ctext index "end - 1c"]
8065 lappend ctext_file_names ""
8066 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8067 $ctext insert end "\n" filesep
8069 if {$type eq "--cc"} {
8070 # start of a new file in a merge diff
8071 set fname [string range $line 10 end]
8072 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8073 lappend treediffs($ids) $fname
8074 add_flist [list $fname]
8077 } else {
8078 set line [string range $line 11 end]
8079 # If the name hasn't changed the length will be odd,
8080 # the middle char will be a space, and the two bits either
8081 # side will be a/name and b/name, or "a/name" and "b/name".
8082 # If the name has changed we'll get "rename from" and
8083 # "rename to" or "copy from" and "copy to" lines following
8084 # this, and we'll use them to get the filenames.
8085 # This complexity is necessary because spaces in the
8086 # filename(s) don't get escaped.
8087 set l [string length $line]
8088 set i [expr {$l / 2}]
8089 if {!(($l & 1) && [string index $line $i] eq " " &&
8090 [string range $line 2 [expr {$i - 1}]] eq \
8091 [string range $line [expr {$i + 3}] end])} {
8092 return
8094 # unescape if quoted and chop off the a/ from the front
8095 if {[string index $line 0] eq "\""} {
8096 set fname [string range [lindex $line 0] 2 end]
8097 } else {
8098 set fname [string range $line 2 [expr {$i - 1}]]
8101 makediffhdr $fname $ids
8103 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8104 set fname [encoding convertfrom [string range $line 16 end]]
8105 $ctext insert end "\n"
8106 set curdiffstart [$ctext index "end - 1c"]
8107 lappend ctext_file_names $fname
8108 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8109 $ctext insert end "$line\n" filesep
8110 set i [lsearch -exact $treediffs($ids) $fname]
8111 if {$i >= 0} {
8112 setinlist difffilestart $i $curdiffstart
8115 } elseif {![string compare -length 2 "@@" $line]} {
8116 regexp {^@@+} $line ats
8117 set line [encoding convertfrom $diffencoding $line]
8118 $ctext insert end "$line\n" hunksep
8119 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8120 set diffline $nl
8122 set diffnparents [expr {[string length $ats] - 1}]
8123 set diffinhdr 0
8125 } elseif {![string compare -length 10 "Submodule " $line]} {
8126 # start of a new submodule
8127 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8128 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8129 } else {
8130 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8132 if {$currdiffsubmod != $fname} {
8133 $ctext insert end "\n"; # Add newline after commit message
8135 set curdiffstart [$ctext index "end - 1c"]
8136 lappend ctext_file_names ""
8137 if {$currdiffsubmod != $fname} {
8138 lappend ctext_file_lines $fname
8139 makediffhdr $fname $ids
8140 set currdiffsubmod $fname
8141 $ctext insert end "\n$line\n" filesep
8142 } else {
8143 $ctext insert end "$line\n" filesep
8145 } elseif {![string compare -length 3 " >" $line]} {
8146 set $currdiffsubmod ""
8147 set line [encoding convertfrom $diffencoding $line]
8148 $ctext insert end "$line\n" dresult
8149 } elseif {![string compare -length 3 " <" $line]} {
8150 set $currdiffsubmod ""
8151 set line [encoding convertfrom $diffencoding $line]
8152 $ctext insert end "$line\n" d0
8153 } elseif {$diffinhdr} {
8154 if {![string compare -length 12 "rename from " $line]} {
8155 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8156 if {[string index $fname 0] eq "\""} {
8157 set fname [lindex $fname 0]
8159 set fname [encoding convertfrom $fname]
8160 set i [lsearch -exact $treediffs($ids) $fname]
8161 if {$i >= 0} {
8162 setinlist difffilestart $i $curdiffstart
8164 } elseif {![string compare -length 10 $line "rename to "] ||
8165 ![string compare -length 8 $line "copy to "]} {
8166 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8167 if {[string index $fname 0] eq "\""} {
8168 set fname [lindex $fname 0]
8170 makediffhdr $fname $ids
8171 } elseif {[string compare -length 3 $line "---"] == 0} {
8172 # do nothing
8173 return
8174 } elseif {[string compare -length 3 $line "+++"] == 0} {
8175 set diffinhdr 0
8176 return
8178 $ctext insert end "$line\n" filesep
8180 } else {
8181 set line [string map {\x1A ^Z} \
8182 [encoding convertfrom $diffencoding $line]]
8183 # parse the prefix - one ' ', '-' or '+' for each parent
8184 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8185 set tag [expr {$diffnparents > 1? "m": "d"}]
8186 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8187 set words_pre_markup ""
8188 set words_post_markup ""
8189 if {[string trim $prefix " -+"] eq {}} {
8190 # prefix only has " ", "-" and "+" in it: normal diff line
8191 set num [string first "-" $prefix]
8192 if {$dowords} {
8193 set line [string range $line 1 end]
8195 if {$num >= 0} {
8196 # removed line, first parent with line is $num
8197 if {$num >= $mergemax} {
8198 set num "max"
8200 if {$dowords && $worddiff eq [mc "Markup words"]} {
8201 $ctext insert end "\[-$line-\]" $tag$num
8202 } else {
8203 $ctext insert end "$line" $tag$num
8205 if {!$dowords} {
8206 $ctext insert end "\n" $tag$num
8208 } else {
8209 set tags {}
8210 if {[string first "+" $prefix] >= 0} {
8211 # added line
8212 lappend tags ${tag}result
8213 if {$diffnparents > 1} {
8214 set num [string first " " $prefix]
8215 if {$num >= 0} {
8216 if {$num >= $mergemax} {
8217 set num "max"
8219 lappend tags m$num
8222 set words_pre_markup "{+"
8223 set words_post_markup "+}"
8225 if {$targetline ne {}} {
8226 if {$diffline == $targetline} {
8227 set diffseehere [$ctext index "end - 1 chars"]
8228 set targetline {}
8229 } else {
8230 incr diffline
8233 if {$dowords && $worddiff eq [mc "Markup words"]} {
8234 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8235 } else {
8236 $ctext insert end "$line" $tags
8238 if {!$dowords} {
8239 $ctext insert end "\n" $tags
8242 } elseif {$dowords && $prefix eq "~"} {
8243 $ctext insert end "\n" {}
8244 } else {
8245 # "\ No newline at end of file",
8246 # or something else we don't recognize
8247 $ctext insert end "$line\n" hunksep
8252 proc changediffdisp {} {
8253 global ctext diffelide
8255 $ctext tag conf d0 -elide [lindex $diffelide 0]
8256 $ctext tag conf dresult -elide [lindex $diffelide 1]
8259 proc highlightfile {cline} {
8260 global cflist cflist_top
8262 if {![info exists cflist_top]} return
8264 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8265 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8266 $cflist see $cline.0
8267 set cflist_top $cline
8270 proc highlightfile_for_scrollpos {topidx} {
8271 global cmitmode difffilestart
8273 if {$cmitmode eq "tree"} return
8274 if {![info exists difffilestart]} return
8276 set top [lindex [split $topidx .] 0]
8277 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8278 highlightfile 0
8279 } else {
8280 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8284 proc prevfile {} {
8285 global difffilestart ctext cmitmode
8287 if {$cmitmode eq "tree"} return
8288 set prev 0.0
8289 set here [$ctext index @0,0]
8290 foreach loc $difffilestart {
8291 if {[$ctext compare $loc >= $here]} {
8292 $ctext yview $prev
8293 return
8295 set prev $loc
8297 $ctext yview $prev
8300 proc nextfile {} {
8301 global difffilestart ctext cmitmode
8303 if {$cmitmode eq "tree"} return
8304 set here [$ctext index @0,0]
8305 foreach loc $difffilestart {
8306 if {[$ctext compare $loc > $here]} {
8307 $ctext yview $loc
8308 return
8313 proc clear_ctext {{first 1.0}} {
8314 global ctext smarktop smarkbot
8315 global ctext_file_names ctext_file_lines
8316 global pendinglinks
8318 set l [lindex [split $first .] 0]
8319 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8320 set smarktop $l
8322 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8323 set smarkbot $l
8325 $ctext delete $first end
8326 if {$first eq "1.0"} {
8327 catch {unset pendinglinks}
8329 set ctext_file_names {}
8330 set ctext_file_lines {}
8333 proc settabs {{firstab {}}} {
8334 global firsttabstop tabstop ctext have_tk85
8336 if {$firstab ne {} && $have_tk85} {
8337 set firsttabstop $firstab
8339 set w [font measure textfont "0"]
8340 if {$firsttabstop != 0} {
8341 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8342 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8343 } elseif {$have_tk85 || $tabstop != 8} {
8344 $ctext conf -tabs [expr {$tabstop * $w}]
8345 } else {
8346 $ctext conf -tabs {}
8350 proc incrsearch {name ix op} {
8351 global ctext searchstring searchdirn
8353 if {[catch {$ctext index anchor}]} {
8354 # no anchor set, use start of selection, or of visible area
8355 set sel [$ctext tag ranges sel]
8356 if {$sel ne {}} {
8357 $ctext mark set anchor [lindex $sel 0]
8358 } elseif {$searchdirn eq "-forwards"} {
8359 $ctext mark set anchor @0,0
8360 } else {
8361 $ctext mark set anchor @0,[winfo height $ctext]
8364 if {$searchstring ne {}} {
8365 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8366 if {$here ne {}} {
8367 $ctext see $here
8368 set mend "$here + $mlen c"
8369 $ctext tag remove sel 1.0 end
8370 $ctext tag add sel $here $mend
8371 suppress_highlighting_file_for_current_scrollpos
8372 highlightfile_for_scrollpos $here
8375 rehighlight_search_results
8378 proc dosearch {} {
8379 global sstring ctext searchstring searchdirn
8381 focus $sstring
8382 $sstring icursor end
8383 set searchdirn -forwards
8384 if {$searchstring ne {}} {
8385 set sel [$ctext tag ranges sel]
8386 if {$sel ne {}} {
8387 set start "[lindex $sel 0] + 1c"
8388 } elseif {[catch {set start [$ctext index anchor]}]} {
8389 set start "@0,0"
8391 set match [$ctext search -count mlen -- $searchstring $start]
8392 $ctext tag remove sel 1.0 end
8393 if {$match eq {}} {
8394 bell
8395 return
8397 $ctext see $match
8398 suppress_highlighting_file_for_current_scrollpos
8399 highlightfile_for_scrollpos $match
8400 set mend "$match + $mlen c"
8401 $ctext tag add sel $match $mend
8402 $ctext mark unset anchor
8403 rehighlight_search_results
8407 proc dosearchback {} {
8408 global sstring ctext searchstring searchdirn
8410 focus $sstring
8411 $sstring icursor end
8412 set searchdirn -backwards
8413 if {$searchstring ne {}} {
8414 set sel [$ctext tag ranges sel]
8415 if {$sel ne {}} {
8416 set start [lindex $sel 0]
8417 } elseif {[catch {set start [$ctext index anchor]}]} {
8418 set start @0,[winfo height $ctext]
8420 set match [$ctext search -backwards -count ml -- $searchstring $start]
8421 $ctext tag remove sel 1.0 end
8422 if {$match eq {}} {
8423 bell
8424 return
8426 $ctext see $match
8427 suppress_highlighting_file_for_current_scrollpos
8428 highlightfile_for_scrollpos $match
8429 set mend "$match + $ml c"
8430 $ctext tag add sel $match $mend
8431 $ctext mark unset anchor
8432 rehighlight_search_results
8436 proc rehighlight_search_results {} {
8437 global ctext searchstring
8439 $ctext tag remove found 1.0 end
8440 $ctext tag remove currentsearchhit 1.0 end
8442 if {$searchstring ne {}} {
8443 searchmarkvisible 1
8447 proc searchmark {first last} {
8448 global ctext searchstring
8450 set sel [$ctext tag ranges sel]
8452 set mend $first.0
8453 while {1} {
8454 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8455 if {$match eq {}} break
8456 set mend "$match + $mlen c"
8457 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8458 $ctext tag add currentsearchhit $match $mend
8459 } else {
8460 $ctext tag add found $match $mend
8465 proc searchmarkvisible {doall} {
8466 global ctext smarktop smarkbot
8468 set topline [lindex [split [$ctext index @0,0] .] 0]
8469 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8470 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8471 # no overlap with previous
8472 searchmark $topline $botline
8473 set smarktop $topline
8474 set smarkbot $botline
8475 } else {
8476 if {$topline < $smarktop} {
8477 searchmark $topline [expr {$smarktop-1}]
8478 set smarktop $topline
8480 if {$botline > $smarkbot} {
8481 searchmark [expr {$smarkbot+1}] $botline
8482 set smarkbot $botline
8487 proc suppress_highlighting_file_for_current_scrollpos {} {
8488 global ctext suppress_highlighting_file_for_this_scrollpos
8490 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8493 proc scrolltext {f0 f1} {
8494 global searchstring cmitmode ctext
8495 global suppress_highlighting_file_for_this_scrollpos
8497 set topidx [$ctext index @0,0]
8498 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8499 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8500 highlightfile_for_scrollpos $topidx
8503 catch {unset suppress_highlighting_file_for_this_scrollpos}
8505 .bleft.bottom.sb set $f0 $f1
8506 if {$searchstring ne {}} {
8507 searchmarkvisible 0
8511 proc setcoords {} {
8512 global linespc charspc canvx0 canvy0
8513 global xspc1 xspc2 lthickness
8515 set linespc [font metrics mainfont -linespace]
8516 set charspc [font measure mainfont "m"]
8517 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8518 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8519 set lthickness [expr {int($linespc / 9) + 1}]
8520 set xspc1(0) $linespc
8521 set xspc2 $linespc
8524 proc redisplay {} {
8525 global canv
8526 global selectedline
8528 set ymax [lindex [$canv cget -scrollregion] 3]
8529 if {$ymax eq {} || $ymax == 0} return
8530 set span [$canv yview]
8531 clear_display
8532 setcanvscroll
8533 allcanvs yview moveto [lindex $span 0]
8534 drawvisible
8535 if {$selectedline ne {}} {
8536 selectline $selectedline 0
8537 allcanvs yview moveto [lindex $span 0]
8541 proc parsefont {f n} {
8542 global fontattr
8544 set fontattr($f,family) [lindex $n 0]
8545 set s [lindex $n 1]
8546 if {$s eq {} || $s == 0} {
8547 set s 10
8548 } elseif {$s < 0} {
8549 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8551 set fontattr($f,size) $s
8552 set fontattr($f,weight) normal
8553 set fontattr($f,slant) roman
8554 foreach style [lrange $n 2 end] {
8555 switch -- $style {
8556 "normal" -
8557 "bold" {set fontattr($f,weight) $style}
8558 "roman" -
8559 "italic" {set fontattr($f,slant) $style}
8564 proc fontflags {f {isbold 0}} {
8565 global fontattr
8567 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8568 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8569 -slant $fontattr($f,slant)]
8572 proc fontname {f} {
8573 global fontattr
8575 set n [list $fontattr($f,family) $fontattr($f,size)]
8576 if {$fontattr($f,weight) eq "bold"} {
8577 lappend n "bold"
8579 if {$fontattr($f,slant) eq "italic"} {
8580 lappend n "italic"
8582 return $n
8585 proc incrfont {inc} {
8586 global mainfont textfont ctext canv cflist showrefstop
8587 global stopped entries fontattr
8589 unmarkmatches
8590 set s $fontattr(mainfont,size)
8591 incr s $inc
8592 if {$s < 1} {
8593 set s 1
8595 set fontattr(mainfont,size) $s
8596 font config mainfont -size $s
8597 font config mainfontbold -size $s
8598 set mainfont [fontname mainfont]
8599 set s $fontattr(textfont,size)
8600 incr s $inc
8601 if {$s < 1} {
8602 set s 1
8604 set fontattr(textfont,size) $s
8605 font config textfont -size $s
8606 font config textfontbold -size $s
8607 set textfont [fontname textfont]
8608 setcoords
8609 settabs
8610 redisplay
8613 proc clearsha1 {} {
8614 global sha1entry sha1string
8615 if {[string length $sha1string] == 40} {
8616 $sha1entry delete 0 end
8620 proc sha1change {n1 n2 op} {
8621 global sha1string currentid sha1but
8622 if {$sha1string == {}
8623 || ([info exists currentid] && $sha1string == $currentid)} {
8624 set state disabled
8625 } else {
8626 set state normal
8628 if {[$sha1but cget -state] == $state} return
8629 if {$state == "normal"} {
8630 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8631 } else {
8632 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8636 proc gotocommit {} {
8637 global sha1string tagids headids curview varcid
8639 if {$sha1string == {}
8640 || ([info exists currentid] && $sha1string == $currentid)} return
8641 if {[info exists tagids($sha1string)]} {
8642 set id $tagids($sha1string)
8643 } elseif {[info exists headids($sha1string)]} {
8644 set id $headids($sha1string)
8645 } else {
8646 set id [string tolower $sha1string]
8647 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8648 set matches [longid $id]
8649 if {$matches ne {}} {
8650 if {[llength $matches] > 1} {
8651 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8652 return
8654 set id [lindex $matches 0]
8656 } else {
8657 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8658 error_popup [mc "Revision %s is not known" $sha1string]
8659 return
8663 if {[commitinview $id $curview]} {
8664 selectline [rowofcommit $id] 1
8665 return
8667 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8668 set msg [mc "SHA1 id %s is not known" $sha1string]
8669 } else {
8670 set msg [mc "Revision %s is not in the current view" $sha1string]
8672 error_popup $msg
8675 proc lineenter {x y id} {
8676 global hoverx hovery hoverid hovertimer
8677 global commitinfo canv
8679 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8680 set hoverx $x
8681 set hovery $y
8682 set hoverid $id
8683 if {[info exists hovertimer]} {
8684 after cancel $hovertimer
8686 set hovertimer [after 500 linehover]
8687 $canv delete hover
8690 proc linemotion {x y id} {
8691 global hoverx hovery hoverid hovertimer
8693 if {[info exists hoverid] && $id == $hoverid} {
8694 set hoverx $x
8695 set hovery $y
8696 if {[info exists hovertimer]} {
8697 after cancel $hovertimer
8699 set hovertimer [after 500 linehover]
8703 proc lineleave {id} {
8704 global hoverid hovertimer canv
8706 if {[info exists hoverid] && $id == $hoverid} {
8707 $canv delete hover
8708 if {[info exists hovertimer]} {
8709 after cancel $hovertimer
8710 unset hovertimer
8712 unset hoverid
8716 proc linehover {} {
8717 global hoverx hovery hoverid hovertimer
8718 global canv linespc lthickness
8719 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8721 global commitinfo
8723 set text [lindex $commitinfo($hoverid) 0]
8724 set ymax [lindex [$canv cget -scrollregion] 3]
8725 if {$ymax == {}} return
8726 set yfrac [lindex [$canv yview] 0]
8727 set x [expr {$hoverx + 2 * $linespc}]
8728 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8729 set x0 [expr {$x - 2 * $lthickness}]
8730 set y0 [expr {$y - 2 * $lthickness}]
8731 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8732 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8733 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8734 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8735 -width 1 -tags hover]
8736 $canv raise $t
8737 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8738 -font mainfont -fill $linehoverfgcolor]
8739 $canv raise $t
8742 proc clickisonarrow {id y} {
8743 global lthickness
8745 set ranges [rowranges $id]
8746 set thresh [expr {2 * $lthickness + 6}]
8747 set n [expr {[llength $ranges] - 1}]
8748 for {set i 1} {$i < $n} {incr i} {
8749 set row [lindex $ranges $i]
8750 if {abs([yc $row] - $y) < $thresh} {
8751 return $i
8754 return {}
8757 proc arrowjump {id n y} {
8758 global canv
8760 # 1 <-> 2, 3 <-> 4, etc...
8761 set n [expr {(($n - 1) ^ 1) + 1}]
8762 set row [lindex [rowranges $id] $n]
8763 set yt [yc $row]
8764 set ymax [lindex [$canv cget -scrollregion] 3]
8765 if {$ymax eq {} || $ymax <= 0} return
8766 set view [$canv yview]
8767 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8768 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8769 if {$yfrac < 0} {
8770 set yfrac 0
8772 allcanvs yview moveto $yfrac
8775 proc lineclick {x y id isnew} {
8776 global ctext commitinfo children canv thickerline curview
8778 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8779 unmarkmatches
8780 unselectline
8781 normalline
8782 $canv delete hover
8783 # draw this line thicker than normal
8784 set thickerline $id
8785 drawlines $id
8786 if {$isnew} {
8787 set ymax [lindex [$canv cget -scrollregion] 3]
8788 if {$ymax eq {}} return
8789 set yfrac [lindex [$canv yview] 0]
8790 set y [expr {$y + $yfrac * $ymax}]
8792 set dirn [clickisonarrow $id $y]
8793 if {$dirn ne {}} {
8794 arrowjump $id $dirn $y
8795 return
8798 if {$isnew} {
8799 addtohistory [list lineclick $x $y $id 0] savectextpos
8801 # fill the details pane with info about this line
8802 $ctext conf -state normal
8803 clear_ctext
8804 settabs 0
8805 $ctext insert end "[mc "Parent"]:\t"
8806 $ctext insert end $id link0
8807 setlink $id link0
8808 set info $commitinfo($id)
8809 $ctext insert end "\n\t[lindex $info 0]\n"
8810 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8811 set date [formatdate [lindex $info 2]]
8812 $ctext insert end "\t[mc "Date"]:\t$date\n"
8813 set kids $children($curview,$id)
8814 if {$kids ne {}} {
8815 $ctext insert end "\n[mc "Children"]:"
8816 set i 0
8817 foreach child $kids {
8818 incr i
8819 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8820 set info $commitinfo($child)
8821 $ctext insert end "\n\t"
8822 $ctext insert end $child link$i
8823 setlink $child link$i
8824 $ctext insert end "\n\t[lindex $info 0]"
8825 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8826 set date [formatdate [lindex $info 2]]
8827 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8830 maybe_scroll_ctext 1
8831 $ctext conf -state disabled
8832 init_flist {}
8835 proc normalline {} {
8836 global thickerline
8837 if {[info exists thickerline]} {
8838 set id $thickerline
8839 unset thickerline
8840 drawlines $id
8844 proc selbyid {id {isnew 1}} {
8845 global curview
8846 if {[commitinview $id $curview]} {
8847 selectline [rowofcommit $id] $isnew
8851 proc mstime {} {
8852 global startmstime
8853 if {![info exists startmstime]} {
8854 set startmstime [clock clicks -milliseconds]
8856 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8859 proc rowmenu {x y id} {
8860 global rowctxmenu selectedline rowmenuid curview
8861 global nullid nullid2 fakerowmenu mainhead markedid
8863 stopfinding
8864 set rowmenuid $id
8865 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8866 set state disabled
8867 } else {
8868 set state normal
8870 if {[info exists markedid] && $markedid ne $id} {
8871 set mstate normal
8872 } else {
8873 set mstate disabled
8875 if {$id ne $nullid && $id ne $nullid2} {
8876 set menu $rowctxmenu
8877 if {$mainhead ne {}} {
8878 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8879 } else {
8880 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8882 $menu entryconfigure 9 -state $mstate
8883 $menu entryconfigure 10 -state $mstate
8884 $menu entryconfigure 11 -state $mstate
8885 } else {
8886 set menu $fakerowmenu
8888 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8889 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8890 $menu entryconfigure [mca "Make patch"] -state $state
8891 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8892 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8893 tk_popup $menu $x $y
8896 proc markhere {} {
8897 global rowmenuid markedid canv
8899 set markedid $rowmenuid
8900 make_idmark $markedid
8903 proc gotomark {} {
8904 global markedid
8906 if {[info exists markedid]} {
8907 selbyid $markedid
8911 proc replace_by_kids {l r} {
8912 global curview children
8914 set id [commitonrow $r]
8915 set l [lreplace $l 0 0]
8916 foreach kid $children($curview,$id) {
8917 lappend l [rowofcommit $kid]
8919 return [lsort -integer -decreasing -unique $l]
8922 proc find_common_desc {} {
8923 global markedid rowmenuid curview children
8925 if {![info exists markedid]} return
8926 if {![commitinview $markedid $curview] ||
8927 ![commitinview $rowmenuid $curview]} return
8928 #set t1 [clock clicks -milliseconds]
8929 set l1 [list [rowofcommit $markedid]]
8930 set l2 [list [rowofcommit $rowmenuid]]
8931 while 1 {
8932 set r1 [lindex $l1 0]
8933 set r2 [lindex $l2 0]
8934 if {$r1 eq {} || $r2 eq {}} break
8935 if {$r1 == $r2} {
8936 selectline $r1 1
8937 break
8939 if {$r1 > $r2} {
8940 set l1 [replace_by_kids $l1 $r1]
8941 } else {
8942 set l2 [replace_by_kids $l2 $r2]
8945 #set t2 [clock clicks -milliseconds]
8946 #puts "took [expr {$t2-$t1}]ms"
8949 proc compare_commits {} {
8950 global markedid rowmenuid curview children
8952 if {![info exists markedid]} return
8953 if {![commitinview $markedid $curview]} return
8954 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8955 do_cmp_commits $markedid $rowmenuid
8958 proc getpatchid {id} {
8959 global patchids
8961 if {![info exists patchids($id)]} {
8962 set cmd [diffcmd [list $id] {-p --root}]
8963 # trim off the initial "|"
8964 set cmd [lrange $cmd 1 end]
8965 if {[catch {
8966 set x [eval exec $cmd | git patch-id]
8967 set patchids($id) [lindex $x 0]
8968 }]} {
8969 set patchids($id) "error"
8972 return $patchids($id)
8975 proc do_cmp_commits {a b} {
8976 global ctext curview parents children patchids commitinfo
8978 $ctext conf -state normal
8979 clear_ctext
8980 init_flist {}
8981 for {set i 0} {$i < 100} {incr i} {
8982 set skipa 0
8983 set skipb 0
8984 if {[llength $parents($curview,$a)] > 1} {
8985 appendshortlink $a [mc "Skipping merge commit "] "\n"
8986 set skipa 1
8987 } else {
8988 set patcha [getpatchid $a]
8990 if {[llength $parents($curview,$b)] > 1} {
8991 appendshortlink $b [mc "Skipping merge commit "] "\n"
8992 set skipb 1
8993 } else {
8994 set patchb [getpatchid $b]
8996 if {!$skipa && !$skipb} {
8997 set heada [lindex $commitinfo($a) 0]
8998 set headb [lindex $commitinfo($b) 0]
8999 if {$patcha eq "error"} {
9000 appendshortlink $a [mc "Error getting patch ID for "] \
9001 [mc " - stopping\n"]
9002 break
9004 if {$patchb eq "error"} {
9005 appendshortlink $b [mc "Error getting patch ID for "] \
9006 [mc " - stopping\n"]
9007 break
9009 if {$patcha eq $patchb} {
9010 if {$heada eq $headb} {
9011 appendshortlink $a [mc "Commit "]
9012 appendshortlink $b " == " " $heada\n"
9013 } else {
9014 appendshortlink $a [mc "Commit "] " $heada\n"
9015 appendshortlink $b [mc " is the same patch as\n "] \
9016 " $headb\n"
9018 set skipa 1
9019 set skipb 1
9020 } else {
9021 $ctext insert end "\n"
9022 appendshortlink $a [mc "Commit "] " $heada\n"
9023 appendshortlink $b [mc " differs from\n "] \
9024 " $headb\n"
9025 $ctext insert end [mc "Diff of commits:\n\n"]
9026 $ctext conf -state disabled
9027 update
9028 diffcommits $a $b
9029 return
9032 if {$skipa} {
9033 set kids [real_children $curview,$a]
9034 if {[llength $kids] != 1} {
9035 $ctext insert end "\n"
9036 appendshortlink $a [mc "Commit "] \
9037 [mc " has %s children - stopping\n" [llength $kids]]
9038 break
9040 set a [lindex $kids 0]
9042 if {$skipb} {
9043 set kids [real_children $curview,$b]
9044 if {[llength $kids] != 1} {
9045 appendshortlink $b [mc "Commit "] \
9046 [mc " has %s children - stopping\n" [llength $kids]]
9047 break
9049 set b [lindex $kids 0]
9052 $ctext conf -state disabled
9055 proc diffcommits {a b} {
9056 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9058 set tmpdir [gitknewtmpdir]
9059 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9060 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9061 if {[catch {
9062 exec git diff-tree -p --pretty $a >$fna
9063 exec git diff-tree -p --pretty $b >$fnb
9064 } err]} {
9065 error_popup [mc "Error writing commit to file: %s" $err]
9066 return
9068 if {[catch {
9069 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9070 } err]} {
9071 error_popup [mc "Error diffing commits: %s" $err]
9072 return
9074 set diffids [list commits $a $b]
9075 set blobdifffd($diffids) $fd
9076 set diffinhdr 0
9077 set currdiffsubmod ""
9078 filerun $fd [list getblobdiffline $fd $diffids]
9081 proc diffvssel {dirn} {
9082 global rowmenuid selectedline
9084 if {$selectedline eq {}} return
9085 if {$dirn} {
9086 set oldid [commitonrow $selectedline]
9087 set newid $rowmenuid
9088 } else {
9089 set oldid $rowmenuid
9090 set newid [commitonrow $selectedline]
9092 addtohistory [list doseldiff $oldid $newid] savectextpos
9093 doseldiff $oldid $newid
9096 proc diffvsmark {dirn} {
9097 global rowmenuid markedid
9099 if {![info exists markedid]} return
9100 if {$dirn} {
9101 set oldid $markedid
9102 set newid $rowmenuid
9103 } else {
9104 set oldid $rowmenuid
9105 set newid $markedid
9107 addtohistory [list doseldiff $oldid $newid] savectextpos
9108 doseldiff $oldid $newid
9111 proc doseldiff {oldid newid} {
9112 global ctext
9113 global commitinfo
9115 $ctext conf -state normal
9116 clear_ctext
9117 init_flist [mc "Top"]
9118 $ctext insert end "[mc "From"] "
9119 $ctext insert end $oldid link0
9120 setlink $oldid link0
9121 $ctext insert end "\n "
9122 $ctext insert end [lindex $commitinfo($oldid) 0]
9123 $ctext insert end "\n\n[mc "To"] "
9124 $ctext insert end $newid link1
9125 setlink $newid link1
9126 $ctext insert end "\n "
9127 $ctext insert end [lindex $commitinfo($newid) 0]
9128 $ctext insert end "\n"
9129 $ctext conf -state disabled
9130 $ctext tag remove found 1.0 end
9131 startdiff [list $oldid $newid]
9134 proc mkpatch {} {
9135 global rowmenuid currentid commitinfo patchtop patchnum NS
9137 if {![info exists currentid]} return
9138 set oldid $currentid
9139 set oldhead [lindex $commitinfo($oldid) 0]
9140 set newid $rowmenuid
9141 set newhead [lindex $commitinfo($newid) 0]
9142 set top .patch
9143 set patchtop $top
9144 catch {destroy $top}
9145 ttk_toplevel $top
9146 make_transient $top .
9147 ${NS}::label $top.title -text [mc "Generate patch"]
9148 grid $top.title - -pady 10
9149 ${NS}::label $top.from -text [mc "From:"]
9150 ${NS}::entry $top.fromsha1 -width 40
9151 $top.fromsha1 insert 0 $oldid
9152 $top.fromsha1 conf -state readonly
9153 grid $top.from $top.fromsha1 -sticky w
9154 ${NS}::entry $top.fromhead -width 60
9155 $top.fromhead insert 0 $oldhead
9156 $top.fromhead conf -state readonly
9157 grid x $top.fromhead -sticky w
9158 ${NS}::label $top.to -text [mc "To:"]
9159 ${NS}::entry $top.tosha1 -width 40
9160 $top.tosha1 insert 0 $newid
9161 $top.tosha1 conf -state readonly
9162 grid $top.to $top.tosha1 -sticky w
9163 ${NS}::entry $top.tohead -width 60
9164 $top.tohead insert 0 $newhead
9165 $top.tohead conf -state readonly
9166 grid x $top.tohead -sticky w
9167 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9168 grid $top.rev x -pady 10 -padx 5
9169 ${NS}::label $top.flab -text [mc "Output file:"]
9170 ${NS}::entry $top.fname -width 60
9171 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9172 incr patchnum
9173 grid $top.flab $top.fname -sticky w
9174 ${NS}::frame $top.buts
9175 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9176 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9177 bind $top <Key-Return> mkpatchgo
9178 bind $top <Key-Escape> mkpatchcan
9179 grid $top.buts.gen $top.buts.can
9180 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9181 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9182 grid $top.buts - -pady 10 -sticky ew
9183 focus $top.fname
9186 proc mkpatchrev {} {
9187 global patchtop
9189 set oldid [$patchtop.fromsha1 get]
9190 set oldhead [$patchtop.fromhead get]
9191 set newid [$patchtop.tosha1 get]
9192 set newhead [$patchtop.tohead get]
9193 foreach e [list fromsha1 fromhead tosha1 tohead] \
9194 v [list $newid $newhead $oldid $oldhead] {
9195 $patchtop.$e conf -state normal
9196 $patchtop.$e delete 0 end
9197 $patchtop.$e insert 0 $v
9198 $patchtop.$e conf -state readonly
9202 proc mkpatchgo {} {
9203 global patchtop nullid nullid2
9205 set oldid [$patchtop.fromsha1 get]
9206 set newid [$patchtop.tosha1 get]
9207 set fname [$patchtop.fname get]
9208 set cmd [diffcmd [list $oldid $newid] -p]
9209 # trim off the initial "|"
9210 set cmd [lrange $cmd 1 end]
9211 lappend cmd >$fname &
9212 if {[catch {eval exec $cmd} err]} {
9213 error_popup "[mc "Error creating patch:"] $err" $patchtop
9215 catch {destroy $patchtop}
9216 unset patchtop
9219 proc mkpatchcan {} {
9220 global patchtop
9222 catch {destroy $patchtop}
9223 unset patchtop
9226 proc mktag {} {
9227 global rowmenuid mktagtop commitinfo NS
9229 set top .maketag
9230 set mktagtop $top
9231 catch {destroy $top}
9232 ttk_toplevel $top
9233 make_transient $top .
9234 ${NS}::label $top.title -text [mc "Create tag"]
9235 grid $top.title - -pady 10
9236 ${NS}::label $top.id -text [mc "ID:"]
9237 ${NS}::entry $top.sha1 -width 40
9238 $top.sha1 insert 0 $rowmenuid
9239 $top.sha1 conf -state readonly
9240 grid $top.id $top.sha1 -sticky w
9241 ${NS}::entry $top.head -width 60
9242 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9243 $top.head conf -state readonly
9244 grid x $top.head -sticky w
9245 ${NS}::label $top.tlab -text [mc "Tag name:"]
9246 ${NS}::entry $top.tag -width 60
9247 grid $top.tlab $top.tag -sticky w
9248 ${NS}::label $top.op -text [mc "Tag message is optional"]
9249 grid $top.op -columnspan 2 -sticky we
9250 ${NS}::label $top.mlab -text [mc "Tag message:"]
9251 ${NS}::entry $top.msg -width 60
9252 grid $top.mlab $top.msg -sticky w
9253 ${NS}::frame $top.buts
9254 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9255 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9256 bind $top <Key-Return> mktaggo
9257 bind $top <Key-Escape> mktagcan
9258 grid $top.buts.gen $top.buts.can
9259 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9260 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9261 grid $top.buts - -pady 10 -sticky ew
9262 focus $top.tag
9265 proc domktag {} {
9266 global mktagtop env tagids idtags
9268 set id [$mktagtop.sha1 get]
9269 set tag [$mktagtop.tag get]
9270 set msg [$mktagtop.msg get]
9271 if {$tag == {}} {
9272 error_popup [mc "No tag name specified"] $mktagtop
9273 return 0
9275 if {[info exists tagids($tag)]} {
9276 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9277 return 0
9279 if {[catch {
9280 if {$msg != {}} {
9281 exec git tag -a -m $msg $tag $id
9282 } else {
9283 exec git tag $tag $id
9285 } err]} {
9286 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9287 return 0
9290 set tagids($tag) $id
9291 lappend idtags($id) $tag
9292 redrawtags $id
9293 addedtag $id
9294 dispneartags 0
9295 run refill_reflist
9296 return 1
9299 proc redrawtags {id} {
9300 global canv linehtag idpos currentid curview cmitlisted markedid
9301 global canvxmax iddrawn circleitem mainheadid circlecolors
9302 global mainheadcirclecolor
9304 if {![commitinview $id $curview]} return
9305 if {![info exists iddrawn($id)]} return
9306 set row [rowofcommit $id]
9307 if {$id eq $mainheadid} {
9308 set ofill $mainheadcirclecolor
9309 } else {
9310 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9312 $canv itemconf $circleitem($row) -fill $ofill
9313 $canv delete tag.$id
9314 set xt [eval drawtags $id $idpos($id)]
9315 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9316 set text [$canv itemcget $linehtag($id) -text]
9317 set font [$canv itemcget $linehtag($id) -font]
9318 set xr [expr {$xt + [font measure $font $text]}]
9319 if {$xr > $canvxmax} {
9320 set canvxmax $xr
9321 setcanvscroll
9323 if {[info exists currentid] && $currentid == $id} {
9324 make_secsel $id
9326 if {[info exists markedid] && $markedid eq $id} {
9327 make_idmark $id
9331 proc mktagcan {} {
9332 global mktagtop
9334 catch {destroy $mktagtop}
9335 unset mktagtop
9338 proc mktaggo {} {
9339 if {![domktag]} return
9340 mktagcan
9343 proc writecommit {} {
9344 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9346 set top .writecommit
9347 set wrcomtop $top
9348 catch {destroy $top}
9349 ttk_toplevel $top
9350 make_transient $top .
9351 ${NS}::label $top.title -text [mc "Write commit to file"]
9352 grid $top.title - -pady 10
9353 ${NS}::label $top.id -text [mc "ID:"]
9354 ${NS}::entry $top.sha1 -width 40
9355 $top.sha1 insert 0 $rowmenuid
9356 $top.sha1 conf -state readonly
9357 grid $top.id $top.sha1 -sticky w
9358 ${NS}::entry $top.head -width 60
9359 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9360 $top.head conf -state readonly
9361 grid x $top.head -sticky w
9362 ${NS}::label $top.clab -text [mc "Command:"]
9363 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9364 grid $top.clab $top.cmd -sticky w -pady 10
9365 ${NS}::label $top.flab -text [mc "Output file:"]
9366 ${NS}::entry $top.fname -width 60
9367 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9368 grid $top.flab $top.fname -sticky w
9369 ${NS}::frame $top.buts
9370 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9371 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9372 bind $top <Key-Return> wrcomgo
9373 bind $top <Key-Escape> wrcomcan
9374 grid $top.buts.gen $top.buts.can
9375 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9376 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9377 grid $top.buts - -pady 10 -sticky ew
9378 focus $top.fname
9381 proc wrcomgo {} {
9382 global wrcomtop
9384 set id [$wrcomtop.sha1 get]
9385 set cmd "echo $id | [$wrcomtop.cmd get]"
9386 set fname [$wrcomtop.fname get]
9387 if {[catch {exec sh -c $cmd >$fname &} err]} {
9388 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9390 catch {destroy $wrcomtop}
9391 unset wrcomtop
9394 proc wrcomcan {} {
9395 global wrcomtop
9397 catch {destroy $wrcomtop}
9398 unset wrcomtop
9401 proc mkbranch {} {
9402 global rowmenuid mkbrtop NS
9404 set top .makebranch
9405 catch {destroy $top}
9406 ttk_toplevel $top
9407 make_transient $top .
9408 ${NS}::label $top.title -text [mc "Create new branch"]
9409 grid $top.title - -pady 10
9410 ${NS}::label $top.id -text [mc "ID:"]
9411 ${NS}::entry $top.sha1 -width 40
9412 $top.sha1 insert 0 $rowmenuid
9413 $top.sha1 conf -state readonly
9414 grid $top.id $top.sha1 -sticky w
9415 ${NS}::label $top.nlab -text [mc "Name:"]
9416 ${NS}::entry $top.name -width 40
9417 grid $top.nlab $top.name -sticky w
9418 ${NS}::frame $top.buts
9419 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9420 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9421 bind $top <Key-Return> [list mkbrgo $top]
9422 bind $top <Key-Escape> "catch {destroy $top}"
9423 grid $top.buts.go $top.buts.can
9424 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9425 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9426 grid $top.buts - -pady 10 -sticky ew
9427 focus $top.name
9430 proc mkbrgo {top} {
9431 global headids idheads
9433 set name [$top.name get]
9434 set id [$top.sha1 get]
9435 set cmdargs {}
9436 set old_id {}
9437 if {$name eq {}} {
9438 error_popup [mc "Please specify a name for the new branch"] $top
9439 return
9441 if {[info exists headids($name)]} {
9442 if {![confirm_popup [mc \
9443 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9444 return
9446 set old_id $headids($name)
9447 lappend cmdargs -f
9449 catch {destroy $top}
9450 lappend cmdargs $name $id
9451 nowbusy newbranch
9452 update
9453 if {[catch {
9454 eval exec git branch $cmdargs
9455 } err]} {
9456 notbusy newbranch
9457 error_popup $err
9458 } else {
9459 notbusy newbranch
9460 if {$old_id ne {}} {
9461 movehead $id $name
9462 movedhead $id $name
9463 redrawtags $old_id
9464 redrawtags $id
9465 } else {
9466 set headids($name) $id
9467 lappend idheads($id) $name
9468 addedhead $id $name
9469 redrawtags $id
9471 dispneartags 0
9472 run refill_reflist
9476 proc exec_citool {tool_args {baseid {}}} {
9477 global commitinfo env
9479 set save_env [array get env GIT_AUTHOR_*]
9481 if {$baseid ne {}} {
9482 if {![info exists commitinfo($baseid)]} {
9483 getcommit $baseid
9485 set author [lindex $commitinfo($baseid) 1]
9486 set date [lindex $commitinfo($baseid) 2]
9487 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9488 $author author name email]
9489 && $date ne {}} {
9490 set env(GIT_AUTHOR_NAME) $name
9491 set env(GIT_AUTHOR_EMAIL) $email
9492 set env(GIT_AUTHOR_DATE) $date
9496 eval exec git citool $tool_args &
9498 array unset env GIT_AUTHOR_*
9499 array set env $save_env
9502 proc cherrypick {} {
9503 global rowmenuid curview
9504 global mainhead mainheadid
9505 global gitdir
9507 set oldhead [exec git rev-parse HEAD]
9508 set dheads [descheads $rowmenuid]
9509 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9510 set ok [confirm_popup [mc "Commit %s is already\
9511 included in branch %s -- really re-apply it?" \
9512 [string range $rowmenuid 0 7] $mainhead]]
9513 if {!$ok} return
9515 nowbusy cherrypick [mc "Cherry-picking"]
9516 update
9517 # Unfortunately git-cherry-pick writes stuff to stderr even when
9518 # no error occurs, and exec takes that as an indication of error...
9519 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9520 notbusy cherrypick
9521 if {[regexp -line \
9522 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9523 $err msg fname]} {
9524 error_popup [mc "Cherry-pick failed because of local changes\
9525 to file '%s'.\nPlease commit, reset or stash\
9526 your changes and try again." $fname]
9527 } elseif {[regexp -line \
9528 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9529 $err]} {
9530 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9531 conflict.\nDo you wish to run git citool to\
9532 resolve it?"]]} {
9533 # Force citool to read MERGE_MSG
9534 file delete [file join $gitdir "GITGUI_MSG"]
9535 exec_citool {} $rowmenuid
9537 } else {
9538 error_popup $err
9540 run updatecommits
9541 return
9543 set newhead [exec git rev-parse HEAD]
9544 if {$newhead eq $oldhead} {
9545 notbusy cherrypick
9546 error_popup [mc "No changes committed"]
9547 return
9549 addnewchild $newhead $oldhead
9550 if {[commitinview $oldhead $curview]} {
9551 # XXX this isn't right if we have a path limit...
9552 insertrow $newhead $oldhead $curview
9553 if {$mainhead ne {}} {
9554 movehead $newhead $mainhead
9555 movedhead $newhead $mainhead
9557 set mainheadid $newhead
9558 redrawtags $oldhead
9559 redrawtags $newhead
9560 selbyid $newhead
9562 notbusy cherrypick
9565 proc revert {} {
9566 global rowmenuid curview
9567 global mainhead mainheadid
9568 global gitdir
9570 set oldhead [exec git rev-parse HEAD]
9571 set dheads [descheads $rowmenuid]
9572 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9573 set ok [confirm_popup [mc "Commit %s is not\
9574 included in branch %s -- really revert it?" \
9575 [string range $rowmenuid 0 7] $mainhead]]
9576 if {!$ok} return
9578 nowbusy revert [mc "Reverting"]
9579 update
9581 if [catch {exec git revert --no-edit $rowmenuid} err] {
9582 notbusy revert
9583 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9584 $err match files] {
9585 regsub {\n( |\t)+} $files "\n" files
9586 error_popup [mc "Revert failed because of local changes to\
9587 the following files:%s Please commit, reset or stash \
9588 your changes and try again." $files]
9589 } elseif [regexp {error: could not revert} $err] {
9590 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9591 Do you wish to run git citool to resolve it?"]] {
9592 # Force citool to read MERGE_MSG
9593 file delete [file join $gitdir "GITGUI_MSG"]
9594 exec_citool {} $rowmenuid
9596 } else { error_popup $err }
9597 run updatecommits
9598 return
9601 set newhead [exec git rev-parse HEAD]
9602 if { $newhead eq $oldhead } {
9603 notbusy revert
9604 error_popup [mc "No changes committed"]
9605 return
9608 addnewchild $newhead $oldhead
9610 if [commitinview $oldhead $curview] {
9611 # XXX this isn't right if we have a path limit...
9612 insertrow $newhead $oldhead $curview
9613 if {$mainhead ne {}} {
9614 movehead $newhead $mainhead
9615 movedhead $newhead $mainhead
9617 set mainheadid $newhead
9618 redrawtags $oldhead
9619 redrawtags $newhead
9620 selbyid $newhead
9623 notbusy revert
9626 proc resethead {} {
9627 global mainhead rowmenuid confirm_ok resettype NS
9629 set confirm_ok 0
9630 set w ".confirmreset"
9631 ttk_toplevel $w
9632 make_transient $w .
9633 wm title $w [mc "Confirm reset"]
9634 ${NS}::label $w.m -text \
9635 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9636 pack $w.m -side top -fill x -padx 20 -pady 20
9637 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9638 set resettype mixed
9639 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9640 -text [mc "Soft: Leave working tree and index untouched"]
9641 grid $w.f.soft -sticky w
9642 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9643 -text [mc "Mixed: Leave working tree untouched, reset index"]
9644 grid $w.f.mixed -sticky w
9645 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9646 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9647 grid $w.f.hard -sticky w
9648 pack $w.f -side top -fill x -padx 4
9649 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9650 pack $w.ok -side left -fill x -padx 20 -pady 20
9651 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9652 bind $w <Key-Escape> [list destroy $w]
9653 pack $w.cancel -side right -fill x -padx 20 -pady 20
9654 bind $w <Visibility> "grab $w; focus $w"
9655 tkwait window $w
9656 if {!$confirm_ok} return
9657 if {[catch {set fd [open \
9658 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9659 error_popup $err
9660 } else {
9661 dohidelocalchanges
9662 filerun $fd [list readresetstat $fd]
9663 nowbusy reset [mc "Resetting"]
9664 selbyid $rowmenuid
9668 proc readresetstat {fd} {
9669 global mainhead mainheadid showlocalchanges rprogcoord
9671 if {[gets $fd line] >= 0} {
9672 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9673 set rprogcoord [expr {1.0 * $m / $n}]
9674 adjustprogress
9676 return 1
9678 set rprogcoord 0
9679 adjustprogress
9680 notbusy reset
9681 if {[catch {close $fd} err]} {
9682 error_popup $err
9684 set oldhead $mainheadid
9685 set newhead [exec git rev-parse HEAD]
9686 if {$newhead ne $oldhead} {
9687 movehead $newhead $mainhead
9688 movedhead $newhead $mainhead
9689 set mainheadid $newhead
9690 redrawtags $oldhead
9691 redrawtags $newhead
9693 if {$showlocalchanges} {
9694 doshowlocalchanges
9696 return 0
9699 # context menu for a head
9700 proc headmenu {x y id head} {
9701 global headmenuid headmenuhead headctxmenu mainhead
9703 stopfinding
9704 set headmenuid $id
9705 set headmenuhead $head
9706 set state normal
9707 if {[string match "remotes/*" $head]} {
9708 set state disabled
9710 if {$head eq $mainhead} {
9711 set state disabled
9713 $headctxmenu entryconfigure 0 -state $state
9714 $headctxmenu entryconfigure 1 -state $state
9715 tk_popup $headctxmenu $x $y
9718 proc cobranch {} {
9719 global headmenuid headmenuhead headids
9720 global showlocalchanges
9722 # check the tree is clean first??
9723 nowbusy checkout [mc "Checking out"]
9724 update
9725 dohidelocalchanges
9726 if {[catch {
9727 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9728 } err]} {
9729 notbusy checkout
9730 error_popup $err
9731 if {$showlocalchanges} {
9732 dodiffindex
9734 } else {
9735 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9739 proc readcheckoutstat {fd newhead newheadid} {
9740 global mainhead mainheadid headids showlocalchanges progresscoords
9741 global viewmainheadid curview
9743 if {[gets $fd line] >= 0} {
9744 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9745 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9746 adjustprogress
9748 return 1
9750 set progresscoords {0 0}
9751 adjustprogress
9752 notbusy checkout
9753 if {[catch {close $fd} err]} {
9754 error_popup $err
9756 set oldmainid $mainheadid
9757 set mainhead $newhead
9758 set mainheadid $newheadid
9759 set viewmainheadid($curview) $newheadid
9760 redrawtags $oldmainid
9761 redrawtags $newheadid
9762 selbyid $newheadid
9763 if {$showlocalchanges} {
9764 dodiffindex
9768 proc rmbranch {} {
9769 global headmenuid headmenuhead mainhead
9770 global idheads
9772 set head $headmenuhead
9773 set id $headmenuid
9774 # this check shouldn't be needed any more...
9775 if {$head eq $mainhead} {
9776 error_popup [mc "Cannot delete the currently checked-out branch"]
9777 return
9779 set dheads [descheads $id]
9780 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9781 # the stuff on this branch isn't on any other branch
9782 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9783 branch.\nReally delete branch %s?" $head $head]]} return
9785 nowbusy rmbranch
9786 update
9787 if {[catch {exec git branch -D $head} err]} {
9788 notbusy rmbranch
9789 error_popup $err
9790 return
9792 removehead $id $head
9793 removedhead $id $head
9794 redrawtags $id
9795 notbusy rmbranch
9796 dispneartags 0
9797 run refill_reflist
9800 # Display a list of tags and heads
9801 proc showrefs {} {
9802 global showrefstop bgcolor fgcolor selectbgcolor NS
9803 global bglist fglist reflistfilter reflist maincursor
9805 set top .showrefs
9806 set showrefstop $top
9807 if {[winfo exists $top]} {
9808 raise $top
9809 refill_reflist
9810 return
9812 ttk_toplevel $top
9813 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9814 make_transient $top .
9815 text $top.list -background $bgcolor -foreground $fgcolor \
9816 -selectbackground $selectbgcolor -font mainfont \
9817 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9818 -width 30 -height 20 -cursor $maincursor \
9819 -spacing1 1 -spacing3 1 -state disabled
9820 $top.list tag configure highlight -background $selectbgcolor
9821 lappend bglist $top.list
9822 lappend fglist $top.list
9823 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9824 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9825 grid $top.list $top.ysb -sticky nsew
9826 grid $top.xsb x -sticky ew
9827 ${NS}::frame $top.f
9828 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9829 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9830 set reflistfilter "*"
9831 trace add variable reflistfilter write reflistfilter_change
9832 pack $top.f.e -side right -fill x -expand 1
9833 pack $top.f.l -side left
9834 grid $top.f - -sticky ew -pady 2
9835 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9836 bind $top <Key-Escape> [list destroy $top]
9837 grid $top.close -
9838 grid columnconfigure $top 0 -weight 1
9839 grid rowconfigure $top 0 -weight 1
9840 bind $top.list <1> {break}
9841 bind $top.list <B1-Motion> {break}
9842 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9843 set reflist {}
9844 refill_reflist
9847 proc sel_reflist {w x y} {
9848 global showrefstop reflist headids tagids otherrefids
9850 if {![winfo exists $showrefstop]} return
9851 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9852 set ref [lindex $reflist [expr {$l-1}]]
9853 set n [lindex $ref 0]
9854 switch -- [lindex $ref 1] {
9855 "H" {selbyid $headids($n)}
9856 "T" {selbyid $tagids($n)}
9857 "o" {selbyid $otherrefids($n)}
9859 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9862 proc unsel_reflist {} {
9863 global showrefstop
9865 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9866 $showrefstop.list tag remove highlight 0.0 end
9869 proc reflistfilter_change {n1 n2 op} {
9870 global reflistfilter
9872 after cancel refill_reflist
9873 after 200 refill_reflist
9876 proc refill_reflist {} {
9877 global reflist reflistfilter showrefstop headids tagids otherrefids
9878 global curview
9880 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9881 set refs {}
9882 foreach n [array names headids] {
9883 if {[string match $reflistfilter $n]} {
9884 if {[commitinview $headids($n) $curview]} {
9885 lappend refs [list $n H]
9886 } else {
9887 interestedin $headids($n) {run refill_reflist}
9891 foreach n [array names tagids] {
9892 if {[string match $reflistfilter $n]} {
9893 if {[commitinview $tagids($n) $curview]} {
9894 lappend refs [list $n T]
9895 } else {
9896 interestedin $tagids($n) {run refill_reflist}
9900 foreach n [array names otherrefids] {
9901 if {[string match $reflistfilter $n]} {
9902 if {[commitinview $otherrefids($n) $curview]} {
9903 lappend refs [list $n o]
9904 } else {
9905 interestedin $otherrefids($n) {run refill_reflist}
9909 set refs [lsort -index 0 $refs]
9910 if {$refs eq $reflist} return
9912 # Update the contents of $showrefstop.list according to the
9913 # differences between $reflist (old) and $refs (new)
9914 $showrefstop.list conf -state normal
9915 $showrefstop.list insert end "\n"
9916 set i 0
9917 set j 0
9918 while {$i < [llength $reflist] || $j < [llength $refs]} {
9919 if {$i < [llength $reflist]} {
9920 if {$j < [llength $refs]} {
9921 set cmp [string compare [lindex $reflist $i 0] \
9922 [lindex $refs $j 0]]
9923 if {$cmp == 0} {
9924 set cmp [string compare [lindex $reflist $i 1] \
9925 [lindex $refs $j 1]]
9927 } else {
9928 set cmp -1
9930 } else {
9931 set cmp 1
9933 switch -- $cmp {
9934 -1 {
9935 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9936 incr i
9939 incr i
9940 incr j
9943 set l [expr {$j + 1}]
9944 $showrefstop.list image create $l.0 -align baseline \
9945 -image reficon-[lindex $refs $j 1] -padx 2
9946 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9947 incr j
9951 set reflist $refs
9952 # delete last newline
9953 $showrefstop.list delete end-2c end-1c
9954 $showrefstop.list conf -state disabled
9957 # Stuff for finding nearby tags
9958 proc getallcommits {} {
9959 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9960 global idheads idtags idotherrefs allparents tagobjid
9961 global gitdir
9963 if {![info exists allcommits]} {
9964 set nextarc 0
9965 set allcommits 0
9966 set seeds {}
9967 set allcwait 0
9968 set cachedarcs 0
9969 set allccache [file join $gitdir "gitk.cache"]
9970 if {![catch {
9971 set f [open $allccache r]
9972 set allcwait 1
9973 getcache $f
9974 }]} return
9977 if {$allcwait} {
9978 return
9980 set cmd [list | git rev-list --parents]
9981 set allcupdate [expr {$seeds ne {}}]
9982 if {!$allcupdate} {
9983 set ids "--all"
9984 } else {
9985 set refs [concat [array names idheads] [array names idtags] \
9986 [array names idotherrefs]]
9987 set ids {}
9988 set tagobjs {}
9989 foreach name [array names tagobjid] {
9990 lappend tagobjs $tagobjid($name)
9992 foreach id [lsort -unique $refs] {
9993 if {![info exists allparents($id)] &&
9994 [lsearch -exact $tagobjs $id] < 0} {
9995 lappend ids $id
9998 if {$ids ne {}} {
9999 foreach id $seeds {
10000 lappend ids "^$id"
10004 if {$ids ne {}} {
10005 set fd [open [concat $cmd $ids] r]
10006 fconfigure $fd -blocking 0
10007 incr allcommits
10008 nowbusy allcommits
10009 filerun $fd [list getallclines $fd]
10010 } else {
10011 dispneartags 0
10015 # Since most commits have 1 parent and 1 child, we group strings of
10016 # such commits into "arcs" joining branch/merge points (BMPs), which
10017 # are commits that either don't have 1 parent or don't have 1 child.
10019 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10020 # arcout(id) - outgoing arcs for BMP
10021 # arcids(a) - list of IDs on arc including end but not start
10022 # arcstart(a) - BMP ID at start of arc
10023 # arcend(a) - BMP ID at end of arc
10024 # growing(a) - arc a is still growing
10025 # arctags(a) - IDs out of arcids (excluding end) that have tags
10026 # archeads(a) - IDs out of arcids (excluding end) that have heads
10027 # The start of an arc is at the descendent end, so "incoming" means
10028 # coming from descendents, and "outgoing" means going towards ancestors.
10030 proc getallclines {fd} {
10031 global allparents allchildren idtags idheads nextarc
10032 global arcnos arcids arctags arcout arcend arcstart archeads growing
10033 global seeds allcommits cachedarcs allcupdate
10035 set nid 0
10036 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10037 set id [lindex $line 0]
10038 if {[info exists allparents($id)]} {
10039 # seen it already
10040 continue
10042 set cachedarcs 0
10043 set olds [lrange $line 1 end]
10044 set allparents($id) $olds
10045 if {![info exists allchildren($id)]} {
10046 set allchildren($id) {}
10047 set arcnos($id) {}
10048 lappend seeds $id
10049 } else {
10050 set a $arcnos($id)
10051 if {[llength $olds] == 1 && [llength $a] == 1} {
10052 lappend arcids($a) $id
10053 if {[info exists idtags($id)]} {
10054 lappend arctags($a) $id
10056 if {[info exists idheads($id)]} {
10057 lappend archeads($a) $id
10059 if {[info exists allparents($olds)]} {
10060 # seen parent already
10061 if {![info exists arcout($olds)]} {
10062 splitarc $olds
10064 lappend arcids($a) $olds
10065 set arcend($a) $olds
10066 unset growing($a)
10068 lappend allchildren($olds) $id
10069 lappend arcnos($olds) $a
10070 continue
10073 foreach a $arcnos($id) {
10074 lappend arcids($a) $id
10075 set arcend($a) $id
10076 unset growing($a)
10079 set ao {}
10080 foreach p $olds {
10081 lappend allchildren($p) $id
10082 set a [incr nextarc]
10083 set arcstart($a) $id
10084 set archeads($a) {}
10085 set arctags($a) {}
10086 set archeads($a) {}
10087 set arcids($a) {}
10088 lappend ao $a
10089 set growing($a) 1
10090 if {[info exists allparents($p)]} {
10091 # seen it already, may need to make a new branch
10092 if {![info exists arcout($p)]} {
10093 splitarc $p
10095 lappend arcids($a) $p
10096 set arcend($a) $p
10097 unset growing($a)
10099 lappend arcnos($p) $a
10101 set arcout($id) $ao
10103 if {$nid > 0} {
10104 global cached_dheads cached_dtags cached_atags
10105 catch {unset cached_dheads}
10106 catch {unset cached_dtags}
10107 catch {unset cached_atags}
10109 if {![eof $fd]} {
10110 return [expr {$nid >= 1000? 2: 1}]
10112 set cacheok 1
10113 if {[catch {
10114 fconfigure $fd -blocking 1
10115 close $fd
10116 } err]} {
10117 # got an error reading the list of commits
10118 # if we were updating, try rereading the whole thing again
10119 if {$allcupdate} {
10120 incr allcommits -1
10121 dropcache $err
10122 return
10124 error_popup "[mc "Error reading commit topology information;\
10125 branch and preceding/following tag information\
10126 will be incomplete."]\n($err)"
10127 set cacheok 0
10129 if {[incr allcommits -1] == 0} {
10130 notbusy allcommits
10131 if {$cacheok} {
10132 run savecache
10135 dispneartags 0
10136 return 0
10139 proc recalcarc {a} {
10140 global arctags archeads arcids idtags idheads
10142 set at {}
10143 set ah {}
10144 foreach id [lrange $arcids($a) 0 end-1] {
10145 if {[info exists idtags($id)]} {
10146 lappend at $id
10148 if {[info exists idheads($id)]} {
10149 lappend ah $id
10152 set arctags($a) $at
10153 set archeads($a) $ah
10156 proc splitarc {p} {
10157 global arcnos arcids nextarc arctags archeads idtags idheads
10158 global arcstart arcend arcout allparents growing
10160 set a $arcnos($p)
10161 if {[llength $a] != 1} {
10162 puts "oops splitarc called but [llength $a] arcs already"
10163 return
10165 set a [lindex $a 0]
10166 set i [lsearch -exact $arcids($a) $p]
10167 if {$i < 0} {
10168 puts "oops splitarc $p not in arc $a"
10169 return
10171 set na [incr nextarc]
10172 if {[info exists arcend($a)]} {
10173 set arcend($na) $arcend($a)
10174 } else {
10175 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10176 set j [lsearch -exact $arcnos($l) $a]
10177 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10179 set tail [lrange $arcids($a) [expr {$i+1}] end]
10180 set arcids($a) [lrange $arcids($a) 0 $i]
10181 set arcend($a) $p
10182 set arcstart($na) $p
10183 set arcout($p) $na
10184 set arcids($na) $tail
10185 if {[info exists growing($a)]} {
10186 set growing($na) 1
10187 unset growing($a)
10190 foreach id $tail {
10191 if {[llength $arcnos($id)] == 1} {
10192 set arcnos($id) $na
10193 } else {
10194 set j [lsearch -exact $arcnos($id) $a]
10195 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10199 # reconstruct tags and heads lists
10200 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10201 recalcarc $a
10202 recalcarc $na
10203 } else {
10204 set arctags($na) {}
10205 set archeads($na) {}
10209 # Update things for a new commit added that is a child of one
10210 # existing commit. Used when cherry-picking.
10211 proc addnewchild {id p} {
10212 global allparents allchildren idtags nextarc
10213 global arcnos arcids arctags arcout arcend arcstart archeads growing
10214 global seeds allcommits
10216 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10217 set allparents($id) [list $p]
10218 set allchildren($id) {}
10219 set arcnos($id) {}
10220 lappend seeds $id
10221 lappend allchildren($p) $id
10222 set a [incr nextarc]
10223 set arcstart($a) $id
10224 set archeads($a) {}
10225 set arctags($a) {}
10226 set arcids($a) [list $p]
10227 set arcend($a) $p
10228 if {![info exists arcout($p)]} {
10229 splitarc $p
10231 lappend arcnos($p) $a
10232 set arcout($id) [list $a]
10235 # This implements a cache for the topology information.
10236 # The cache saves, for each arc, the start and end of the arc,
10237 # the ids on the arc, and the outgoing arcs from the end.
10238 proc readcache {f} {
10239 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10240 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10241 global allcwait
10243 set a $nextarc
10244 set lim $cachedarcs
10245 if {$lim - $a > 500} {
10246 set lim [expr {$a + 500}]
10248 if {[catch {
10249 if {$a == $lim} {
10250 # finish reading the cache and setting up arctags, etc.
10251 set line [gets $f]
10252 if {$line ne "1"} {error "bad final version"}
10253 close $f
10254 foreach id [array names idtags] {
10255 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10256 [llength $allparents($id)] == 1} {
10257 set a [lindex $arcnos($id) 0]
10258 if {$arctags($a) eq {}} {
10259 recalcarc $a
10263 foreach id [array names idheads] {
10264 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10265 [llength $allparents($id)] == 1} {
10266 set a [lindex $arcnos($id) 0]
10267 if {$archeads($a) eq {}} {
10268 recalcarc $a
10272 foreach id [lsort -unique $possible_seeds] {
10273 if {$arcnos($id) eq {}} {
10274 lappend seeds $id
10277 set allcwait 0
10278 } else {
10279 while {[incr a] <= $lim} {
10280 set line [gets $f]
10281 if {[llength $line] != 3} {error "bad line"}
10282 set s [lindex $line 0]
10283 set arcstart($a) $s
10284 lappend arcout($s) $a
10285 if {![info exists arcnos($s)]} {
10286 lappend possible_seeds $s
10287 set arcnos($s) {}
10289 set e [lindex $line 1]
10290 if {$e eq {}} {
10291 set growing($a) 1
10292 } else {
10293 set arcend($a) $e
10294 if {![info exists arcout($e)]} {
10295 set arcout($e) {}
10298 set arcids($a) [lindex $line 2]
10299 foreach id $arcids($a) {
10300 lappend allparents($s) $id
10301 set s $id
10302 lappend arcnos($id) $a
10304 if {![info exists allparents($s)]} {
10305 set allparents($s) {}
10307 set arctags($a) {}
10308 set archeads($a) {}
10310 set nextarc [expr {$a - 1}]
10312 } err]} {
10313 dropcache $err
10314 return 0
10316 if {!$allcwait} {
10317 getallcommits
10319 return $allcwait
10322 proc getcache {f} {
10323 global nextarc cachedarcs possible_seeds
10325 if {[catch {
10326 set line [gets $f]
10327 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10328 # make sure it's an integer
10329 set cachedarcs [expr {int([lindex $line 1])}]
10330 if {$cachedarcs < 0} {error "bad number of arcs"}
10331 set nextarc 0
10332 set possible_seeds {}
10333 run readcache $f
10334 } err]} {
10335 dropcache $err
10337 return 0
10340 proc dropcache {err} {
10341 global allcwait nextarc cachedarcs seeds
10343 #puts "dropping cache ($err)"
10344 foreach v {arcnos arcout arcids arcstart arcend growing \
10345 arctags archeads allparents allchildren} {
10346 global $v
10347 catch {unset $v}
10349 set allcwait 0
10350 set nextarc 0
10351 set cachedarcs 0
10352 set seeds {}
10353 getallcommits
10356 proc writecache {f} {
10357 global cachearc cachedarcs allccache
10358 global arcstart arcend arcnos arcids arcout
10360 set a $cachearc
10361 set lim $cachedarcs
10362 if {$lim - $a > 1000} {
10363 set lim [expr {$a + 1000}]
10365 if {[catch {
10366 while {[incr a] <= $lim} {
10367 if {[info exists arcend($a)]} {
10368 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10369 } else {
10370 puts $f [list $arcstart($a) {} $arcids($a)]
10373 } err]} {
10374 catch {close $f}
10375 catch {file delete $allccache}
10376 #puts "writing cache failed ($err)"
10377 return 0
10379 set cachearc [expr {$a - 1}]
10380 if {$a > $cachedarcs} {
10381 puts $f "1"
10382 close $f
10383 return 0
10385 return 1
10388 proc savecache {} {
10389 global nextarc cachedarcs cachearc allccache
10391 if {$nextarc == $cachedarcs} return
10392 set cachearc 0
10393 set cachedarcs $nextarc
10394 catch {
10395 set f [open $allccache w]
10396 puts $f [list 1 $cachedarcs]
10397 run writecache $f
10401 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10402 # or 0 if neither is true.
10403 proc anc_or_desc {a b} {
10404 global arcout arcstart arcend arcnos cached_isanc
10406 if {$arcnos($a) eq $arcnos($b)} {
10407 # Both are on the same arc(s); either both are the same BMP,
10408 # or if one is not a BMP, the other is also not a BMP or is
10409 # the BMP at end of the arc (and it only has 1 incoming arc).
10410 # Or both can be BMPs with no incoming arcs.
10411 if {$a eq $b || $arcnos($a) eq {}} {
10412 return 0
10414 # assert {[llength $arcnos($a)] == 1}
10415 set arc [lindex $arcnos($a) 0]
10416 set i [lsearch -exact $arcids($arc) $a]
10417 set j [lsearch -exact $arcids($arc) $b]
10418 if {$i < 0 || $i > $j} {
10419 return 1
10420 } else {
10421 return -1
10425 if {![info exists arcout($a)]} {
10426 set arc [lindex $arcnos($a) 0]
10427 if {[info exists arcend($arc)]} {
10428 set aend $arcend($arc)
10429 } else {
10430 set aend {}
10432 set a $arcstart($arc)
10433 } else {
10434 set aend $a
10436 if {![info exists arcout($b)]} {
10437 set arc [lindex $arcnos($b) 0]
10438 if {[info exists arcend($arc)]} {
10439 set bend $arcend($arc)
10440 } else {
10441 set bend {}
10443 set b $arcstart($arc)
10444 } else {
10445 set bend $b
10447 if {$a eq $bend} {
10448 return 1
10450 if {$b eq $aend} {
10451 return -1
10453 if {[info exists cached_isanc($a,$bend)]} {
10454 if {$cached_isanc($a,$bend)} {
10455 return 1
10458 if {[info exists cached_isanc($b,$aend)]} {
10459 if {$cached_isanc($b,$aend)} {
10460 return -1
10462 if {[info exists cached_isanc($a,$bend)]} {
10463 return 0
10467 set todo [list $a $b]
10468 set anc($a) a
10469 set anc($b) b
10470 for {set i 0} {$i < [llength $todo]} {incr i} {
10471 set x [lindex $todo $i]
10472 if {$anc($x) eq {}} {
10473 continue
10475 foreach arc $arcnos($x) {
10476 set xd $arcstart($arc)
10477 if {$xd eq $bend} {
10478 set cached_isanc($a,$bend) 1
10479 set cached_isanc($b,$aend) 0
10480 return 1
10481 } elseif {$xd eq $aend} {
10482 set cached_isanc($b,$aend) 1
10483 set cached_isanc($a,$bend) 0
10484 return -1
10486 if {![info exists anc($xd)]} {
10487 set anc($xd) $anc($x)
10488 lappend todo $xd
10489 } elseif {$anc($xd) ne $anc($x)} {
10490 set anc($xd) {}
10494 set cached_isanc($a,$bend) 0
10495 set cached_isanc($b,$aend) 0
10496 return 0
10499 # This identifies whether $desc has an ancestor that is
10500 # a growing tip of the graph and which is not an ancestor of $anc
10501 # and returns 0 if so and 1 if not.
10502 # If we subsequently discover a tag on such a growing tip, and that
10503 # turns out to be a descendent of $anc (which it could, since we
10504 # don't necessarily see children before parents), then $desc
10505 # isn't a good choice to display as a descendent tag of
10506 # $anc (since it is the descendent of another tag which is
10507 # a descendent of $anc). Similarly, $anc isn't a good choice to
10508 # display as a ancestor tag of $desc.
10510 proc is_certain {desc anc} {
10511 global arcnos arcout arcstart arcend growing problems
10513 set certain {}
10514 if {[llength $arcnos($anc)] == 1} {
10515 # tags on the same arc are certain
10516 if {$arcnos($desc) eq $arcnos($anc)} {
10517 return 1
10519 if {![info exists arcout($anc)]} {
10520 # if $anc is partway along an arc, use the start of the arc instead
10521 set a [lindex $arcnos($anc) 0]
10522 set anc $arcstart($a)
10525 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10526 set x $desc
10527 } else {
10528 set a [lindex $arcnos($desc) 0]
10529 set x $arcend($a)
10531 if {$x == $anc} {
10532 return 1
10534 set anclist [list $x]
10535 set dl($x) 1
10536 set nnh 1
10537 set ngrowanc 0
10538 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10539 set x [lindex $anclist $i]
10540 if {$dl($x)} {
10541 incr nnh -1
10543 set done($x) 1
10544 foreach a $arcout($x) {
10545 if {[info exists growing($a)]} {
10546 if {![info exists growanc($x)] && $dl($x)} {
10547 set growanc($x) 1
10548 incr ngrowanc
10550 } else {
10551 set y $arcend($a)
10552 if {[info exists dl($y)]} {
10553 if {$dl($y)} {
10554 if {!$dl($x)} {
10555 set dl($y) 0
10556 if {![info exists done($y)]} {
10557 incr nnh -1
10559 if {[info exists growanc($x)]} {
10560 incr ngrowanc -1
10562 set xl [list $y]
10563 for {set k 0} {$k < [llength $xl]} {incr k} {
10564 set z [lindex $xl $k]
10565 foreach c $arcout($z) {
10566 if {[info exists arcend($c)]} {
10567 set v $arcend($c)
10568 if {[info exists dl($v)] && $dl($v)} {
10569 set dl($v) 0
10570 if {![info exists done($v)]} {
10571 incr nnh -1
10573 if {[info exists growanc($v)]} {
10574 incr ngrowanc -1
10576 lappend xl $v
10583 } elseif {$y eq $anc || !$dl($x)} {
10584 set dl($y) 0
10585 lappend anclist $y
10586 } else {
10587 set dl($y) 1
10588 lappend anclist $y
10589 incr nnh
10594 foreach x [array names growanc] {
10595 if {$dl($x)} {
10596 return 0
10598 return 0
10600 return 1
10603 proc validate_arctags {a} {
10604 global arctags idtags
10606 set i -1
10607 set na $arctags($a)
10608 foreach id $arctags($a) {
10609 incr i
10610 if {![info exists idtags($id)]} {
10611 set na [lreplace $na $i $i]
10612 incr i -1
10615 set arctags($a) $na
10618 proc validate_archeads {a} {
10619 global archeads idheads
10621 set i -1
10622 set na $archeads($a)
10623 foreach id $archeads($a) {
10624 incr i
10625 if {![info exists idheads($id)]} {
10626 set na [lreplace $na $i $i]
10627 incr i -1
10630 set archeads($a) $na
10633 # Return the list of IDs that have tags that are descendents of id,
10634 # ignoring IDs that are descendents of IDs already reported.
10635 proc desctags {id} {
10636 global arcnos arcstart arcids arctags idtags allparents
10637 global growing cached_dtags
10639 if {![info exists allparents($id)]} {
10640 return {}
10642 set t1 [clock clicks -milliseconds]
10643 set argid $id
10644 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10645 # part-way along an arc; check that arc first
10646 set a [lindex $arcnos($id) 0]
10647 if {$arctags($a) ne {}} {
10648 validate_arctags $a
10649 set i [lsearch -exact $arcids($a) $id]
10650 set tid {}
10651 foreach t $arctags($a) {
10652 set j [lsearch -exact $arcids($a) $t]
10653 if {$j >= $i} break
10654 set tid $t
10656 if {$tid ne {}} {
10657 return $tid
10660 set id $arcstart($a)
10661 if {[info exists idtags($id)]} {
10662 return $id
10665 if {[info exists cached_dtags($id)]} {
10666 return $cached_dtags($id)
10669 set origid $id
10670 set todo [list $id]
10671 set queued($id) 1
10672 set nc 1
10673 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10674 set id [lindex $todo $i]
10675 set done($id) 1
10676 set ta [info exists hastaggedancestor($id)]
10677 if {!$ta} {
10678 incr nc -1
10680 # ignore tags on starting node
10681 if {!$ta && $i > 0} {
10682 if {[info exists idtags($id)]} {
10683 set tagloc($id) $id
10684 set ta 1
10685 } elseif {[info exists cached_dtags($id)]} {
10686 set tagloc($id) $cached_dtags($id)
10687 set ta 1
10690 foreach a $arcnos($id) {
10691 set d $arcstart($a)
10692 if {!$ta && $arctags($a) ne {}} {
10693 validate_arctags $a
10694 if {$arctags($a) ne {}} {
10695 lappend tagloc($id) [lindex $arctags($a) end]
10698 if {$ta || $arctags($a) ne {}} {
10699 set tomark [list $d]
10700 for {set j 0} {$j < [llength $tomark]} {incr j} {
10701 set dd [lindex $tomark $j]
10702 if {![info exists hastaggedancestor($dd)]} {
10703 if {[info exists done($dd)]} {
10704 foreach b $arcnos($dd) {
10705 lappend tomark $arcstart($b)
10707 if {[info exists tagloc($dd)]} {
10708 unset tagloc($dd)
10710 } elseif {[info exists queued($dd)]} {
10711 incr nc -1
10713 set hastaggedancestor($dd) 1
10717 if {![info exists queued($d)]} {
10718 lappend todo $d
10719 set queued($d) 1
10720 if {![info exists hastaggedancestor($d)]} {
10721 incr nc
10726 set tags {}
10727 foreach id [array names tagloc] {
10728 if {![info exists hastaggedancestor($id)]} {
10729 foreach t $tagloc($id) {
10730 if {[lsearch -exact $tags $t] < 0} {
10731 lappend tags $t
10736 set t2 [clock clicks -milliseconds]
10737 set loopix $i
10739 # remove tags that are descendents of other tags
10740 for {set i 0} {$i < [llength $tags]} {incr i} {
10741 set a [lindex $tags $i]
10742 for {set j 0} {$j < $i} {incr j} {
10743 set b [lindex $tags $j]
10744 set r [anc_or_desc $a $b]
10745 if {$r == 1} {
10746 set tags [lreplace $tags $j $j]
10747 incr j -1
10748 incr i -1
10749 } elseif {$r == -1} {
10750 set tags [lreplace $tags $i $i]
10751 incr i -1
10752 break
10757 if {[array names growing] ne {}} {
10758 # graph isn't finished, need to check if any tag could get
10759 # eclipsed by another tag coming later. Simply ignore any
10760 # tags that could later get eclipsed.
10761 set ctags {}
10762 foreach t $tags {
10763 if {[is_certain $t $origid]} {
10764 lappend ctags $t
10767 if {$tags eq $ctags} {
10768 set cached_dtags($origid) $tags
10769 } else {
10770 set tags $ctags
10772 } else {
10773 set cached_dtags($origid) $tags
10775 set t3 [clock clicks -milliseconds]
10776 if {0 && $t3 - $t1 >= 100} {
10777 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10778 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10780 return $tags
10783 proc anctags {id} {
10784 global arcnos arcids arcout arcend arctags idtags allparents
10785 global growing cached_atags
10787 if {![info exists allparents($id)]} {
10788 return {}
10790 set t1 [clock clicks -milliseconds]
10791 set argid $id
10792 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10793 # part-way along an arc; check that arc first
10794 set a [lindex $arcnos($id) 0]
10795 if {$arctags($a) ne {}} {
10796 validate_arctags $a
10797 set i [lsearch -exact $arcids($a) $id]
10798 foreach t $arctags($a) {
10799 set j [lsearch -exact $arcids($a) $t]
10800 if {$j > $i} {
10801 return $t
10805 if {![info exists arcend($a)]} {
10806 return {}
10808 set id $arcend($a)
10809 if {[info exists idtags($id)]} {
10810 return $id
10813 if {[info exists cached_atags($id)]} {
10814 return $cached_atags($id)
10817 set origid $id
10818 set todo [list $id]
10819 set queued($id) 1
10820 set taglist {}
10821 set nc 1
10822 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10823 set id [lindex $todo $i]
10824 set done($id) 1
10825 set td [info exists hastaggeddescendent($id)]
10826 if {!$td} {
10827 incr nc -1
10829 # ignore tags on starting node
10830 if {!$td && $i > 0} {
10831 if {[info exists idtags($id)]} {
10832 set tagloc($id) $id
10833 set td 1
10834 } elseif {[info exists cached_atags($id)]} {
10835 set tagloc($id) $cached_atags($id)
10836 set td 1
10839 foreach a $arcout($id) {
10840 if {!$td && $arctags($a) ne {}} {
10841 validate_arctags $a
10842 if {$arctags($a) ne {}} {
10843 lappend tagloc($id) [lindex $arctags($a) 0]
10846 if {![info exists arcend($a)]} continue
10847 set d $arcend($a)
10848 if {$td || $arctags($a) ne {}} {
10849 set tomark [list $d]
10850 for {set j 0} {$j < [llength $tomark]} {incr j} {
10851 set dd [lindex $tomark $j]
10852 if {![info exists hastaggeddescendent($dd)]} {
10853 if {[info exists done($dd)]} {
10854 foreach b $arcout($dd) {
10855 if {[info exists arcend($b)]} {
10856 lappend tomark $arcend($b)
10859 if {[info exists tagloc($dd)]} {
10860 unset tagloc($dd)
10862 } elseif {[info exists queued($dd)]} {
10863 incr nc -1
10865 set hastaggeddescendent($dd) 1
10869 if {![info exists queued($d)]} {
10870 lappend todo $d
10871 set queued($d) 1
10872 if {![info exists hastaggeddescendent($d)]} {
10873 incr nc
10878 set t2 [clock clicks -milliseconds]
10879 set loopix $i
10880 set tags {}
10881 foreach id [array names tagloc] {
10882 if {![info exists hastaggeddescendent($id)]} {
10883 foreach t $tagloc($id) {
10884 if {[lsearch -exact $tags $t] < 0} {
10885 lappend tags $t
10891 # remove tags that are ancestors of other tags
10892 for {set i 0} {$i < [llength $tags]} {incr i} {
10893 set a [lindex $tags $i]
10894 for {set j 0} {$j < $i} {incr j} {
10895 set b [lindex $tags $j]
10896 set r [anc_or_desc $a $b]
10897 if {$r == -1} {
10898 set tags [lreplace $tags $j $j]
10899 incr j -1
10900 incr i -1
10901 } elseif {$r == 1} {
10902 set tags [lreplace $tags $i $i]
10903 incr i -1
10904 break
10909 if {[array names growing] ne {}} {
10910 # graph isn't finished, need to check if any tag could get
10911 # eclipsed by another tag coming later. Simply ignore any
10912 # tags that could later get eclipsed.
10913 set ctags {}
10914 foreach t $tags {
10915 if {[is_certain $origid $t]} {
10916 lappend ctags $t
10919 if {$tags eq $ctags} {
10920 set cached_atags($origid) $tags
10921 } else {
10922 set tags $ctags
10924 } else {
10925 set cached_atags($origid) $tags
10927 set t3 [clock clicks -milliseconds]
10928 if {0 && $t3 - $t1 >= 100} {
10929 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10930 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10932 return $tags
10935 # Return the list of IDs that have heads that are descendents of id,
10936 # including id itself if it has a head.
10937 proc descheads {id} {
10938 global arcnos arcstart arcids archeads idheads cached_dheads
10939 global allparents arcout
10941 if {![info exists allparents($id)]} {
10942 return {}
10944 set aret {}
10945 if {![info exists arcout($id)]} {
10946 # part-way along an arc; check it first
10947 set a [lindex $arcnos($id) 0]
10948 if {$archeads($a) ne {}} {
10949 validate_archeads $a
10950 set i [lsearch -exact $arcids($a) $id]
10951 foreach t $archeads($a) {
10952 set j [lsearch -exact $arcids($a) $t]
10953 if {$j > $i} break
10954 lappend aret $t
10957 set id $arcstart($a)
10959 set origid $id
10960 set todo [list $id]
10961 set seen($id) 1
10962 set ret {}
10963 for {set i 0} {$i < [llength $todo]} {incr i} {
10964 set id [lindex $todo $i]
10965 if {[info exists cached_dheads($id)]} {
10966 set ret [concat $ret $cached_dheads($id)]
10967 } else {
10968 if {[info exists idheads($id)]} {
10969 lappend ret $id
10971 foreach a $arcnos($id) {
10972 if {$archeads($a) ne {}} {
10973 validate_archeads $a
10974 if {$archeads($a) ne {}} {
10975 set ret [concat $ret $archeads($a)]
10978 set d $arcstart($a)
10979 if {![info exists seen($d)]} {
10980 lappend todo $d
10981 set seen($d) 1
10986 set ret [lsort -unique $ret]
10987 set cached_dheads($origid) $ret
10988 return [concat $ret $aret]
10991 proc addedtag {id} {
10992 global arcnos arcout cached_dtags cached_atags
10994 if {![info exists arcnos($id)]} return
10995 if {![info exists arcout($id)]} {
10996 recalcarc [lindex $arcnos($id) 0]
10998 catch {unset cached_dtags}
10999 catch {unset cached_atags}
11002 proc addedhead {hid head} {
11003 global arcnos arcout cached_dheads
11005 if {![info exists arcnos($hid)]} return
11006 if {![info exists arcout($hid)]} {
11007 recalcarc [lindex $arcnos($hid) 0]
11009 catch {unset cached_dheads}
11012 proc removedhead {hid head} {
11013 global cached_dheads
11015 catch {unset cached_dheads}
11018 proc movedhead {hid head} {
11019 global arcnos arcout cached_dheads
11021 if {![info exists arcnos($hid)]} return
11022 if {![info exists arcout($hid)]} {
11023 recalcarc [lindex $arcnos($hid) 0]
11025 catch {unset cached_dheads}
11028 proc changedrefs {} {
11029 global cached_dheads cached_dtags cached_atags cached_tagcontent
11030 global arctags archeads arcnos arcout idheads idtags
11032 foreach id [concat [array names idheads] [array names idtags]] {
11033 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11034 set a [lindex $arcnos($id) 0]
11035 if {![info exists donearc($a)]} {
11036 recalcarc $a
11037 set donearc($a) 1
11041 catch {unset cached_tagcontent}
11042 catch {unset cached_dtags}
11043 catch {unset cached_atags}
11044 catch {unset cached_dheads}
11047 proc rereadrefs {} {
11048 global idtags idheads idotherrefs mainheadid
11050 set refids [concat [array names idtags] \
11051 [array names idheads] [array names idotherrefs]]
11052 foreach id $refids {
11053 if {![info exists ref($id)]} {
11054 set ref($id) [listrefs $id]
11057 set oldmainhead $mainheadid
11058 readrefs
11059 changedrefs
11060 set refids [lsort -unique [concat $refids [array names idtags] \
11061 [array names idheads] [array names idotherrefs]]]
11062 foreach id $refids {
11063 set v [listrefs $id]
11064 if {![info exists ref($id)] || $ref($id) != $v} {
11065 redrawtags $id
11068 if {$oldmainhead ne $mainheadid} {
11069 redrawtags $oldmainhead
11070 redrawtags $mainheadid
11072 run refill_reflist
11075 proc listrefs {id} {
11076 global idtags idheads idotherrefs
11078 set x {}
11079 if {[info exists idtags($id)]} {
11080 set x $idtags($id)
11082 set y {}
11083 if {[info exists idheads($id)]} {
11084 set y $idheads($id)
11086 set z {}
11087 if {[info exists idotherrefs($id)]} {
11088 set z $idotherrefs($id)
11090 return [list $x $y $z]
11093 proc add_tag_ctext {tag} {
11094 global ctext cached_tagcontent tagids
11096 if {![info exists cached_tagcontent($tag)]} {
11097 catch {
11098 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11101 $ctext insert end "[mc "Tag"]: $tag\n" bold
11102 if {[info exists cached_tagcontent($tag)]} {
11103 set text $cached_tagcontent($tag)
11104 } else {
11105 set text "[mc "Id"]: $tagids($tag)"
11107 appendwithlinks $text {}
11110 proc showtag {tag isnew} {
11111 global ctext cached_tagcontent tagids linknum tagobjid
11113 if {$isnew} {
11114 addtohistory [list showtag $tag 0] savectextpos
11116 $ctext conf -state normal
11117 clear_ctext
11118 settabs 0
11119 set linknum 0
11120 add_tag_ctext $tag
11121 maybe_scroll_ctext 1
11122 $ctext conf -state disabled
11123 init_flist {}
11126 proc showtags {id isnew} {
11127 global idtags ctext linknum
11129 if {$isnew} {
11130 addtohistory [list showtags $id 0] savectextpos
11132 $ctext conf -state normal
11133 clear_ctext
11134 settabs 0
11135 set linknum 0
11136 set sep {}
11137 foreach tag $idtags($id) {
11138 $ctext insert end $sep
11139 add_tag_ctext $tag
11140 set sep "\n\n"
11142 maybe_scroll_ctext 1
11143 $ctext conf -state disabled
11144 init_flist {}
11147 proc doquit {} {
11148 global stopped
11149 global gitktmpdir
11151 set stopped 100
11152 savestuff .
11153 destroy .
11155 if {[info exists gitktmpdir]} {
11156 catch {file delete -force $gitktmpdir}
11160 proc mkfontdisp {font top which} {
11161 global fontattr fontpref $font NS use_ttk
11163 set fontpref($font) [set $font]
11164 ${NS}::button $top.${font}but -text $which \
11165 -command [list choosefont $font $which]
11166 ${NS}::label $top.$font -relief flat -font $font \
11167 -text $fontattr($font,family) -justify left
11168 grid x $top.${font}but $top.$font -sticky w
11171 proc choosefont {font which} {
11172 global fontparam fontlist fonttop fontattr
11173 global prefstop NS
11175 set fontparam(which) $which
11176 set fontparam(font) $font
11177 set fontparam(family) [font actual $font -family]
11178 set fontparam(size) $fontattr($font,size)
11179 set fontparam(weight) $fontattr($font,weight)
11180 set fontparam(slant) $fontattr($font,slant)
11181 set top .gitkfont
11182 set fonttop $top
11183 if {![winfo exists $top]} {
11184 font create sample
11185 eval font config sample [font actual $font]
11186 ttk_toplevel $top
11187 make_transient $top $prefstop
11188 wm title $top [mc "Gitk font chooser"]
11189 ${NS}::label $top.l -textvariable fontparam(which)
11190 pack $top.l -side top
11191 set fontlist [lsort [font families]]
11192 ${NS}::frame $top.f
11193 listbox $top.f.fam -listvariable fontlist \
11194 -yscrollcommand [list $top.f.sb set]
11195 bind $top.f.fam <<ListboxSelect>> selfontfam
11196 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11197 pack $top.f.sb -side right -fill y
11198 pack $top.f.fam -side left -fill both -expand 1
11199 pack $top.f -side top -fill both -expand 1
11200 ${NS}::frame $top.g
11201 spinbox $top.g.size -from 4 -to 40 -width 4 \
11202 -textvariable fontparam(size) \
11203 -validatecommand {string is integer -strict %s}
11204 checkbutton $top.g.bold -padx 5 \
11205 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11206 -variable fontparam(weight) -onvalue bold -offvalue normal
11207 checkbutton $top.g.ital -padx 5 \
11208 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11209 -variable fontparam(slant) -onvalue italic -offvalue roman
11210 pack $top.g.size $top.g.bold $top.g.ital -side left
11211 pack $top.g -side top
11212 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11213 -background white
11214 $top.c create text 100 25 -anchor center -text $which -font sample \
11215 -fill black -tags text
11216 bind $top.c <Configure> [list centertext $top.c]
11217 pack $top.c -side top -fill x
11218 ${NS}::frame $top.buts
11219 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11220 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11221 bind $top <Key-Return> fontok
11222 bind $top <Key-Escape> fontcan
11223 grid $top.buts.ok $top.buts.can
11224 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11225 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11226 pack $top.buts -side bottom -fill x
11227 trace add variable fontparam write chg_fontparam
11228 } else {
11229 raise $top
11230 $top.c itemconf text -text $which
11232 set i [lsearch -exact $fontlist $fontparam(family)]
11233 if {$i >= 0} {
11234 $top.f.fam selection set $i
11235 $top.f.fam see $i
11239 proc centertext {w} {
11240 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11243 proc fontok {} {
11244 global fontparam fontpref prefstop
11246 set f $fontparam(font)
11247 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11248 if {$fontparam(weight) eq "bold"} {
11249 lappend fontpref($f) "bold"
11251 if {$fontparam(slant) eq "italic"} {
11252 lappend fontpref($f) "italic"
11254 set w $prefstop.notebook.fonts.$f
11255 $w conf -text $fontparam(family) -font $fontpref($f)
11257 fontcan
11260 proc fontcan {} {
11261 global fonttop fontparam
11263 if {[info exists fonttop]} {
11264 catch {destroy $fonttop}
11265 catch {font delete sample}
11266 unset fonttop
11267 unset fontparam
11271 if {[package vsatisfies [package provide Tk] 8.6]} {
11272 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11273 # function to make use of it.
11274 proc choosefont {font which} {
11275 tk fontchooser configure -title $which -font $font \
11276 -command [list on_choosefont $font $which]
11277 tk fontchooser show
11279 proc on_choosefont {font which newfont} {
11280 global fontparam
11281 puts stderr "$font $newfont"
11282 array set f [font actual $newfont]
11283 set fontparam(which) $which
11284 set fontparam(font) $font
11285 set fontparam(family) $f(-family)
11286 set fontparam(size) $f(-size)
11287 set fontparam(weight) $f(-weight)
11288 set fontparam(slant) $f(-slant)
11289 fontok
11293 proc selfontfam {} {
11294 global fonttop fontparam
11296 set i [$fonttop.f.fam curselection]
11297 if {$i ne {}} {
11298 set fontparam(family) [$fonttop.f.fam get $i]
11302 proc chg_fontparam {v sub op} {
11303 global fontparam
11305 font config sample -$sub $fontparam($sub)
11308 # Create a property sheet tab page
11309 proc create_prefs_page {w} {
11310 global NS
11311 set parent [join [lrange [split $w .] 0 end-1] .]
11312 if {[winfo class $parent] eq "TNotebook"} {
11313 ${NS}::frame $w
11314 } else {
11315 ${NS}::labelframe $w
11319 proc prefspage_general {notebook} {
11320 global NS maxwidth maxgraphpct showneartags showlocalchanges
11321 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11322 global hideremotes want_ttk have_ttk maxrefs
11324 set page [create_prefs_page $notebook.general]
11326 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11327 grid $page.ldisp - -sticky w -pady 10
11328 ${NS}::label $page.spacer -text " "
11329 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11330 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11331 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11332 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11333 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11334 grid x $page.maxpctl $page.maxpct -sticky w
11335 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11336 -variable showlocalchanges
11337 grid x $page.showlocal -sticky w
11338 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11339 -variable autoselect
11340 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11341 grid x $page.autoselect $page.autosellen -sticky w
11342 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11343 -variable hideremotes
11344 grid x $page.hideremotes -sticky w
11346 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11347 grid $page.ddisp - -sticky w -pady 10
11348 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11349 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11350 grid x $page.tabstopl $page.tabstop -sticky w
11351 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11352 -variable showneartags
11353 grid x $page.ntag -sticky w
11354 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11355 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11356 grid x $page.maxrefsl $page.maxrefs -sticky w
11357 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11358 -variable limitdiffs
11359 grid x $page.ldiff -sticky w
11360 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11361 -variable perfile_attrs
11362 grid x $page.lattr -sticky w
11364 ${NS}::entry $page.extdifft -textvariable extdifftool
11365 ${NS}::frame $page.extdifff
11366 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11367 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11368 pack $page.extdifff.l $page.extdifff.b -side left
11369 pack configure $page.extdifff.l -padx 10
11370 grid x $page.extdifff $page.extdifft -sticky ew
11372 ${NS}::label $page.lgen -text [mc "General options"]
11373 grid $page.lgen - -sticky w -pady 10
11374 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11375 -text [mc "Use themed widgets"]
11376 if {$have_ttk} {
11377 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11378 } else {
11379 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11381 grid x $page.want_ttk $page.ttk_note -sticky w
11382 return $page
11385 proc prefspage_colors {notebook} {
11386 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11388 set page [create_prefs_page $notebook.colors]
11390 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11391 grid $page.cdisp - -sticky w -pady 10
11392 label $page.ui -padx 40 -relief sunk -background $uicolor
11393 ${NS}::button $page.uibut -text [mc "Interface"] \
11394 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11395 grid x $page.uibut $page.ui -sticky w
11396 label $page.bg -padx 40 -relief sunk -background $bgcolor
11397 ${NS}::button $page.bgbut -text [mc "Background"] \
11398 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11399 grid x $page.bgbut $page.bg -sticky w
11400 label $page.fg -padx 40 -relief sunk -background $fgcolor
11401 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11402 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11403 grid x $page.fgbut $page.fg -sticky w
11404 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11405 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11406 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11407 [list $ctext tag conf d0 -foreground]]
11408 grid x $page.diffoldbut $page.diffold -sticky w
11409 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11410 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11411 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11412 [list $ctext tag conf dresult -foreground]]
11413 grid x $page.diffnewbut $page.diffnew -sticky w
11414 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11415 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11416 -command [list choosecolor diffcolors 2 $page.hunksep \
11417 [mc "diff hunk header"] \
11418 [list $ctext tag conf hunksep -foreground]]
11419 grid x $page.hunksepbut $page.hunksep -sticky w
11420 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11421 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11422 -command [list choosecolor markbgcolor {} $page.markbgsep \
11423 [mc "marked line background"] \
11424 [list $ctext tag conf omark -background]]
11425 grid x $page.markbgbut $page.markbgsep -sticky w
11426 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11427 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11428 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11429 grid x $page.selbgbut $page.selbgsep -sticky w
11430 return $page
11433 proc prefspage_fonts {notebook} {
11434 global NS
11435 set page [create_prefs_page $notebook.fonts]
11436 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11437 grid $page.cfont - -sticky w -pady 10
11438 mkfontdisp mainfont $page [mc "Main font"]
11439 mkfontdisp textfont $page [mc "Diff display font"]
11440 mkfontdisp uifont $page [mc "User interface font"]
11441 return $page
11444 proc doprefs {} {
11445 global maxwidth maxgraphpct use_ttk NS
11446 global oldprefs prefstop showneartags showlocalchanges
11447 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11448 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11449 global hideremotes want_ttk have_ttk
11451 set top .gitkprefs
11452 set prefstop $top
11453 if {[winfo exists $top]} {
11454 raise $top
11455 return
11457 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11458 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11459 set oldprefs($v) [set $v]
11461 ttk_toplevel $top
11462 wm title $top [mc "Gitk preferences"]
11463 make_transient $top .
11465 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11466 set notebook [ttk::notebook $top.notebook]
11467 } else {
11468 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11471 lappend pages [prefspage_general $notebook] [mc "General"]
11472 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11473 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11474 set col 0
11475 foreach {page title} $pages {
11476 if {$use_notebook} {
11477 $notebook add $page -text $title
11478 } else {
11479 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11480 -text $title -command [list raise $page]]
11481 $page configure -text $title
11482 grid $btn -row 0 -column [incr col] -sticky w
11483 grid $page -row 1 -column 0 -sticky news -columnspan 100
11487 if {!$use_notebook} {
11488 grid columnconfigure $notebook 0 -weight 1
11489 grid rowconfigure $notebook 1 -weight 1
11490 raise [lindex $pages 0]
11493 grid $notebook -sticky news -padx 2 -pady 2
11494 grid rowconfigure $top 0 -weight 1
11495 grid columnconfigure $top 0 -weight 1
11497 ${NS}::frame $top.buts
11498 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11499 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11500 bind $top <Key-Return> prefsok
11501 bind $top <Key-Escape> prefscan
11502 grid $top.buts.ok $top.buts.can
11503 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11504 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11505 grid $top.buts - - -pady 10 -sticky ew
11506 grid columnconfigure $top 2 -weight 1
11507 bind $top <Visibility> [list focus $top.buts.ok]
11510 proc choose_extdiff {} {
11511 global extdifftool
11513 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11514 if {$prog ne {}} {
11515 set extdifftool $prog
11519 proc choosecolor {v vi w x cmd} {
11520 global $v
11522 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11523 -title [mc "Gitk: choose color for %s" $x]]
11524 if {$c eq {}} return
11525 $w conf -background $c
11526 lset $v $vi $c
11527 eval $cmd $c
11530 proc setselbg {c} {
11531 global bglist cflist
11532 foreach w $bglist {
11533 $w configure -selectbackground $c
11535 $cflist tag configure highlight \
11536 -background [$cflist cget -selectbackground]
11537 allcanvs itemconf secsel -fill $c
11540 # This sets the background color and the color scheme for the whole UI.
11541 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11542 # if we don't specify one ourselves, which makes the checkbuttons and
11543 # radiobuttons look bad. This chooses white for selectColor if the
11544 # background color is light, or black if it is dark.
11545 proc setui {c} {
11546 if {[tk windowingsystem] eq "win32"} { return }
11547 set bg [winfo rgb . $c]
11548 set selc black
11549 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11550 set selc white
11552 tk_setPalette background $c selectColor $selc
11555 proc setbg {c} {
11556 global bglist
11558 foreach w $bglist {
11559 $w conf -background $c
11563 proc setfg {c} {
11564 global fglist canv
11566 foreach w $fglist {
11567 $w conf -foreground $c
11569 allcanvs itemconf text -fill $c
11570 $canv itemconf circle -outline $c
11571 $canv itemconf markid -outline $c
11574 proc prefscan {} {
11575 global oldprefs prefstop
11577 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11578 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11579 global $v
11580 set $v $oldprefs($v)
11582 catch {destroy $prefstop}
11583 unset prefstop
11584 fontcan
11587 proc prefsok {} {
11588 global maxwidth maxgraphpct
11589 global oldprefs prefstop showneartags showlocalchanges
11590 global fontpref mainfont textfont uifont
11591 global limitdiffs treediffs perfile_attrs
11592 global hideremotes
11594 catch {destroy $prefstop}
11595 unset prefstop
11596 fontcan
11597 set fontchanged 0
11598 if {$mainfont ne $fontpref(mainfont)} {
11599 set mainfont $fontpref(mainfont)
11600 parsefont mainfont $mainfont
11601 eval font configure mainfont [fontflags mainfont]
11602 eval font configure mainfontbold [fontflags mainfont 1]
11603 setcoords
11604 set fontchanged 1
11606 if {$textfont ne $fontpref(textfont)} {
11607 set textfont $fontpref(textfont)
11608 parsefont textfont $textfont
11609 eval font configure textfont [fontflags textfont]
11610 eval font configure textfontbold [fontflags textfont 1]
11612 if {$uifont ne $fontpref(uifont)} {
11613 set uifont $fontpref(uifont)
11614 parsefont uifont $uifont
11615 eval font configure uifont [fontflags uifont]
11617 settabs
11618 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11619 if {$showlocalchanges} {
11620 doshowlocalchanges
11621 } else {
11622 dohidelocalchanges
11625 if {$limitdiffs != $oldprefs(limitdiffs) ||
11626 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11627 # treediffs elements are limited by path;
11628 # won't have encodings cached if perfile_attrs was just turned on
11629 catch {unset treediffs}
11631 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11632 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11633 redisplay
11634 } elseif {$showneartags != $oldprefs(showneartags) ||
11635 $limitdiffs != $oldprefs(limitdiffs)} {
11636 reselectline
11638 if {$hideremotes != $oldprefs(hideremotes)} {
11639 rereadrefs
11643 proc formatdate {d} {
11644 global datetimeformat
11645 if {$d ne {}} {
11646 # If $datetimeformat includes a timezone, display in the
11647 # timezone of the argument. Otherwise, display in local time.
11648 if {[string match {*%[zZ]*} $datetimeformat]} {
11649 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11650 # Tcl < 8.5 does not support -timezone. Emulate it by
11651 # setting TZ (e.g. TZ=<-0430>+04:30).
11652 global env
11653 if {[info exists env(TZ)]} {
11654 set savedTZ $env(TZ)
11656 set zone [lindex $d 1]
11657 set sign [string map {+ - - +} [string index $zone 0]]
11658 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11659 set d [clock format [lindex $d 0] -format $datetimeformat]
11660 if {[info exists savedTZ]} {
11661 set env(TZ) $savedTZ
11662 } else {
11663 unset env(TZ)
11666 } else {
11667 set d [clock format [lindex $d 0] -format $datetimeformat]
11670 return $d
11673 # This list of encoding names and aliases is distilled from
11674 # http://www.iana.org/assignments/character-sets.
11675 # Not all of them are supported by Tcl.
11676 set encoding_aliases {
11677 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11678 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11679 { ISO-10646-UTF-1 csISO10646UTF1 }
11680 { ISO_646.basic:1983 ref csISO646basic1983 }
11681 { INVARIANT csINVARIANT }
11682 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11683 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11684 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11685 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11686 { NATS-DANO iso-ir-9-1 csNATSDANO }
11687 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11688 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11689 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11690 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11691 { ISO-2022-KR csISO2022KR }
11692 { EUC-KR csEUCKR }
11693 { ISO-2022-JP csISO2022JP }
11694 { ISO-2022-JP-2 csISO2022JP2 }
11695 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11696 csISO13JISC6220jp }
11697 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11698 { IT iso-ir-15 ISO646-IT csISO15Italian }
11699 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11700 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11701 { greek7-old iso-ir-18 csISO18Greek7Old }
11702 { latin-greek iso-ir-19 csISO19LatinGreek }
11703 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11704 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11705 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11706 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11707 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11708 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11709 { INIS iso-ir-49 csISO49INIS }
11710 { INIS-8 iso-ir-50 csISO50INIS8 }
11711 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11712 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11713 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11714 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11715 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11716 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11717 csISO60Norwegian1 }
11718 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11719 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11720 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11721 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11722 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11723 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11724 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11725 { greek7 iso-ir-88 csISO88Greek7 }
11726 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11727 { iso-ir-90 csISO90 }
11728 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11729 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11730 csISO92JISC62991984b }
11731 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11732 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11733 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11734 csISO95JIS62291984handadd }
11735 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11736 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11737 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11738 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11739 CP819 csISOLatin1 }
11740 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11741 { T.61-7bit iso-ir-102 csISO102T617bit }
11742 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11743 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11744 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11745 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11746 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11747 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11748 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11749 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11750 arabic csISOLatinArabic }
11751 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11752 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11753 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11754 greek greek8 csISOLatinGreek }
11755 { T.101-G2 iso-ir-128 csISO128T101G2 }
11756 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11757 csISOLatinHebrew }
11758 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11759 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11760 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11761 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11762 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11763 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11764 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11765 csISOLatinCyrillic }
11766 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11767 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11768 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11769 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11770 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11771 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11772 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11773 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11774 { ISO_10367-box iso-ir-155 csISO10367Box }
11775 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11776 { latin-lap lap iso-ir-158 csISO158Lap }
11777 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11778 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11779 { us-dk csUSDK }
11780 { dk-us csDKUS }
11781 { JIS_X0201 X0201 csHalfWidthKatakana }
11782 { KSC5636 ISO646-KR csKSC5636 }
11783 { ISO-10646-UCS-2 csUnicode }
11784 { ISO-10646-UCS-4 csUCS4 }
11785 { DEC-MCS dec csDECMCS }
11786 { hp-roman8 roman8 r8 csHPRoman8 }
11787 { macintosh mac csMacintosh }
11788 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11789 csIBM037 }
11790 { IBM038 EBCDIC-INT cp038 csIBM038 }
11791 { IBM273 CP273 csIBM273 }
11792 { IBM274 EBCDIC-BE CP274 csIBM274 }
11793 { IBM275 EBCDIC-BR cp275 csIBM275 }
11794 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11795 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11796 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11797 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11798 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11799 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11800 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11801 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11802 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11803 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11804 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11805 { IBM437 cp437 437 csPC8CodePage437 }
11806 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11807 { IBM775 cp775 csPC775Baltic }
11808 { IBM850 cp850 850 csPC850Multilingual }
11809 { IBM851 cp851 851 csIBM851 }
11810 { IBM852 cp852 852 csPCp852 }
11811 { IBM855 cp855 855 csIBM855 }
11812 { IBM857 cp857 857 csIBM857 }
11813 { IBM860 cp860 860 csIBM860 }
11814 { IBM861 cp861 861 cp-is csIBM861 }
11815 { IBM862 cp862 862 csPC862LatinHebrew }
11816 { IBM863 cp863 863 csIBM863 }
11817 { IBM864 cp864 csIBM864 }
11818 { IBM865 cp865 865 csIBM865 }
11819 { IBM866 cp866 866 csIBM866 }
11820 { IBM868 CP868 cp-ar csIBM868 }
11821 { IBM869 cp869 869 cp-gr csIBM869 }
11822 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11823 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11824 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11825 { IBM891 cp891 csIBM891 }
11826 { IBM903 cp903 csIBM903 }
11827 { IBM904 cp904 904 csIBBM904 }
11828 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11829 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11830 { IBM1026 CP1026 csIBM1026 }
11831 { EBCDIC-AT-DE csIBMEBCDICATDE }
11832 { EBCDIC-AT-DE-A csEBCDICATDEA }
11833 { EBCDIC-CA-FR csEBCDICCAFR }
11834 { EBCDIC-DK-NO csEBCDICDKNO }
11835 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11836 { EBCDIC-FI-SE csEBCDICFISE }
11837 { EBCDIC-FI-SE-A csEBCDICFISEA }
11838 { EBCDIC-FR csEBCDICFR }
11839 { EBCDIC-IT csEBCDICIT }
11840 { EBCDIC-PT csEBCDICPT }
11841 { EBCDIC-ES csEBCDICES }
11842 { EBCDIC-ES-A csEBCDICESA }
11843 { EBCDIC-ES-S csEBCDICESS }
11844 { EBCDIC-UK csEBCDICUK }
11845 { EBCDIC-US csEBCDICUS }
11846 { UNKNOWN-8BIT csUnknown8BiT }
11847 { MNEMONIC csMnemonic }
11848 { MNEM csMnem }
11849 { VISCII csVISCII }
11850 { VIQR csVIQR }
11851 { KOI8-R csKOI8R }
11852 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11853 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11854 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11855 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11856 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11857 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11858 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11859 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11860 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11861 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11862 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11863 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11864 { IBM1047 IBM-1047 }
11865 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11866 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11867 { UNICODE-1-1 csUnicode11 }
11868 { CESU-8 csCESU-8 }
11869 { BOCU-1 csBOCU-1 }
11870 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11871 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11872 l8 }
11873 { ISO-8859-15 ISO_8859-15 Latin-9 }
11874 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11875 { GBK CP936 MS936 windows-936 }
11876 { JIS_Encoding csJISEncoding }
11877 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11878 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11879 EUC-JP }
11880 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11881 { ISO-10646-UCS-Basic csUnicodeASCII }
11882 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11883 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11884 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11885 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11886 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11887 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11888 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11889 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11890 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11891 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11892 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11893 { Ventura-US csVenturaUS }
11894 { Ventura-International csVenturaInternational }
11895 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11896 { PC8-Turkish csPC8Turkish }
11897 { IBM-Symbols csIBMSymbols }
11898 { IBM-Thai csIBMThai }
11899 { HP-Legal csHPLegal }
11900 { HP-Pi-font csHPPiFont }
11901 { HP-Math8 csHPMath8 }
11902 { Adobe-Symbol-Encoding csHPPSMath }
11903 { HP-DeskTop csHPDesktop }
11904 { Ventura-Math csVenturaMath }
11905 { Microsoft-Publishing csMicrosoftPublishing }
11906 { Windows-31J csWindows31J }
11907 { GB2312 csGB2312 }
11908 { Big5 csBig5 }
11911 proc tcl_encoding {enc} {
11912 global encoding_aliases tcl_encoding_cache
11913 if {[info exists tcl_encoding_cache($enc)]} {
11914 return $tcl_encoding_cache($enc)
11916 set names [encoding names]
11917 set lcnames [string tolower $names]
11918 set enc [string tolower $enc]
11919 set i [lsearch -exact $lcnames $enc]
11920 if {$i < 0} {
11921 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11922 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11923 set i [lsearch -exact $lcnames $encx]
11926 if {$i < 0} {
11927 foreach l $encoding_aliases {
11928 set ll [string tolower $l]
11929 if {[lsearch -exact $ll $enc] < 0} continue
11930 # look through the aliases for one that tcl knows about
11931 foreach e $ll {
11932 set i [lsearch -exact $lcnames $e]
11933 if {$i < 0} {
11934 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11935 set i [lsearch -exact $lcnames $ex]
11938 if {$i >= 0} break
11940 break
11943 set tclenc {}
11944 if {$i >= 0} {
11945 set tclenc [lindex $names $i]
11947 set tcl_encoding_cache($enc) $tclenc
11948 return $tclenc
11951 proc gitattr {path attr default} {
11952 global path_attr_cache
11953 if {[info exists path_attr_cache($attr,$path)]} {
11954 set r $path_attr_cache($attr,$path)
11955 } else {
11956 set r "unspecified"
11957 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11958 regexp "(.*): $attr: (.*)" $line m f r
11960 set path_attr_cache($attr,$path) $r
11962 if {$r eq "unspecified"} {
11963 return $default
11965 return $r
11968 proc cache_gitattr {attr pathlist} {
11969 global path_attr_cache
11970 set newlist {}
11971 foreach path $pathlist {
11972 if {![info exists path_attr_cache($attr,$path)]} {
11973 lappend newlist $path
11976 set lim 1000
11977 if {[tk windowingsystem] == "win32"} {
11978 # windows has a 32k limit on the arguments to a command...
11979 set lim 30
11981 while {$newlist ne {}} {
11982 set head [lrange $newlist 0 [expr {$lim - 1}]]
11983 set newlist [lrange $newlist $lim end]
11984 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11985 foreach row [split $rlist "\n"] {
11986 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11987 if {[string index $path 0] eq "\""} {
11988 set path [encoding convertfrom [lindex $path 0]]
11990 set path_attr_cache($attr,$path) $value
11997 proc get_path_encoding {path} {
11998 global gui_encoding perfile_attrs
11999 set tcl_enc $gui_encoding
12000 if {$path ne {} && $perfile_attrs} {
12001 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12002 if {$enc2 ne {}} {
12003 set tcl_enc $enc2
12006 return $tcl_enc
12009 # First check that Tcl/Tk is recent enough
12010 if {[catch {package require Tk 8.4} err]} {
12011 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12012 Gitk requires at least Tcl/Tk 8.4." list
12013 exit 1
12016 # on OSX bring the current Wish process window to front
12017 if {[tk windowingsystem] eq "aqua"} {
12018 exec osascript -e [format {
12019 tell application "System Events"
12020 set frontmost of processes whose unix id is %d to true
12021 end tell
12022 } [pid] ]
12025 # Unset GIT_TRACE var if set
12026 if { [info exists ::env(GIT_TRACE)] } {
12027 unset ::env(GIT_TRACE)
12030 # defaults...
12031 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12033 set gitencoding {}
12034 catch {
12035 set gitencoding [exec git config --get i18n.commitencoding]
12037 catch {
12038 set gitencoding [exec git config --get i18n.logoutputencoding]
12040 if {$gitencoding == ""} {
12041 set gitencoding "utf-8"
12043 set tclencoding [tcl_encoding $gitencoding]
12044 if {$tclencoding == {}} {
12045 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12048 set gui_encoding [encoding system]
12049 catch {
12050 set enc [exec git config --get gui.encoding]
12051 if {$enc ne {}} {
12052 set tclenc [tcl_encoding $enc]
12053 if {$tclenc ne {}} {
12054 set gui_encoding $tclenc
12055 } else {
12056 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12061 set log_showroot true
12062 catch {
12063 set log_showroot [exec git config --bool --get log.showroot]
12066 if {[tk windowingsystem] eq "aqua"} {
12067 set mainfont {{Lucida Grande} 9}
12068 set textfont {Monaco 9}
12069 set uifont {{Lucida Grande} 9 bold}
12070 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12071 # fontconfig!
12072 set mainfont {sans 9}
12073 set textfont {monospace 9}
12074 set uifont {sans 9 bold}
12075 } else {
12076 set mainfont {Helvetica 9}
12077 set textfont {Courier 9}
12078 set uifont {Helvetica 9 bold}
12080 set tabstop 8
12081 set findmergefiles 0
12082 set maxgraphpct 50
12083 set maxwidth 16
12084 set revlistorder 0
12085 set fastdate 0
12086 set uparrowlen 5
12087 set downarrowlen 5
12088 set mingaplen 100
12089 set cmitmode "patch"
12090 set wrapcomment "none"
12091 set showneartags 1
12092 set hideremotes 0
12093 set maxrefs 20
12094 set visiblerefs {"master"}
12095 set maxlinelen 200
12096 set showlocalchanges 1
12097 set limitdiffs 1
12098 set datetimeformat "%Y-%m-%d %H:%M:%S"
12099 set autoselect 1
12100 set autosellen 40
12101 set perfile_attrs 0
12102 set want_ttk 1
12104 if {[tk windowingsystem] eq "aqua"} {
12105 set extdifftool "opendiff"
12106 } else {
12107 set extdifftool "meld"
12110 set colors {green red blue magenta darkgrey brown orange}
12111 if {[tk windowingsystem] eq "win32"} {
12112 set uicolor SystemButtonFace
12113 set uifgcolor SystemButtonText
12114 set uifgdisabledcolor SystemDisabledText
12115 set bgcolor SystemWindow
12116 set fgcolor SystemWindowText
12117 set selectbgcolor SystemHighlight
12118 } else {
12119 set uicolor grey85
12120 set uifgcolor black
12121 set uifgdisabledcolor "#999"
12122 set bgcolor white
12123 set fgcolor black
12124 set selectbgcolor gray85
12126 set diffcolors {red "#00a000" blue}
12127 set diffcontext 3
12128 set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12129 set ignorespace 0
12130 set worddiff ""
12131 set markbgcolor "#e0e0ff"
12133 set headbgcolor green
12134 set headfgcolor black
12135 set headoutlinecolor black
12136 set remotebgcolor #ffddaa
12137 set tagbgcolor yellow
12138 set tagfgcolor black
12139 set tagoutlinecolor black
12140 set reflinecolor black
12141 set filesepbgcolor #aaaaaa
12142 set filesepfgcolor black
12143 set linehoverbgcolor #ffff80
12144 set linehoverfgcolor black
12145 set linehoveroutlinecolor black
12146 set mainheadcirclecolor yellow
12147 set workingfilescirclecolor red
12148 set indexcirclecolor green
12149 set circlecolors {white blue gray blue blue}
12150 set linkfgcolor blue
12151 set circleoutlinecolor $fgcolor
12152 set foundbgcolor yellow
12153 set currentsearchhitbgcolor orange
12155 # button for popping up context menus
12156 if {[tk windowingsystem] eq "aqua"} {
12157 set ctxbut <Button-2>
12158 } else {
12159 set ctxbut <Button-3>
12162 ## For msgcat loading, first locate the installation location.
12163 if { [info exists ::env(GITK_MSGSDIR)] } {
12164 ## Msgsdir was manually set in the environment.
12165 set gitk_msgsdir $::env(GITK_MSGSDIR)
12166 } else {
12167 ## Let's guess the prefix from argv0.
12168 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12169 set gitk_libdir [file join $gitk_prefix share gitk lib]
12170 set gitk_msgsdir [file join $gitk_libdir msgs]
12171 unset gitk_prefix
12174 ## Internationalization (i18n) through msgcat and gettext. See
12175 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12176 package require msgcat
12177 namespace import ::msgcat::mc
12178 ## And eventually load the actual message catalog
12179 ::msgcat::mcload $gitk_msgsdir
12181 catch {
12182 # follow the XDG base directory specification by default. See
12183 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12184 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12185 # XDG_CONFIG_HOME environment variable is set
12186 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12187 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12188 } else {
12189 # default XDG_CONFIG_HOME
12190 set config_file "~/.config/git/gitk"
12191 set config_file_tmp "~/.config/git/gitk-tmp"
12193 if {![file exists $config_file]} {
12194 # for backward compatibility use the old config file if it exists
12195 if {[file exists "~/.gitk"]} {
12196 set config_file "~/.gitk"
12197 set config_file_tmp "~/.gitk-tmp"
12198 } elseif {![file exists [file dirname $config_file]]} {
12199 file mkdir [file dirname $config_file]
12202 source $config_file
12204 config_check_tmp_exists 50
12206 set config_variables {
12207 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12208 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12209 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12210 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12211 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12212 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12213 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12214 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12215 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12216 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12218 foreach var $config_variables {
12219 config_init_trace $var
12220 trace add variable $var write config_variable_change_cb
12223 parsefont mainfont $mainfont
12224 eval font create mainfont [fontflags mainfont]
12225 eval font create mainfontbold [fontflags mainfont 1]
12227 parsefont textfont $textfont
12228 eval font create textfont [fontflags textfont]
12229 eval font create textfontbold [fontflags textfont 1]
12231 parsefont uifont $uifont
12232 eval font create uifont [fontflags uifont]
12234 setui $uicolor
12236 setoptions
12238 # check that we can find a .git directory somewhere...
12239 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12240 show_error {} . [mc "Cannot find a git repository here."]
12241 exit 1
12244 set selecthead {}
12245 set selectheadid {}
12247 set revtreeargs {}
12248 set cmdline_files {}
12249 set i 0
12250 set revtreeargscmd {}
12251 foreach arg $argv {
12252 switch -glob -- $arg {
12253 "" { }
12254 "--" {
12255 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12256 break
12258 "--select-commit=*" {
12259 set selecthead [string range $arg 16 end]
12261 "--argscmd=*" {
12262 set revtreeargscmd [string range $arg 10 end]
12264 default {
12265 lappend revtreeargs $arg
12268 incr i
12271 if {$selecthead eq "HEAD"} {
12272 set selecthead {}
12275 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12276 # no -- on command line, but some arguments (other than --argscmd)
12277 if {[catch {
12278 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12279 set cmdline_files [split $f "\n"]
12280 set n [llength $cmdline_files]
12281 set revtreeargs [lrange $revtreeargs 0 end-$n]
12282 # Unfortunately git rev-parse doesn't produce an error when
12283 # something is both a revision and a filename. To be consistent
12284 # with git log and git rev-list, check revtreeargs for filenames.
12285 foreach arg $revtreeargs {
12286 if {[file exists $arg]} {
12287 show_error {} . [mc "Ambiguous argument '%s': both revision\
12288 and filename" $arg]
12289 exit 1
12292 } err]} {
12293 # unfortunately we get both stdout and stderr in $err,
12294 # so look for "fatal:".
12295 set i [string first "fatal:" $err]
12296 if {$i > 0} {
12297 set err [string range $err [expr {$i + 6}] end]
12299 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12300 exit 1
12304 set nullid "0000000000000000000000000000000000000000"
12305 set nullid2 "0000000000000000000000000000000000000001"
12306 set nullfile "/dev/null"
12308 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12309 if {![info exists have_ttk]} {
12310 set have_ttk [llength [info commands ::ttk::style]]
12312 set use_ttk [expr {$have_ttk && $want_ttk}]
12313 set NS [expr {$use_ttk ? "ttk" : ""}]
12315 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12317 set show_notes {}
12318 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12319 set show_notes "--show-notes"
12322 set appname "gitk"
12324 set runq {}
12325 set history {}
12326 set historyindex 0
12327 set fh_serial 0
12328 set nhl_names {}
12329 set highlight_paths {}
12330 set findpattern {}
12331 set searchdirn -forwards
12332 set boldids {}
12333 set boldnameids {}
12334 set diffelide {0 0}
12335 set markingmatches 0
12336 set linkentercount 0
12337 set need_redisplay 0
12338 set nrows_drawn 0
12339 set firsttabstop 0
12341 set nextviewnum 1
12342 set curview 0
12343 set selectedview 0
12344 set selectedhlview [mc "None"]
12345 set highlight_related [mc "None"]
12346 set highlight_files {}
12347 set viewfiles(0) {}
12348 set viewperm(0) 0
12349 set viewchanged(0) 0
12350 set viewargs(0) {}
12351 set viewargscmd(0) {}
12353 set selectedline {}
12354 set numcommits 0
12355 set loginstance 0
12356 set cmdlineok 0
12357 set stopped 0
12358 set stuffsaved 0
12359 set patchnum 0
12360 set lserial 0
12361 set hasworktree [hasworktree]
12362 set cdup {}
12363 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12364 set cdup [exec git rev-parse --show-cdup]
12366 set worktree [exec git rev-parse --show-toplevel]
12367 setcoords
12368 makewindow
12369 catch {
12370 image create photo gitlogo -width 16 -height 16
12372 image create photo gitlogominus -width 4 -height 2
12373 gitlogominus put #C00000 -to 0 0 4 2
12374 gitlogo copy gitlogominus -to 1 5
12375 gitlogo copy gitlogominus -to 6 5
12376 gitlogo copy gitlogominus -to 11 5
12377 image delete gitlogominus
12379 image create photo gitlogoplus -width 4 -height 4
12380 gitlogoplus put #008000 -to 1 0 3 4
12381 gitlogoplus put #008000 -to 0 1 4 3
12382 gitlogo copy gitlogoplus -to 1 9
12383 gitlogo copy gitlogoplus -to 6 9
12384 gitlogo copy gitlogoplus -to 11 9
12385 image delete gitlogoplus
12387 image create photo gitlogo32 -width 32 -height 32
12388 gitlogo32 copy gitlogo -zoom 2 2
12390 wm iconphoto . -default gitlogo gitlogo32
12392 # wait for the window to become visible
12393 tkwait visibility .
12394 wm title . "$appname: [reponame]"
12395 update
12396 readrefs
12398 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12399 # create a view for the files/dirs specified on the command line
12400 set curview 1
12401 set selectedview 1
12402 set nextviewnum 2
12403 set viewname(1) [mc "Command line"]
12404 set viewfiles(1) $cmdline_files
12405 set viewargs(1) $revtreeargs
12406 set viewargscmd(1) $revtreeargscmd
12407 set viewperm(1) 0
12408 set viewchanged(1) 0
12409 set vdatemode(1) 0
12410 addviewmenu 1
12411 .bar.view entryconf [mca "Edit view..."] -state normal
12412 .bar.view entryconf [mca "Delete view"] -state normal
12415 if {[info exists permviews]} {
12416 foreach v $permviews {
12417 set n $nextviewnum
12418 incr nextviewnum
12419 set viewname($n) [lindex $v 0]
12420 set viewfiles($n) [lindex $v 1]
12421 set viewargs($n) [lindex $v 2]
12422 set viewargscmd($n) [lindex $v 3]
12423 set viewperm($n) 1
12424 set viewchanged($n) 0
12425 addviewmenu $n
12429 if {[tk windowingsystem] eq "win32"} {
12430 focus -force .
12433 getcommits {}
12435 # Local variables:
12436 # mode: tcl
12437 # indent-tabs-mode: t
12438 # tab-width: 8
12439 # End: