Git 2.6-rc1
[git.git] / gitk-git / gitk
blob9a2daf3c55b2292239ec9667a919b5121a7e965e
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 {igrep b .. "--invert-grep" {mc "Matches none Commit Info criteria"}}
4070 {changes_l l + {} {mc "Changes to Files:"}}
4071 {pickaxe_s r0 . {} {mc "Fixed String"}}
4072 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4073 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4074 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4075 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4076 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4077 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4078 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4079 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4080 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4081 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4082 {lright b . "--left-right" {mc "Mark branch sides"}}
4083 {first b . "--first-parent" {mc "Limit to first parent"}}
4084 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4085 {args t50 *. {} {mc "Additional arguments to git log:"}}
4086 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4087 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4090 # Convert $newviewopts($n, ...) into args for git log.
4091 proc encode_view_opts {n} {
4092 global known_view_options newviewopts
4094 set rargs [list]
4095 foreach opt $known_view_options {
4096 set patterns [lindex $opt 3]
4097 if {$patterns eq {}} continue
4098 set pattern [lindex $patterns 0]
4100 if {[lindex $opt 1] eq "b"} {
4101 set val $newviewopts($n,[lindex $opt 0])
4102 if {$val} {
4103 lappend rargs $pattern
4105 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4106 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4107 set val $newviewopts($n,$button_id)
4108 if {$val eq $value} {
4109 lappend rargs $pattern
4111 } else {
4112 set val $newviewopts($n,[lindex $opt 0])
4113 set val [string trim $val]
4114 if {$val ne {}} {
4115 set pfix [string range $pattern 0 end-1]
4116 lappend rargs $pfix$val
4120 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4121 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4124 # Fill $newviewopts($n, ...) based on args for git log.
4125 proc decode_view_opts {n view_args} {
4126 global known_view_options newviewopts
4128 foreach opt $known_view_options {
4129 set id [lindex $opt 0]
4130 if {[lindex $opt 1] eq "b"} {
4131 # Checkboxes
4132 set val 0
4133 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4134 # Radiobuttons
4135 regexp {^(.*_)} $id uselessvar id
4136 set val 0
4137 } else {
4138 # Text fields
4139 set val {}
4141 set newviewopts($n,$id) $val
4143 set oargs [list]
4144 set refargs [list]
4145 foreach arg $view_args {
4146 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4147 && ![info exists found(limit)]} {
4148 set newviewopts($n,limit) $cnt
4149 set found(limit) 1
4150 continue
4152 catch { unset val }
4153 foreach opt $known_view_options {
4154 set id [lindex $opt 0]
4155 if {[info exists found($id)]} continue
4156 foreach pattern [lindex $opt 3] {
4157 if {![string match $pattern $arg]} continue
4158 if {[lindex $opt 1] eq "b"} {
4159 # Check buttons
4160 set val 1
4161 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4162 # Radio buttons
4163 regexp {^(.*_)} $id uselessvar id
4164 set val $num
4165 } else {
4166 # Text input fields
4167 set size [string length $pattern]
4168 set val [string range $arg [expr {$size-1}] end]
4170 set newviewopts($n,$id) $val
4171 set found($id) 1
4172 break
4174 if {[info exists val]} break
4176 if {[info exists val]} continue
4177 if {[regexp {^-} $arg]} {
4178 lappend oargs $arg
4179 } else {
4180 lappend refargs $arg
4183 set newviewopts($n,refs) [shellarglist $refargs]
4184 set newviewopts($n,args) [shellarglist $oargs]
4187 proc edit_or_newview {} {
4188 global curview
4190 if {$curview > 0} {
4191 editview
4192 } else {
4193 newview 0
4197 proc editview {} {
4198 global curview
4199 global viewname viewperm newviewname newviewopts
4200 global viewargs viewargscmd
4202 set top .gitkvedit-$curview
4203 if {[winfo exists $top]} {
4204 raise $top
4205 return
4207 decode_view_opts $curview $viewargs($curview)
4208 set newviewname($curview) $viewname($curview)
4209 set newviewopts($curview,perm) $viewperm($curview)
4210 set newviewopts($curview,cmd) $viewargscmd($curview)
4211 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4214 proc vieweditor {top n title} {
4215 global newviewname newviewopts viewfiles bgcolor
4216 global known_view_options NS
4218 ttk_toplevel $top
4219 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4220 make_transient $top .
4222 # View name
4223 ${NS}::frame $top.nfr
4224 ${NS}::label $top.nl -text [mc "View Name"]
4225 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4226 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4227 pack $top.nl -in $top.nfr -side left -padx {0 5}
4228 pack $top.name -in $top.nfr -side left -padx {0 25}
4230 # View options
4231 set cframe $top.nfr
4232 set cexpand 0
4233 set cnt 0
4234 foreach opt $known_view_options {
4235 set id [lindex $opt 0]
4236 set type [lindex $opt 1]
4237 set flags [lindex $opt 2]
4238 set title [eval [lindex $opt 4]]
4239 set lxpad 0
4241 if {$flags eq "+" || $flags eq "*"} {
4242 set cframe $top.fr$cnt
4243 incr cnt
4244 ${NS}::frame $cframe
4245 pack $cframe -in $top -fill x -pady 3 -padx 3
4246 set cexpand [expr {$flags eq "*"}]
4247 } elseif {$flags eq ".." || $flags eq "*."} {
4248 set cframe $top.fr$cnt
4249 incr cnt
4250 ${NS}::frame $cframe
4251 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4252 set cexpand [expr {$flags eq "*."}]
4253 } else {
4254 set lxpad 5
4257 if {$type eq "l"} {
4258 ${NS}::label $cframe.l_$id -text $title
4259 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4260 } elseif {$type eq "b"} {
4261 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4262 pack $cframe.c_$id -in $cframe -side left \
4263 -padx [list $lxpad 0] -expand $cexpand -anchor w
4264 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4265 regexp {^(.*_)} $id uselessvar button_id
4266 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4267 pack $cframe.c_$id -in $cframe -side left \
4268 -padx [list $lxpad 0] -expand $cexpand -anchor w
4269 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4270 ${NS}::label $cframe.l_$id -text $title
4271 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4272 -textvariable newviewopts($n,$id)
4273 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4274 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4275 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4276 ${NS}::label $cframe.l_$id -text $title
4277 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4278 -textvariable newviewopts($n,$id)
4279 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4280 pack $cframe.e_$id -in $cframe -side top -fill x
4281 } elseif {$type eq "path"} {
4282 ${NS}::label $top.l -text $title
4283 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4284 text $top.t -width 40 -height 5 -background $bgcolor
4285 if {[info exists viewfiles($n)]} {
4286 foreach f $viewfiles($n) {
4287 $top.t insert end $f
4288 $top.t insert end "\n"
4290 $top.t delete {end - 1c} end
4291 $top.t mark set insert 0.0
4293 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4297 ${NS}::frame $top.buts
4298 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4299 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4300 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4301 bind $top <Control-Return> [list newviewok $top $n]
4302 bind $top <F5> [list newviewok $top $n 1]
4303 bind $top <Escape> [list destroy $top]
4304 grid $top.buts.ok $top.buts.apply $top.buts.can
4305 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4306 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4307 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4308 pack $top.buts -in $top -side top -fill x
4309 focus $top.t
4312 proc doviewmenu {m first cmd op argv} {
4313 set nmenu [$m index end]
4314 for {set i $first} {$i <= $nmenu} {incr i} {
4315 if {[$m entrycget $i -command] eq $cmd} {
4316 eval $m $op $i $argv
4317 break
4322 proc allviewmenus {n op args} {
4323 # global viewhlmenu
4325 doviewmenu .bar.view 5 [list showview $n] $op $args
4326 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4329 proc newviewok {top n {apply 0}} {
4330 global nextviewnum newviewperm newviewname newishighlight
4331 global viewname viewfiles viewperm viewchanged selectedview curview
4332 global viewargs viewargscmd newviewopts viewhlmenu
4334 if {[catch {
4335 set newargs [encode_view_opts $n]
4336 } err]} {
4337 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4338 return
4340 set files {}
4341 foreach f [split [$top.t get 0.0 end] "\n"] {
4342 set ft [string trim $f]
4343 if {$ft ne {}} {
4344 lappend files $ft
4347 if {![info exists viewfiles($n)]} {
4348 # creating a new view
4349 incr nextviewnum
4350 set viewname($n) $newviewname($n)
4351 set viewperm($n) $newviewopts($n,perm)
4352 set viewchanged($n) 1
4353 set viewfiles($n) $files
4354 set viewargs($n) $newargs
4355 set viewargscmd($n) $newviewopts($n,cmd)
4356 addviewmenu $n
4357 if {!$newishighlight} {
4358 run showview $n
4359 } else {
4360 run addvhighlight $n
4362 } else {
4363 # editing an existing view
4364 set viewperm($n) $newviewopts($n,perm)
4365 set viewchanged($n) 1
4366 if {$newviewname($n) ne $viewname($n)} {
4367 set viewname($n) $newviewname($n)
4368 doviewmenu .bar.view 5 [list showview $n] \
4369 entryconf [list -label $viewname($n)]
4370 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4371 # entryconf [list -label $viewname($n) -value $viewname($n)]
4373 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4374 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4375 set viewfiles($n) $files
4376 set viewargs($n) $newargs
4377 set viewargscmd($n) $newviewopts($n,cmd)
4378 if {$curview == $n} {
4379 run reloadcommits
4383 if {$apply} return
4384 catch {destroy $top}
4387 proc delview {} {
4388 global curview viewperm hlview selectedhlview viewchanged
4390 if {$curview == 0} return
4391 if {[info exists hlview] && $hlview == $curview} {
4392 set selectedhlview [mc "None"]
4393 unset hlview
4395 allviewmenus $curview delete
4396 set viewperm($curview) 0
4397 set viewchanged($curview) 1
4398 showview 0
4401 proc addviewmenu {n} {
4402 global viewname viewhlmenu
4404 .bar.view add radiobutton -label $viewname($n) \
4405 -command [list showview $n] -variable selectedview -value $n
4406 #$viewhlmenu add radiobutton -label $viewname($n) \
4407 # -command [list addvhighlight $n] -variable selectedhlview
4410 proc showview {n} {
4411 global curview cached_commitrow ordertok
4412 global displayorder parentlist rowidlist rowisopt rowfinal
4413 global colormap rowtextx nextcolor canvxmax
4414 global numcommits viewcomplete
4415 global selectedline currentid canv canvy0
4416 global treediffs
4417 global pending_select mainheadid
4418 global commitidx
4419 global selectedview
4420 global hlview selectedhlview commitinterest
4422 if {$n == $curview} return
4423 set selid {}
4424 set ymax [lindex [$canv cget -scrollregion] 3]
4425 set span [$canv yview]
4426 set ytop [expr {[lindex $span 0] * $ymax}]
4427 set ybot [expr {[lindex $span 1] * $ymax}]
4428 set yscreen [expr {($ybot - $ytop) / 2}]
4429 if {$selectedline ne {}} {
4430 set selid $currentid
4431 set y [yc $selectedline]
4432 if {$ytop < $y && $y < $ybot} {
4433 set yscreen [expr {$y - $ytop}]
4435 } elseif {[info exists pending_select]} {
4436 set selid $pending_select
4437 unset pending_select
4439 unselectline
4440 normalline
4441 catch {unset treediffs}
4442 clear_display
4443 if {[info exists hlview] && $hlview == $n} {
4444 unset hlview
4445 set selectedhlview [mc "None"]
4447 catch {unset commitinterest}
4448 catch {unset cached_commitrow}
4449 catch {unset ordertok}
4451 set curview $n
4452 set selectedview $n
4453 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4454 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4456 run refill_reflist
4457 if {![info exists viewcomplete($n)]} {
4458 getcommits $selid
4459 return
4462 set displayorder {}
4463 set parentlist {}
4464 set rowidlist {}
4465 set rowisopt {}
4466 set rowfinal {}
4467 set numcommits $commitidx($n)
4469 catch {unset colormap}
4470 catch {unset rowtextx}
4471 set nextcolor 0
4472 set canvxmax [$canv cget -width]
4473 set curview $n
4474 set row 0
4475 setcanvscroll
4476 set yf 0
4477 set row {}
4478 if {$selid ne {} && [commitinview $selid $n]} {
4479 set row [rowofcommit $selid]
4480 # try to get the selected row in the same position on the screen
4481 set ymax [lindex [$canv cget -scrollregion] 3]
4482 set ytop [expr {[yc $row] - $yscreen}]
4483 if {$ytop < 0} {
4484 set ytop 0
4486 set yf [expr {$ytop * 1.0 / $ymax}]
4488 allcanvs yview moveto $yf
4489 drawvisible
4490 if {$row ne {}} {
4491 selectline $row 0
4492 } elseif {!$viewcomplete($n)} {
4493 reset_pending_select $selid
4494 } else {
4495 reset_pending_select {}
4497 if {[commitinview $pending_select $curview]} {
4498 selectline [rowofcommit $pending_select] 1
4499 } else {
4500 set row [first_real_row]
4501 if {$row < $numcommits} {
4502 selectline $row 0
4506 if {!$viewcomplete($n)} {
4507 if {$numcommits == 0} {
4508 show_status [mc "Reading commits..."]
4510 } elseif {$numcommits == 0} {
4511 show_status [mc "No commits selected"]
4515 # Stuff relating to the highlighting facility
4517 proc ishighlighted {id} {
4518 global vhighlights fhighlights nhighlights rhighlights
4520 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4521 return $nhighlights($id)
4523 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4524 return $vhighlights($id)
4526 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4527 return $fhighlights($id)
4529 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4530 return $rhighlights($id)
4532 return 0
4535 proc bolden {id font} {
4536 global canv linehtag currentid boldids need_redisplay markedid
4538 # need_redisplay = 1 means the display is stale and about to be redrawn
4539 if {$need_redisplay} return
4540 lappend boldids $id
4541 $canv itemconf $linehtag($id) -font $font
4542 if {[info exists currentid] && $id eq $currentid} {
4543 $canv delete secsel
4544 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4545 -outline {{}} -tags secsel \
4546 -fill [$canv cget -selectbackground]]
4547 $canv lower $t
4549 if {[info exists markedid] && $id eq $markedid} {
4550 make_idmark $id
4554 proc bolden_name {id font} {
4555 global canv2 linentag currentid boldnameids need_redisplay
4557 if {$need_redisplay} return
4558 lappend boldnameids $id
4559 $canv2 itemconf $linentag($id) -font $font
4560 if {[info exists currentid] && $id eq $currentid} {
4561 $canv2 delete secsel
4562 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4563 -outline {{}} -tags secsel \
4564 -fill [$canv2 cget -selectbackground]]
4565 $canv2 lower $t
4569 proc unbolden {} {
4570 global boldids
4572 set stillbold {}
4573 foreach id $boldids {
4574 if {![ishighlighted $id]} {
4575 bolden $id mainfont
4576 } else {
4577 lappend stillbold $id
4580 set boldids $stillbold
4583 proc addvhighlight {n} {
4584 global hlview viewcomplete curview vhl_done commitidx
4586 if {[info exists hlview]} {
4587 delvhighlight
4589 set hlview $n
4590 if {$n != $curview && ![info exists viewcomplete($n)]} {
4591 start_rev_list $n
4593 set vhl_done $commitidx($hlview)
4594 if {$vhl_done > 0} {
4595 drawvisible
4599 proc delvhighlight {} {
4600 global hlview vhighlights
4602 if {![info exists hlview]} return
4603 unset hlview
4604 catch {unset vhighlights}
4605 unbolden
4608 proc vhighlightmore {} {
4609 global hlview vhl_done commitidx vhighlights curview
4611 set max $commitidx($hlview)
4612 set vr [visiblerows]
4613 set r0 [lindex $vr 0]
4614 set r1 [lindex $vr 1]
4615 for {set i $vhl_done} {$i < $max} {incr i} {
4616 set id [commitonrow $i $hlview]
4617 if {[commitinview $id $curview]} {
4618 set row [rowofcommit $id]
4619 if {$r0 <= $row && $row <= $r1} {
4620 if {![highlighted $row]} {
4621 bolden $id mainfontbold
4623 set vhighlights($id) 1
4627 set vhl_done $max
4628 return 0
4631 proc askvhighlight {row id} {
4632 global hlview vhighlights iddrawn
4634 if {[commitinview $id $hlview]} {
4635 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4636 bolden $id mainfontbold
4638 set vhighlights($id) 1
4639 } else {
4640 set vhighlights($id) 0
4644 proc hfiles_change {} {
4645 global highlight_files filehighlight fhighlights fh_serial
4646 global highlight_paths
4648 if {[info exists filehighlight]} {
4649 # delete previous highlights
4650 catch {close $filehighlight}
4651 unset filehighlight
4652 catch {unset fhighlights}
4653 unbolden
4654 unhighlight_filelist
4656 set highlight_paths {}
4657 after cancel do_file_hl $fh_serial
4658 incr fh_serial
4659 if {$highlight_files ne {}} {
4660 after 300 do_file_hl $fh_serial
4664 proc gdttype_change {name ix op} {
4665 global gdttype highlight_files findstring findpattern
4667 stopfinding
4668 if {$findstring ne {}} {
4669 if {$gdttype eq [mc "containing:"]} {
4670 if {$highlight_files ne {}} {
4671 set highlight_files {}
4672 hfiles_change
4674 findcom_change
4675 } else {
4676 if {$findpattern ne {}} {
4677 set findpattern {}
4678 findcom_change
4680 set highlight_files $findstring
4681 hfiles_change
4683 drawvisible
4685 # enable/disable findtype/findloc menus too
4688 proc find_change {name ix op} {
4689 global gdttype findstring highlight_files
4691 stopfinding
4692 if {$gdttype eq [mc "containing:"]} {
4693 findcom_change
4694 } else {
4695 if {$highlight_files ne $findstring} {
4696 set highlight_files $findstring
4697 hfiles_change
4700 drawvisible
4703 proc findcom_change args {
4704 global nhighlights boldnameids
4705 global findpattern findtype findstring gdttype
4707 stopfinding
4708 # delete previous highlights, if any
4709 foreach id $boldnameids {
4710 bolden_name $id mainfont
4712 set boldnameids {}
4713 catch {unset nhighlights}
4714 unbolden
4715 unmarkmatches
4716 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4717 set findpattern {}
4718 } elseif {$findtype eq [mc "Regexp"]} {
4719 set findpattern $findstring
4720 } else {
4721 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4722 $findstring]
4723 set findpattern "*$e*"
4727 proc makepatterns {l} {
4728 set ret {}
4729 foreach e $l {
4730 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4731 if {[string index $ee end] eq "/"} {
4732 lappend ret "$ee*"
4733 } else {
4734 lappend ret $ee
4735 lappend ret "$ee/*"
4738 return $ret
4741 proc do_file_hl {serial} {
4742 global highlight_files filehighlight highlight_paths gdttype fhl_list
4743 global cdup findtype
4745 if {$gdttype eq [mc "touching paths:"]} {
4746 # If "exact" match then convert backslashes to forward slashes.
4747 # Most useful to support Windows-flavoured file paths.
4748 if {$findtype eq [mc "Exact"]} {
4749 set highlight_files [string map {"\\" "/"} $highlight_files]
4751 if {[catch {set paths [shellsplit $highlight_files]}]} return
4752 set highlight_paths [makepatterns $paths]
4753 highlight_filelist
4754 set relative_paths {}
4755 foreach path $paths {
4756 lappend relative_paths [file join $cdup $path]
4758 set gdtargs [concat -- $relative_paths]
4759 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4760 set gdtargs [list "-S$highlight_files"]
4761 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4762 set gdtargs [list "-G$highlight_files"]
4763 } else {
4764 # must be "containing:", i.e. we're searching commit info
4765 return
4767 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4768 set filehighlight [open $cmd r+]
4769 fconfigure $filehighlight -blocking 0
4770 filerun $filehighlight readfhighlight
4771 set fhl_list {}
4772 drawvisible
4773 flushhighlights
4776 proc flushhighlights {} {
4777 global filehighlight fhl_list
4779 if {[info exists filehighlight]} {
4780 lappend fhl_list {}
4781 puts $filehighlight ""
4782 flush $filehighlight
4786 proc askfilehighlight {row id} {
4787 global filehighlight fhighlights fhl_list
4789 lappend fhl_list $id
4790 set fhighlights($id) -1
4791 puts $filehighlight $id
4794 proc readfhighlight {} {
4795 global filehighlight fhighlights curview iddrawn
4796 global fhl_list find_dirn
4798 if {![info exists filehighlight]} {
4799 return 0
4801 set nr 0
4802 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4803 set line [string trim $line]
4804 set i [lsearch -exact $fhl_list $line]
4805 if {$i < 0} continue
4806 for {set j 0} {$j < $i} {incr j} {
4807 set id [lindex $fhl_list $j]
4808 set fhighlights($id) 0
4810 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4811 if {$line eq {}} continue
4812 if {![commitinview $line $curview]} continue
4813 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4814 bolden $line mainfontbold
4816 set fhighlights($line) 1
4818 if {[eof $filehighlight]} {
4819 # strange...
4820 puts "oops, git diff-tree died"
4821 catch {close $filehighlight}
4822 unset filehighlight
4823 return 0
4825 if {[info exists find_dirn]} {
4826 run findmore
4828 return 1
4831 proc doesmatch {f} {
4832 global findtype findpattern
4834 if {$findtype eq [mc "Regexp"]} {
4835 return [regexp $findpattern $f]
4836 } elseif {$findtype eq [mc "IgnCase"]} {
4837 return [string match -nocase $findpattern $f]
4838 } else {
4839 return [string match $findpattern $f]
4843 proc askfindhighlight {row id} {
4844 global nhighlights commitinfo iddrawn
4845 global findloc
4846 global markingmatches
4848 if {![info exists commitinfo($id)]} {
4849 getcommit $id
4851 set info $commitinfo($id)
4852 set isbold 0
4853 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4854 foreach f $info ty $fldtypes {
4855 if {$ty eq ""} continue
4856 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4857 [doesmatch $f]} {
4858 if {$ty eq [mc "Author"]} {
4859 set isbold 2
4860 break
4862 set isbold 1
4865 if {$isbold && [info exists iddrawn($id)]} {
4866 if {![ishighlighted $id]} {
4867 bolden $id mainfontbold
4868 if {$isbold > 1} {
4869 bolden_name $id mainfontbold
4872 if {$markingmatches} {
4873 markrowmatches $row $id
4876 set nhighlights($id) $isbold
4879 proc markrowmatches {row id} {
4880 global canv canv2 linehtag linentag commitinfo findloc
4882 set headline [lindex $commitinfo($id) 0]
4883 set author [lindex $commitinfo($id) 1]
4884 $canv delete match$row
4885 $canv2 delete match$row
4886 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4887 set m [findmatches $headline]
4888 if {$m ne {}} {
4889 markmatches $canv $row $headline $linehtag($id) $m \
4890 [$canv itemcget $linehtag($id) -font] $row
4893 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4894 set m [findmatches $author]
4895 if {$m ne {}} {
4896 markmatches $canv2 $row $author $linentag($id) $m \
4897 [$canv2 itemcget $linentag($id) -font] $row
4902 proc vrel_change {name ix op} {
4903 global highlight_related
4905 rhighlight_none
4906 if {$highlight_related ne [mc "None"]} {
4907 run drawvisible
4911 # prepare for testing whether commits are descendents or ancestors of a
4912 proc rhighlight_sel {a} {
4913 global descendent desc_todo ancestor anc_todo
4914 global highlight_related
4916 catch {unset descendent}
4917 set desc_todo [list $a]
4918 catch {unset ancestor}
4919 set anc_todo [list $a]
4920 if {$highlight_related ne [mc "None"]} {
4921 rhighlight_none
4922 run drawvisible
4926 proc rhighlight_none {} {
4927 global rhighlights
4929 catch {unset rhighlights}
4930 unbolden
4933 proc is_descendent {a} {
4934 global curview children descendent desc_todo
4936 set v $curview
4937 set la [rowofcommit $a]
4938 set todo $desc_todo
4939 set leftover {}
4940 set done 0
4941 for {set i 0} {$i < [llength $todo]} {incr i} {
4942 set do [lindex $todo $i]
4943 if {[rowofcommit $do] < $la} {
4944 lappend leftover $do
4945 continue
4947 foreach nk $children($v,$do) {
4948 if {![info exists descendent($nk)]} {
4949 set descendent($nk) 1
4950 lappend todo $nk
4951 if {$nk eq $a} {
4952 set done 1
4956 if {$done} {
4957 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4958 return
4961 set descendent($a) 0
4962 set desc_todo $leftover
4965 proc is_ancestor {a} {
4966 global curview parents ancestor anc_todo
4968 set v $curview
4969 set la [rowofcommit $a]
4970 set todo $anc_todo
4971 set leftover {}
4972 set done 0
4973 for {set i 0} {$i < [llength $todo]} {incr i} {
4974 set do [lindex $todo $i]
4975 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4976 lappend leftover $do
4977 continue
4979 foreach np $parents($v,$do) {
4980 if {![info exists ancestor($np)]} {
4981 set ancestor($np) 1
4982 lappend todo $np
4983 if {$np eq $a} {
4984 set done 1
4988 if {$done} {
4989 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4990 return
4993 set ancestor($a) 0
4994 set anc_todo $leftover
4997 proc askrelhighlight {row id} {
4998 global descendent highlight_related iddrawn rhighlights
4999 global selectedline ancestor
5001 if {$selectedline eq {}} return
5002 set isbold 0
5003 if {$highlight_related eq [mc "Descendant"] ||
5004 $highlight_related eq [mc "Not descendant"]} {
5005 if {![info exists descendent($id)]} {
5006 is_descendent $id
5008 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5009 set isbold 1
5011 } elseif {$highlight_related eq [mc "Ancestor"] ||
5012 $highlight_related eq [mc "Not ancestor"]} {
5013 if {![info exists ancestor($id)]} {
5014 is_ancestor $id
5016 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5017 set isbold 1
5020 if {[info exists iddrawn($id)]} {
5021 if {$isbold && ![ishighlighted $id]} {
5022 bolden $id mainfontbold
5025 set rhighlights($id) $isbold
5028 # Graph layout functions
5030 proc shortids {ids} {
5031 set res {}
5032 foreach id $ids {
5033 if {[llength $id] > 1} {
5034 lappend res [shortids $id]
5035 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5036 lappend res [string range $id 0 7]
5037 } else {
5038 lappend res $id
5041 return $res
5044 proc ntimes {n o} {
5045 set ret {}
5046 set o [list $o]
5047 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5048 if {($n & $mask) != 0} {
5049 set ret [concat $ret $o]
5051 set o [concat $o $o]
5053 return $ret
5056 proc ordertoken {id} {
5057 global ordertok curview varcid varcstart varctok curview parents children
5058 global nullid nullid2
5060 if {[info exists ordertok($id)]} {
5061 return $ordertok($id)
5063 set origid $id
5064 set todo {}
5065 while {1} {
5066 if {[info exists varcid($curview,$id)]} {
5067 set a $varcid($curview,$id)
5068 set p [lindex $varcstart($curview) $a]
5069 } else {
5070 set p [lindex $children($curview,$id) 0]
5072 if {[info exists ordertok($p)]} {
5073 set tok $ordertok($p)
5074 break
5076 set id [first_real_child $curview,$p]
5077 if {$id eq {}} {
5078 # it's a root
5079 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5080 break
5082 if {[llength $parents($curview,$id)] == 1} {
5083 lappend todo [list $p {}]
5084 } else {
5085 set j [lsearch -exact $parents($curview,$id) $p]
5086 if {$j < 0} {
5087 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5089 lappend todo [list $p [strrep $j]]
5092 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5093 set p [lindex $todo $i 0]
5094 append tok [lindex $todo $i 1]
5095 set ordertok($p) $tok
5097 set ordertok($origid) $tok
5098 return $tok
5101 # Work out where id should go in idlist so that order-token
5102 # values increase from left to right
5103 proc idcol {idlist id {i 0}} {
5104 set t [ordertoken $id]
5105 if {$i < 0} {
5106 set i 0
5108 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5109 if {$i > [llength $idlist]} {
5110 set i [llength $idlist]
5112 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5113 incr i
5114 } else {
5115 if {$t > [ordertoken [lindex $idlist $i]]} {
5116 while {[incr i] < [llength $idlist] &&
5117 $t >= [ordertoken [lindex $idlist $i]]} {}
5120 return $i
5123 proc initlayout {} {
5124 global rowidlist rowisopt rowfinal displayorder parentlist
5125 global numcommits canvxmax canv
5126 global nextcolor
5127 global colormap rowtextx
5129 set numcommits 0
5130 set displayorder {}
5131 set parentlist {}
5132 set nextcolor 0
5133 set rowidlist {}
5134 set rowisopt {}
5135 set rowfinal {}
5136 set canvxmax [$canv cget -width]
5137 catch {unset colormap}
5138 catch {unset rowtextx}
5139 setcanvscroll
5142 proc setcanvscroll {} {
5143 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5144 global lastscrollset lastscrollrows
5146 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5147 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5148 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5149 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5150 set lastscrollset [clock clicks -milliseconds]
5151 set lastscrollrows $numcommits
5154 proc visiblerows {} {
5155 global canv numcommits linespc
5157 set ymax [lindex [$canv cget -scrollregion] 3]
5158 if {$ymax eq {} || $ymax == 0} return
5159 set f [$canv yview]
5160 set y0 [expr {int([lindex $f 0] * $ymax)}]
5161 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5162 if {$r0 < 0} {
5163 set r0 0
5165 set y1 [expr {int([lindex $f 1] * $ymax)}]
5166 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5167 if {$r1 >= $numcommits} {
5168 set r1 [expr {$numcommits - 1}]
5170 return [list $r0 $r1]
5173 proc layoutmore {} {
5174 global commitidx viewcomplete curview
5175 global numcommits pending_select curview
5176 global lastscrollset lastscrollrows
5178 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5179 [clock clicks -milliseconds] - $lastscrollset > 500} {
5180 setcanvscroll
5182 if {[info exists pending_select] &&
5183 [commitinview $pending_select $curview]} {
5184 update
5185 selectline [rowofcommit $pending_select] 1
5187 drawvisible
5190 # With path limiting, we mightn't get the actual HEAD commit,
5191 # so ask git rev-list what is the first ancestor of HEAD that
5192 # touches a file in the path limit.
5193 proc get_viewmainhead {view} {
5194 global viewmainheadid vfilelimit viewinstances mainheadid
5196 catch {
5197 set rfd [open [concat | git rev-list -1 $mainheadid \
5198 -- $vfilelimit($view)] r]
5199 set j [reg_instance $rfd]
5200 lappend viewinstances($view) $j
5201 fconfigure $rfd -blocking 0
5202 filerun $rfd [list getviewhead $rfd $j $view]
5203 set viewmainheadid($curview) {}
5207 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5208 proc getviewhead {fd inst view} {
5209 global viewmainheadid commfd curview viewinstances showlocalchanges
5211 set id {}
5212 if {[gets $fd line] < 0} {
5213 if {![eof $fd]} {
5214 return 1
5216 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5217 set id $line
5219 set viewmainheadid($view) $id
5220 close $fd
5221 unset commfd($inst)
5222 set i [lsearch -exact $viewinstances($view) $inst]
5223 if {$i >= 0} {
5224 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5226 if {$showlocalchanges && $id ne {} && $view == $curview} {
5227 doshowlocalchanges
5229 return 0
5232 proc doshowlocalchanges {} {
5233 global curview viewmainheadid
5235 if {$viewmainheadid($curview) eq {}} return
5236 if {[commitinview $viewmainheadid($curview) $curview]} {
5237 dodiffindex
5238 } else {
5239 interestedin $viewmainheadid($curview) dodiffindex
5243 proc dohidelocalchanges {} {
5244 global nullid nullid2 lserial curview
5246 if {[commitinview $nullid $curview]} {
5247 removefakerow $nullid
5249 if {[commitinview $nullid2 $curview]} {
5250 removefakerow $nullid2
5252 incr lserial
5255 # spawn off a process to do git diff-index --cached HEAD
5256 proc dodiffindex {} {
5257 global lserial showlocalchanges vfilelimit curview
5258 global hasworktree git_version
5260 if {!$showlocalchanges || !$hasworktree} return
5261 incr lserial
5262 if {[package vcompare $git_version "1.7.2"] >= 0} {
5263 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5264 } else {
5265 set cmd "|git diff-index --cached HEAD"
5267 if {$vfilelimit($curview) ne {}} {
5268 set cmd [concat $cmd -- $vfilelimit($curview)]
5270 set fd [open $cmd r]
5271 fconfigure $fd -blocking 0
5272 set i [reg_instance $fd]
5273 filerun $fd [list readdiffindex $fd $lserial $i]
5276 proc readdiffindex {fd serial inst} {
5277 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5278 global vfilelimit
5280 set isdiff 1
5281 if {[gets $fd line] < 0} {
5282 if {![eof $fd]} {
5283 return 1
5285 set isdiff 0
5287 # we only need to see one line and we don't really care what it says...
5288 stop_instance $inst
5290 if {$serial != $lserial} {
5291 return 0
5294 # now see if there are any local changes not checked in to the index
5295 set cmd "|git diff-files"
5296 if {$vfilelimit($curview) ne {}} {
5297 set cmd [concat $cmd -- $vfilelimit($curview)]
5299 set fd [open $cmd r]
5300 fconfigure $fd -blocking 0
5301 set i [reg_instance $fd]
5302 filerun $fd [list readdifffiles $fd $serial $i]
5304 if {$isdiff && ![commitinview $nullid2 $curview]} {
5305 # add the line for the changes in the index to the graph
5306 set hl [mc "Local changes checked in to index but not committed"]
5307 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5308 set commitdata($nullid2) "\n $hl\n"
5309 if {[commitinview $nullid $curview]} {
5310 removefakerow $nullid
5312 insertfakerow $nullid2 $viewmainheadid($curview)
5313 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5314 if {[commitinview $nullid $curview]} {
5315 removefakerow $nullid
5317 removefakerow $nullid2
5319 return 0
5322 proc readdifffiles {fd serial inst} {
5323 global viewmainheadid nullid nullid2 curview
5324 global commitinfo commitdata lserial
5326 set isdiff 1
5327 if {[gets $fd line] < 0} {
5328 if {![eof $fd]} {
5329 return 1
5331 set isdiff 0
5333 # we only need to see one line and we don't really care what it says...
5334 stop_instance $inst
5336 if {$serial != $lserial} {
5337 return 0
5340 if {$isdiff && ![commitinview $nullid $curview]} {
5341 # add the line for the local diff to the graph
5342 set hl [mc "Local uncommitted changes, not checked in to index"]
5343 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5344 set commitdata($nullid) "\n $hl\n"
5345 if {[commitinview $nullid2 $curview]} {
5346 set p $nullid2
5347 } else {
5348 set p $viewmainheadid($curview)
5350 insertfakerow $nullid $p
5351 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5352 removefakerow $nullid
5354 return 0
5357 proc nextuse {id row} {
5358 global curview children
5360 if {[info exists children($curview,$id)]} {
5361 foreach kid $children($curview,$id) {
5362 if {![commitinview $kid $curview]} {
5363 return -1
5365 if {[rowofcommit $kid] > $row} {
5366 return [rowofcommit $kid]
5370 if {[commitinview $id $curview]} {
5371 return [rowofcommit $id]
5373 return -1
5376 proc prevuse {id row} {
5377 global curview children
5379 set ret -1
5380 if {[info exists children($curview,$id)]} {
5381 foreach kid $children($curview,$id) {
5382 if {![commitinview $kid $curview]} break
5383 if {[rowofcommit $kid] < $row} {
5384 set ret [rowofcommit $kid]
5388 return $ret
5391 proc make_idlist {row} {
5392 global displayorder parentlist uparrowlen downarrowlen mingaplen
5393 global commitidx curview children
5395 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5396 if {$r < 0} {
5397 set r 0
5399 set ra [expr {$row - $downarrowlen}]
5400 if {$ra < 0} {
5401 set ra 0
5403 set rb [expr {$row + $uparrowlen}]
5404 if {$rb > $commitidx($curview)} {
5405 set rb $commitidx($curview)
5407 make_disporder $r [expr {$rb + 1}]
5408 set ids {}
5409 for {} {$r < $ra} {incr r} {
5410 set nextid [lindex $displayorder [expr {$r + 1}]]
5411 foreach p [lindex $parentlist $r] {
5412 if {$p eq $nextid} continue
5413 set rn [nextuse $p $r]
5414 if {$rn >= $row &&
5415 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5416 lappend ids [list [ordertoken $p] $p]
5420 for {} {$r < $row} {incr r} {
5421 set nextid [lindex $displayorder [expr {$r + 1}]]
5422 foreach p [lindex $parentlist $r] {
5423 if {$p eq $nextid} continue
5424 set rn [nextuse $p $r]
5425 if {$rn < 0 || $rn >= $row} {
5426 lappend ids [list [ordertoken $p] $p]
5430 set id [lindex $displayorder $row]
5431 lappend ids [list [ordertoken $id] $id]
5432 while {$r < $rb} {
5433 foreach p [lindex $parentlist $r] {
5434 set firstkid [lindex $children($curview,$p) 0]
5435 if {[rowofcommit $firstkid] < $row} {
5436 lappend ids [list [ordertoken $p] $p]
5439 incr r
5440 set id [lindex $displayorder $r]
5441 if {$id ne {}} {
5442 set firstkid [lindex $children($curview,$id) 0]
5443 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5444 lappend ids [list [ordertoken $id] $id]
5448 set idlist {}
5449 foreach idx [lsort -unique $ids] {
5450 lappend idlist [lindex $idx 1]
5452 return $idlist
5455 proc rowsequal {a b} {
5456 while {[set i [lsearch -exact $a {}]] >= 0} {
5457 set a [lreplace $a $i $i]
5459 while {[set i [lsearch -exact $b {}]] >= 0} {
5460 set b [lreplace $b $i $i]
5462 return [expr {$a eq $b}]
5465 proc makeupline {id row rend col} {
5466 global rowidlist uparrowlen downarrowlen mingaplen
5468 for {set r $rend} {1} {set r $rstart} {
5469 set rstart [prevuse $id $r]
5470 if {$rstart < 0} return
5471 if {$rstart < $row} break
5473 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5474 set rstart [expr {$rend - $uparrowlen - 1}]
5476 for {set r $rstart} {[incr r] <= $row} {} {
5477 set idlist [lindex $rowidlist $r]
5478 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5479 set col [idcol $idlist $id $col]
5480 lset rowidlist $r [linsert $idlist $col $id]
5481 changedrow $r
5486 proc layoutrows {row endrow} {
5487 global rowidlist rowisopt rowfinal displayorder
5488 global uparrowlen downarrowlen maxwidth mingaplen
5489 global children parentlist
5490 global commitidx viewcomplete curview
5492 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5493 set idlist {}
5494 if {$row > 0} {
5495 set rm1 [expr {$row - 1}]
5496 foreach id [lindex $rowidlist $rm1] {
5497 if {$id ne {}} {
5498 lappend idlist $id
5501 set final [lindex $rowfinal $rm1]
5503 for {} {$row < $endrow} {incr row} {
5504 set rm1 [expr {$row - 1}]
5505 if {$rm1 < 0 || $idlist eq {}} {
5506 set idlist [make_idlist $row]
5507 set final 1
5508 } else {
5509 set id [lindex $displayorder $rm1]
5510 set col [lsearch -exact $idlist $id]
5511 set idlist [lreplace $idlist $col $col]
5512 foreach p [lindex $parentlist $rm1] {
5513 if {[lsearch -exact $idlist $p] < 0} {
5514 set col [idcol $idlist $p $col]
5515 set idlist [linsert $idlist $col $p]
5516 # if not the first child, we have to insert a line going up
5517 if {$id ne [lindex $children($curview,$p) 0]} {
5518 makeupline $p $rm1 $row $col
5522 set id [lindex $displayorder $row]
5523 if {$row > $downarrowlen} {
5524 set termrow [expr {$row - $downarrowlen - 1}]
5525 foreach p [lindex $parentlist $termrow] {
5526 set i [lsearch -exact $idlist $p]
5527 if {$i < 0} continue
5528 set nr [nextuse $p $termrow]
5529 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5530 set idlist [lreplace $idlist $i $i]
5534 set col [lsearch -exact $idlist $id]
5535 if {$col < 0} {
5536 set col [idcol $idlist $id]
5537 set idlist [linsert $idlist $col $id]
5538 if {$children($curview,$id) ne {}} {
5539 makeupline $id $rm1 $row $col
5542 set r [expr {$row + $uparrowlen - 1}]
5543 if {$r < $commitidx($curview)} {
5544 set x $col
5545 foreach p [lindex $parentlist $r] {
5546 if {[lsearch -exact $idlist $p] >= 0} continue
5547 set fk [lindex $children($curview,$p) 0]
5548 if {[rowofcommit $fk] < $row} {
5549 set x [idcol $idlist $p $x]
5550 set idlist [linsert $idlist $x $p]
5553 if {[incr r] < $commitidx($curview)} {
5554 set p [lindex $displayorder $r]
5555 if {[lsearch -exact $idlist $p] < 0} {
5556 set fk [lindex $children($curview,$p) 0]
5557 if {$fk ne {} && [rowofcommit $fk] < $row} {
5558 set x [idcol $idlist $p $x]
5559 set idlist [linsert $idlist $x $p]
5565 if {$final && !$viewcomplete($curview) &&
5566 $row + $uparrowlen + $mingaplen + $downarrowlen
5567 >= $commitidx($curview)} {
5568 set final 0
5570 set l [llength $rowidlist]
5571 if {$row == $l} {
5572 lappend rowidlist $idlist
5573 lappend rowisopt 0
5574 lappend rowfinal $final
5575 } elseif {$row < $l} {
5576 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5577 lset rowidlist $row $idlist
5578 changedrow $row
5580 lset rowfinal $row $final
5581 } else {
5582 set pad [ntimes [expr {$row - $l}] {}]
5583 set rowidlist [concat $rowidlist $pad]
5584 lappend rowidlist $idlist
5585 set rowfinal [concat $rowfinal $pad]
5586 lappend rowfinal $final
5587 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5590 return $row
5593 proc changedrow {row} {
5594 global displayorder iddrawn rowisopt need_redisplay
5596 set l [llength $rowisopt]
5597 if {$row < $l} {
5598 lset rowisopt $row 0
5599 if {$row + 1 < $l} {
5600 lset rowisopt [expr {$row + 1}] 0
5601 if {$row + 2 < $l} {
5602 lset rowisopt [expr {$row + 2}] 0
5606 set id [lindex $displayorder $row]
5607 if {[info exists iddrawn($id)]} {
5608 set need_redisplay 1
5612 proc insert_pad {row col npad} {
5613 global rowidlist
5615 set pad [ntimes $npad {}]
5616 set idlist [lindex $rowidlist $row]
5617 set bef [lrange $idlist 0 [expr {$col - 1}]]
5618 set aft [lrange $idlist $col end]
5619 set i [lsearch -exact $aft {}]
5620 if {$i > 0} {
5621 set aft [lreplace $aft $i $i]
5623 lset rowidlist $row [concat $bef $pad $aft]
5624 changedrow $row
5627 proc optimize_rows {row col endrow} {
5628 global rowidlist rowisopt displayorder curview children
5630 if {$row < 1} {
5631 set row 1
5633 for {} {$row < $endrow} {incr row; set col 0} {
5634 if {[lindex $rowisopt $row]} continue
5635 set haspad 0
5636 set y0 [expr {$row - 1}]
5637 set ym [expr {$row - 2}]
5638 set idlist [lindex $rowidlist $row]
5639 set previdlist [lindex $rowidlist $y0]
5640 if {$idlist eq {} || $previdlist eq {}} continue
5641 if {$ym >= 0} {
5642 set pprevidlist [lindex $rowidlist $ym]
5643 if {$pprevidlist eq {}} continue
5644 } else {
5645 set pprevidlist {}
5647 set x0 -1
5648 set xm -1
5649 for {} {$col < [llength $idlist]} {incr col} {
5650 set id [lindex $idlist $col]
5651 if {[lindex $previdlist $col] eq $id} continue
5652 if {$id eq {}} {
5653 set haspad 1
5654 continue
5656 set x0 [lsearch -exact $previdlist $id]
5657 if {$x0 < 0} continue
5658 set z [expr {$x0 - $col}]
5659 set isarrow 0
5660 set z0 {}
5661 if {$ym >= 0} {
5662 set xm [lsearch -exact $pprevidlist $id]
5663 if {$xm >= 0} {
5664 set z0 [expr {$xm - $x0}]
5667 if {$z0 eq {}} {
5668 # if row y0 is the first child of $id then it's not an arrow
5669 if {[lindex $children($curview,$id) 0] ne
5670 [lindex $displayorder $y0]} {
5671 set isarrow 1
5674 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5675 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5676 set isarrow 1
5678 # Looking at lines from this row to the previous row,
5679 # make them go straight up if they end in an arrow on
5680 # the previous row; otherwise make them go straight up
5681 # or at 45 degrees.
5682 if {$z < -1 || ($z < 0 && $isarrow)} {
5683 # Line currently goes left too much;
5684 # insert pads in the previous row, then optimize it
5685 set npad [expr {-1 - $z + $isarrow}]
5686 insert_pad $y0 $x0 $npad
5687 if {$y0 > 0} {
5688 optimize_rows $y0 $x0 $row
5690 set previdlist [lindex $rowidlist $y0]
5691 set x0 [lsearch -exact $previdlist $id]
5692 set z [expr {$x0 - $col}]
5693 if {$z0 ne {}} {
5694 set pprevidlist [lindex $rowidlist $ym]
5695 set xm [lsearch -exact $pprevidlist $id]
5696 set z0 [expr {$xm - $x0}]
5698 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5699 # Line currently goes right too much;
5700 # insert pads in this line
5701 set npad [expr {$z - 1 + $isarrow}]
5702 insert_pad $row $col $npad
5703 set idlist [lindex $rowidlist $row]
5704 incr col $npad
5705 set z [expr {$x0 - $col}]
5706 set haspad 1
5708 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5709 # this line links to its first child on row $row-2
5710 set id [lindex $displayorder $ym]
5711 set xc [lsearch -exact $pprevidlist $id]
5712 if {$xc >= 0} {
5713 set z0 [expr {$xc - $x0}]
5716 # avoid lines jigging left then immediately right
5717 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5718 insert_pad $y0 $x0 1
5719 incr x0
5720 optimize_rows $y0 $x0 $row
5721 set previdlist [lindex $rowidlist $y0]
5724 if {!$haspad} {
5725 # Find the first column that doesn't have a line going right
5726 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5727 set id [lindex $idlist $col]
5728 if {$id eq {}} break
5729 set x0 [lsearch -exact $previdlist $id]
5730 if {$x0 < 0} {
5731 # check if this is the link to the first child
5732 set kid [lindex $displayorder $y0]
5733 if {[lindex $children($curview,$id) 0] eq $kid} {
5734 # it is, work out offset to child
5735 set x0 [lsearch -exact $previdlist $kid]
5738 if {$x0 <= $col} break
5740 # Insert a pad at that column as long as it has a line and
5741 # isn't the last column
5742 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5743 set idlist [linsert $idlist $col {}]
5744 lset rowidlist $row $idlist
5745 changedrow $row
5751 proc xc {row col} {
5752 global canvx0 linespc
5753 return [expr {$canvx0 + $col * $linespc}]
5756 proc yc {row} {
5757 global canvy0 linespc
5758 return [expr {$canvy0 + $row * $linespc}]
5761 proc linewidth {id} {
5762 global thickerline lthickness
5764 set wid $lthickness
5765 if {[info exists thickerline] && $id eq $thickerline} {
5766 set wid [expr {2 * $lthickness}]
5768 return $wid
5771 proc rowranges {id} {
5772 global curview children uparrowlen downarrowlen
5773 global rowidlist
5775 set kids $children($curview,$id)
5776 if {$kids eq {}} {
5777 return {}
5779 set ret {}
5780 lappend kids $id
5781 foreach child $kids {
5782 if {![commitinview $child $curview]} break
5783 set row [rowofcommit $child]
5784 if {![info exists prev]} {
5785 lappend ret [expr {$row + 1}]
5786 } else {
5787 if {$row <= $prevrow} {
5788 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5790 # see if the line extends the whole way from prevrow to row
5791 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5792 [lsearch -exact [lindex $rowidlist \
5793 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5794 # it doesn't, see where it ends
5795 set r [expr {$prevrow + $downarrowlen}]
5796 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5797 while {[incr r -1] > $prevrow &&
5798 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5799 } else {
5800 while {[incr r] <= $row &&
5801 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5802 incr r -1
5804 lappend ret $r
5805 # see where it starts up again
5806 set r [expr {$row - $uparrowlen}]
5807 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5808 while {[incr r] < $row &&
5809 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5810 } else {
5811 while {[incr r -1] >= $prevrow &&
5812 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5813 incr r
5815 lappend ret $r
5818 if {$child eq $id} {
5819 lappend ret $row
5821 set prev $child
5822 set prevrow $row
5824 return $ret
5827 proc drawlineseg {id row endrow arrowlow} {
5828 global rowidlist displayorder iddrawn linesegs
5829 global canv colormap linespc curview maxlinelen parentlist
5831 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5832 set le [expr {$row + 1}]
5833 set arrowhigh 1
5834 while {1} {
5835 set c [lsearch -exact [lindex $rowidlist $le] $id]
5836 if {$c < 0} {
5837 incr le -1
5838 break
5840 lappend cols $c
5841 set x [lindex $displayorder $le]
5842 if {$x eq $id} {
5843 set arrowhigh 0
5844 break
5846 if {[info exists iddrawn($x)] || $le == $endrow} {
5847 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5848 if {$c >= 0} {
5849 lappend cols $c
5850 set arrowhigh 0
5852 break
5854 incr le
5856 if {$le <= $row} {
5857 return $row
5860 set lines {}
5861 set i 0
5862 set joinhigh 0
5863 if {[info exists linesegs($id)]} {
5864 set lines $linesegs($id)
5865 foreach li $lines {
5866 set r0 [lindex $li 0]
5867 if {$r0 > $row} {
5868 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5869 set joinhigh 1
5871 break
5873 incr i
5876 set joinlow 0
5877 if {$i > 0} {
5878 set li [lindex $lines [expr {$i-1}]]
5879 set r1 [lindex $li 1]
5880 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5881 set joinlow 1
5885 set x [lindex $cols [expr {$le - $row}]]
5886 set xp [lindex $cols [expr {$le - 1 - $row}]]
5887 set dir [expr {$xp - $x}]
5888 if {$joinhigh} {
5889 set ith [lindex $lines $i 2]
5890 set coords [$canv coords $ith]
5891 set ah [$canv itemcget $ith -arrow]
5892 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5893 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5894 if {$x2 ne {} && $x - $x2 == $dir} {
5895 set coords [lrange $coords 0 end-2]
5897 } else {
5898 set coords [list [xc $le $x] [yc $le]]
5900 if {$joinlow} {
5901 set itl [lindex $lines [expr {$i-1}] 2]
5902 set al [$canv itemcget $itl -arrow]
5903 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5904 } elseif {$arrowlow} {
5905 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5906 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5907 set arrowlow 0
5910 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5911 for {set y $le} {[incr y -1] > $row} {} {
5912 set x $xp
5913 set xp [lindex $cols [expr {$y - 1 - $row}]]
5914 set ndir [expr {$xp - $x}]
5915 if {$dir != $ndir || $xp < 0} {
5916 lappend coords [xc $y $x] [yc $y]
5918 set dir $ndir
5920 if {!$joinlow} {
5921 if {$xp < 0} {
5922 # join parent line to first child
5923 set ch [lindex $displayorder $row]
5924 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5925 if {$xc < 0} {
5926 puts "oops: drawlineseg: child $ch not on row $row"
5927 } elseif {$xc != $x} {
5928 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5929 set d [expr {int(0.5 * $linespc)}]
5930 set x1 [xc $row $x]
5931 if {$xc < $x} {
5932 set x2 [expr {$x1 - $d}]
5933 } else {
5934 set x2 [expr {$x1 + $d}]
5936 set y2 [yc $row]
5937 set y1 [expr {$y2 + $d}]
5938 lappend coords $x1 $y1 $x2 $y2
5939 } elseif {$xc < $x - 1} {
5940 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5941 } elseif {$xc > $x + 1} {
5942 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5944 set x $xc
5946 lappend coords [xc $row $x] [yc $row]
5947 } else {
5948 set xn [xc $row $xp]
5949 set yn [yc $row]
5950 lappend coords $xn $yn
5952 if {!$joinhigh} {
5953 assigncolor $id
5954 set t [$canv create line $coords -width [linewidth $id] \
5955 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5956 $canv lower $t
5957 bindline $t $id
5958 set lines [linsert $lines $i [list $row $le $t]]
5959 } else {
5960 $canv coords $ith $coords
5961 if {$arrow ne $ah} {
5962 $canv itemconf $ith -arrow $arrow
5964 lset lines $i 0 $row
5966 } else {
5967 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5968 set ndir [expr {$xo - $xp}]
5969 set clow [$canv coords $itl]
5970 if {$dir == $ndir} {
5971 set clow [lrange $clow 2 end]
5973 set coords [concat $coords $clow]
5974 if {!$joinhigh} {
5975 lset lines [expr {$i-1}] 1 $le
5976 } else {
5977 # coalesce two pieces
5978 $canv delete $ith
5979 set b [lindex $lines [expr {$i-1}] 0]
5980 set e [lindex $lines $i 1]
5981 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5983 $canv coords $itl $coords
5984 if {$arrow ne $al} {
5985 $canv itemconf $itl -arrow $arrow
5989 set linesegs($id) $lines
5990 return $le
5993 proc drawparentlinks {id row} {
5994 global rowidlist canv colormap curview parentlist
5995 global idpos linespc
5997 set rowids [lindex $rowidlist $row]
5998 set col [lsearch -exact $rowids $id]
5999 if {$col < 0} return
6000 set olds [lindex $parentlist $row]
6001 set row2 [expr {$row + 1}]
6002 set x [xc $row $col]
6003 set y [yc $row]
6004 set y2 [yc $row2]
6005 set d [expr {int(0.5 * $linespc)}]
6006 set ymid [expr {$y + $d}]
6007 set ids [lindex $rowidlist $row2]
6008 # rmx = right-most X coord used
6009 set rmx 0
6010 foreach p $olds {
6011 set i [lsearch -exact $ids $p]
6012 if {$i < 0} {
6013 puts "oops, parent $p of $id not in list"
6014 continue
6016 set x2 [xc $row2 $i]
6017 if {$x2 > $rmx} {
6018 set rmx $x2
6020 set j [lsearch -exact $rowids $p]
6021 if {$j < 0} {
6022 # drawlineseg will do this one for us
6023 continue
6025 assigncolor $p
6026 # should handle duplicated parents here...
6027 set coords [list $x $y]
6028 if {$i != $col} {
6029 # if attaching to a vertical segment, draw a smaller
6030 # slant for visual distinctness
6031 if {$i == $j} {
6032 if {$i < $col} {
6033 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6034 } else {
6035 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6037 } elseif {$i < $col && $i < $j} {
6038 # segment slants towards us already
6039 lappend coords [xc $row $j] $y
6040 } else {
6041 if {$i < $col - 1} {
6042 lappend coords [expr {$x2 + $linespc}] $y
6043 } elseif {$i > $col + 1} {
6044 lappend coords [expr {$x2 - $linespc}] $y
6046 lappend coords $x2 $y2
6048 } else {
6049 lappend coords $x2 $y2
6051 set t [$canv create line $coords -width [linewidth $p] \
6052 -fill $colormap($p) -tags lines.$p]
6053 $canv lower $t
6054 bindline $t $p
6056 if {$rmx > [lindex $idpos($id) 1]} {
6057 lset idpos($id) 1 $rmx
6058 redrawtags $id
6062 proc drawlines {id} {
6063 global canv
6065 $canv itemconf lines.$id -width [linewidth $id]
6068 proc drawcmittext {id row col} {
6069 global linespc canv canv2 canv3 fgcolor curview
6070 global cmitlisted commitinfo rowidlist parentlist
6071 global rowtextx idpos idtags idheads idotherrefs
6072 global linehtag linentag linedtag selectedline
6073 global canvxmax boldids boldnameids fgcolor markedid
6074 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6075 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6076 global circleoutlinecolor
6078 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6079 set listed $cmitlisted($curview,$id)
6080 if {$id eq $nullid} {
6081 set ofill $workingfilescirclecolor
6082 } elseif {$id eq $nullid2} {
6083 set ofill $indexcirclecolor
6084 } elseif {$id eq $mainheadid} {
6085 set ofill $mainheadcirclecolor
6086 } else {
6087 set ofill [lindex $circlecolors $listed]
6089 set x [xc $row $col]
6090 set y [yc $row]
6091 set orad [expr {$linespc / 3}]
6092 if {$listed <= 2} {
6093 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6094 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6095 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6096 } elseif {$listed == 3} {
6097 # triangle pointing left for left-side commits
6098 set t [$canv create polygon \
6099 [expr {$x - $orad}] $y \
6100 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6101 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6102 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6103 } else {
6104 # triangle pointing right for right-side commits
6105 set t [$canv create polygon \
6106 [expr {$x + $orad - 1}] $y \
6107 [expr {$x - $orad}] [expr {$y - $orad}] \
6108 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6109 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6111 set circleitem($row) $t
6112 $canv raise $t
6113 $canv bind $t <1> {selcanvline {} %x %y}
6114 set rmx [llength [lindex $rowidlist $row]]
6115 set olds [lindex $parentlist $row]
6116 if {$olds ne {}} {
6117 set nextids [lindex $rowidlist [expr {$row + 1}]]
6118 foreach p $olds {
6119 set i [lsearch -exact $nextids $p]
6120 if {$i > $rmx} {
6121 set rmx $i
6125 set xt [xc $row $rmx]
6126 set rowtextx($row) $xt
6127 set idpos($id) [list $x $xt $y]
6128 if {[info exists idtags($id)] || [info exists idheads($id)]
6129 || [info exists idotherrefs($id)]} {
6130 set xt [drawtags $id $x $xt $y]
6132 if {[lindex $commitinfo($id) 6] > 0} {
6133 set xt [drawnotesign $xt $y]
6135 set headline [lindex $commitinfo($id) 0]
6136 set name [lindex $commitinfo($id) 1]
6137 set date [lindex $commitinfo($id) 2]
6138 set date [formatdate $date]
6139 set font mainfont
6140 set nfont mainfont
6141 set isbold [ishighlighted $id]
6142 if {$isbold > 0} {
6143 lappend boldids $id
6144 set font mainfontbold
6145 if {$isbold > 1} {
6146 lappend boldnameids $id
6147 set nfont mainfontbold
6150 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6151 -text $headline -font $font -tags text]
6152 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6153 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6154 -text $name -font $nfont -tags text]
6155 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6156 -text $date -font mainfont -tags text]
6157 if {$selectedline == $row} {
6158 make_secsel $id
6160 if {[info exists markedid] && $markedid eq $id} {
6161 make_idmark $id
6163 set xr [expr {$xt + [font measure $font $headline]}]
6164 if {$xr > $canvxmax} {
6165 set canvxmax $xr
6166 setcanvscroll
6170 proc drawcmitrow {row} {
6171 global displayorder rowidlist nrows_drawn
6172 global iddrawn markingmatches
6173 global commitinfo numcommits
6174 global filehighlight fhighlights findpattern nhighlights
6175 global hlview vhighlights
6176 global highlight_related rhighlights
6178 if {$row >= $numcommits} return
6180 set id [lindex $displayorder $row]
6181 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6182 askvhighlight $row $id
6184 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6185 askfilehighlight $row $id
6187 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6188 askfindhighlight $row $id
6190 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6191 askrelhighlight $row $id
6193 if {![info exists iddrawn($id)]} {
6194 set col [lsearch -exact [lindex $rowidlist $row] $id]
6195 if {$col < 0} {
6196 puts "oops, row $row id $id not in list"
6197 return
6199 if {![info exists commitinfo($id)]} {
6200 getcommit $id
6202 assigncolor $id
6203 drawcmittext $id $row $col
6204 set iddrawn($id) 1
6205 incr nrows_drawn
6207 if {$markingmatches} {
6208 markrowmatches $row $id
6212 proc drawcommits {row {endrow {}}} {
6213 global numcommits iddrawn displayorder curview need_redisplay
6214 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6216 if {$row < 0} {
6217 set row 0
6219 if {$endrow eq {}} {
6220 set endrow $row
6222 if {$endrow >= $numcommits} {
6223 set endrow [expr {$numcommits - 1}]
6226 set rl1 [expr {$row - $downarrowlen - 3}]
6227 if {$rl1 < 0} {
6228 set rl1 0
6230 set ro1 [expr {$row - 3}]
6231 if {$ro1 < 0} {
6232 set ro1 0
6234 set r2 [expr {$endrow + $uparrowlen + 3}]
6235 if {$r2 > $numcommits} {
6236 set r2 $numcommits
6238 for {set r $rl1} {$r < $r2} {incr r} {
6239 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6240 if {$rl1 < $r} {
6241 layoutrows $rl1 $r
6243 set rl1 [expr {$r + 1}]
6246 if {$rl1 < $r} {
6247 layoutrows $rl1 $r
6249 optimize_rows $ro1 0 $r2
6250 if {$need_redisplay || $nrows_drawn > 2000} {
6251 clear_display
6254 # make the lines join to already-drawn rows either side
6255 set r [expr {$row - 1}]
6256 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6257 set r $row
6259 set er [expr {$endrow + 1}]
6260 if {$er >= $numcommits ||
6261 ![info exists iddrawn([lindex $displayorder $er])]} {
6262 set er $endrow
6264 for {} {$r <= $er} {incr r} {
6265 set id [lindex $displayorder $r]
6266 set wasdrawn [info exists iddrawn($id)]
6267 drawcmitrow $r
6268 if {$r == $er} break
6269 set nextid [lindex $displayorder [expr {$r + 1}]]
6270 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6271 drawparentlinks $id $r
6273 set rowids [lindex $rowidlist $r]
6274 foreach lid $rowids {
6275 if {$lid eq {}} continue
6276 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6277 if {$lid eq $id} {
6278 # see if this is the first child of any of its parents
6279 foreach p [lindex $parentlist $r] {
6280 if {[lsearch -exact $rowids $p] < 0} {
6281 # make this line extend up to the child
6282 set lineend($p) [drawlineseg $p $r $er 0]
6285 } else {
6286 set lineend($lid) [drawlineseg $lid $r $er 1]
6292 proc undolayout {row} {
6293 global uparrowlen mingaplen downarrowlen
6294 global rowidlist rowisopt rowfinal need_redisplay
6296 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6297 if {$r < 0} {
6298 set r 0
6300 if {[llength $rowidlist] > $r} {
6301 incr r -1
6302 set rowidlist [lrange $rowidlist 0 $r]
6303 set rowfinal [lrange $rowfinal 0 $r]
6304 set rowisopt [lrange $rowisopt 0 $r]
6305 set need_redisplay 1
6306 run drawvisible
6310 proc drawvisible {} {
6311 global canv linespc curview vrowmod selectedline targetrow targetid
6312 global need_redisplay cscroll numcommits
6314 set fs [$canv yview]
6315 set ymax [lindex [$canv cget -scrollregion] 3]
6316 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6317 set f0 [lindex $fs 0]
6318 set f1 [lindex $fs 1]
6319 set y0 [expr {int($f0 * $ymax)}]
6320 set y1 [expr {int($f1 * $ymax)}]
6322 if {[info exists targetid]} {
6323 if {[commitinview $targetid $curview]} {
6324 set r [rowofcommit $targetid]
6325 if {$r != $targetrow} {
6326 # Fix up the scrollregion and change the scrolling position
6327 # now that our target row has moved.
6328 set diff [expr {($r - $targetrow) * $linespc}]
6329 set targetrow $r
6330 setcanvscroll
6331 set ymax [lindex [$canv cget -scrollregion] 3]
6332 incr y0 $diff
6333 incr y1 $diff
6334 set f0 [expr {$y0 / $ymax}]
6335 set f1 [expr {$y1 / $ymax}]
6336 allcanvs yview moveto $f0
6337 $cscroll set $f0 $f1
6338 set need_redisplay 1
6340 } else {
6341 unset targetid
6345 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6346 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6347 if {$endrow >= $vrowmod($curview)} {
6348 update_arcrows $curview
6350 if {$selectedline ne {} &&
6351 $row <= $selectedline && $selectedline <= $endrow} {
6352 set targetrow $selectedline
6353 } elseif {[info exists targetid]} {
6354 set targetrow [expr {int(($row + $endrow) / 2)}]
6356 if {[info exists targetrow]} {
6357 if {$targetrow >= $numcommits} {
6358 set targetrow [expr {$numcommits - 1}]
6360 set targetid [commitonrow $targetrow]
6362 drawcommits $row $endrow
6365 proc clear_display {} {
6366 global iddrawn linesegs need_redisplay nrows_drawn
6367 global vhighlights fhighlights nhighlights rhighlights
6368 global linehtag linentag linedtag boldids boldnameids
6370 allcanvs delete all
6371 catch {unset iddrawn}
6372 catch {unset linesegs}
6373 catch {unset linehtag}
6374 catch {unset linentag}
6375 catch {unset linedtag}
6376 set boldids {}
6377 set boldnameids {}
6378 catch {unset vhighlights}
6379 catch {unset fhighlights}
6380 catch {unset nhighlights}
6381 catch {unset rhighlights}
6382 set need_redisplay 0
6383 set nrows_drawn 0
6386 proc findcrossings {id} {
6387 global rowidlist parentlist numcommits displayorder
6389 set cross {}
6390 set ccross {}
6391 foreach {s e} [rowranges $id] {
6392 if {$e >= $numcommits} {
6393 set e [expr {$numcommits - 1}]
6395 if {$e <= $s} continue
6396 for {set row $e} {[incr row -1] >= $s} {} {
6397 set x [lsearch -exact [lindex $rowidlist $row] $id]
6398 if {$x < 0} break
6399 set olds [lindex $parentlist $row]
6400 set kid [lindex $displayorder $row]
6401 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6402 if {$kidx < 0} continue
6403 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6404 foreach p $olds {
6405 set px [lsearch -exact $nextrow $p]
6406 if {$px < 0} continue
6407 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6408 if {[lsearch -exact $ccross $p] >= 0} continue
6409 if {$x == $px + ($kidx < $px? -1: 1)} {
6410 lappend ccross $p
6411 } elseif {[lsearch -exact $cross $p] < 0} {
6412 lappend cross $p
6418 return [concat $ccross {{}} $cross]
6421 proc assigncolor {id} {
6422 global colormap colors nextcolor
6423 global parents children children curview
6425 if {[info exists colormap($id)]} return
6426 set ncolors [llength $colors]
6427 if {[info exists children($curview,$id)]} {
6428 set kids $children($curview,$id)
6429 } else {
6430 set kids {}
6432 if {[llength $kids] == 1} {
6433 set child [lindex $kids 0]
6434 if {[info exists colormap($child)]
6435 && [llength $parents($curview,$child)] == 1} {
6436 set colormap($id) $colormap($child)
6437 return
6440 set badcolors {}
6441 set origbad {}
6442 foreach x [findcrossings $id] {
6443 if {$x eq {}} {
6444 # delimiter between corner crossings and other crossings
6445 if {[llength $badcolors] >= $ncolors - 1} break
6446 set origbad $badcolors
6448 if {[info exists colormap($x)]
6449 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6450 lappend badcolors $colormap($x)
6453 if {[llength $badcolors] >= $ncolors} {
6454 set badcolors $origbad
6456 set origbad $badcolors
6457 if {[llength $badcolors] < $ncolors - 1} {
6458 foreach child $kids {
6459 if {[info exists colormap($child)]
6460 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6461 lappend badcolors $colormap($child)
6463 foreach p $parents($curview,$child) {
6464 if {[info exists colormap($p)]
6465 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6466 lappend badcolors $colormap($p)
6470 if {[llength $badcolors] >= $ncolors} {
6471 set badcolors $origbad
6474 for {set i 0} {$i <= $ncolors} {incr i} {
6475 set c [lindex $colors $nextcolor]
6476 if {[incr nextcolor] >= $ncolors} {
6477 set nextcolor 0
6479 if {[lsearch -exact $badcolors $c]} break
6481 set colormap($id) $c
6484 proc bindline {t id} {
6485 global canv
6487 $canv bind $t <Enter> "lineenter %x %y $id"
6488 $canv bind $t <Motion> "linemotion %x %y $id"
6489 $canv bind $t <Leave> "lineleave $id"
6490 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6493 proc graph_pane_width {} {
6494 global use_ttk
6496 if {$use_ttk} {
6497 set g [.tf.histframe.pwclist sashpos 0]
6498 } else {
6499 set g [.tf.histframe.pwclist sash coord 0]
6501 return [lindex $g 0]
6504 proc totalwidth {l font extra} {
6505 set tot 0
6506 foreach str $l {
6507 set tot [expr {$tot + [font measure $font $str] + $extra}]
6509 return $tot
6512 proc drawtags {id x xt y1} {
6513 global idtags idheads idotherrefs mainhead
6514 global linespc lthickness
6515 global canv rowtextx curview fgcolor bgcolor ctxbut
6516 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6517 global tagbgcolor tagfgcolor tagoutlinecolor
6518 global reflinecolor
6520 set marks {}
6521 set ntags 0
6522 set nheads 0
6523 set singletag 0
6524 set maxtags 3
6525 set maxtagpct 25
6526 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6527 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6528 set extra [expr {$delta + $lthickness + $linespc}]
6530 if {[info exists idtags($id)]} {
6531 set marks $idtags($id)
6532 set ntags [llength $marks]
6533 if {$ntags > $maxtags ||
6534 [totalwidth $marks mainfont $extra] > $maxwidth} {
6535 # show just a single "n tags..." tag
6536 set singletag 1
6537 if {$ntags == 1} {
6538 set marks [list "tag..."]
6539 } else {
6540 set marks [list [format "%d tags..." $ntags]]
6542 set ntags 1
6545 if {[info exists idheads($id)]} {
6546 set marks [concat $marks $idheads($id)]
6547 set nheads [llength $idheads($id)]
6549 if {[info exists idotherrefs($id)]} {
6550 set marks [concat $marks $idotherrefs($id)]
6552 if {$marks eq {}} {
6553 return $xt
6556 set yt [expr {$y1 - 0.5 * $linespc}]
6557 set yb [expr {$yt + $linespc - 1}]
6558 set xvals {}
6559 set wvals {}
6560 set i -1
6561 foreach tag $marks {
6562 incr i
6563 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6564 set wid [font measure mainfontbold $tag]
6565 } else {
6566 set wid [font measure mainfont $tag]
6568 lappend xvals $xt
6569 lappend wvals $wid
6570 set xt [expr {$xt + $wid + $extra}]
6572 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6573 -width $lthickness -fill $reflinecolor -tags tag.$id]
6574 $canv lower $t
6575 foreach tag $marks x $xvals wid $wvals {
6576 set tag_quoted [string map {% %%} $tag]
6577 set xl [expr {$x + $delta}]
6578 set xr [expr {$x + $delta + $wid + $lthickness}]
6579 set font mainfont
6580 if {[incr ntags -1] >= 0} {
6581 # draw a tag
6582 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6583 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6584 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6585 -tags tag.$id]
6586 if {$singletag} {
6587 set tagclick [list showtags $id 1]
6588 } else {
6589 set tagclick [list showtag $tag_quoted 1]
6591 $canv bind $t <1> $tagclick
6592 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6593 } else {
6594 # draw a head or other ref
6595 if {[incr nheads -1] >= 0} {
6596 set col $headbgcolor
6597 if {$tag eq $mainhead} {
6598 set font mainfontbold
6600 } else {
6601 set col "#ddddff"
6603 set xl [expr {$xl - $delta/2}]
6604 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6605 -width 1 -outline black -fill $col -tags tag.$id
6606 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6607 set rwid [font measure mainfont $remoteprefix]
6608 set xi [expr {$x + 1}]
6609 set yti [expr {$yt + 1}]
6610 set xri [expr {$x + $rwid}]
6611 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6612 -width 0 -fill $remotebgcolor -tags tag.$id
6615 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6616 -font $font -tags [list tag.$id text]]
6617 if {$ntags >= 0} {
6618 $canv bind $t <1> $tagclick
6619 } elseif {$nheads >= 0} {
6620 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6623 return $xt
6626 proc drawnotesign {xt y} {
6627 global linespc canv fgcolor
6629 set orad [expr {$linespc / 3}]
6630 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6631 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6632 -fill yellow -outline $fgcolor -width 1 -tags circle]
6633 set xt [expr {$xt + $orad * 3}]
6634 return $xt
6637 proc xcoord {i level ln} {
6638 global canvx0 xspc1 xspc2
6640 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6641 if {$i > 0 && $i == $level} {
6642 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6643 } elseif {$i > $level} {
6644 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6646 return $x
6649 proc show_status {msg} {
6650 global canv fgcolor
6652 clear_display
6653 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6654 -tags text -fill $fgcolor
6657 # Don't change the text pane cursor if it is currently the hand cursor,
6658 # showing that we are over a sha1 ID link.
6659 proc settextcursor {c} {
6660 global ctext curtextcursor
6662 if {[$ctext cget -cursor] == $curtextcursor} {
6663 $ctext config -cursor $c
6665 set curtextcursor $c
6668 proc nowbusy {what {name {}}} {
6669 global isbusy busyname statusw
6671 if {[array names isbusy] eq {}} {
6672 . config -cursor watch
6673 settextcursor watch
6675 set isbusy($what) 1
6676 set busyname($what) $name
6677 if {$name ne {}} {
6678 $statusw conf -text $name
6682 proc notbusy {what} {
6683 global isbusy maincursor textcursor busyname statusw
6685 catch {
6686 unset isbusy($what)
6687 if {$busyname($what) ne {} &&
6688 [$statusw cget -text] eq $busyname($what)} {
6689 $statusw conf -text {}
6692 if {[array names isbusy] eq {}} {
6693 . config -cursor $maincursor
6694 settextcursor $textcursor
6698 proc findmatches {f} {
6699 global findtype findstring
6700 if {$findtype == [mc "Regexp"]} {
6701 set matches [regexp -indices -all -inline $findstring $f]
6702 } else {
6703 set fs $findstring
6704 if {$findtype == [mc "IgnCase"]} {
6705 set f [string tolower $f]
6706 set fs [string tolower $fs]
6708 set matches {}
6709 set i 0
6710 set l [string length $fs]
6711 while {[set j [string first $fs $f $i]] >= 0} {
6712 lappend matches [list $j [expr {$j+$l-1}]]
6713 set i [expr {$j + $l}]
6716 return $matches
6719 proc dofind {{dirn 1} {wrap 1}} {
6720 global findstring findstartline findcurline selectedline numcommits
6721 global gdttype filehighlight fh_serial find_dirn findallowwrap
6723 if {[info exists find_dirn]} {
6724 if {$find_dirn == $dirn} return
6725 stopfinding
6727 focus .
6728 if {$findstring eq {} || $numcommits == 0} return
6729 if {$selectedline eq {}} {
6730 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6731 } else {
6732 set findstartline $selectedline
6734 set findcurline $findstartline
6735 nowbusy finding [mc "Searching"]
6736 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6737 after cancel do_file_hl $fh_serial
6738 do_file_hl $fh_serial
6740 set find_dirn $dirn
6741 set findallowwrap $wrap
6742 run findmore
6745 proc stopfinding {} {
6746 global find_dirn findcurline fprogcoord
6748 if {[info exists find_dirn]} {
6749 unset find_dirn
6750 unset findcurline
6751 notbusy finding
6752 set fprogcoord 0
6753 adjustprogress
6755 stopblaming
6758 proc findmore {} {
6759 global commitdata commitinfo numcommits findpattern findloc
6760 global findstartline findcurline findallowwrap
6761 global find_dirn gdttype fhighlights fprogcoord
6762 global curview varcorder vrownum varccommits vrowmod
6764 if {![info exists find_dirn]} {
6765 return 0
6767 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6768 set l $findcurline
6769 set moretodo 0
6770 if {$find_dirn > 0} {
6771 incr l
6772 if {$l >= $numcommits} {
6773 set l 0
6775 if {$l <= $findstartline} {
6776 set lim [expr {$findstartline + 1}]
6777 } else {
6778 set lim $numcommits
6779 set moretodo $findallowwrap
6781 } else {
6782 if {$l == 0} {
6783 set l $numcommits
6785 incr l -1
6786 if {$l >= $findstartline} {
6787 set lim [expr {$findstartline - 1}]
6788 } else {
6789 set lim -1
6790 set moretodo $findallowwrap
6793 set n [expr {($lim - $l) * $find_dirn}]
6794 if {$n > 500} {
6795 set n 500
6796 set moretodo 1
6798 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6799 update_arcrows $curview
6801 set found 0
6802 set domore 1
6803 set ai [bsearch $vrownum($curview) $l]
6804 set a [lindex $varcorder($curview) $ai]
6805 set arow [lindex $vrownum($curview) $ai]
6806 set ids [lindex $varccommits($curview,$a)]
6807 set arowend [expr {$arow + [llength $ids]}]
6808 if {$gdttype eq [mc "containing:"]} {
6809 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6810 if {$l < $arow || $l >= $arowend} {
6811 incr ai $find_dirn
6812 set a [lindex $varcorder($curview) $ai]
6813 set arow [lindex $vrownum($curview) $ai]
6814 set ids [lindex $varccommits($curview,$a)]
6815 set arowend [expr {$arow + [llength $ids]}]
6817 set id [lindex $ids [expr {$l - $arow}]]
6818 # shouldn't happen unless git log doesn't give all the commits...
6819 if {![info exists commitdata($id)] ||
6820 ![doesmatch $commitdata($id)]} {
6821 continue
6823 if {![info exists commitinfo($id)]} {
6824 getcommit $id
6826 set info $commitinfo($id)
6827 foreach f $info ty $fldtypes {
6828 if {$ty eq ""} continue
6829 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6830 [doesmatch $f]} {
6831 set found 1
6832 break
6835 if {$found} break
6837 } else {
6838 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6839 if {$l < $arow || $l >= $arowend} {
6840 incr ai $find_dirn
6841 set a [lindex $varcorder($curview) $ai]
6842 set arow [lindex $vrownum($curview) $ai]
6843 set ids [lindex $varccommits($curview,$a)]
6844 set arowend [expr {$arow + [llength $ids]}]
6846 set id [lindex $ids [expr {$l - $arow}]]
6847 if {![info exists fhighlights($id)]} {
6848 # this sets fhighlights($id) to -1
6849 askfilehighlight $l $id
6851 if {$fhighlights($id) > 0} {
6852 set found $domore
6853 break
6855 if {$fhighlights($id) < 0} {
6856 if {$domore} {
6857 set domore 0
6858 set findcurline [expr {$l - $find_dirn}]
6863 if {$found || ($domore && !$moretodo)} {
6864 unset findcurline
6865 unset find_dirn
6866 notbusy finding
6867 set fprogcoord 0
6868 adjustprogress
6869 if {$found} {
6870 findselectline $l
6871 } else {
6872 bell
6874 return 0
6876 if {!$domore} {
6877 flushhighlights
6878 } else {
6879 set findcurline [expr {$l - $find_dirn}]
6881 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6882 if {$n < 0} {
6883 incr n $numcommits
6885 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6886 adjustprogress
6887 return $domore
6890 proc findselectline {l} {
6891 global findloc commentend ctext findcurline markingmatches gdttype
6893 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6894 set findcurline $l
6895 selectline $l 1
6896 if {$markingmatches &&
6897 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6898 # highlight the matches in the comments
6899 set f [$ctext get 1.0 $commentend]
6900 set matches [findmatches $f]
6901 foreach match $matches {
6902 set start [lindex $match 0]
6903 set end [expr {[lindex $match 1] + 1}]
6904 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6907 drawvisible
6910 # mark the bits of a headline or author that match a find string
6911 proc markmatches {canv l str tag matches font row} {
6912 global selectedline
6914 set bbox [$canv bbox $tag]
6915 set x0 [lindex $bbox 0]
6916 set y0 [lindex $bbox 1]
6917 set y1 [lindex $bbox 3]
6918 foreach match $matches {
6919 set start [lindex $match 0]
6920 set end [lindex $match 1]
6921 if {$start > $end} continue
6922 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6923 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6924 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6925 [expr {$x0+$xlen+2}] $y1 \
6926 -outline {} -tags [list match$l matches] -fill yellow]
6927 $canv lower $t
6928 if {$row == $selectedline} {
6929 $canv raise $t secsel
6934 proc unmarkmatches {} {
6935 global markingmatches
6937 allcanvs delete matches
6938 set markingmatches 0
6939 stopfinding
6942 proc selcanvline {w x y} {
6943 global canv canvy0 ctext linespc
6944 global rowtextx
6945 set ymax [lindex [$canv cget -scrollregion] 3]
6946 if {$ymax == {}} return
6947 set yfrac [lindex [$canv yview] 0]
6948 set y [expr {$y + $yfrac * $ymax}]
6949 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6950 if {$l < 0} {
6951 set l 0
6953 if {$w eq $canv} {
6954 set xmax [lindex [$canv cget -scrollregion] 2]
6955 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6956 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6958 unmarkmatches
6959 selectline $l 1
6962 proc commit_descriptor {p} {
6963 global commitinfo
6964 if {![info exists commitinfo($p)]} {
6965 getcommit $p
6967 set l "..."
6968 if {[llength $commitinfo($p)] > 1} {
6969 set l [lindex $commitinfo($p) 0]
6971 return "$p ($l)\n"
6974 # append some text to the ctext widget, and make any SHA1 ID
6975 # that we know about be a clickable link.
6976 proc appendwithlinks {text tags} {
6977 global ctext linknum curview
6979 set start [$ctext index "end - 1c"]
6980 $ctext insert end $text $tags
6981 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6982 foreach l $links {
6983 set s [lindex $l 0]
6984 set e [lindex $l 1]
6985 set linkid [string range $text $s $e]
6986 incr e
6987 $ctext tag delete link$linknum
6988 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6989 setlink $linkid link$linknum
6990 incr linknum
6994 proc setlink {id lk} {
6995 global curview ctext pendinglinks
6996 global linkfgcolor
6998 if {[string range $id 0 1] eq "-g"} {
6999 set id [string range $id 2 end]
7002 set known 0
7003 if {[string length $id] < 40} {
7004 set matches [longid $id]
7005 if {[llength $matches] > 0} {
7006 if {[llength $matches] > 1} return
7007 set known 1
7008 set id [lindex $matches 0]
7010 } else {
7011 set known [commitinview $id $curview]
7013 if {$known} {
7014 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7015 $ctext tag bind $lk <1> [list selbyid $id]
7016 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7017 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7018 } else {
7019 lappend pendinglinks($id) $lk
7020 interestedin $id {makelink %P}
7024 proc appendshortlink {id {pre {}} {post {}}} {
7025 global ctext linknum
7027 $ctext insert end $pre
7028 $ctext tag delete link$linknum
7029 $ctext insert end [string range $id 0 7] link$linknum
7030 $ctext insert end $post
7031 setlink $id link$linknum
7032 incr linknum
7035 proc makelink {id} {
7036 global pendinglinks
7038 if {![info exists pendinglinks($id)]} return
7039 foreach lk $pendinglinks($id) {
7040 setlink $id $lk
7042 unset pendinglinks($id)
7045 proc linkcursor {w inc} {
7046 global linkentercount curtextcursor
7048 if {[incr linkentercount $inc] > 0} {
7049 $w configure -cursor hand2
7050 } else {
7051 $w configure -cursor $curtextcursor
7052 if {$linkentercount < 0} {
7053 set linkentercount 0
7058 proc viewnextline {dir} {
7059 global canv linespc
7061 $canv delete hover
7062 set ymax [lindex [$canv cget -scrollregion] 3]
7063 set wnow [$canv yview]
7064 set wtop [expr {[lindex $wnow 0] * $ymax}]
7065 set newtop [expr {$wtop + $dir * $linespc}]
7066 if {$newtop < 0} {
7067 set newtop 0
7068 } elseif {$newtop > $ymax} {
7069 set newtop $ymax
7071 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7074 # add a list of tag or branch names at position pos
7075 # returns the number of names inserted
7076 proc appendrefs {pos ids var} {
7077 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7079 if {[catch {$ctext index $pos}]} {
7080 return 0
7082 $ctext conf -state normal
7083 $ctext delete $pos "$pos lineend"
7084 set tags {}
7085 foreach id $ids {
7086 foreach tag [set $var\($id\)] {
7087 lappend tags [list $tag $id]
7091 set sep {}
7092 set tags [lsort -index 0 -decreasing $tags]
7093 set nutags 0
7095 if {[llength $tags] > $maxrefs} {
7096 # If we are displaying heads, and there are too many,
7097 # see if there are some important heads to display.
7098 # Currently that are the current head and heads listed in $visiblerefs option
7099 set itags {}
7100 if {$var eq "idheads"} {
7101 set utags {}
7102 foreach ti $tags {
7103 set hname [lindex $ti 0]
7104 set id [lindex $ti 1]
7105 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7106 [llength $itags] < $maxrefs} {
7107 lappend itags $ti
7108 } else {
7109 lappend utags $ti
7112 set tags $utags
7114 if {$itags ne {}} {
7115 set str [mc "and many more"]
7116 set sep " "
7117 } else {
7118 set str [mc "many"]
7120 $ctext insert $pos "$str ([llength $tags])"
7121 set nutags [llength $tags]
7122 set tags $itags
7125 foreach ti $tags {
7126 set id [lindex $ti 1]
7127 set lk link$linknum
7128 incr linknum
7129 $ctext tag delete $lk
7130 $ctext insert $pos $sep
7131 $ctext insert $pos [lindex $ti 0] $lk
7132 setlink $id $lk
7133 set sep ", "
7135 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7136 $ctext conf -state disabled
7137 return [expr {[llength $tags] + $nutags}]
7140 # called when we have finished computing the nearby tags
7141 proc dispneartags {delay} {
7142 global selectedline currentid showneartags tagphase
7144 if {$selectedline eq {} || !$showneartags} return
7145 after cancel dispnexttag
7146 if {$delay} {
7147 after 200 dispnexttag
7148 set tagphase -1
7149 } else {
7150 after idle dispnexttag
7151 set tagphase 0
7155 proc dispnexttag {} {
7156 global selectedline currentid showneartags tagphase ctext
7158 if {$selectedline eq {} || !$showneartags} return
7159 switch -- $tagphase {
7161 set dtags [desctags $currentid]
7162 if {$dtags ne {}} {
7163 appendrefs precedes $dtags idtags
7167 set atags [anctags $currentid]
7168 if {$atags ne {}} {
7169 appendrefs follows $atags idtags
7173 set dheads [descheads $currentid]
7174 if {$dheads ne {}} {
7175 if {[appendrefs branch $dheads idheads] > 1
7176 && [$ctext get "branch -3c"] eq "h"} {
7177 # turn "Branch" into "Branches"
7178 $ctext conf -state normal
7179 $ctext insert "branch -2c" "es"
7180 $ctext conf -state disabled
7185 if {[incr tagphase] <= 2} {
7186 after idle dispnexttag
7190 proc make_secsel {id} {
7191 global linehtag linentag linedtag canv canv2 canv3
7193 if {![info exists linehtag($id)]} return
7194 $canv delete secsel
7195 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7196 -tags secsel -fill [$canv cget -selectbackground]]
7197 $canv lower $t
7198 $canv2 delete secsel
7199 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7200 -tags secsel -fill [$canv2 cget -selectbackground]]
7201 $canv2 lower $t
7202 $canv3 delete secsel
7203 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7204 -tags secsel -fill [$canv3 cget -selectbackground]]
7205 $canv3 lower $t
7208 proc make_idmark {id} {
7209 global linehtag canv fgcolor
7211 if {![info exists linehtag($id)]} return
7212 $canv delete markid
7213 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7214 -tags markid -outline $fgcolor]
7215 $canv raise $t
7218 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7219 global canv ctext commitinfo selectedline
7220 global canvy0 linespc parents children curview
7221 global currentid sha1entry
7222 global commentend idtags linknum
7223 global mergemax numcommits pending_select
7224 global cmitmode showneartags allcommits
7225 global targetrow targetid lastscrollrows
7226 global autoselect autosellen jump_to_here
7227 global vinlinediff
7229 catch {unset pending_select}
7230 $canv delete hover
7231 normalline
7232 unsel_reflist
7233 stopfinding
7234 if {$l < 0 || $l >= $numcommits} return
7235 set id [commitonrow $l]
7236 set targetid $id
7237 set targetrow $l
7238 set selectedline $l
7239 set currentid $id
7240 if {$lastscrollrows < $numcommits} {
7241 setcanvscroll
7244 if {$cmitmode ne "patch" && $switch_to_patch} {
7245 set cmitmode "patch"
7248 set y [expr {$canvy0 + $l * $linespc}]
7249 set ymax [lindex [$canv cget -scrollregion] 3]
7250 set ytop [expr {$y - $linespc - 1}]
7251 set ybot [expr {$y + $linespc + 1}]
7252 set wnow [$canv yview]
7253 set wtop [expr {[lindex $wnow 0] * $ymax}]
7254 set wbot [expr {[lindex $wnow 1] * $ymax}]
7255 set wh [expr {$wbot - $wtop}]
7256 set newtop $wtop
7257 if {$ytop < $wtop} {
7258 if {$ybot < $wtop} {
7259 set newtop [expr {$y - $wh / 2.0}]
7260 } else {
7261 set newtop $ytop
7262 if {$newtop > $wtop - $linespc} {
7263 set newtop [expr {$wtop - $linespc}]
7266 } elseif {$ybot > $wbot} {
7267 if {$ytop > $wbot} {
7268 set newtop [expr {$y - $wh / 2.0}]
7269 } else {
7270 set newtop [expr {$ybot - $wh}]
7271 if {$newtop < $wtop + $linespc} {
7272 set newtop [expr {$wtop + $linespc}]
7276 if {$newtop != $wtop} {
7277 if {$newtop < 0} {
7278 set newtop 0
7280 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7281 drawvisible
7284 make_secsel $id
7286 if {$isnew} {
7287 addtohistory [list selbyid $id 0] savecmitpos
7290 $sha1entry delete 0 end
7291 $sha1entry insert 0 $id
7292 if {$autoselect} {
7293 $sha1entry selection range 0 $autosellen
7295 rhighlight_sel $id
7297 $ctext conf -state normal
7298 clear_ctext
7299 set linknum 0
7300 if {![info exists commitinfo($id)]} {
7301 getcommit $id
7303 set info $commitinfo($id)
7304 set date [formatdate [lindex $info 2]]
7305 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7306 set date [formatdate [lindex $info 4]]
7307 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7308 if {[info exists idtags($id)]} {
7309 $ctext insert end [mc "Tags:"]
7310 foreach tag $idtags($id) {
7311 $ctext insert end " $tag"
7313 $ctext insert end "\n"
7316 set headers {}
7317 set olds $parents($curview,$id)
7318 if {[llength $olds] > 1} {
7319 set np 0
7320 foreach p $olds {
7321 if {$np >= $mergemax} {
7322 set tag mmax
7323 } else {
7324 set tag m$np
7326 $ctext insert end "[mc "Parent"]: " $tag
7327 appendwithlinks [commit_descriptor $p] {}
7328 incr np
7330 } else {
7331 foreach p $olds {
7332 append headers "[mc "Parent"]: [commit_descriptor $p]"
7336 foreach c $children($curview,$id) {
7337 append headers "[mc "Child"]: [commit_descriptor $c]"
7340 # make anything that looks like a SHA1 ID be a clickable link
7341 appendwithlinks $headers {}
7342 if {$showneartags} {
7343 if {![info exists allcommits]} {
7344 getallcommits
7346 $ctext insert end "[mc "Branch"]: "
7347 $ctext mark set branch "end -1c"
7348 $ctext mark gravity branch left
7349 $ctext insert end "\n[mc "Follows"]: "
7350 $ctext mark set follows "end -1c"
7351 $ctext mark gravity follows left
7352 $ctext insert end "\n[mc "Precedes"]: "
7353 $ctext mark set precedes "end -1c"
7354 $ctext mark gravity precedes left
7355 $ctext insert end "\n"
7356 dispneartags 1
7358 $ctext insert end "\n"
7359 set comment [lindex $info 5]
7360 if {[string first "\r" $comment] >= 0} {
7361 set comment [string map {"\r" "\n "} $comment]
7363 appendwithlinks $comment {comment}
7365 $ctext tag remove found 1.0 end
7366 $ctext conf -state disabled
7367 set commentend [$ctext index "end - 1c"]
7369 set jump_to_here $desired_loc
7370 init_flist [mc "Comments"]
7371 if {$cmitmode eq "tree"} {
7372 gettree $id
7373 } elseif {$vinlinediff($curview) == 1} {
7374 showinlinediff $id
7375 } elseif {[llength $olds] <= 1} {
7376 startdiff $id
7377 } else {
7378 mergediff $id
7382 proc selfirstline {} {
7383 unmarkmatches
7384 selectline 0 1
7387 proc sellastline {} {
7388 global numcommits
7389 unmarkmatches
7390 set l [expr {$numcommits - 1}]
7391 selectline $l 1
7394 proc selnextline {dir} {
7395 global selectedline
7396 focus .
7397 if {$selectedline eq {}} return
7398 set l [expr {$selectedline + $dir}]
7399 unmarkmatches
7400 selectline $l 1
7403 proc selnextpage {dir} {
7404 global canv linespc selectedline numcommits
7406 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7407 if {$lpp < 1} {
7408 set lpp 1
7410 allcanvs yview scroll [expr {$dir * $lpp}] units
7411 drawvisible
7412 if {$selectedline eq {}} return
7413 set l [expr {$selectedline + $dir * $lpp}]
7414 if {$l < 0} {
7415 set l 0
7416 } elseif {$l >= $numcommits} {
7417 set l [expr $numcommits - 1]
7419 unmarkmatches
7420 selectline $l 1
7423 proc unselectline {} {
7424 global selectedline currentid
7426 set selectedline {}
7427 catch {unset currentid}
7428 allcanvs delete secsel
7429 rhighlight_none
7432 proc reselectline {} {
7433 global selectedline
7435 if {$selectedline ne {}} {
7436 selectline $selectedline 0
7440 proc addtohistory {cmd {saveproc {}}} {
7441 global history historyindex curview
7443 unset_posvars
7444 save_position
7445 set elt [list $curview $cmd $saveproc {}]
7446 if {$historyindex > 0
7447 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7448 return
7451 if {$historyindex < [llength $history]} {
7452 set history [lreplace $history $historyindex end $elt]
7453 } else {
7454 lappend history $elt
7456 incr historyindex
7457 if {$historyindex > 1} {
7458 .tf.bar.leftbut conf -state normal
7459 } else {
7460 .tf.bar.leftbut conf -state disabled
7462 .tf.bar.rightbut conf -state disabled
7465 # save the scrolling position of the diff display pane
7466 proc save_position {} {
7467 global historyindex history
7469 if {$historyindex < 1} return
7470 set hi [expr {$historyindex - 1}]
7471 set fn [lindex $history $hi 2]
7472 if {$fn ne {}} {
7473 lset history $hi 3 [eval $fn]
7477 proc unset_posvars {} {
7478 global last_posvars
7480 if {[info exists last_posvars]} {
7481 foreach {var val} $last_posvars {
7482 global $var
7483 catch {unset $var}
7485 unset last_posvars
7489 proc godo {elt} {
7490 global curview last_posvars
7492 set view [lindex $elt 0]
7493 set cmd [lindex $elt 1]
7494 set pv [lindex $elt 3]
7495 if {$curview != $view} {
7496 showview $view
7498 unset_posvars
7499 foreach {var val} $pv {
7500 global $var
7501 set $var $val
7503 set last_posvars $pv
7504 eval $cmd
7507 proc goback {} {
7508 global history historyindex
7509 focus .
7511 if {$historyindex > 1} {
7512 save_position
7513 incr historyindex -1
7514 godo [lindex $history [expr {$historyindex - 1}]]
7515 .tf.bar.rightbut conf -state normal
7517 if {$historyindex <= 1} {
7518 .tf.bar.leftbut conf -state disabled
7522 proc goforw {} {
7523 global history historyindex
7524 focus .
7526 if {$historyindex < [llength $history]} {
7527 save_position
7528 set cmd [lindex $history $historyindex]
7529 incr historyindex
7530 godo $cmd
7531 .tf.bar.leftbut conf -state normal
7533 if {$historyindex >= [llength $history]} {
7534 .tf.bar.rightbut conf -state disabled
7538 proc go_to_parent {i} {
7539 global parents curview targetid
7540 set ps $parents($curview,$targetid)
7541 if {[llength $ps] >= $i} {
7542 selbyid [lindex $ps [expr $i - 1]]
7546 proc gettree {id} {
7547 global treefilelist treeidlist diffids diffmergeid treepending
7548 global nullid nullid2
7550 set diffids $id
7551 catch {unset diffmergeid}
7552 if {![info exists treefilelist($id)]} {
7553 if {![info exists treepending]} {
7554 if {$id eq $nullid} {
7555 set cmd [list | git ls-files]
7556 } elseif {$id eq $nullid2} {
7557 set cmd [list | git ls-files --stage -t]
7558 } else {
7559 set cmd [list | git ls-tree -r $id]
7561 if {[catch {set gtf [open $cmd r]}]} {
7562 return
7564 set treepending $id
7565 set treefilelist($id) {}
7566 set treeidlist($id) {}
7567 fconfigure $gtf -blocking 0 -encoding binary
7568 filerun $gtf [list gettreeline $gtf $id]
7570 } else {
7571 setfilelist $id
7575 proc gettreeline {gtf id} {
7576 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7578 set nl 0
7579 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7580 if {$diffids eq $nullid} {
7581 set fname $line
7582 } else {
7583 set i [string first "\t" $line]
7584 if {$i < 0} continue
7585 set fname [string range $line [expr {$i+1}] end]
7586 set line [string range $line 0 [expr {$i-1}]]
7587 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7588 set sha1 [lindex $line 2]
7589 lappend treeidlist($id) $sha1
7591 if {[string index $fname 0] eq "\""} {
7592 set fname [lindex $fname 0]
7594 set fname [encoding convertfrom $fname]
7595 lappend treefilelist($id) $fname
7597 if {![eof $gtf]} {
7598 return [expr {$nl >= 1000? 2: 1}]
7600 close $gtf
7601 unset treepending
7602 if {$cmitmode ne "tree"} {
7603 if {![info exists diffmergeid]} {
7604 gettreediffs $diffids
7606 } elseif {$id ne $diffids} {
7607 gettree $diffids
7608 } else {
7609 setfilelist $id
7611 return 0
7614 proc showfile {f} {
7615 global treefilelist treeidlist diffids nullid nullid2
7616 global ctext_file_names ctext_file_lines
7617 global ctext commentend
7619 set i [lsearch -exact $treefilelist($diffids) $f]
7620 if {$i < 0} {
7621 puts "oops, $f not in list for id $diffids"
7622 return
7624 if {$diffids eq $nullid} {
7625 if {[catch {set bf [open $f r]} err]} {
7626 puts "oops, can't read $f: $err"
7627 return
7629 } else {
7630 set blob [lindex $treeidlist($diffids) $i]
7631 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7632 puts "oops, error reading blob $blob: $err"
7633 return
7636 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7637 filerun $bf [list getblobline $bf $diffids]
7638 $ctext config -state normal
7639 clear_ctext $commentend
7640 lappend ctext_file_names $f
7641 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7642 $ctext insert end "\n"
7643 $ctext insert end "$f\n" filesep
7644 $ctext config -state disabled
7645 $ctext yview $commentend
7646 settabs 0
7649 proc getblobline {bf id} {
7650 global diffids cmitmode ctext
7652 if {$id ne $diffids || $cmitmode ne "tree"} {
7653 catch {close $bf}
7654 return 0
7656 $ctext config -state normal
7657 set nl 0
7658 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7659 $ctext insert end "$line\n"
7661 if {[eof $bf]} {
7662 global jump_to_here ctext_file_names commentend
7664 # delete last newline
7665 $ctext delete "end - 2c" "end - 1c"
7666 close $bf
7667 if {$jump_to_here ne {} &&
7668 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7669 set lnum [expr {[lindex $jump_to_here 1] +
7670 [lindex [split $commentend .] 0]}]
7671 mark_ctext_line $lnum
7673 $ctext config -state disabled
7674 return 0
7676 $ctext config -state disabled
7677 return [expr {$nl >= 1000? 2: 1}]
7680 proc mark_ctext_line {lnum} {
7681 global ctext markbgcolor
7683 $ctext tag delete omark
7684 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7685 $ctext tag conf omark -background $markbgcolor
7686 $ctext see $lnum.0
7689 proc mergediff {id} {
7690 global diffmergeid
7691 global diffids treediffs
7692 global parents curview
7694 set diffmergeid $id
7695 set diffids $id
7696 set treediffs($id) {}
7697 set np [llength $parents($curview,$id)]
7698 settabs $np
7699 getblobdiffs $id
7702 proc startdiff {ids} {
7703 global treediffs diffids treepending diffmergeid nullid nullid2
7705 settabs 1
7706 set diffids $ids
7707 catch {unset diffmergeid}
7708 if {![info exists treediffs($ids)] ||
7709 [lsearch -exact $ids $nullid] >= 0 ||
7710 [lsearch -exact $ids $nullid2] >= 0} {
7711 if {![info exists treepending]} {
7712 gettreediffs $ids
7714 } else {
7715 addtocflist $ids
7719 proc showinlinediff {ids} {
7720 global commitinfo commitdata ctext
7721 global treediffs
7723 set info $commitinfo($ids)
7724 set diff [lindex $info 7]
7725 set difflines [split $diff "\n"]
7727 initblobdiffvars
7728 set treediff {}
7730 set inhdr 0
7731 foreach line $difflines {
7732 if {![string compare -length 5 "diff " $line]} {
7733 set inhdr 1
7734 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7735 # offset also accounts for the b/ prefix
7736 lappend treediff [string range $line 6 end]
7737 set inhdr 0
7741 set treediffs($ids) $treediff
7742 add_flist $treediff
7744 $ctext conf -state normal
7745 foreach line $difflines {
7746 parseblobdiffline $ids $line
7748 maybe_scroll_ctext 1
7749 $ctext conf -state disabled
7752 # If the filename (name) is under any of the passed filter paths
7753 # then return true to include the file in the listing.
7754 proc path_filter {filter name} {
7755 set worktree [gitworktree]
7756 foreach p $filter {
7757 set fq_p [file normalize $p]
7758 set fq_n [file normalize [file join $worktree $name]]
7759 if {[string match [file normalize $fq_p]* $fq_n]} {
7760 return 1
7763 return 0
7766 proc addtocflist {ids} {
7767 global treediffs
7769 add_flist $treediffs($ids)
7770 getblobdiffs $ids
7773 proc diffcmd {ids flags} {
7774 global log_showroot nullid nullid2 git_version
7776 set i [lsearch -exact $ids $nullid]
7777 set j [lsearch -exact $ids $nullid2]
7778 if {$i >= 0} {
7779 if {[llength $ids] > 1 && $j < 0} {
7780 # comparing working directory with some specific revision
7781 set cmd [concat | git diff-index $flags]
7782 if {$i == 0} {
7783 lappend cmd -R [lindex $ids 1]
7784 } else {
7785 lappend cmd [lindex $ids 0]
7787 } else {
7788 # comparing working directory with index
7789 set cmd [concat | git diff-files $flags]
7790 if {$j == 1} {
7791 lappend cmd -R
7794 } elseif {$j >= 0} {
7795 if {[package vcompare $git_version "1.7.2"] >= 0} {
7796 set flags "$flags --ignore-submodules=dirty"
7798 set cmd [concat | git diff-index --cached $flags]
7799 if {[llength $ids] > 1} {
7800 # comparing index with specific revision
7801 if {$j == 0} {
7802 lappend cmd -R [lindex $ids 1]
7803 } else {
7804 lappend cmd [lindex $ids 0]
7806 } else {
7807 # comparing index with HEAD
7808 lappend cmd HEAD
7810 } else {
7811 if {$log_showroot} {
7812 lappend flags --root
7814 set cmd [concat | git diff-tree -r $flags $ids]
7816 return $cmd
7819 proc gettreediffs {ids} {
7820 global treediff treepending limitdiffs vfilelimit curview
7822 set cmd [diffcmd $ids {--no-commit-id}]
7823 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7824 set cmd [concat $cmd -- $vfilelimit($curview)]
7826 if {[catch {set gdtf [open $cmd r]}]} return
7828 set treepending $ids
7829 set treediff {}
7830 fconfigure $gdtf -blocking 0 -encoding binary
7831 filerun $gdtf [list gettreediffline $gdtf $ids]
7834 proc gettreediffline {gdtf ids} {
7835 global treediff treediffs treepending diffids diffmergeid
7836 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7838 set nr 0
7839 set sublist {}
7840 set max 1000
7841 if {$perfile_attrs} {
7842 # cache_gitattr is slow, and even slower on win32 where we
7843 # have to invoke it for only about 30 paths at a time
7844 set max 500
7845 if {[tk windowingsystem] == "win32"} {
7846 set max 120
7849 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7850 set i [string first "\t" $line]
7851 if {$i >= 0} {
7852 set file [string range $line [expr {$i+1}] end]
7853 if {[string index $file 0] eq "\""} {
7854 set file [lindex $file 0]
7856 set file [encoding convertfrom $file]
7857 if {$file ne [lindex $treediff end]} {
7858 lappend treediff $file
7859 lappend sublist $file
7863 if {$perfile_attrs} {
7864 cache_gitattr encoding $sublist
7866 if {![eof $gdtf]} {
7867 return [expr {$nr >= $max? 2: 1}]
7869 close $gdtf
7870 set treediffs($ids) $treediff
7871 unset treepending
7872 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7873 gettree $diffids
7874 } elseif {$ids != $diffids} {
7875 if {![info exists diffmergeid]} {
7876 gettreediffs $diffids
7878 } else {
7879 addtocflist $ids
7881 return 0
7884 # empty string or positive integer
7885 proc diffcontextvalidate {v} {
7886 return [regexp {^(|[1-9][0-9]*)$} $v]
7889 proc diffcontextchange {n1 n2 op} {
7890 global diffcontextstring diffcontext
7892 if {[string is integer -strict $diffcontextstring]} {
7893 if {$diffcontextstring >= 0} {
7894 set diffcontext $diffcontextstring
7895 reselectline
7900 proc changeignorespace {} {
7901 reselectline
7904 proc changeworddiff {name ix op} {
7905 reselectline
7908 proc initblobdiffvars {} {
7909 global diffencoding targetline diffnparents
7910 global diffinhdr currdiffsubmod diffseehere
7911 set targetline {}
7912 set diffnparents 0
7913 set diffinhdr 0
7914 set diffencoding [get_path_encoding {}]
7915 set currdiffsubmod ""
7916 set diffseehere -1
7919 proc getblobdiffs {ids} {
7920 global blobdifffd diffids env
7921 global treediffs
7922 global diffcontext
7923 global ignorespace
7924 global worddiff
7925 global limitdiffs vfilelimit curview
7926 global git_version
7928 set textconv {}
7929 if {[package vcompare $git_version "1.6.1"] >= 0} {
7930 set textconv "--textconv"
7932 set submodule {}
7933 if {[package vcompare $git_version "1.6.6"] >= 0} {
7934 set submodule "--submodule"
7936 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7937 if {$ignorespace} {
7938 append cmd " -w"
7940 if {$worddiff ne [mc "Line diff"]} {
7941 append cmd " --word-diff=porcelain"
7943 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7944 set cmd [concat $cmd -- $vfilelimit($curview)]
7946 if {[catch {set bdf [open $cmd r]} err]} {
7947 error_popup [mc "Error getting diffs: %s" $err]
7948 return
7950 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7951 set blobdifffd($ids) $bdf
7952 initblobdiffvars
7953 filerun $bdf [list getblobdiffline $bdf $diffids]
7956 proc savecmitpos {} {
7957 global ctext cmitmode
7959 if {$cmitmode eq "tree"} {
7960 return {}
7962 return [list target_scrollpos [$ctext index @0,0]]
7965 proc savectextpos {} {
7966 global ctext
7968 return [list target_scrollpos [$ctext index @0,0]]
7971 proc maybe_scroll_ctext {ateof} {
7972 global ctext target_scrollpos
7974 if {![info exists target_scrollpos]} return
7975 if {!$ateof} {
7976 set nlines [expr {[winfo height $ctext]
7977 / [font metrics textfont -linespace]}]
7978 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7980 $ctext yview $target_scrollpos
7981 unset target_scrollpos
7984 proc setinlist {var i val} {
7985 global $var
7987 while {[llength [set $var]] < $i} {
7988 lappend $var {}
7990 if {[llength [set $var]] == $i} {
7991 lappend $var $val
7992 } else {
7993 lset $var $i $val
7997 proc makediffhdr {fname ids} {
7998 global ctext curdiffstart treediffs diffencoding
7999 global ctext_file_names jump_to_here targetline diffline
8001 set fname [encoding convertfrom $fname]
8002 set diffencoding [get_path_encoding $fname]
8003 set i [lsearch -exact $treediffs($ids) $fname]
8004 if {$i >= 0} {
8005 setinlist difffilestart $i $curdiffstart
8007 lset ctext_file_names end $fname
8008 set l [expr {(78 - [string length $fname]) / 2}]
8009 set pad [string range "----------------------------------------" 1 $l]
8010 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8011 set targetline {}
8012 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8013 set targetline [lindex $jump_to_here 1]
8015 set diffline 0
8018 proc blobdiffmaybeseehere {ateof} {
8019 global diffseehere
8020 if {$diffseehere >= 0} {
8021 mark_ctext_line [lindex [split $diffseehere .] 0]
8023 maybe_scroll_ctext $ateof
8026 proc getblobdiffline {bdf ids} {
8027 global diffids blobdifffd
8028 global ctext
8030 set nr 0
8031 $ctext conf -state normal
8032 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8033 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8034 catch {close $bdf}
8035 return 0
8037 parseblobdiffline $ids $line
8039 $ctext conf -state disabled
8040 blobdiffmaybeseehere [eof $bdf]
8041 if {[eof $bdf]} {
8042 catch {close $bdf}
8043 return 0
8045 return [expr {$nr >= 1000? 2: 1}]
8048 proc parseblobdiffline {ids line} {
8049 global ctext curdiffstart
8050 global diffnexthead diffnextnote difffilestart
8051 global ctext_file_names ctext_file_lines
8052 global diffinhdr treediffs mergemax diffnparents
8053 global diffencoding jump_to_here targetline diffline currdiffsubmod
8054 global worddiff diffseehere
8056 if {![string compare -length 5 "diff " $line]} {
8057 if {![regexp {^diff (--cc|--git) } $line m type]} {
8058 set line [encoding convertfrom $line]
8059 $ctext insert end "$line\n" hunksep
8060 continue
8062 # start of a new file
8063 set diffinhdr 1
8064 $ctext insert end "\n"
8065 set curdiffstart [$ctext index "end - 1c"]
8066 lappend ctext_file_names ""
8067 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8068 $ctext insert end "\n" filesep
8070 if {$type eq "--cc"} {
8071 # start of a new file in a merge diff
8072 set fname [string range $line 10 end]
8073 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8074 lappend treediffs($ids) $fname
8075 add_flist [list $fname]
8078 } else {
8079 set line [string range $line 11 end]
8080 # If the name hasn't changed the length will be odd,
8081 # the middle char will be a space, and the two bits either
8082 # side will be a/name and b/name, or "a/name" and "b/name".
8083 # If the name has changed we'll get "rename from" and
8084 # "rename to" or "copy from" and "copy to" lines following
8085 # this, and we'll use them to get the filenames.
8086 # This complexity is necessary because spaces in the
8087 # filename(s) don't get escaped.
8088 set l [string length $line]
8089 set i [expr {$l / 2}]
8090 if {!(($l & 1) && [string index $line $i] eq " " &&
8091 [string range $line 2 [expr {$i - 1}]] eq \
8092 [string range $line [expr {$i + 3}] end])} {
8093 return
8095 # unescape if quoted and chop off the a/ from the front
8096 if {[string index $line 0] eq "\""} {
8097 set fname [string range [lindex $line 0] 2 end]
8098 } else {
8099 set fname [string range $line 2 [expr {$i - 1}]]
8102 makediffhdr $fname $ids
8104 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8105 set fname [encoding convertfrom [string range $line 16 end]]
8106 $ctext insert end "\n"
8107 set curdiffstart [$ctext index "end - 1c"]
8108 lappend ctext_file_names $fname
8109 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8110 $ctext insert end "$line\n" filesep
8111 set i [lsearch -exact $treediffs($ids) $fname]
8112 if {$i >= 0} {
8113 setinlist difffilestart $i $curdiffstart
8116 } elseif {![string compare -length 2 "@@" $line]} {
8117 regexp {^@@+} $line ats
8118 set line [encoding convertfrom $diffencoding $line]
8119 $ctext insert end "$line\n" hunksep
8120 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8121 set diffline $nl
8123 set diffnparents [expr {[string length $ats] - 1}]
8124 set diffinhdr 0
8126 } elseif {![string compare -length 10 "Submodule " $line]} {
8127 # start of a new submodule
8128 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8129 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8130 } else {
8131 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8133 if {$currdiffsubmod != $fname} {
8134 $ctext insert end "\n"; # Add newline after commit message
8136 set curdiffstart [$ctext index "end - 1c"]
8137 lappend ctext_file_names ""
8138 if {$currdiffsubmod != $fname} {
8139 lappend ctext_file_lines $fname
8140 makediffhdr $fname $ids
8141 set currdiffsubmod $fname
8142 $ctext insert end "\n$line\n" filesep
8143 } else {
8144 $ctext insert end "$line\n" filesep
8146 } elseif {![string compare -length 3 " >" $line]} {
8147 set $currdiffsubmod ""
8148 set line [encoding convertfrom $diffencoding $line]
8149 $ctext insert end "$line\n" dresult
8150 } elseif {![string compare -length 3 " <" $line]} {
8151 set $currdiffsubmod ""
8152 set line [encoding convertfrom $diffencoding $line]
8153 $ctext insert end "$line\n" d0
8154 } elseif {$diffinhdr} {
8155 if {![string compare -length 12 "rename from " $line]} {
8156 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8157 if {[string index $fname 0] eq "\""} {
8158 set fname [lindex $fname 0]
8160 set fname [encoding convertfrom $fname]
8161 set i [lsearch -exact $treediffs($ids) $fname]
8162 if {$i >= 0} {
8163 setinlist difffilestart $i $curdiffstart
8165 } elseif {![string compare -length 10 $line "rename to "] ||
8166 ![string compare -length 8 $line "copy to "]} {
8167 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8168 if {[string index $fname 0] eq "\""} {
8169 set fname [lindex $fname 0]
8171 makediffhdr $fname $ids
8172 } elseif {[string compare -length 3 $line "---"] == 0} {
8173 # do nothing
8174 return
8175 } elseif {[string compare -length 3 $line "+++"] == 0} {
8176 set diffinhdr 0
8177 return
8179 $ctext insert end "$line\n" filesep
8181 } else {
8182 set line [string map {\x1A ^Z} \
8183 [encoding convertfrom $diffencoding $line]]
8184 # parse the prefix - one ' ', '-' or '+' for each parent
8185 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8186 set tag [expr {$diffnparents > 1? "m": "d"}]
8187 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8188 set words_pre_markup ""
8189 set words_post_markup ""
8190 if {[string trim $prefix " -+"] eq {}} {
8191 # prefix only has " ", "-" and "+" in it: normal diff line
8192 set num [string first "-" $prefix]
8193 if {$dowords} {
8194 set line [string range $line 1 end]
8196 if {$num >= 0} {
8197 # removed line, first parent with line is $num
8198 if {$num >= $mergemax} {
8199 set num "max"
8201 if {$dowords && $worddiff eq [mc "Markup words"]} {
8202 $ctext insert end "\[-$line-\]" $tag$num
8203 } else {
8204 $ctext insert end "$line" $tag$num
8206 if {!$dowords} {
8207 $ctext insert end "\n" $tag$num
8209 } else {
8210 set tags {}
8211 if {[string first "+" $prefix] >= 0} {
8212 # added line
8213 lappend tags ${tag}result
8214 if {$diffnparents > 1} {
8215 set num [string first " " $prefix]
8216 if {$num >= 0} {
8217 if {$num >= $mergemax} {
8218 set num "max"
8220 lappend tags m$num
8223 set words_pre_markup "{+"
8224 set words_post_markup "+}"
8226 if {$targetline ne {}} {
8227 if {$diffline == $targetline} {
8228 set diffseehere [$ctext index "end - 1 chars"]
8229 set targetline {}
8230 } else {
8231 incr diffline
8234 if {$dowords && $worddiff eq [mc "Markup words"]} {
8235 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8236 } else {
8237 $ctext insert end "$line" $tags
8239 if {!$dowords} {
8240 $ctext insert end "\n" $tags
8243 } elseif {$dowords && $prefix eq "~"} {
8244 $ctext insert end "\n" {}
8245 } else {
8246 # "\ No newline at end of file",
8247 # or something else we don't recognize
8248 $ctext insert end "$line\n" hunksep
8253 proc changediffdisp {} {
8254 global ctext diffelide
8256 $ctext tag conf d0 -elide [lindex $diffelide 0]
8257 $ctext tag conf dresult -elide [lindex $diffelide 1]
8260 proc highlightfile {cline} {
8261 global cflist cflist_top
8263 if {![info exists cflist_top]} return
8265 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8266 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8267 $cflist see $cline.0
8268 set cflist_top $cline
8271 proc highlightfile_for_scrollpos {topidx} {
8272 global cmitmode difffilestart
8274 if {$cmitmode eq "tree"} return
8275 if {![info exists difffilestart]} return
8277 set top [lindex [split $topidx .] 0]
8278 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8279 highlightfile 0
8280 } else {
8281 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8285 proc prevfile {} {
8286 global difffilestart ctext cmitmode
8288 if {$cmitmode eq "tree"} return
8289 set prev 0.0
8290 set here [$ctext index @0,0]
8291 foreach loc $difffilestart {
8292 if {[$ctext compare $loc >= $here]} {
8293 $ctext yview $prev
8294 return
8296 set prev $loc
8298 $ctext yview $prev
8301 proc nextfile {} {
8302 global difffilestart ctext cmitmode
8304 if {$cmitmode eq "tree"} return
8305 set here [$ctext index @0,0]
8306 foreach loc $difffilestart {
8307 if {[$ctext compare $loc > $here]} {
8308 $ctext yview $loc
8309 return
8314 proc clear_ctext {{first 1.0}} {
8315 global ctext smarktop smarkbot
8316 global ctext_file_names ctext_file_lines
8317 global pendinglinks
8319 set l [lindex [split $first .] 0]
8320 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8321 set smarktop $l
8323 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8324 set smarkbot $l
8326 $ctext delete $first end
8327 if {$first eq "1.0"} {
8328 catch {unset pendinglinks}
8330 set ctext_file_names {}
8331 set ctext_file_lines {}
8334 proc settabs {{firstab {}}} {
8335 global firsttabstop tabstop ctext have_tk85
8337 if {$firstab ne {} && $have_tk85} {
8338 set firsttabstop $firstab
8340 set w [font measure textfont "0"]
8341 if {$firsttabstop != 0} {
8342 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8343 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8344 } elseif {$have_tk85 || $tabstop != 8} {
8345 $ctext conf -tabs [expr {$tabstop * $w}]
8346 } else {
8347 $ctext conf -tabs {}
8351 proc incrsearch {name ix op} {
8352 global ctext searchstring searchdirn
8354 if {[catch {$ctext index anchor}]} {
8355 # no anchor set, use start of selection, or of visible area
8356 set sel [$ctext tag ranges sel]
8357 if {$sel ne {}} {
8358 $ctext mark set anchor [lindex $sel 0]
8359 } elseif {$searchdirn eq "-forwards"} {
8360 $ctext mark set anchor @0,0
8361 } else {
8362 $ctext mark set anchor @0,[winfo height $ctext]
8365 if {$searchstring ne {}} {
8366 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8367 if {$here ne {}} {
8368 $ctext see $here
8369 set mend "$here + $mlen c"
8370 $ctext tag remove sel 1.0 end
8371 $ctext tag add sel $here $mend
8372 suppress_highlighting_file_for_current_scrollpos
8373 highlightfile_for_scrollpos $here
8376 rehighlight_search_results
8379 proc dosearch {} {
8380 global sstring ctext searchstring searchdirn
8382 focus $sstring
8383 $sstring icursor end
8384 set searchdirn -forwards
8385 if {$searchstring ne {}} {
8386 set sel [$ctext tag ranges sel]
8387 if {$sel ne {}} {
8388 set start "[lindex $sel 0] + 1c"
8389 } elseif {[catch {set start [$ctext index anchor]}]} {
8390 set start "@0,0"
8392 set match [$ctext search -count mlen -- $searchstring $start]
8393 $ctext tag remove sel 1.0 end
8394 if {$match eq {}} {
8395 bell
8396 return
8398 $ctext see $match
8399 suppress_highlighting_file_for_current_scrollpos
8400 highlightfile_for_scrollpos $match
8401 set mend "$match + $mlen c"
8402 $ctext tag add sel $match $mend
8403 $ctext mark unset anchor
8404 rehighlight_search_results
8408 proc dosearchback {} {
8409 global sstring ctext searchstring searchdirn
8411 focus $sstring
8412 $sstring icursor end
8413 set searchdirn -backwards
8414 if {$searchstring ne {}} {
8415 set sel [$ctext tag ranges sel]
8416 if {$sel ne {}} {
8417 set start [lindex $sel 0]
8418 } elseif {[catch {set start [$ctext index anchor]}]} {
8419 set start @0,[winfo height $ctext]
8421 set match [$ctext search -backwards -count ml -- $searchstring $start]
8422 $ctext tag remove sel 1.0 end
8423 if {$match eq {}} {
8424 bell
8425 return
8427 $ctext see $match
8428 suppress_highlighting_file_for_current_scrollpos
8429 highlightfile_for_scrollpos $match
8430 set mend "$match + $ml c"
8431 $ctext tag add sel $match $mend
8432 $ctext mark unset anchor
8433 rehighlight_search_results
8437 proc rehighlight_search_results {} {
8438 global ctext searchstring
8440 $ctext tag remove found 1.0 end
8441 $ctext tag remove currentsearchhit 1.0 end
8443 if {$searchstring ne {}} {
8444 searchmarkvisible 1
8448 proc searchmark {first last} {
8449 global ctext searchstring
8451 set sel [$ctext tag ranges sel]
8453 set mend $first.0
8454 while {1} {
8455 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8456 if {$match eq {}} break
8457 set mend "$match + $mlen c"
8458 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8459 $ctext tag add currentsearchhit $match $mend
8460 } else {
8461 $ctext tag add found $match $mend
8466 proc searchmarkvisible {doall} {
8467 global ctext smarktop smarkbot
8469 set topline [lindex [split [$ctext index @0,0] .] 0]
8470 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8471 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8472 # no overlap with previous
8473 searchmark $topline $botline
8474 set smarktop $topline
8475 set smarkbot $botline
8476 } else {
8477 if {$topline < $smarktop} {
8478 searchmark $topline [expr {$smarktop-1}]
8479 set smarktop $topline
8481 if {$botline > $smarkbot} {
8482 searchmark [expr {$smarkbot+1}] $botline
8483 set smarkbot $botline
8488 proc suppress_highlighting_file_for_current_scrollpos {} {
8489 global ctext suppress_highlighting_file_for_this_scrollpos
8491 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8494 proc scrolltext {f0 f1} {
8495 global searchstring cmitmode ctext
8496 global suppress_highlighting_file_for_this_scrollpos
8498 set topidx [$ctext index @0,0]
8499 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8500 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8501 highlightfile_for_scrollpos $topidx
8504 catch {unset suppress_highlighting_file_for_this_scrollpos}
8506 .bleft.bottom.sb set $f0 $f1
8507 if {$searchstring ne {}} {
8508 searchmarkvisible 0
8512 proc setcoords {} {
8513 global linespc charspc canvx0 canvy0
8514 global xspc1 xspc2 lthickness
8516 set linespc [font metrics mainfont -linespace]
8517 set charspc [font measure mainfont "m"]
8518 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8519 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8520 set lthickness [expr {int($linespc / 9) + 1}]
8521 set xspc1(0) $linespc
8522 set xspc2 $linespc
8525 proc redisplay {} {
8526 global canv
8527 global selectedline
8529 set ymax [lindex [$canv cget -scrollregion] 3]
8530 if {$ymax eq {} || $ymax == 0} return
8531 set span [$canv yview]
8532 clear_display
8533 setcanvscroll
8534 allcanvs yview moveto [lindex $span 0]
8535 drawvisible
8536 if {$selectedline ne {}} {
8537 selectline $selectedline 0
8538 allcanvs yview moveto [lindex $span 0]
8542 proc parsefont {f n} {
8543 global fontattr
8545 set fontattr($f,family) [lindex $n 0]
8546 set s [lindex $n 1]
8547 if {$s eq {} || $s == 0} {
8548 set s 10
8549 } elseif {$s < 0} {
8550 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8552 set fontattr($f,size) $s
8553 set fontattr($f,weight) normal
8554 set fontattr($f,slant) roman
8555 foreach style [lrange $n 2 end] {
8556 switch -- $style {
8557 "normal" -
8558 "bold" {set fontattr($f,weight) $style}
8559 "roman" -
8560 "italic" {set fontattr($f,slant) $style}
8565 proc fontflags {f {isbold 0}} {
8566 global fontattr
8568 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8569 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8570 -slant $fontattr($f,slant)]
8573 proc fontname {f} {
8574 global fontattr
8576 set n [list $fontattr($f,family) $fontattr($f,size)]
8577 if {$fontattr($f,weight) eq "bold"} {
8578 lappend n "bold"
8580 if {$fontattr($f,slant) eq "italic"} {
8581 lappend n "italic"
8583 return $n
8586 proc incrfont {inc} {
8587 global mainfont textfont ctext canv cflist showrefstop
8588 global stopped entries fontattr
8590 unmarkmatches
8591 set s $fontattr(mainfont,size)
8592 incr s $inc
8593 if {$s < 1} {
8594 set s 1
8596 set fontattr(mainfont,size) $s
8597 font config mainfont -size $s
8598 font config mainfontbold -size $s
8599 set mainfont [fontname mainfont]
8600 set s $fontattr(textfont,size)
8601 incr s $inc
8602 if {$s < 1} {
8603 set s 1
8605 set fontattr(textfont,size) $s
8606 font config textfont -size $s
8607 font config textfontbold -size $s
8608 set textfont [fontname textfont]
8609 setcoords
8610 settabs
8611 redisplay
8614 proc clearsha1 {} {
8615 global sha1entry sha1string
8616 if {[string length $sha1string] == 40} {
8617 $sha1entry delete 0 end
8621 proc sha1change {n1 n2 op} {
8622 global sha1string currentid sha1but
8623 if {$sha1string == {}
8624 || ([info exists currentid] && $sha1string == $currentid)} {
8625 set state disabled
8626 } else {
8627 set state normal
8629 if {[$sha1but cget -state] == $state} return
8630 if {$state == "normal"} {
8631 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8632 } else {
8633 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8637 proc gotocommit {} {
8638 global sha1string tagids headids curview varcid
8640 if {$sha1string == {}
8641 || ([info exists currentid] && $sha1string == $currentid)} return
8642 if {[info exists tagids($sha1string)]} {
8643 set id $tagids($sha1string)
8644 } elseif {[info exists headids($sha1string)]} {
8645 set id $headids($sha1string)
8646 } else {
8647 set id [string tolower $sha1string]
8648 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8649 set matches [longid $id]
8650 if {$matches ne {}} {
8651 if {[llength $matches] > 1} {
8652 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8653 return
8655 set id [lindex $matches 0]
8657 } else {
8658 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8659 error_popup [mc "Revision %s is not known" $sha1string]
8660 return
8664 if {[commitinview $id $curview]} {
8665 selectline [rowofcommit $id] 1
8666 return
8668 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8669 set msg [mc "SHA1 id %s is not known" $sha1string]
8670 } else {
8671 set msg [mc "Revision %s is not in the current view" $sha1string]
8673 error_popup $msg
8676 proc lineenter {x y id} {
8677 global hoverx hovery hoverid hovertimer
8678 global commitinfo canv
8680 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8681 set hoverx $x
8682 set hovery $y
8683 set hoverid $id
8684 if {[info exists hovertimer]} {
8685 after cancel $hovertimer
8687 set hovertimer [after 500 linehover]
8688 $canv delete hover
8691 proc linemotion {x y id} {
8692 global hoverx hovery hoverid hovertimer
8694 if {[info exists hoverid] && $id == $hoverid} {
8695 set hoverx $x
8696 set hovery $y
8697 if {[info exists hovertimer]} {
8698 after cancel $hovertimer
8700 set hovertimer [after 500 linehover]
8704 proc lineleave {id} {
8705 global hoverid hovertimer canv
8707 if {[info exists hoverid] && $id == $hoverid} {
8708 $canv delete hover
8709 if {[info exists hovertimer]} {
8710 after cancel $hovertimer
8711 unset hovertimer
8713 unset hoverid
8717 proc linehover {} {
8718 global hoverx hovery hoverid hovertimer
8719 global canv linespc lthickness
8720 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8722 global commitinfo
8724 set text [lindex $commitinfo($hoverid) 0]
8725 set ymax [lindex [$canv cget -scrollregion] 3]
8726 if {$ymax == {}} return
8727 set yfrac [lindex [$canv yview] 0]
8728 set x [expr {$hoverx + 2 * $linespc}]
8729 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8730 set x0 [expr {$x - 2 * $lthickness}]
8731 set y0 [expr {$y - 2 * $lthickness}]
8732 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8733 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8734 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8735 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8736 -width 1 -tags hover]
8737 $canv raise $t
8738 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8739 -font mainfont -fill $linehoverfgcolor]
8740 $canv raise $t
8743 proc clickisonarrow {id y} {
8744 global lthickness
8746 set ranges [rowranges $id]
8747 set thresh [expr {2 * $lthickness + 6}]
8748 set n [expr {[llength $ranges] - 1}]
8749 for {set i 1} {$i < $n} {incr i} {
8750 set row [lindex $ranges $i]
8751 if {abs([yc $row] - $y) < $thresh} {
8752 return $i
8755 return {}
8758 proc arrowjump {id n y} {
8759 global canv
8761 # 1 <-> 2, 3 <-> 4, etc...
8762 set n [expr {(($n - 1) ^ 1) + 1}]
8763 set row [lindex [rowranges $id] $n]
8764 set yt [yc $row]
8765 set ymax [lindex [$canv cget -scrollregion] 3]
8766 if {$ymax eq {} || $ymax <= 0} return
8767 set view [$canv yview]
8768 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8769 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8770 if {$yfrac < 0} {
8771 set yfrac 0
8773 allcanvs yview moveto $yfrac
8776 proc lineclick {x y id isnew} {
8777 global ctext commitinfo children canv thickerline curview
8779 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8780 unmarkmatches
8781 unselectline
8782 normalline
8783 $canv delete hover
8784 # draw this line thicker than normal
8785 set thickerline $id
8786 drawlines $id
8787 if {$isnew} {
8788 set ymax [lindex [$canv cget -scrollregion] 3]
8789 if {$ymax eq {}} return
8790 set yfrac [lindex [$canv yview] 0]
8791 set y [expr {$y + $yfrac * $ymax}]
8793 set dirn [clickisonarrow $id $y]
8794 if {$dirn ne {}} {
8795 arrowjump $id $dirn $y
8796 return
8799 if {$isnew} {
8800 addtohistory [list lineclick $x $y $id 0] savectextpos
8802 # fill the details pane with info about this line
8803 $ctext conf -state normal
8804 clear_ctext
8805 settabs 0
8806 $ctext insert end "[mc "Parent"]:\t"
8807 $ctext insert end $id link0
8808 setlink $id link0
8809 set info $commitinfo($id)
8810 $ctext insert end "\n\t[lindex $info 0]\n"
8811 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8812 set date [formatdate [lindex $info 2]]
8813 $ctext insert end "\t[mc "Date"]:\t$date\n"
8814 set kids $children($curview,$id)
8815 if {$kids ne {}} {
8816 $ctext insert end "\n[mc "Children"]:"
8817 set i 0
8818 foreach child $kids {
8819 incr i
8820 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8821 set info $commitinfo($child)
8822 $ctext insert end "\n\t"
8823 $ctext insert end $child link$i
8824 setlink $child link$i
8825 $ctext insert end "\n\t[lindex $info 0]"
8826 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8827 set date [formatdate [lindex $info 2]]
8828 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8831 maybe_scroll_ctext 1
8832 $ctext conf -state disabled
8833 init_flist {}
8836 proc normalline {} {
8837 global thickerline
8838 if {[info exists thickerline]} {
8839 set id $thickerline
8840 unset thickerline
8841 drawlines $id
8845 proc selbyid {id {isnew 1}} {
8846 global curview
8847 if {[commitinview $id $curview]} {
8848 selectline [rowofcommit $id] $isnew
8852 proc mstime {} {
8853 global startmstime
8854 if {![info exists startmstime]} {
8855 set startmstime [clock clicks -milliseconds]
8857 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8860 proc rowmenu {x y id} {
8861 global rowctxmenu selectedline rowmenuid curview
8862 global nullid nullid2 fakerowmenu mainhead markedid
8864 stopfinding
8865 set rowmenuid $id
8866 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8867 set state disabled
8868 } else {
8869 set state normal
8871 if {[info exists markedid] && $markedid ne $id} {
8872 set mstate normal
8873 } else {
8874 set mstate disabled
8876 if {$id ne $nullid && $id ne $nullid2} {
8877 set menu $rowctxmenu
8878 if {$mainhead ne {}} {
8879 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8880 } else {
8881 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8883 $menu entryconfigure 9 -state $mstate
8884 $menu entryconfigure 10 -state $mstate
8885 $menu entryconfigure 11 -state $mstate
8886 } else {
8887 set menu $fakerowmenu
8889 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8890 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8891 $menu entryconfigure [mca "Make patch"] -state $state
8892 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8893 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8894 tk_popup $menu $x $y
8897 proc markhere {} {
8898 global rowmenuid markedid canv
8900 set markedid $rowmenuid
8901 make_idmark $markedid
8904 proc gotomark {} {
8905 global markedid
8907 if {[info exists markedid]} {
8908 selbyid $markedid
8912 proc replace_by_kids {l r} {
8913 global curview children
8915 set id [commitonrow $r]
8916 set l [lreplace $l 0 0]
8917 foreach kid $children($curview,$id) {
8918 lappend l [rowofcommit $kid]
8920 return [lsort -integer -decreasing -unique $l]
8923 proc find_common_desc {} {
8924 global markedid rowmenuid curview children
8926 if {![info exists markedid]} return
8927 if {![commitinview $markedid $curview] ||
8928 ![commitinview $rowmenuid $curview]} return
8929 #set t1 [clock clicks -milliseconds]
8930 set l1 [list [rowofcommit $markedid]]
8931 set l2 [list [rowofcommit $rowmenuid]]
8932 while 1 {
8933 set r1 [lindex $l1 0]
8934 set r2 [lindex $l2 0]
8935 if {$r1 eq {} || $r2 eq {}} break
8936 if {$r1 == $r2} {
8937 selectline $r1 1
8938 break
8940 if {$r1 > $r2} {
8941 set l1 [replace_by_kids $l1 $r1]
8942 } else {
8943 set l2 [replace_by_kids $l2 $r2]
8946 #set t2 [clock clicks -milliseconds]
8947 #puts "took [expr {$t2-$t1}]ms"
8950 proc compare_commits {} {
8951 global markedid rowmenuid curview children
8953 if {![info exists markedid]} return
8954 if {![commitinview $markedid $curview]} return
8955 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8956 do_cmp_commits $markedid $rowmenuid
8959 proc getpatchid {id} {
8960 global patchids
8962 if {![info exists patchids($id)]} {
8963 set cmd [diffcmd [list $id] {-p --root}]
8964 # trim off the initial "|"
8965 set cmd [lrange $cmd 1 end]
8966 if {[catch {
8967 set x [eval exec $cmd | git patch-id]
8968 set patchids($id) [lindex $x 0]
8969 }]} {
8970 set patchids($id) "error"
8973 return $patchids($id)
8976 proc do_cmp_commits {a b} {
8977 global ctext curview parents children patchids commitinfo
8979 $ctext conf -state normal
8980 clear_ctext
8981 init_flist {}
8982 for {set i 0} {$i < 100} {incr i} {
8983 set skipa 0
8984 set skipb 0
8985 if {[llength $parents($curview,$a)] > 1} {
8986 appendshortlink $a [mc "Skipping merge commit "] "\n"
8987 set skipa 1
8988 } else {
8989 set patcha [getpatchid $a]
8991 if {[llength $parents($curview,$b)] > 1} {
8992 appendshortlink $b [mc "Skipping merge commit "] "\n"
8993 set skipb 1
8994 } else {
8995 set patchb [getpatchid $b]
8997 if {!$skipa && !$skipb} {
8998 set heada [lindex $commitinfo($a) 0]
8999 set headb [lindex $commitinfo($b) 0]
9000 if {$patcha eq "error"} {
9001 appendshortlink $a [mc "Error getting patch ID for "] \
9002 [mc " - stopping\n"]
9003 break
9005 if {$patchb eq "error"} {
9006 appendshortlink $b [mc "Error getting patch ID for "] \
9007 [mc " - stopping\n"]
9008 break
9010 if {$patcha eq $patchb} {
9011 if {$heada eq $headb} {
9012 appendshortlink $a [mc "Commit "]
9013 appendshortlink $b " == " " $heada\n"
9014 } else {
9015 appendshortlink $a [mc "Commit "] " $heada\n"
9016 appendshortlink $b [mc " is the same patch as\n "] \
9017 " $headb\n"
9019 set skipa 1
9020 set skipb 1
9021 } else {
9022 $ctext insert end "\n"
9023 appendshortlink $a [mc "Commit "] " $heada\n"
9024 appendshortlink $b [mc " differs from\n "] \
9025 " $headb\n"
9026 $ctext insert end [mc "Diff of commits:\n\n"]
9027 $ctext conf -state disabled
9028 update
9029 diffcommits $a $b
9030 return
9033 if {$skipa} {
9034 set kids [real_children $curview,$a]
9035 if {[llength $kids] != 1} {
9036 $ctext insert end "\n"
9037 appendshortlink $a [mc "Commit "] \
9038 [mc " has %s children - stopping\n" [llength $kids]]
9039 break
9041 set a [lindex $kids 0]
9043 if {$skipb} {
9044 set kids [real_children $curview,$b]
9045 if {[llength $kids] != 1} {
9046 appendshortlink $b [mc "Commit "] \
9047 [mc " has %s children - stopping\n" [llength $kids]]
9048 break
9050 set b [lindex $kids 0]
9053 $ctext conf -state disabled
9056 proc diffcommits {a b} {
9057 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9059 set tmpdir [gitknewtmpdir]
9060 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9061 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9062 if {[catch {
9063 exec git diff-tree -p --pretty $a >$fna
9064 exec git diff-tree -p --pretty $b >$fnb
9065 } err]} {
9066 error_popup [mc "Error writing commit to file: %s" $err]
9067 return
9069 if {[catch {
9070 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9071 } err]} {
9072 error_popup [mc "Error diffing commits: %s" $err]
9073 return
9075 set diffids [list commits $a $b]
9076 set blobdifffd($diffids) $fd
9077 set diffinhdr 0
9078 set currdiffsubmod ""
9079 filerun $fd [list getblobdiffline $fd $diffids]
9082 proc diffvssel {dirn} {
9083 global rowmenuid selectedline
9085 if {$selectedline eq {}} return
9086 if {$dirn} {
9087 set oldid [commitonrow $selectedline]
9088 set newid $rowmenuid
9089 } else {
9090 set oldid $rowmenuid
9091 set newid [commitonrow $selectedline]
9093 addtohistory [list doseldiff $oldid $newid] savectextpos
9094 doseldiff $oldid $newid
9097 proc diffvsmark {dirn} {
9098 global rowmenuid markedid
9100 if {![info exists markedid]} return
9101 if {$dirn} {
9102 set oldid $markedid
9103 set newid $rowmenuid
9104 } else {
9105 set oldid $rowmenuid
9106 set newid $markedid
9108 addtohistory [list doseldiff $oldid $newid] savectextpos
9109 doseldiff $oldid $newid
9112 proc doseldiff {oldid newid} {
9113 global ctext
9114 global commitinfo
9116 $ctext conf -state normal
9117 clear_ctext
9118 init_flist [mc "Top"]
9119 $ctext insert end "[mc "From"] "
9120 $ctext insert end $oldid link0
9121 setlink $oldid link0
9122 $ctext insert end "\n "
9123 $ctext insert end [lindex $commitinfo($oldid) 0]
9124 $ctext insert end "\n\n[mc "To"] "
9125 $ctext insert end $newid link1
9126 setlink $newid link1
9127 $ctext insert end "\n "
9128 $ctext insert end [lindex $commitinfo($newid) 0]
9129 $ctext insert end "\n"
9130 $ctext conf -state disabled
9131 $ctext tag remove found 1.0 end
9132 startdiff [list $oldid $newid]
9135 proc mkpatch {} {
9136 global rowmenuid currentid commitinfo patchtop patchnum NS
9138 if {![info exists currentid]} return
9139 set oldid $currentid
9140 set oldhead [lindex $commitinfo($oldid) 0]
9141 set newid $rowmenuid
9142 set newhead [lindex $commitinfo($newid) 0]
9143 set top .patch
9144 set patchtop $top
9145 catch {destroy $top}
9146 ttk_toplevel $top
9147 make_transient $top .
9148 ${NS}::label $top.title -text [mc "Generate patch"]
9149 grid $top.title - -pady 10
9150 ${NS}::label $top.from -text [mc "From:"]
9151 ${NS}::entry $top.fromsha1 -width 40
9152 $top.fromsha1 insert 0 $oldid
9153 $top.fromsha1 conf -state readonly
9154 grid $top.from $top.fromsha1 -sticky w
9155 ${NS}::entry $top.fromhead -width 60
9156 $top.fromhead insert 0 $oldhead
9157 $top.fromhead conf -state readonly
9158 grid x $top.fromhead -sticky w
9159 ${NS}::label $top.to -text [mc "To:"]
9160 ${NS}::entry $top.tosha1 -width 40
9161 $top.tosha1 insert 0 $newid
9162 $top.tosha1 conf -state readonly
9163 grid $top.to $top.tosha1 -sticky w
9164 ${NS}::entry $top.tohead -width 60
9165 $top.tohead insert 0 $newhead
9166 $top.tohead conf -state readonly
9167 grid x $top.tohead -sticky w
9168 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9169 grid $top.rev x -pady 10 -padx 5
9170 ${NS}::label $top.flab -text [mc "Output file:"]
9171 ${NS}::entry $top.fname -width 60
9172 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9173 incr patchnum
9174 grid $top.flab $top.fname -sticky w
9175 ${NS}::frame $top.buts
9176 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9177 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9178 bind $top <Key-Return> mkpatchgo
9179 bind $top <Key-Escape> mkpatchcan
9180 grid $top.buts.gen $top.buts.can
9181 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9182 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9183 grid $top.buts - -pady 10 -sticky ew
9184 focus $top.fname
9187 proc mkpatchrev {} {
9188 global patchtop
9190 set oldid [$patchtop.fromsha1 get]
9191 set oldhead [$patchtop.fromhead get]
9192 set newid [$patchtop.tosha1 get]
9193 set newhead [$patchtop.tohead get]
9194 foreach e [list fromsha1 fromhead tosha1 tohead] \
9195 v [list $newid $newhead $oldid $oldhead] {
9196 $patchtop.$e conf -state normal
9197 $patchtop.$e delete 0 end
9198 $patchtop.$e insert 0 $v
9199 $patchtop.$e conf -state readonly
9203 proc mkpatchgo {} {
9204 global patchtop nullid nullid2
9206 set oldid [$patchtop.fromsha1 get]
9207 set newid [$patchtop.tosha1 get]
9208 set fname [$patchtop.fname get]
9209 set cmd [diffcmd [list $oldid $newid] -p]
9210 # trim off the initial "|"
9211 set cmd [lrange $cmd 1 end]
9212 lappend cmd >$fname &
9213 if {[catch {eval exec $cmd} err]} {
9214 error_popup "[mc "Error creating patch:"] $err" $patchtop
9216 catch {destroy $patchtop}
9217 unset patchtop
9220 proc mkpatchcan {} {
9221 global patchtop
9223 catch {destroy $patchtop}
9224 unset patchtop
9227 proc mktag {} {
9228 global rowmenuid mktagtop commitinfo NS
9230 set top .maketag
9231 set mktagtop $top
9232 catch {destroy $top}
9233 ttk_toplevel $top
9234 make_transient $top .
9235 ${NS}::label $top.title -text [mc "Create tag"]
9236 grid $top.title - -pady 10
9237 ${NS}::label $top.id -text [mc "ID:"]
9238 ${NS}::entry $top.sha1 -width 40
9239 $top.sha1 insert 0 $rowmenuid
9240 $top.sha1 conf -state readonly
9241 grid $top.id $top.sha1 -sticky w
9242 ${NS}::entry $top.head -width 60
9243 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9244 $top.head conf -state readonly
9245 grid x $top.head -sticky w
9246 ${NS}::label $top.tlab -text [mc "Tag name:"]
9247 ${NS}::entry $top.tag -width 60
9248 grid $top.tlab $top.tag -sticky w
9249 ${NS}::label $top.op -text [mc "Tag message is optional"]
9250 grid $top.op -columnspan 2 -sticky we
9251 ${NS}::label $top.mlab -text [mc "Tag message:"]
9252 ${NS}::entry $top.msg -width 60
9253 grid $top.mlab $top.msg -sticky w
9254 ${NS}::frame $top.buts
9255 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9256 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9257 bind $top <Key-Return> mktaggo
9258 bind $top <Key-Escape> mktagcan
9259 grid $top.buts.gen $top.buts.can
9260 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9261 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9262 grid $top.buts - -pady 10 -sticky ew
9263 focus $top.tag
9266 proc domktag {} {
9267 global mktagtop env tagids idtags
9269 set id [$mktagtop.sha1 get]
9270 set tag [$mktagtop.tag get]
9271 set msg [$mktagtop.msg get]
9272 if {$tag == {}} {
9273 error_popup [mc "No tag name specified"] $mktagtop
9274 return 0
9276 if {[info exists tagids($tag)]} {
9277 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9278 return 0
9280 if {[catch {
9281 if {$msg != {}} {
9282 exec git tag -a -m $msg $tag $id
9283 } else {
9284 exec git tag $tag $id
9286 } err]} {
9287 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9288 return 0
9291 set tagids($tag) $id
9292 lappend idtags($id) $tag
9293 redrawtags $id
9294 addedtag $id
9295 dispneartags 0
9296 run refill_reflist
9297 return 1
9300 proc redrawtags {id} {
9301 global canv linehtag idpos currentid curview cmitlisted markedid
9302 global canvxmax iddrawn circleitem mainheadid circlecolors
9303 global mainheadcirclecolor
9305 if {![commitinview $id $curview]} return
9306 if {![info exists iddrawn($id)]} return
9307 set row [rowofcommit $id]
9308 if {$id eq $mainheadid} {
9309 set ofill $mainheadcirclecolor
9310 } else {
9311 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9313 $canv itemconf $circleitem($row) -fill $ofill
9314 $canv delete tag.$id
9315 set xt [eval drawtags $id $idpos($id)]
9316 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9317 set text [$canv itemcget $linehtag($id) -text]
9318 set font [$canv itemcget $linehtag($id) -font]
9319 set xr [expr {$xt + [font measure $font $text]}]
9320 if {$xr > $canvxmax} {
9321 set canvxmax $xr
9322 setcanvscroll
9324 if {[info exists currentid] && $currentid == $id} {
9325 make_secsel $id
9327 if {[info exists markedid] && $markedid eq $id} {
9328 make_idmark $id
9332 proc mktagcan {} {
9333 global mktagtop
9335 catch {destroy $mktagtop}
9336 unset mktagtop
9339 proc mktaggo {} {
9340 if {![domktag]} return
9341 mktagcan
9344 proc writecommit {} {
9345 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9347 set top .writecommit
9348 set wrcomtop $top
9349 catch {destroy $top}
9350 ttk_toplevel $top
9351 make_transient $top .
9352 ${NS}::label $top.title -text [mc "Write commit to file"]
9353 grid $top.title - -pady 10
9354 ${NS}::label $top.id -text [mc "ID:"]
9355 ${NS}::entry $top.sha1 -width 40
9356 $top.sha1 insert 0 $rowmenuid
9357 $top.sha1 conf -state readonly
9358 grid $top.id $top.sha1 -sticky w
9359 ${NS}::entry $top.head -width 60
9360 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9361 $top.head conf -state readonly
9362 grid x $top.head -sticky w
9363 ${NS}::label $top.clab -text [mc "Command:"]
9364 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9365 grid $top.clab $top.cmd -sticky w -pady 10
9366 ${NS}::label $top.flab -text [mc "Output file:"]
9367 ${NS}::entry $top.fname -width 60
9368 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9369 grid $top.flab $top.fname -sticky w
9370 ${NS}::frame $top.buts
9371 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9372 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9373 bind $top <Key-Return> wrcomgo
9374 bind $top <Key-Escape> wrcomcan
9375 grid $top.buts.gen $top.buts.can
9376 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9377 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9378 grid $top.buts - -pady 10 -sticky ew
9379 focus $top.fname
9382 proc wrcomgo {} {
9383 global wrcomtop
9385 set id [$wrcomtop.sha1 get]
9386 set cmd "echo $id | [$wrcomtop.cmd get]"
9387 set fname [$wrcomtop.fname get]
9388 if {[catch {exec sh -c $cmd >$fname &} err]} {
9389 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9391 catch {destroy $wrcomtop}
9392 unset wrcomtop
9395 proc wrcomcan {} {
9396 global wrcomtop
9398 catch {destroy $wrcomtop}
9399 unset wrcomtop
9402 proc mkbranch {} {
9403 global rowmenuid mkbrtop NS
9405 set top .makebranch
9406 catch {destroy $top}
9407 ttk_toplevel $top
9408 make_transient $top .
9409 ${NS}::label $top.title -text [mc "Create new branch"]
9410 grid $top.title - -pady 10
9411 ${NS}::label $top.id -text [mc "ID:"]
9412 ${NS}::entry $top.sha1 -width 40
9413 $top.sha1 insert 0 $rowmenuid
9414 $top.sha1 conf -state readonly
9415 grid $top.id $top.sha1 -sticky w
9416 ${NS}::label $top.nlab -text [mc "Name:"]
9417 ${NS}::entry $top.name -width 40
9418 grid $top.nlab $top.name -sticky w
9419 ${NS}::frame $top.buts
9420 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9421 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9422 bind $top <Key-Return> [list mkbrgo $top]
9423 bind $top <Key-Escape> "catch {destroy $top}"
9424 grid $top.buts.go $top.buts.can
9425 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9426 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9427 grid $top.buts - -pady 10 -sticky ew
9428 focus $top.name
9431 proc mkbrgo {top} {
9432 global headids idheads
9434 set name [$top.name get]
9435 set id [$top.sha1 get]
9436 set cmdargs {}
9437 set old_id {}
9438 if {$name eq {}} {
9439 error_popup [mc "Please specify a name for the new branch"] $top
9440 return
9442 if {[info exists headids($name)]} {
9443 if {![confirm_popup [mc \
9444 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9445 return
9447 set old_id $headids($name)
9448 lappend cmdargs -f
9450 catch {destroy $top}
9451 lappend cmdargs $name $id
9452 nowbusy newbranch
9453 update
9454 if {[catch {
9455 eval exec git branch $cmdargs
9456 } err]} {
9457 notbusy newbranch
9458 error_popup $err
9459 } else {
9460 notbusy newbranch
9461 if {$old_id ne {}} {
9462 movehead $id $name
9463 movedhead $id $name
9464 redrawtags $old_id
9465 redrawtags $id
9466 } else {
9467 set headids($name) $id
9468 lappend idheads($id) $name
9469 addedhead $id $name
9470 redrawtags $id
9472 dispneartags 0
9473 run refill_reflist
9477 proc exec_citool {tool_args {baseid {}}} {
9478 global commitinfo env
9480 set save_env [array get env GIT_AUTHOR_*]
9482 if {$baseid ne {}} {
9483 if {![info exists commitinfo($baseid)]} {
9484 getcommit $baseid
9486 set author [lindex $commitinfo($baseid) 1]
9487 set date [lindex $commitinfo($baseid) 2]
9488 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9489 $author author name email]
9490 && $date ne {}} {
9491 set env(GIT_AUTHOR_NAME) $name
9492 set env(GIT_AUTHOR_EMAIL) $email
9493 set env(GIT_AUTHOR_DATE) $date
9497 eval exec git citool $tool_args &
9499 array unset env GIT_AUTHOR_*
9500 array set env $save_env
9503 proc cherrypick {} {
9504 global rowmenuid curview
9505 global mainhead mainheadid
9506 global gitdir
9508 set oldhead [exec git rev-parse HEAD]
9509 set dheads [descheads $rowmenuid]
9510 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9511 set ok [confirm_popup [mc "Commit %s is already\
9512 included in branch %s -- really re-apply it?" \
9513 [string range $rowmenuid 0 7] $mainhead]]
9514 if {!$ok} return
9516 nowbusy cherrypick [mc "Cherry-picking"]
9517 update
9518 # Unfortunately git-cherry-pick writes stuff to stderr even when
9519 # no error occurs, and exec takes that as an indication of error...
9520 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9521 notbusy cherrypick
9522 if {[regexp -line \
9523 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9524 $err msg fname]} {
9525 error_popup [mc "Cherry-pick failed because of local changes\
9526 to file '%s'.\nPlease commit, reset or stash\
9527 your changes and try again." $fname]
9528 } elseif {[regexp -line \
9529 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9530 $err]} {
9531 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9532 conflict.\nDo you wish to run git citool to\
9533 resolve it?"]]} {
9534 # Force citool to read MERGE_MSG
9535 file delete [file join $gitdir "GITGUI_MSG"]
9536 exec_citool {} $rowmenuid
9538 } else {
9539 error_popup $err
9541 run updatecommits
9542 return
9544 set newhead [exec git rev-parse HEAD]
9545 if {$newhead eq $oldhead} {
9546 notbusy cherrypick
9547 error_popup [mc "No changes committed"]
9548 return
9550 addnewchild $newhead $oldhead
9551 if {[commitinview $oldhead $curview]} {
9552 # XXX this isn't right if we have a path limit...
9553 insertrow $newhead $oldhead $curview
9554 if {$mainhead ne {}} {
9555 movehead $newhead $mainhead
9556 movedhead $newhead $mainhead
9558 set mainheadid $newhead
9559 redrawtags $oldhead
9560 redrawtags $newhead
9561 selbyid $newhead
9563 notbusy cherrypick
9566 proc revert {} {
9567 global rowmenuid curview
9568 global mainhead mainheadid
9569 global gitdir
9571 set oldhead [exec git rev-parse HEAD]
9572 set dheads [descheads $rowmenuid]
9573 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9574 set ok [confirm_popup [mc "Commit %s is not\
9575 included in branch %s -- really revert it?" \
9576 [string range $rowmenuid 0 7] $mainhead]]
9577 if {!$ok} return
9579 nowbusy revert [mc "Reverting"]
9580 update
9582 if [catch {exec git revert --no-edit $rowmenuid} err] {
9583 notbusy revert
9584 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9585 $err match files] {
9586 regsub {\n( |\t)+} $files "\n" files
9587 error_popup [mc "Revert failed because of local changes to\
9588 the following files:%s Please commit, reset or stash \
9589 your changes and try again." $files]
9590 } elseif [regexp {error: could not revert} $err] {
9591 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9592 Do you wish to run git citool to resolve it?"]] {
9593 # Force citool to read MERGE_MSG
9594 file delete [file join $gitdir "GITGUI_MSG"]
9595 exec_citool {} $rowmenuid
9597 } else { error_popup $err }
9598 run updatecommits
9599 return
9602 set newhead [exec git rev-parse HEAD]
9603 if { $newhead eq $oldhead } {
9604 notbusy revert
9605 error_popup [mc "No changes committed"]
9606 return
9609 addnewchild $newhead $oldhead
9611 if [commitinview $oldhead $curview] {
9612 # XXX this isn't right if we have a path limit...
9613 insertrow $newhead $oldhead $curview
9614 if {$mainhead ne {}} {
9615 movehead $newhead $mainhead
9616 movedhead $newhead $mainhead
9618 set mainheadid $newhead
9619 redrawtags $oldhead
9620 redrawtags $newhead
9621 selbyid $newhead
9624 notbusy revert
9627 proc resethead {} {
9628 global mainhead rowmenuid confirm_ok resettype NS
9630 set confirm_ok 0
9631 set w ".confirmreset"
9632 ttk_toplevel $w
9633 make_transient $w .
9634 wm title $w [mc "Confirm reset"]
9635 ${NS}::label $w.m -text \
9636 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9637 pack $w.m -side top -fill x -padx 20 -pady 20
9638 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9639 set resettype mixed
9640 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9641 -text [mc "Soft: Leave working tree and index untouched"]
9642 grid $w.f.soft -sticky w
9643 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9644 -text [mc "Mixed: Leave working tree untouched, reset index"]
9645 grid $w.f.mixed -sticky w
9646 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9647 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9648 grid $w.f.hard -sticky w
9649 pack $w.f -side top -fill x -padx 4
9650 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9651 pack $w.ok -side left -fill x -padx 20 -pady 20
9652 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9653 bind $w <Key-Escape> [list destroy $w]
9654 pack $w.cancel -side right -fill x -padx 20 -pady 20
9655 bind $w <Visibility> "grab $w; focus $w"
9656 tkwait window $w
9657 if {!$confirm_ok} return
9658 if {[catch {set fd [open \
9659 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9660 error_popup $err
9661 } else {
9662 dohidelocalchanges
9663 filerun $fd [list readresetstat $fd]
9664 nowbusy reset [mc "Resetting"]
9665 selbyid $rowmenuid
9669 proc readresetstat {fd} {
9670 global mainhead mainheadid showlocalchanges rprogcoord
9672 if {[gets $fd line] >= 0} {
9673 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9674 set rprogcoord [expr {1.0 * $m / $n}]
9675 adjustprogress
9677 return 1
9679 set rprogcoord 0
9680 adjustprogress
9681 notbusy reset
9682 if {[catch {close $fd} err]} {
9683 error_popup $err
9685 set oldhead $mainheadid
9686 set newhead [exec git rev-parse HEAD]
9687 if {$newhead ne $oldhead} {
9688 movehead $newhead $mainhead
9689 movedhead $newhead $mainhead
9690 set mainheadid $newhead
9691 redrawtags $oldhead
9692 redrawtags $newhead
9694 if {$showlocalchanges} {
9695 doshowlocalchanges
9697 return 0
9700 # context menu for a head
9701 proc headmenu {x y id head} {
9702 global headmenuid headmenuhead headctxmenu mainhead
9704 stopfinding
9705 set headmenuid $id
9706 set headmenuhead $head
9707 set state normal
9708 if {[string match "remotes/*" $head]} {
9709 set state disabled
9711 if {$head eq $mainhead} {
9712 set state disabled
9714 $headctxmenu entryconfigure 0 -state $state
9715 $headctxmenu entryconfigure 1 -state $state
9716 tk_popup $headctxmenu $x $y
9719 proc cobranch {} {
9720 global headmenuid headmenuhead headids
9721 global showlocalchanges
9723 # check the tree is clean first??
9724 nowbusy checkout [mc "Checking out"]
9725 update
9726 dohidelocalchanges
9727 if {[catch {
9728 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9729 } err]} {
9730 notbusy checkout
9731 error_popup $err
9732 if {$showlocalchanges} {
9733 dodiffindex
9735 } else {
9736 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9740 proc readcheckoutstat {fd newhead newheadid} {
9741 global mainhead mainheadid headids showlocalchanges progresscoords
9742 global viewmainheadid curview
9744 if {[gets $fd line] >= 0} {
9745 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9746 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9747 adjustprogress
9749 return 1
9751 set progresscoords {0 0}
9752 adjustprogress
9753 notbusy checkout
9754 if {[catch {close $fd} err]} {
9755 error_popup $err
9757 set oldmainid $mainheadid
9758 set mainhead $newhead
9759 set mainheadid $newheadid
9760 set viewmainheadid($curview) $newheadid
9761 redrawtags $oldmainid
9762 redrawtags $newheadid
9763 selbyid $newheadid
9764 if {$showlocalchanges} {
9765 dodiffindex
9769 proc rmbranch {} {
9770 global headmenuid headmenuhead mainhead
9771 global idheads
9773 set head $headmenuhead
9774 set id $headmenuid
9775 # this check shouldn't be needed any more...
9776 if {$head eq $mainhead} {
9777 error_popup [mc "Cannot delete the currently checked-out branch"]
9778 return
9780 set dheads [descheads $id]
9781 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9782 # the stuff on this branch isn't on any other branch
9783 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9784 branch.\nReally delete branch %s?" $head $head]]} return
9786 nowbusy rmbranch
9787 update
9788 if {[catch {exec git branch -D $head} err]} {
9789 notbusy rmbranch
9790 error_popup $err
9791 return
9793 removehead $id $head
9794 removedhead $id $head
9795 redrawtags $id
9796 notbusy rmbranch
9797 dispneartags 0
9798 run refill_reflist
9801 # Display a list of tags and heads
9802 proc showrefs {} {
9803 global showrefstop bgcolor fgcolor selectbgcolor NS
9804 global bglist fglist reflistfilter reflist maincursor
9806 set top .showrefs
9807 set showrefstop $top
9808 if {[winfo exists $top]} {
9809 raise $top
9810 refill_reflist
9811 return
9813 ttk_toplevel $top
9814 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9815 make_transient $top .
9816 text $top.list -background $bgcolor -foreground $fgcolor \
9817 -selectbackground $selectbgcolor -font mainfont \
9818 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9819 -width 30 -height 20 -cursor $maincursor \
9820 -spacing1 1 -spacing3 1 -state disabled
9821 $top.list tag configure highlight -background $selectbgcolor
9822 lappend bglist $top.list
9823 lappend fglist $top.list
9824 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9825 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9826 grid $top.list $top.ysb -sticky nsew
9827 grid $top.xsb x -sticky ew
9828 ${NS}::frame $top.f
9829 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9830 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9831 set reflistfilter "*"
9832 trace add variable reflistfilter write reflistfilter_change
9833 pack $top.f.e -side right -fill x -expand 1
9834 pack $top.f.l -side left
9835 grid $top.f - -sticky ew -pady 2
9836 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9837 bind $top <Key-Escape> [list destroy $top]
9838 grid $top.close -
9839 grid columnconfigure $top 0 -weight 1
9840 grid rowconfigure $top 0 -weight 1
9841 bind $top.list <1> {break}
9842 bind $top.list <B1-Motion> {break}
9843 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9844 set reflist {}
9845 refill_reflist
9848 proc sel_reflist {w x y} {
9849 global showrefstop reflist headids tagids otherrefids
9851 if {![winfo exists $showrefstop]} return
9852 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9853 set ref [lindex $reflist [expr {$l-1}]]
9854 set n [lindex $ref 0]
9855 switch -- [lindex $ref 1] {
9856 "H" {selbyid $headids($n)}
9857 "T" {selbyid $tagids($n)}
9858 "o" {selbyid $otherrefids($n)}
9860 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9863 proc unsel_reflist {} {
9864 global showrefstop
9866 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9867 $showrefstop.list tag remove highlight 0.0 end
9870 proc reflistfilter_change {n1 n2 op} {
9871 global reflistfilter
9873 after cancel refill_reflist
9874 after 200 refill_reflist
9877 proc refill_reflist {} {
9878 global reflist reflistfilter showrefstop headids tagids otherrefids
9879 global curview
9881 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9882 set refs {}
9883 foreach n [array names headids] {
9884 if {[string match $reflistfilter $n]} {
9885 if {[commitinview $headids($n) $curview]} {
9886 lappend refs [list $n H]
9887 } else {
9888 interestedin $headids($n) {run refill_reflist}
9892 foreach n [array names tagids] {
9893 if {[string match $reflistfilter $n]} {
9894 if {[commitinview $tagids($n) $curview]} {
9895 lappend refs [list $n T]
9896 } else {
9897 interestedin $tagids($n) {run refill_reflist}
9901 foreach n [array names otherrefids] {
9902 if {[string match $reflistfilter $n]} {
9903 if {[commitinview $otherrefids($n) $curview]} {
9904 lappend refs [list $n o]
9905 } else {
9906 interestedin $otherrefids($n) {run refill_reflist}
9910 set refs [lsort -index 0 $refs]
9911 if {$refs eq $reflist} return
9913 # Update the contents of $showrefstop.list according to the
9914 # differences between $reflist (old) and $refs (new)
9915 $showrefstop.list conf -state normal
9916 $showrefstop.list insert end "\n"
9917 set i 0
9918 set j 0
9919 while {$i < [llength $reflist] || $j < [llength $refs]} {
9920 if {$i < [llength $reflist]} {
9921 if {$j < [llength $refs]} {
9922 set cmp [string compare [lindex $reflist $i 0] \
9923 [lindex $refs $j 0]]
9924 if {$cmp == 0} {
9925 set cmp [string compare [lindex $reflist $i 1] \
9926 [lindex $refs $j 1]]
9928 } else {
9929 set cmp -1
9931 } else {
9932 set cmp 1
9934 switch -- $cmp {
9935 -1 {
9936 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9937 incr i
9940 incr i
9941 incr j
9944 set l [expr {$j + 1}]
9945 $showrefstop.list image create $l.0 -align baseline \
9946 -image reficon-[lindex $refs $j 1] -padx 2
9947 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9948 incr j
9952 set reflist $refs
9953 # delete last newline
9954 $showrefstop.list delete end-2c end-1c
9955 $showrefstop.list conf -state disabled
9958 # Stuff for finding nearby tags
9959 proc getallcommits {} {
9960 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9961 global idheads idtags idotherrefs allparents tagobjid
9962 global gitdir
9964 if {![info exists allcommits]} {
9965 set nextarc 0
9966 set allcommits 0
9967 set seeds {}
9968 set allcwait 0
9969 set cachedarcs 0
9970 set allccache [file join $gitdir "gitk.cache"]
9971 if {![catch {
9972 set f [open $allccache r]
9973 set allcwait 1
9974 getcache $f
9975 }]} return
9978 if {$allcwait} {
9979 return
9981 set cmd [list | git rev-list --parents]
9982 set allcupdate [expr {$seeds ne {}}]
9983 if {!$allcupdate} {
9984 set ids "--all"
9985 } else {
9986 set refs [concat [array names idheads] [array names idtags] \
9987 [array names idotherrefs]]
9988 set ids {}
9989 set tagobjs {}
9990 foreach name [array names tagobjid] {
9991 lappend tagobjs $tagobjid($name)
9993 foreach id [lsort -unique $refs] {
9994 if {![info exists allparents($id)] &&
9995 [lsearch -exact $tagobjs $id] < 0} {
9996 lappend ids $id
9999 if {$ids ne {}} {
10000 foreach id $seeds {
10001 lappend ids "^$id"
10005 if {$ids ne {}} {
10006 set fd [open [concat $cmd $ids] r]
10007 fconfigure $fd -blocking 0
10008 incr allcommits
10009 nowbusy allcommits
10010 filerun $fd [list getallclines $fd]
10011 } else {
10012 dispneartags 0
10016 # Since most commits have 1 parent and 1 child, we group strings of
10017 # such commits into "arcs" joining branch/merge points (BMPs), which
10018 # are commits that either don't have 1 parent or don't have 1 child.
10020 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10021 # arcout(id) - outgoing arcs for BMP
10022 # arcids(a) - list of IDs on arc including end but not start
10023 # arcstart(a) - BMP ID at start of arc
10024 # arcend(a) - BMP ID at end of arc
10025 # growing(a) - arc a is still growing
10026 # arctags(a) - IDs out of arcids (excluding end) that have tags
10027 # archeads(a) - IDs out of arcids (excluding end) that have heads
10028 # The start of an arc is at the descendent end, so "incoming" means
10029 # coming from descendents, and "outgoing" means going towards ancestors.
10031 proc getallclines {fd} {
10032 global allparents allchildren idtags idheads nextarc
10033 global arcnos arcids arctags arcout arcend arcstart archeads growing
10034 global seeds allcommits cachedarcs allcupdate
10036 set nid 0
10037 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10038 set id [lindex $line 0]
10039 if {[info exists allparents($id)]} {
10040 # seen it already
10041 continue
10043 set cachedarcs 0
10044 set olds [lrange $line 1 end]
10045 set allparents($id) $olds
10046 if {![info exists allchildren($id)]} {
10047 set allchildren($id) {}
10048 set arcnos($id) {}
10049 lappend seeds $id
10050 } else {
10051 set a $arcnos($id)
10052 if {[llength $olds] == 1 && [llength $a] == 1} {
10053 lappend arcids($a) $id
10054 if {[info exists idtags($id)]} {
10055 lappend arctags($a) $id
10057 if {[info exists idheads($id)]} {
10058 lappend archeads($a) $id
10060 if {[info exists allparents($olds)]} {
10061 # seen parent already
10062 if {![info exists arcout($olds)]} {
10063 splitarc $olds
10065 lappend arcids($a) $olds
10066 set arcend($a) $olds
10067 unset growing($a)
10069 lappend allchildren($olds) $id
10070 lappend arcnos($olds) $a
10071 continue
10074 foreach a $arcnos($id) {
10075 lappend arcids($a) $id
10076 set arcend($a) $id
10077 unset growing($a)
10080 set ao {}
10081 foreach p $olds {
10082 lappend allchildren($p) $id
10083 set a [incr nextarc]
10084 set arcstart($a) $id
10085 set archeads($a) {}
10086 set arctags($a) {}
10087 set archeads($a) {}
10088 set arcids($a) {}
10089 lappend ao $a
10090 set growing($a) 1
10091 if {[info exists allparents($p)]} {
10092 # seen it already, may need to make a new branch
10093 if {![info exists arcout($p)]} {
10094 splitarc $p
10096 lappend arcids($a) $p
10097 set arcend($a) $p
10098 unset growing($a)
10100 lappend arcnos($p) $a
10102 set arcout($id) $ao
10104 if {$nid > 0} {
10105 global cached_dheads cached_dtags cached_atags
10106 catch {unset cached_dheads}
10107 catch {unset cached_dtags}
10108 catch {unset cached_atags}
10110 if {![eof $fd]} {
10111 return [expr {$nid >= 1000? 2: 1}]
10113 set cacheok 1
10114 if {[catch {
10115 fconfigure $fd -blocking 1
10116 close $fd
10117 } err]} {
10118 # got an error reading the list of commits
10119 # if we were updating, try rereading the whole thing again
10120 if {$allcupdate} {
10121 incr allcommits -1
10122 dropcache $err
10123 return
10125 error_popup "[mc "Error reading commit topology information;\
10126 branch and preceding/following tag information\
10127 will be incomplete."]\n($err)"
10128 set cacheok 0
10130 if {[incr allcommits -1] == 0} {
10131 notbusy allcommits
10132 if {$cacheok} {
10133 run savecache
10136 dispneartags 0
10137 return 0
10140 proc recalcarc {a} {
10141 global arctags archeads arcids idtags idheads
10143 set at {}
10144 set ah {}
10145 foreach id [lrange $arcids($a) 0 end-1] {
10146 if {[info exists idtags($id)]} {
10147 lappend at $id
10149 if {[info exists idheads($id)]} {
10150 lappend ah $id
10153 set arctags($a) $at
10154 set archeads($a) $ah
10157 proc splitarc {p} {
10158 global arcnos arcids nextarc arctags archeads idtags idheads
10159 global arcstart arcend arcout allparents growing
10161 set a $arcnos($p)
10162 if {[llength $a] != 1} {
10163 puts "oops splitarc called but [llength $a] arcs already"
10164 return
10166 set a [lindex $a 0]
10167 set i [lsearch -exact $arcids($a) $p]
10168 if {$i < 0} {
10169 puts "oops splitarc $p not in arc $a"
10170 return
10172 set na [incr nextarc]
10173 if {[info exists arcend($a)]} {
10174 set arcend($na) $arcend($a)
10175 } else {
10176 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10177 set j [lsearch -exact $arcnos($l) $a]
10178 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10180 set tail [lrange $arcids($a) [expr {$i+1}] end]
10181 set arcids($a) [lrange $arcids($a) 0 $i]
10182 set arcend($a) $p
10183 set arcstart($na) $p
10184 set arcout($p) $na
10185 set arcids($na) $tail
10186 if {[info exists growing($a)]} {
10187 set growing($na) 1
10188 unset growing($a)
10191 foreach id $tail {
10192 if {[llength $arcnos($id)] == 1} {
10193 set arcnos($id) $na
10194 } else {
10195 set j [lsearch -exact $arcnos($id) $a]
10196 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10200 # reconstruct tags and heads lists
10201 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10202 recalcarc $a
10203 recalcarc $na
10204 } else {
10205 set arctags($na) {}
10206 set archeads($na) {}
10210 # Update things for a new commit added that is a child of one
10211 # existing commit. Used when cherry-picking.
10212 proc addnewchild {id p} {
10213 global allparents allchildren idtags nextarc
10214 global arcnos arcids arctags arcout arcend arcstart archeads growing
10215 global seeds allcommits
10217 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10218 set allparents($id) [list $p]
10219 set allchildren($id) {}
10220 set arcnos($id) {}
10221 lappend seeds $id
10222 lappend allchildren($p) $id
10223 set a [incr nextarc]
10224 set arcstart($a) $id
10225 set archeads($a) {}
10226 set arctags($a) {}
10227 set arcids($a) [list $p]
10228 set arcend($a) $p
10229 if {![info exists arcout($p)]} {
10230 splitarc $p
10232 lappend arcnos($p) $a
10233 set arcout($id) [list $a]
10236 # This implements a cache for the topology information.
10237 # The cache saves, for each arc, the start and end of the arc,
10238 # the ids on the arc, and the outgoing arcs from the end.
10239 proc readcache {f} {
10240 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10241 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10242 global allcwait
10244 set a $nextarc
10245 set lim $cachedarcs
10246 if {$lim - $a > 500} {
10247 set lim [expr {$a + 500}]
10249 if {[catch {
10250 if {$a == $lim} {
10251 # finish reading the cache and setting up arctags, etc.
10252 set line [gets $f]
10253 if {$line ne "1"} {error "bad final version"}
10254 close $f
10255 foreach id [array names idtags] {
10256 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10257 [llength $allparents($id)] == 1} {
10258 set a [lindex $arcnos($id) 0]
10259 if {$arctags($a) eq {}} {
10260 recalcarc $a
10264 foreach id [array names idheads] {
10265 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10266 [llength $allparents($id)] == 1} {
10267 set a [lindex $arcnos($id) 0]
10268 if {$archeads($a) eq {}} {
10269 recalcarc $a
10273 foreach id [lsort -unique $possible_seeds] {
10274 if {$arcnos($id) eq {}} {
10275 lappend seeds $id
10278 set allcwait 0
10279 } else {
10280 while {[incr a] <= $lim} {
10281 set line [gets $f]
10282 if {[llength $line] != 3} {error "bad line"}
10283 set s [lindex $line 0]
10284 set arcstart($a) $s
10285 lappend arcout($s) $a
10286 if {![info exists arcnos($s)]} {
10287 lappend possible_seeds $s
10288 set arcnos($s) {}
10290 set e [lindex $line 1]
10291 if {$e eq {}} {
10292 set growing($a) 1
10293 } else {
10294 set arcend($a) $e
10295 if {![info exists arcout($e)]} {
10296 set arcout($e) {}
10299 set arcids($a) [lindex $line 2]
10300 foreach id $arcids($a) {
10301 lappend allparents($s) $id
10302 set s $id
10303 lappend arcnos($id) $a
10305 if {![info exists allparents($s)]} {
10306 set allparents($s) {}
10308 set arctags($a) {}
10309 set archeads($a) {}
10311 set nextarc [expr {$a - 1}]
10313 } err]} {
10314 dropcache $err
10315 return 0
10317 if {!$allcwait} {
10318 getallcommits
10320 return $allcwait
10323 proc getcache {f} {
10324 global nextarc cachedarcs possible_seeds
10326 if {[catch {
10327 set line [gets $f]
10328 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10329 # make sure it's an integer
10330 set cachedarcs [expr {int([lindex $line 1])}]
10331 if {$cachedarcs < 0} {error "bad number of arcs"}
10332 set nextarc 0
10333 set possible_seeds {}
10334 run readcache $f
10335 } err]} {
10336 dropcache $err
10338 return 0
10341 proc dropcache {err} {
10342 global allcwait nextarc cachedarcs seeds
10344 #puts "dropping cache ($err)"
10345 foreach v {arcnos arcout arcids arcstart arcend growing \
10346 arctags archeads allparents allchildren} {
10347 global $v
10348 catch {unset $v}
10350 set allcwait 0
10351 set nextarc 0
10352 set cachedarcs 0
10353 set seeds {}
10354 getallcommits
10357 proc writecache {f} {
10358 global cachearc cachedarcs allccache
10359 global arcstart arcend arcnos arcids arcout
10361 set a $cachearc
10362 set lim $cachedarcs
10363 if {$lim - $a > 1000} {
10364 set lim [expr {$a + 1000}]
10366 if {[catch {
10367 while {[incr a] <= $lim} {
10368 if {[info exists arcend($a)]} {
10369 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10370 } else {
10371 puts $f [list $arcstart($a) {} $arcids($a)]
10374 } err]} {
10375 catch {close $f}
10376 catch {file delete $allccache}
10377 #puts "writing cache failed ($err)"
10378 return 0
10380 set cachearc [expr {$a - 1}]
10381 if {$a > $cachedarcs} {
10382 puts $f "1"
10383 close $f
10384 return 0
10386 return 1
10389 proc savecache {} {
10390 global nextarc cachedarcs cachearc allccache
10392 if {$nextarc == $cachedarcs} return
10393 set cachearc 0
10394 set cachedarcs $nextarc
10395 catch {
10396 set f [open $allccache w]
10397 puts $f [list 1 $cachedarcs]
10398 run writecache $f
10402 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10403 # or 0 if neither is true.
10404 proc anc_or_desc {a b} {
10405 global arcout arcstart arcend arcnos cached_isanc
10407 if {$arcnos($a) eq $arcnos($b)} {
10408 # Both are on the same arc(s); either both are the same BMP,
10409 # or if one is not a BMP, the other is also not a BMP or is
10410 # the BMP at end of the arc (and it only has 1 incoming arc).
10411 # Or both can be BMPs with no incoming arcs.
10412 if {$a eq $b || $arcnos($a) eq {}} {
10413 return 0
10415 # assert {[llength $arcnos($a)] == 1}
10416 set arc [lindex $arcnos($a) 0]
10417 set i [lsearch -exact $arcids($arc) $a]
10418 set j [lsearch -exact $arcids($arc) $b]
10419 if {$i < 0 || $i > $j} {
10420 return 1
10421 } else {
10422 return -1
10426 if {![info exists arcout($a)]} {
10427 set arc [lindex $arcnos($a) 0]
10428 if {[info exists arcend($arc)]} {
10429 set aend $arcend($arc)
10430 } else {
10431 set aend {}
10433 set a $arcstart($arc)
10434 } else {
10435 set aend $a
10437 if {![info exists arcout($b)]} {
10438 set arc [lindex $arcnos($b) 0]
10439 if {[info exists arcend($arc)]} {
10440 set bend $arcend($arc)
10441 } else {
10442 set bend {}
10444 set b $arcstart($arc)
10445 } else {
10446 set bend $b
10448 if {$a eq $bend} {
10449 return 1
10451 if {$b eq $aend} {
10452 return -1
10454 if {[info exists cached_isanc($a,$bend)]} {
10455 if {$cached_isanc($a,$bend)} {
10456 return 1
10459 if {[info exists cached_isanc($b,$aend)]} {
10460 if {$cached_isanc($b,$aend)} {
10461 return -1
10463 if {[info exists cached_isanc($a,$bend)]} {
10464 return 0
10468 set todo [list $a $b]
10469 set anc($a) a
10470 set anc($b) b
10471 for {set i 0} {$i < [llength $todo]} {incr i} {
10472 set x [lindex $todo $i]
10473 if {$anc($x) eq {}} {
10474 continue
10476 foreach arc $arcnos($x) {
10477 set xd $arcstart($arc)
10478 if {$xd eq $bend} {
10479 set cached_isanc($a,$bend) 1
10480 set cached_isanc($b,$aend) 0
10481 return 1
10482 } elseif {$xd eq $aend} {
10483 set cached_isanc($b,$aend) 1
10484 set cached_isanc($a,$bend) 0
10485 return -1
10487 if {![info exists anc($xd)]} {
10488 set anc($xd) $anc($x)
10489 lappend todo $xd
10490 } elseif {$anc($xd) ne $anc($x)} {
10491 set anc($xd) {}
10495 set cached_isanc($a,$bend) 0
10496 set cached_isanc($b,$aend) 0
10497 return 0
10500 # This identifies whether $desc has an ancestor that is
10501 # a growing tip of the graph and which is not an ancestor of $anc
10502 # and returns 0 if so and 1 if not.
10503 # If we subsequently discover a tag on such a growing tip, and that
10504 # turns out to be a descendent of $anc (which it could, since we
10505 # don't necessarily see children before parents), then $desc
10506 # isn't a good choice to display as a descendent tag of
10507 # $anc (since it is the descendent of another tag which is
10508 # a descendent of $anc). Similarly, $anc isn't a good choice to
10509 # display as a ancestor tag of $desc.
10511 proc is_certain {desc anc} {
10512 global arcnos arcout arcstart arcend growing problems
10514 set certain {}
10515 if {[llength $arcnos($anc)] == 1} {
10516 # tags on the same arc are certain
10517 if {$arcnos($desc) eq $arcnos($anc)} {
10518 return 1
10520 if {![info exists arcout($anc)]} {
10521 # if $anc is partway along an arc, use the start of the arc instead
10522 set a [lindex $arcnos($anc) 0]
10523 set anc $arcstart($a)
10526 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10527 set x $desc
10528 } else {
10529 set a [lindex $arcnos($desc) 0]
10530 set x $arcend($a)
10532 if {$x == $anc} {
10533 return 1
10535 set anclist [list $x]
10536 set dl($x) 1
10537 set nnh 1
10538 set ngrowanc 0
10539 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10540 set x [lindex $anclist $i]
10541 if {$dl($x)} {
10542 incr nnh -1
10544 set done($x) 1
10545 foreach a $arcout($x) {
10546 if {[info exists growing($a)]} {
10547 if {![info exists growanc($x)] && $dl($x)} {
10548 set growanc($x) 1
10549 incr ngrowanc
10551 } else {
10552 set y $arcend($a)
10553 if {[info exists dl($y)]} {
10554 if {$dl($y)} {
10555 if {!$dl($x)} {
10556 set dl($y) 0
10557 if {![info exists done($y)]} {
10558 incr nnh -1
10560 if {[info exists growanc($x)]} {
10561 incr ngrowanc -1
10563 set xl [list $y]
10564 for {set k 0} {$k < [llength $xl]} {incr k} {
10565 set z [lindex $xl $k]
10566 foreach c $arcout($z) {
10567 if {[info exists arcend($c)]} {
10568 set v $arcend($c)
10569 if {[info exists dl($v)] && $dl($v)} {
10570 set dl($v) 0
10571 if {![info exists done($v)]} {
10572 incr nnh -1
10574 if {[info exists growanc($v)]} {
10575 incr ngrowanc -1
10577 lappend xl $v
10584 } elseif {$y eq $anc || !$dl($x)} {
10585 set dl($y) 0
10586 lappend anclist $y
10587 } else {
10588 set dl($y) 1
10589 lappend anclist $y
10590 incr nnh
10595 foreach x [array names growanc] {
10596 if {$dl($x)} {
10597 return 0
10599 return 0
10601 return 1
10604 proc validate_arctags {a} {
10605 global arctags idtags
10607 set i -1
10608 set na $arctags($a)
10609 foreach id $arctags($a) {
10610 incr i
10611 if {![info exists idtags($id)]} {
10612 set na [lreplace $na $i $i]
10613 incr i -1
10616 set arctags($a) $na
10619 proc validate_archeads {a} {
10620 global archeads idheads
10622 set i -1
10623 set na $archeads($a)
10624 foreach id $archeads($a) {
10625 incr i
10626 if {![info exists idheads($id)]} {
10627 set na [lreplace $na $i $i]
10628 incr i -1
10631 set archeads($a) $na
10634 # Return the list of IDs that have tags that are descendents of id,
10635 # ignoring IDs that are descendents of IDs already reported.
10636 proc desctags {id} {
10637 global arcnos arcstart arcids arctags idtags allparents
10638 global growing cached_dtags
10640 if {![info exists allparents($id)]} {
10641 return {}
10643 set t1 [clock clicks -milliseconds]
10644 set argid $id
10645 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10646 # part-way along an arc; check that arc first
10647 set a [lindex $arcnos($id) 0]
10648 if {$arctags($a) ne {}} {
10649 validate_arctags $a
10650 set i [lsearch -exact $arcids($a) $id]
10651 set tid {}
10652 foreach t $arctags($a) {
10653 set j [lsearch -exact $arcids($a) $t]
10654 if {$j >= $i} break
10655 set tid $t
10657 if {$tid ne {}} {
10658 return $tid
10661 set id $arcstart($a)
10662 if {[info exists idtags($id)]} {
10663 return $id
10666 if {[info exists cached_dtags($id)]} {
10667 return $cached_dtags($id)
10670 set origid $id
10671 set todo [list $id]
10672 set queued($id) 1
10673 set nc 1
10674 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10675 set id [lindex $todo $i]
10676 set done($id) 1
10677 set ta [info exists hastaggedancestor($id)]
10678 if {!$ta} {
10679 incr nc -1
10681 # ignore tags on starting node
10682 if {!$ta && $i > 0} {
10683 if {[info exists idtags($id)]} {
10684 set tagloc($id) $id
10685 set ta 1
10686 } elseif {[info exists cached_dtags($id)]} {
10687 set tagloc($id) $cached_dtags($id)
10688 set ta 1
10691 foreach a $arcnos($id) {
10692 set d $arcstart($a)
10693 if {!$ta && $arctags($a) ne {}} {
10694 validate_arctags $a
10695 if {$arctags($a) ne {}} {
10696 lappend tagloc($id) [lindex $arctags($a) end]
10699 if {$ta || $arctags($a) ne {}} {
10700 set tomark [list $d]
10701 for {set j 0} {$j < [llength $tomark]} {incr j} {
10702 set dd [lindex $tomark $j]
10703 if {![info exists hastaggedancestor($dd)]} {
10704 if {[info exists done($dd)]} {
10705 foreach b $arcnos($dd) {
10706 lappend tomark $arcstart($b)
10708 if {[info exists tagloc($dd)]} {
10709 unset tagloc($dd)
10711 } elseif {[info exists queued($dd)]} {
10712 incr nc -1
10714 set hastaggedancestor($dd) 1
10718 if {![info exists queued($d)]} {
10719 lappend todo $d
10720 set queued($d) 1
10721 if {![info exists hastaggedancestor($d)]} {
10722 incr nc
10727 set tags {}
10728 foreach id [array names tagloc] {
10729 if {![info exists hastaggedancestor($id)]} {
10730 foreach t $tagloc($id) {
10731 if {[lsearch -exact $tags $t] < 0} {
10732 lappend tags $t
10737 set t2 [clock clicks -milliseconds]
10738 set loopix $i
10740 # remove tags that are descendents of other tags
10741 for {set i 0} {$i < [llength $tags]} {incr i} {
10742 set a [lindex $tags $i]
10743 for {set j 0} {$j < $i} {incr j} {
10744 set b [lindex $tags $j]
10745 set r [anc_or_desc $a $b]
10746 if {$r == 1} {
10747 set tags [lreplace $tags $j $j]
10748 incr j -1
10749 incr i -1
10750 } elseif {$r == -1} {
10751 set tags [lreplace $tags $i $i]
10752 incr i -1
10753 break
10758 if {[array names growing] ne {}} {
10759 # graph isn't finished, need to check if any tag could get
10760 # eclipsed by another tag coming later. Simply ignore any
10761 # tags that could later get eclipsed.
10762 set ctags {}
10763 foreach t $tags {
10764 if {[is_certain $t $origid]} {
10765 lappend ctags $t
10768 if {$tags eq $ctags} {
10769 set cached_dtags($origid) $tags
10770 } else {
10771 set tags $ctags
10773 } else {
10774 set cached_dtags($origid) $tags
10776 set t3 [clock clicks -milliseconds]
10777 if {0 && $t3 - $t1 >= 100} {
10778 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10779 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10781 return $tags
10784 proc anctags {id} {
10785 global arcnos arcids arcout arcend arctags idtags allparents
10786 global growing cached_atags
10788 if {![info exists allparents($id)]} {
10789 return {}
10791 set t1 [clock clicks -milliseconds]
10792 set argid $id
10793 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10794 # part-way along an arc; check that arc first
10795 set a [lindex $arcnos($id) 0]
10796 if {$arctags($a) ne {}} {
10797 validate_arctags $a
10798 set i [lsearch -exact $arcids($a) $id]
10799 foreach t $arctags($a) {
10800 set j [lsearch -exact $arcids($a) $t]
10801 if {$j > $i} {
10802 return $t
10806 if {![info exists arcend($a)]} {
10807 return {}
10809 set id $arcend($a)
10810 if {[info exists idtags($id)]} {
10811 return $id
10814 if {[info exists cached_atags($id)]} {
10815 return $cached_atags($id)
10818 set origid $id
10819 set todo [list $id]
10820 set queued($id) 1
10821 set taglist {}
10822 set nc 1
10823 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10824 set id [lindex $todo $i]
10825 set done($id) 1
10826 set td [info exists hastaggeddescendent($id)]
10827 if {!$td} {
10828 incr nc -1
10830 # ignore tags on starting node
10831 if {!$td && $i > 0} {
10832 if {[info exists idtags($id)]} {
10833 set tagloc($id) $id
10834 set td 1
10835 } elseif {[info exists cached_atags($id)]} {
10836 set tagloc($id) $cached_atags($id)
10837 set td 1
10840 foreach a $arcout($id) {
10841 if {!$td && $arctags($a) ne {}} {
10842 validate_arctags $a
10843 if {$arctags($a) ne {}} {
10844 lappend tagloc($id) [lindex $arctags($a) 0]
10847 if {![info exists arcend($a)]} continue
10848 set d $arcend($a)
10849 if {$td || $arctags($a) ne {}} {
10850 set tomark [list $d]
10851 for {set j 0} {$j < [llength $tomark]} {incr j} {
10852 set dd [lindex $tomark $j]
10853 if {![info exists hastaggeddescendent($dd)]} {
10854 if {[info exists done($dd)]} {
10855 foreach b $arcout($dd) {
10856 if {[info exists arcend($b)]} {
10857 lappend tomark $arcend($b)
10860 if {[info exists tagloc($dd)]} {
10861 unset tagloc($dd)
10863 } elseif {[info exists queued($dd)]} {
10864 incr nc -1
10866 set hastaggeddescendent($dd) 1
10870 if {![info exists queued($d)]} {
10871 lappend todo $d
10872 set queued($d) 1
10873 if {![info exists hastaggeddescendent($d)]} {
10874 incr nc
10879 set t2 [clock clicks -milliseconds]
10880 set loopix $i
10881 set tags {}
10882 foreach id [array names tagloc] {
10883 if {![info exists hastaggeddescendent($id)]} {
10884 foreach t $tagloc($id) {
10885 if {[lsearch -exact $tags $t] < 0} {
10886 lappend tags $t
10892 # remove tags that are ancestors of other tags
10893 for {set i 0} {$i < [llength $tags]} {incr i} {
10894 set a [lindex $tags $i]
10895 for {set j 0} {$j < $i} {incr j} {
10896 set b [lindex $tags $j]
10897 set r [anc_or_desc $a $b]
10898 if {$r == -1} {
10899 set tags [lreplace $tags $j $j]
10900 incr j -1
10901 incr i -1
10902 } elseif {$r == 1} {
10903 set tags [lreplace $tags $i $i]
10904 incr i -1
10905 break
10910 if {[array names growing] ne {}} {
10911 # graph isn't finished, need to check if any tag could get
10912 # eclipsed by another tag coming later. Simply ignore any
10913 # tags that could later get eclipsed.
10914 set ctags {}
10915 foreach t $tags {
10916 if {[is_certain $origid $t]} {
10917 lappend ctags $t
10920 if {$tags eq $ctags} {
10921 set cached_atags($origid) $tags
10922 } else {
10923 set tags $ctags
10925 } else {
10926 set cached_atags($origid) $tags
10928 set t3 [clock clicks -milliseconds]
10929 if {0 && $t3 - $t1 >= 100} {
10930 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10931 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10933 return $tags
10936 # Return the list of IDs that have heads that are descendents of id,
10937 # including id itself if it has a head.
10938 proc descheads {id} {
10939 global arcnos arcstart arcids archeads idheads cached_dheads
10940 global allparents arcout
10942 if {![info exists allparents($id)]} {
10943 return {}
10945 set aret {}
10946 if {![info exists arcout($id)]} {
10947 # part-way along an arc; check it first
10948 set a [lindex $arcnos($id) 0]
10949 if {$archeads($a) ne {}} {
10950 validate_archeads $a
10951 set i [lsearch -exact $arcids($a) $id]
10952 foreach t $archeads($a) {
10953 set j [lsearch -exact $arcids($a) $t]
10954 if {$j > $i} break
10955 lappend aret $t
10958 set id $arcstart($a)
10960 set origid $id
10961 set todo [list $id]
10962 set seen($id) 1
10963 set ret {}
10964 for {set i 0} {$i < [llength $todo]} {incr i} {
10965 set id [lindex $todo $i]
10966 if {[info exists cached_dheads($id)]} {
10967 set ret [concat $ret $cached_dheads($id)]
10968 } else {
10969 if {[info exists idheads($id)]} {
10970 lappend ret $id
10972 foreach a $arcnos($id) {
10973 if {$archeads($a) ne {}} {
10974 validate_archeads $a
10975 if {$archeads($a) ne {}} {
10976 set ret [concat $ret $archeads($a)]
10979 set d $arcstart($a)
10980 if {![info exists seen($d)]} {
10981 lappend todo $d
10982 set seen($d) 1
10987 set ret [lsort -unique $ret]
10988 set cached_dheads($origid) $ret
10989 return [concat $ret $aret]
10992 proc addedtag {id} {
10993 global arcnos arcout cached_dtags cached_atags
10995 if {![info exists arcnos($id)]} return
10996 if {![info exists arcout($id)]} {
10997 recalcarc [lindex $arcnos($id) 0]
10999 catch {unset cached_dtags}
11000 catch {unset cached_atags}
11003 proc addedhead {hid head} {
11004 global arcnos arcout cached_dheads
11006 if {![info exists arcnos($hid)]} return
11007 if {![info exists arcout($hid)]} {
11008 recalcarc [lindex $arcnos($hid) 0]
11010 catch {unset cached_dheads}
11013 proc removedhead {hid head} {
11014 global cached_dheads
11016 catch {unset cached_dheads}
11019 proc movedhead {hid head} {
11020 global arcnos arcout cached_dheads
11022 if {![info exists arcnos($hid)]} return
11023 if {![info exists arcout($hid)]} {
11024 recalcarc [lindex $arcnos($hid) 0]
11026 catch {unset cached_dheads}
11029 proc changedrefs {} {
11030 global cached_dheads cached_dtags cached_atags cached_tagcontent
11031 global arctags archeads arcnos arcout idheads idtags
11033 foreach id [concat [array names idheads] [array names idtags]] {
11034 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11035 set a [lindex $arcnos($id) 0]
11036 if {![info exists donearc($a)]} {
11037 recalcarc $a
11038 set donearc($a) 1
11042 catch {unset cached_tagcontent}
11043 catch {unset cached_dtags}
11044 catch {unset cached_atags}
11045 catch {unset cached_dheads}
11048 proc rereadrefs {} {
11049 global idtags idheads idotherrefs mainheadid
11051 set refids [concat [array names idtags] \
11052 [array names idheads] [array names idotherrefs]]
11053 foreach id $refids {
11054 if {![info exists ref($id)]} {
11055 set ref($id) [listrefs $id]
11058 set oldmainhead $mainheadid
11059 readrefs
11060 changedrefs
11061 set refids [lsort -unique [concat $refids [array names idtags] \
11062 [array names idheads] [array names idotherrefs]]]
11063 foreach id $refids {
11064 set v [listrefs $id]
11065 if {![info exists ref($id)] || $ref($id) != $v} {
11066 redrawtags $id
11069 if {$oldmainhead ne $mainheadid} {
11070 redrawtags $oldmainhead
11071 redrawtags $mainheadid
11073 run refill_reflist
11076 proc listrefs {id} {
11077 global idtags idheads idotherrefs
11079 set x {}
11080 if {[info exists idtags($id)]} {
11081 set x $idtags($id)
11083 set y {}
11084 if {[info exists idheads($id)]} {
11085 set y $idheads($id)
11087 set z {}
11088 if {[info exists idotherrefs($id)]} {
11089 set z $idotherrefs($id)
11091 return [list $x $y $z]
11094 proc add_tag_ctext {tag} {
11095 global ctext cached_tagcontent tagids
11097 if {![info exists cached_tagcontent($tag)]} {
11098 catch {
11099 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11102 $ctext insert end "[mc "Tag"]: $tag\n" bold
11103 if {[info exists cached_tagcontent($tag)]} {
11104 set text $cached_tagcontent($tag)
11105 } else {
11106 set text "[mc "Id"]: $tagids($tag)"
11108 appendwithlinks $text {}
11111 proc showtag {tag isnew} {
11112 global ctext cached_tagcontent tagids linknum tagobjid
11114 if {$isnew} {
11115 addtohistory [list showtag $tag 0] savectextpos
11117 $ctext conf -state normal
11118 clear_ctext
11119 settabs 0
11120 set linknum 0
11121 add_tag_ctext $tag
11122 maybe_scroll_ctext 1
11123 $ctext conf -state disabled
11124 init_flist {}
11127 proc showtags {id isnew} {
11128 global idtags ctext linknum
11130 if {$isnew} {
11131 addtohistory [list showtags $id 0] savectextpos
11133 $ctext conf -state normal
11134 clear_ctext
11135 settabs 0
11136 set linknum 0
11137 set sep {}
11138 foreach tag $idtags($id) {
11139 $ctext insert end $sep
11140 add_tag_ctext $tag
11141 set sep "\n\n"
11143 maybe_scroll_ctext 1
11144 $ctext conf -state disabled
11145 init_flist {}
11148 proc doquit {} {
11149 global stopped
11150 global gitktmpdir
11152 set stopped 100
11153 savestuff .
11154 destroy .
11156 if {[info exists gitktmpdir]} {
11157 catch {file delete -force $gitktmpdir}
11161 proc mkfontdisp {font top which} {
11162 global fontattr fontpref $font NS use_ttk
11164 set fontpref($font) [set $font]
11165 ${NS}::button $top.${font}but -text $which \
11166 -command [list choosefont $font $which]
11167 ${NS}::label $top.$font -relief flat -font $font \
11168 -text $fontattr($font,family) -justify left
11169 grid x $top.${font}but $top.$font -sticky w
11172 proc choosefont {font which} {
11173 global fontparam fontlist fonttop fontattr
11174 global prefstop NS
11176 set fontparam(which) $which
11177 set fontparam(font) $font
11178 set fontparam(family) [font actual $font -family]
11179 set fontparam(size) $fontattr($font,size)
11180 set fontparam(weight) $fontattr($font,weight)
11181 set fontparam(slant) $fontattr($font,slant)
11182 set top .gitkfont
11183 set fonttop $top
11184 if {![winfo exists $top]} {
11185 font create sample
11186 eval font config sample [font actual $font]
11187 ttk_toplevel $top
11188 make_transient $top $prefstop
11189 wm title $top [mc "Gitk font chooser"]
11190 ${NS}::label $top.l -textvariable fontparam(which)
11191 pack $top.l -side top
11192 set fontlist [lsort [font families]]
11193 ${NS}::frame $top.f
11194 listbox $top.f.fam -listvariable fontlist \
11195 -yscrollcommand [list $top.f.sb set]
11196 bind $top.f.fam <<ListboxSelect>> selfontfam
11197 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11198 pack $top.f.sb -side right -fill y
11199 pack $top.f.fam -side left -fill both -expand 1
11200 pack $top.f -side top -fill both -expand 1
11201 ${NS}::frame $top.g
11202 spinbox $top.g.size -from 4 -to 40 -width 4 \
11203 -textvariable fontparam(size) \
11204 -validatecommand {string is integer -strict %s}
11205 checkbutton $top.g.bold -padx 5 \
11206 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11207 -variable fontparam(weight) -onvalue bold -offvalue normal
11208 checkbutton $top.g.ital -padx 5 \
11209 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11210 -variable fontparam(slant) -onvalue italic -offvalue roman
11211 pack $top.g.size $top.g.bold $top.g.ital -side left
11212 pack $top.g -side top
11213 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11214 -background white
11215 $top.c create text 100 25 -anchor center -text $which -font sample \
11216 -fill black -tags text
11217 bind $top.c <Configure> [list centertext $top.c]
11218 pack $top.c -side top -fill x
11219 ${NS}::frame $top.buts
11220 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11221 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11222 bind $top <Key-Return> fontok
11223 bind $top <Key-Escape> fontcan
11224 grid $top.buts.ok $top.buts.can
11225 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11226 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11227 pack $top.buts -side bottom -fill x
11228 trace add variable fontparam write chg_fontparam
11229 } else {
11230 raise $top
11231 $top.c itemconf text -text $which
11233 set i [lsearch -exact $fontlist $fontparam(family)]
11234 if {$i >= 0} {
11235 $top.f.fam selection set $i
11236 $top.f.fam see $i
11240 proc centertext {w} {
11241 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11244 proc fontok {} {
11245 global fontparam fontpref prefstop
11247 set f $fontparam(font)
11248 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11249 if {$fontparam(weight) eq "bold"} {
11250 lappend fontpref($f) "bold"
11252 if {$fontparam(slant) eq "italic"} {
11253 lappend fontpref($f) "italic"
11255 set w $prefstop.notebook.fonts.$f
11256 $w conf -text $fontparam(family) -font $fontpref($f)
11258 fontcan
11261 proc fontcan {} {
11262 global fonttop fontparam
11264 if {[info exists fonttop]} {
11265 catch {destroy $fonttop}
11266 catch {font delete sample}
11267 unset fonttop
11268 unset fontparam
11272 if {[package vsatisfies [package provide Tk] 8.6]} {
11273 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11274 # function to make use of it.
11275 proc choosefont {font which} {
11276 tk fontchooser configure -title $which -font $font \
11277 -command [list on_choosefont $font $which]
11278 tk fontchooser show
11280 proc on_choosefont {font which newfont} {
11281 global fontparam
11282 puts stderr "$font $newfont"
11283 array set f [font actual $newfont]
11284 set fontparam(which) $which
11285 set fontparam(font) $font
11286 set fontparam(family) $f(-family)
11287 set fontparam(size) $f(-size)
11288 set fontparam(weight) $f(-weight)
11289 set fontparam(slant) $f(-slant)
11290 fontok
11294 proc selfontfam {} {
11295 global fonttop fontparam
11297 set i [$fonttop.f.fam curselection]
11298 if {$i ne {}} {
11299 set fontparam(family) [$fonttop.f.fam get $i]
11303 proc chg_fontparam {v sub op} {
11304 global fontparam
11306 font config sample -$sub $fontparam($sub)
11309 # Create a property sheet tab page
11310 proc create_prefs_page {w} {
11311 global NS
11312 set parent [join [lrange [split $w .] 0 end-1] .]
11313 if {[winfo class $parent] eq "TNotebook"} {
11314 ${NS}::frame $w
11315 } else {
11316 ${NS}::labelframe $w
11320 proc prefspage_general {notebook} {
11321 global NS maxwidth maxgraphpct showneartags showlocalchanges
11322 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11323 global hideremotes want_ttk have_ttk maxrefs
11325 set page [create_prefs_page $notebook.general]
11327 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11328 grid $page.ldisp - -sticky w -pady 10
11329 ${NS}::label $page.spacer -text " "
11330 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11331 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11332 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11333 #xgettext:no-tcl-format
11334 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11335 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11336 grid x $page.maxpctl $page.maxpct -sticky w
11337 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11338 -variable showlocalchanges
11339 grid x $page.showlocal -sticky w
11340 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11341 -variable autoselect
11342 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11343 grid x $page.autoselect $page.autosellen -sticky w
11344 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11345 -variable hideremotes
11346 grid x $page.hideremotes -sticky w
11348 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11349 grid $page.ddisp - -sticky w -pady 10
11350 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11351 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11352 grid x $page.tabstopl $page.tabstop -sticky w
11353 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11354 -variable showneartags
11355 grid x $page.ntag -sticky w
11356 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11357 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11358 grid x $page.maxrefsl $page.maxrefs -sticky w
11359 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11360 -variable limitdiffs
11361 grid x $page.ldiff -sticky w
11362 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11363 -variable perfile_attrs
11364 grid x $page.lattr -sticky w
11366 ${NS}::entry $page.extdifft -textvariable extdifftool
11367 ${NS}::frame $page.extdifff
11368 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11369 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11370 pack $page.extdifff.l $page.extdifff.b -side left
11371 pack configure $page.extdifff.l -padx 10
11372 grid x $page.extdifff $page.extdifft -sticky ew
11374 ${NS}::label $page.lgen -text [mc "General options"]
11375 grid $page.lgen - -sticky w -pady 10
11376 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11377 -text [mc "Use themed widgets"]
11378 if {$have_ttk} {
11379 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11380 } else {
11381 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11383 grid x $page.want_ttk $page.ttk_note -sticky w
11384 return $page
11387 proc prefspage_colors {notebook} {
11388 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11390 set page [create_prefs_page $notebook.colors]
11392 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11393 grid $page.cdisp - -sticky w -pady 10
11394 label $page.ui -padx 40 -relief sunk -background $uicolor
11395 ${NS}::button $page.uibut -text [mc "Interface"] \
11396 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11397 grid x $page.uibut $page.ui -sticky w
11398 label $page.bg -padx 40 -relief sunk -background $bgcolor
11399 ${NS}::button $page.bgbut -text [mc "Background"] \
11400 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11401 grid x $page.bgbut $page.bg -sticky w
11402 label $page.fg -padx 40 -relief sunk -background $fgcolor
11403 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11404 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11405 grid x $page.fgbut $page.fg -sticky w
11406 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11407 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11408 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11409 [list $ctext tag conf d0 -foreground]]
11410 grid x $page.diffoldbut $page.diffold -sticky w
11411 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11412 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11413 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11414 [list $ctext tag conf dresult -foreground]]
11415 grid x $page.diffnewbut $page.diffnew -sticky w
11416 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11417 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11418 -command [list choosecolor diffcolors 2 $page.hunksep \
11419 [mc "diff hunk header"] \
11420 [list $ctext tag conf hunksep -foreground]]
11421 grid x $page.hunksepbut $page.hunksep -sticky w
11422 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11423 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11424 -command [list choosecolor markbgcolor {} $page.markbgsep \
11425 [mc "marked line background"] \
11426 [list $ctext tag conf omark -background]]
11427 grid x $page.markbgbut $page.markbgsep -sticky w
11428 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11429 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11430 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11431 grid x $page.selbgbut $page.selbgsep -sticky w
11432 return $page
11435 proc prefspage_fonts {notebook} {
11436 global NS
11437 set page [create_prefs_page $notebook.fonts]
11438 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11439 grid $page.cfont - -sticky w -pady 10
11440 mkfontdisp mainfont $page [mc "Main font"]
11441 mkfontdisp textfont $page [mc "Diff display font"]
11442 mkfontdisp uifont $page [mc "User interface font"]
11443 return $page
11446 proc doprefs {} {
11447 global maxwidth maxgraphpct use_ttk NS
11448 global oldprefs prefstop showneartags showlocalchanges
11449 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11450 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11451 global hideremotes want_ttk have_ttk
11453 set top .gitkprefs
11454 set prefstop $top
11455 if {[winfo exists $top]} {
11456 raise $top
11457 return
11459 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11460 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11461 set oldprefs($v) [set $v]
11463 ttk_toplevel $top
11464 wm title $top [mc "Gitk preferences"]
11465 make_transient $top .
11467 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11468 set notebook [ttk::notebook $top.notebook]
11469 } else {
11470 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11473 lappend pages [prefspage_general $notebook] [mc "General"]
11474 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11475 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11476 set col 0
11477 foreach {page title} $pages {
11478 if {$use_notebook} {
11479 $notebook add $page -text $title
11480 } else {
11481 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11482 -text $title -command [list raise $page]]
11483 $page configure -text $title
11484 grid $btn -row 0 -column [incr col] -sticky w
11485 grid $page -row 1 -column 0 -sticky news -columnspan 100
11489 if {!$use_notebook} {
11490 grid columnconfigure $notebook 0 -weight 1
11491 grid rowconfigure $notebook 1 -weight 1
11492 raise [lindex $pages 0]
11495 grid $notebook -sticky news -padx 2 -pady 2
11496 grid rowconfigure $top 0 -weight 1
11497 grid columnconfigure $top 0 -weight 1
11499 ${NS}::frame $top.buts
11500 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11501 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11502 bind $top <Key-Return> prefsok
11503 bind $top <Key-Escape> prefscan
11504 grid $top.buts.ok $top.buts.can
11505 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11506 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11507 grid $top.buts - - -pady 10 -sticky ew
11508 grid columnconfigure $top 2 -weight 1
11509 bind $top <Visibility> [list focus $top.buts.ok]
11512 proc choose_extdiff {} {
11513 global extdifftool
11515 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11516 if {$prog ne {}} {
11517 set extdifftool $prog
11521 proc choosecolor {v vi w x cmd} {
11522 global $v
11524 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11525 -title [mc "Gitk: choose color for %s" $x]]
11526 if {$c eq {}} return
11527 $w conf -background $c
11528 lset $v $vi $c
11529 eval $cmd $c
11532 proc setselbg {c} {
11533 global bglist cflist
11534 foreach w $bglist {
11535 $w configure -selectbackground $c
11537 $cflist tag configure highlight \
11538 -background [$cflist cget -selectbackground]
11539 allcanvs itemconf secsel -fill $c
11542 # This sets the background color and the color scheme for the whole UI.
11543 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11544 # if we don't specify one ourselves, which makes the checkbuttons and
11545 # radiobuttons look bad. This chooses white for selectColor if the
11546 # background color is light, or black if it is dark.
11547 proc setui {c} {
11548 if {[tk windowingsystem] eq "win32"} { return }
11549 set bg [winfo rgb . $c]
11550 set selc black
11551 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11552 set selc white
11554 tk_setPalette background $c selectColor $selc
11557 proc setbg {c} {
11558 global bglist
11560 foreach w $bglist {
11561 $w conf -background $c
11565 proc setfg {c} {
11566 global fglist canv
11568 foreach w $fglist {
11569 $w conf -foreground $c
11571 allcanvs itemconf text -fill $c
11572 $canv itemconf circle -outline $c
11573 $canv itemconf markid -outline $c
11576 proc prefscan {} {
11577 global oldprefs prefstop
11579 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11580 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11581 global $v
11582 set $v $oldprefs($v)
11584 catch {destroy $prefstop}
11585 unset prefstop
11586 fontcan
11589 proc prefsok {} {
11590 global maxwidth maxgraphpct
11591 global oldprefs prefstop showneartags showlocalchanges
11592 global fontpref mainfont textfont uifont
11593 global limitdiffs treediffs perfile_attrs
11594 global hideremotes
11596 catch {destroy $prefstop}
11597 unset prefstop
11598 fontcan
11599 set fontchanged 0
11600 if {$mainfont ne $fontpref(mainfont)} {
11601 set mainfont $fontpref(mainfont)
11602 parsefont mainfont $mainfont
11603 eval font configure mainfont [fontflags mainfont]
11604 eval font configure mainfontbold [fontflags mainfont 1]
11605 setcoords
11606 set fontchanged 1
11608 if {$textfont ne $fontpref(textfont)} {
11609 set textfont $fontpref(textfont)
11610 parsefont textfont $textfont
11611 eval font configure textfont [fontflags textfont]
11612 eval font configure textfontbold [fontflags textfont 1]
11614 if {$uifont ne $fontpref(uifont)} {
11615 set uifont $fontpref(uifont)
11616 parsefont uifont $uifont
11617 eval font configure uifont [fontflags uifont]
11619 settabs
11620 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11621 if {$showlocalchanges} {
11622 doshowlocalchanges
11623 } else {
11624 dohidelocalchanges
11627 if {$limitdiffs != $oldprefs(limitdiffs) ||
11628 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11629 # treediffs elements are limited by path;
11630 # won't have encodings cached if perfile_attrs was just turned on
11631 catch {unset treediffs}
11633 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11634 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11635 redisplay
11636 } elseif {$showneartags != $oldprefs(showneartags) ||
11637 $limitdiffs != $oldprefs(limitdiffs)} {
11638 reselectline
11640 if {$hideremotes != $oldprefs(hideremotes)} {
11641 rereadrefs
11645 proc formatdate {d} {
11646 global datetimeformat
11647 if {$d ne {}} {
11648 # If $datetimeformat includes a timezone, display in the
11649 # timezone of the argument. Otherwise, display in local time.
11650 if {[string match {*%[zZ]*} $datetimeformat]} {
11651 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11652 # Tcl < 8.5 does not support -timezone. Emulate it by
11653 # setting TZ (e.g. TZ=<-0430>+04:30).
11654 global env
11655 if {[info exists env(TZ)]} {
11656 set savedTZ $env(TZ)
11658 set zone [lindex $d 1]
11659 set sign [string map {+ - - +} [string index $zone 0]]
11660 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11661 set d [clock format [lindex $d 0] -format $datetimeformat]
11662 if {[info exists savedTZ]} {
11663 set env(TZ) $savedTZ
11664 } else {
11665 unset env(TZ)
11668 } else {
11669 set d [clock format [lindex $d 0] -format $datetimeformat]
11672 return $d
11675 # This list of encoding names and aliases is distilled from
11676 # http://www.iana.org/assignments/character-sets.
11677 # Not all of them are supported by Tcl.
11678 set encoding_aliases {
11679 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11680 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11681 { ISO-10646-UTF-1 csISO10646UTF1 }
11682 { ISO_646.basic:1983 ref csISO646basic1983 }
11683 { INVARIANT csINVARIANT }
11684 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11685 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11686 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11687 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11688 { NATS-DANO iso-ir-9-1 csNATSDANO }
11689 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11690 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11691 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11692 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11693 { ISO-2022-KR csISO2022KR }
11694 { EUC-KR csEUCKR }
11695 { ISO-2022-JP csISO2022JP }
11696 { ISO-2022-JP-2 csISO2022JP2 }
11697 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11698 csISO13JISC6220jp }
11699 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11700 { IT iso-ir-15 ISO646-IT csISO15Italian }
11701 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11702 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11703 { greek7-old iso-ir-18 csISO18Greek7Old }
11704 { latin-greek iso-ir-19 csISO19LatinGreek }
11705 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11706 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11707 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11708 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11709 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11710 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11711 { INIS iso-ir-49 csISO49INIS }
11712 { INIS-8 iso-ir-50 csISO50INIS8 }
11713 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11714 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11715 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11716 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11717 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11718 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11719 csISO60Norwegian1 }
11720 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11721 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11722 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11723 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11724 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11725 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11726 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11727 { greek7 iso-ir-88 csISO88Greek7 }
11728 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11729 { iso-ir-90 csISO90 }
11730 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11731 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11732 csISO92JISC62991984b }
11733 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11734 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11735 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11736 csISO95JIS62291984handadd }
11737 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11738 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11739 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11740 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11741 CP819 csISOLatin1 }
11742 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11743 { T.61-7bit iso-ir-102 csISO102T617bit }
11744 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11745 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11746 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11747 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11748 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11749 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11750 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11751 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11752 arabic csISOLatinArabic }
11753 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11754 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11755 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11756 greek greek8 csISOLatinGreek }
11757 { T.101-G2 iso-ir-128 csISO128T101G2 }
11758 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11759 csISOLatinHebrew }
11760 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11761 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11762 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11763 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11764 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11765 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11766 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11767 csISOLatinCyrillic }
11768 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11769 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11770 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11771 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11772 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11773 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11774 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11775 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11776 { ISO_10367-box iso-ir-155 csISO10367Box }
11777 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11778 { latin-lap lap iso-ir-158 csISO158Lap }
11779 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11780 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11781 { us-dk csUSDK }
11782 { dk-us csDKUS }
11783 { JIS_X0201 X0201 csHalfWidthKatakana }
11784 { KSC5636 ISO646-KR csKSC5636 }
11785 { ISO-10646-UCS-2 csUnicode }
11786 { ISO-10646-UCS-4 csUCS4 }
11787 { DEC-MCS dec csDECMCS }
11788 { hp-roman8 roman8 r8 csHPRoman8 }
11789 { macintosh mac csMacintosh }
11790 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11791 csIBM037 }
11792 { IBM038 EBCDIC-INT cp038 csIBM038 }
11793 { IBM273 CP273 csIBM273 }
11794 { IBM274 EBCDIC-BE CP274 csIBM274 }
11795 { IBM275 EBCDIC-BR cp275 csIBM275 }
11796 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11797 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11798 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11799 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11800 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11801 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11802 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11803 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11804 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11805 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11806 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11807 { IBM437 cp437 437 csPC8CodePage437 }
11808 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11809 { IBM775 cp775 csPC775Baltic }
11810 { IBM850 cp850 850 csPC850Multilingual }
11811 { IBM851 cp851 851 csIBM851 }
11812 { IBM852 cp852 852 csPCp852 }
11813 { IBM855 cp855 855 csIBM855 }
11814 { IBM857 cp857 857 csIBM857 }
11815 { IBM860 cp860 860 csIBM860 }
11816 { IBM861 cp861 861 cp-is csIBM861 }
11817 { IBM862 cp862 862 csPC862LatinHebrew }
11818 { IBM863 cp863 863 csIBM863 }
11819 { IBM864 cp864 csIBM864 }
11820 { IBM865 cp865 865 csIBM865 }
11821 { IBM866 cp866 866 csIBM866 }
11822 { IBM868 CP868 cp-ar csIBM868 }
11823 { IBM869 cp869 869 cp-gr csIBM869 }
11824 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11825 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11826 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11827 { IBM891 cp891 csIBM891 }
11828 { IBM903 cp903 csIBM903 }
11829 { IBM904 cp904 904 csIBBM904 }
11830 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11831 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11832 { IBM1026 CP1026 csIBM1026 }
11833 { EBCDIC-AT-DE csIBMEBCDICATDE }
11834 { EBCDIC-AT-DE-A csEBCDICATDEA }
11835 { EBCDIC-CA-FR csEBCDICCAFR }
11836 { EBCDIC-DK-NO csEBCDICDKNO }
11837 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11838 { EBCDIC-FI-SE csEBCDICFISE }
11839 { EBCDIC-FI-SE-A csEBCDICFISEA }
11840 { EBCDIC-FR csEBCDICFR }
11841 { EBCDIC-IT csEBCDICIT }
11842 { EBCDIC-PT csEBCDICPT }
11843 { EBCDIC-ES csEBCDICES }
11844 { EBCDIC-ES-A csEBCDICESA }
11845 { EBCDIC-ES-S csEBCDICESS }
11846 { EBCDIC-UK csEBCDICUK }
11847 { EBCDIC-US csEBCDICUS }
11848 { UNKNOWN-8BIT csUnknown8BiT }
11849 { MNEMONIC csMnemonic }
11850 { MNEM csMnem }
11851 { VISCII csVISCII }
11852 { VIQR csVIQR }
11853 { KOI8-R csKOI8R }
11854 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11855 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11856 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11857 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11858 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11859 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11860 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11861 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11862 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11863 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11864 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11865 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11866 { IBM1047 IBM-1047 }
11867 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11868 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11869 { UNICODE-1-1 csUnicode11 }
11870 { CESU-8 csCESU-8 }
11871 { BOCU-1 csBOCU-1 }
11872 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11873 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11874 l8 }
11875 { ISO-8859-15 ISO_8859-15 Latin-9 }
11876 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11877 { GBK CP936 MS936 windows-936 }
11878 { JIS_Encoding csJISEncoding }
11879 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11880 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11881 EUC-JP }
11882 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11883 { ISO-10646-UCS-Basic csUnicodeASCII }
11884 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11885 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11886 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11887 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11888 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11889 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11890 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11891 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11892 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11893 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11894 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11895 { Ventura-US csVenturaUS }
11896 { Ventura-International csVenturaInternational }
11897 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11898 { PC8-Turkish csPC8Turkish }
11899 { IBM-Symbols csIBMSymbols }
11900 { IBM-Thai csIBMThai }
11901 { HP-Legal csHPLegal }
11902 { HP-Pi-font csHPPiFont }
11903 { HP-Math8 csHPMath8 }
11904 { Adobe-Symbol-Encoding csHPPSMath }
11905 { HP-DeskTop csHPDesktop }
11906 { Ventura-Math csVenturaMath }
11907 { Microsoft-Publishing csMicrosoftPublishing }
11908 { Windows-31J csWindows31J }
11909 { GB2312 csGB2312 }
11910 { Big5 csBig5 }
11913 proc tcl_encoding {enc} {
11914 global encoding_aliases tcl_encoding_cache
11915 if {[info exists tcl_encoding_cache($enc)]} {
11916 return $tcl_encoding_cache($enc)
11918 set names [encoding names]
11919 set lcnames [string tolower $names]
11920 set enc [string tolower $enc]
11921 set i [lsearch -exact $lcnames $enc]
11922 if {$i < 0} {
11923 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11924 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11925 set i [lsearch -exact $lcnames $encx]
11928 if {$i < 0} {
11929 foreach l $encoding_aliases {
11930 set ll [string tolower $l]
11931 if {[lsearch -exact $ll $enc] < 0} continue
11932 # look through the aliases for one that tcl knows about
11933 foreach e $ll {
11934 set i [lsearch -exact $lcnames $e]
11935 if {$i < 0} {
11936 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11937 set i [lsearch -exact $lcnames $ex]
11940 if {$i >= 0} break
11942 break
11945 set tclenc {}
11946 if {$i >= 0} {
11947 set tclenc [lindex $names $i]
11949 set tcl_encoding_cache($enc) $tclenc
11950 return $tclenc
11953 proc gitattr {path attr default} {
11954 global path_attr_cache
11955 if {[info exists path_attr_cache($attr,$path)]} {
11956 set r $path_attr_cache($attr,$path)
11957 } else {
11958 set r "unspecified"
11959 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11960 regexp "(.*): $attr: (.*)" $line m f r
11962 set path_attr_cache($attr,$path) $r
11964 if {$r eq "unspecified"} {
11965 return $default
11967 return $r
11970 proc cache_gitattr {attr pathlist} {
11971 global path_attr_cache
11972 set newlist {}
11973 foreach path $pathlist {
11974 if {![info exists path_attr_cache($attr,$path)]} {
11975 lappend newlist $path
11978 set lim 1000
11979 if {[tk windowingsystem] == "win32"} {
11980 # windows has a 32k limit on the arguments to a command...
11981 set lim 30
11983 while {$newlist ne {}} {
11984 set head [lrange $newlist 0 [expr {$lim - 1}]]
11985 set newlist [lrange $newlist $lim end]
11986 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11987 foreach row [split $rlist "\n"] {
11988 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11989 if {[string index $path 0] eq "\""} {
11990 set path [encoding convertfrom [lindex $path 0]]
11992 set path_attr_cache($attr,$path) $value
11999 proc get_path_encoding {path} {
12000 global gui_encoding perfile_attrs
12001 set tcl_enc $gui_encoding
12002 if {$path ne {} && $perfile_attrs} {
12003 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12004 if {$enc2 ne {}} {
12005 set tcl_enc $enc2
12008 return $tcl_enc
12011 # First check that Tcl/Tk is recent enough
12012 if {[catch {package require Tk 8.4} err]} {
12013 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12014 Gitk requires at least Tcl/Tk 8.4." list
12015 exit 1
12018 # on OSX bring the current Wish process window to front
12019 if {[tk windowingsystem] eq "aqua"} {
12020 exec osascript -e [format {
12021 tell application "System Events"
12022 set frontmost of processes whose unix id is %d to true
12023 end tell
12024 } [pid] ]
12027 # Unset GIT_TRACE var if set
12028 if { [info exists ::env(GIT_TRACE)] } {
12029 unset ::env(GIT_TRACE)
12032 # defaults...
12033 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12035 set gitencoding {}
12036 catch {
12037 set gitencoding [exec git config --get i18n.commitencoding]
12039 catch {
12040 set gitencoding [exec git config --get i18n.logoutputencoding]
12042 if {$gitencoding == ""} {
12043 set gitencoding "utf-8"
12045 set tclencoding [tcl_encoding $gitencoding]
12046 if {$tclencoding == {}} {
12047 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12050 set gui_encoding [encoding system]
12051 catch {
12052 set enc [exec git config --get gui.encoding]
12053 if {$enc ne {}} {
12054 set tclenc [tcl_encoding $enc]
12055 if {$tclenc ne {}} {
12056 set gui_encoding $tclenc
12057 } else {
12058 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12063 set log_showroot true
12064 catch {
12065 set log_showroot [exec git config --bool --get log.showroot]
12068 if {[tk windowingsystem] eq "aqua"} {
12069 set mainfont {{Lucida Grande} 9}
12070 set textfont {Monaco 9}
12071 set uifont {{Lucida Grande} 9 bold}
12072 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12073 # fontconfig!
12074 set mainfont {sans 9}
12075 set textfont {monospace 9}
12076 set uifont {sans 9 bold}
12077 } else {
12078 set mainfont {Helvetica 9}
12079 set textfont {Courier 9}
12080 set uifont {Helvetica 9 bold}
12082 set tabstop 8
12083 set findmergefiles 0
12084 set maxgraphpct 50
12085 set maxwidth 16
12086 set revlistorder 0
12087 set fastdate 0
12088 set uparrowlen 5
12089 set downarrowlen 5
12090 set mingaplen 100
12091 set cmitmode "patch"
12092 set wrapcomment "none"
12093 set showneartags 1
12094 set hideremotes 0
12095 set maxrefs 20
12096 set visiblerefs {"master"}
12097 set maxlinelen 200
12098 set showlocalchanges 1
12099 set limitdiffs 1
12100 set datetimeformat "%Y-%m-%d %H:%M:%S"
12101 set autoselect 1
12102 set autosellen 40
12103 set perfile_attrs 0
12104 set want_ttk 1
12106 if {[tk windowingsystem] eq "aqua"} {
12107 set extdifftool "opendiff"
12108 } else {
12109 set extdifftool "meld"
12112 set colors {green red blue magenta darkgrey brown orange}
12113 if {[tk windowingsystem] eq "win32"} {
12114 set uicolor SystemButtonFace
12115 set uifgcolor SystemButtonText
12116 set uifgdisabledcolor SystemDisabledText
12117 set bgcolor SystemWindow
12118 set fgcolor SystemWindowText
12119 set selectbgcolor SystemHighlight
12120 } else {
12121 set uicolor grey85
12122 set uifgcolor black
12123 set uifgdisabledcolor "#999"
12124 set bgcolor white
12125 set fgcolor black
12126 set selectbgcolor gray85
12128 set diffcolors {red "#00a000" blue}
12129 set diffcontext 3
12130 set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12131 set ignorespace 0
12132 set worddiff ""
12133 set markbgcolor "#e0e0ff"
12135 set headbgcolor green
12136 set headfgcolor black
12137 set headoutlinecolor black
12138 set remotebgcolor #ffddaa
12139 set tagbgcolor yellow
12140 set tagfgcolor black
12141 set tagoutlinecolor black
12142 set reflinecolor black
12143 set filesepbgcolor #aaaaaa
12144 set filesepfgcolor black
12145 set linehoverbgcolor #ffff80
12146 set linehoverfgcolor black
12147 set linehoveroutlinecolor black
12148 set mainheadcirclecolor yellow
12149 set workingfilescirclecolor red
12150 set indexcirclecolor green
12151 set circlecolors {white blue gray blue blue}
12152 set linkfgcolor blue
12153 set circleoutlinecolor $fgcolor
12154 set foundbgcolor yellow
12155 set currentsearchhitbgcolor orange
12157 # button for popping up context menus
12158 if {[tk windowingsystem] eq "aqua"} {
12159 set ctxbut <Button-2>
12160 } else {
12161 set ctxbut <Button-3>
12164 ## For msgcat loading, first locate the installation location.
12165 if { [info exists ::env(GITK_MSGSDIR)] } {
12166 ## Msgsdir was manually set in the environment.
12167 set gitk_msgsdir $::env(GITK_MSGSDIR)
12168 } else {
12169 ## Let's guess the prefix from argv0.
12170 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12171 set gitk_libdir [file join $gitk_prefix share gitk lib]
12172 set gitk_msgsdir [file join $gitk_libdir msgs]
12173 unset gitk_prefix
12176 ## Internationalization (i18n) through msgcat and gettext. See
12177 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12178 package require msgcat
12179 namespace import ::msgcat::mc
12180 ## And eventually load the actual message catalog
12181 ::msgcat::mcload $gitk_msgsdir
12183 catch {
12184 # follow the XDG base directory specification by default. See
12185 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12186 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12187 # XDG_CONFIG_HOME environment variable is set
12188 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12189 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12190 } else {
12191 # default XDG_CONFIG_HOME
12192 set config_file "~/.config/git/gitk"
12193 set config_file_tmp "~/.config/git/gitk-tmp"
12195 if {![file exists $config_file]} {
12196 # for backward compatibility use the old config file if it exists
12197 if {[file exists "~/.gitk"]} {
12198 set config_file "~/.gitk"
12199 set config_file_tmp "~/.gitk-tmp"
12200 } elseif {![file exists [file dirname $config_file]]} {
12201 file mkdir [file dirname $config_file]
12204 source $config_file
12206 config_check_tmp_exists 50
12208 set config_variables {
12209 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12210 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12211 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12212 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12213 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12214 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12215 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12216 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12217 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12218 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12220 foreach var $config_variables {
12221 config_init_trace $var
12222 trace add variable $var write config_variable_change_cb
12225 parsefont mainfont $mainfont
12226 eval font create mainfont [fontflags mainfont]
12227 eval font create mainfontbold [fontflags mainfont 1]
12229 parsefont textfont $textfont
12230 eval font create textfont [fontflags textfont]
12231 eval font create textfontbold [fontflags textfont 1]
12233 parsefont uifont $uifont
12234 eval font create uifont [fontflags uifont]
12236 setui $uicolor
12238 setoptions
12240 # check that we can find a .git directory somewhere...
12241 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12242 show_error {} . [mc "Cannot find a git repository here."]
12243 exit 1
12246 set selecthead {}
12247 set selectheadid {}
12249 set revtreeargs {}
12250 set cmdline_files {}
12251 set i 0
12252 set revtreeargscmd {}
12253 foreach arg $argv {
12254 switch -glob -- $arg {
12255 "" { }
12256 "--" {
12257 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12258 break
12260 "--select-commit=*" {
12261 set selecthead [string range $arg 16 end]
12263 "--argscmd=*" {
12264 set revtreeargscmd [string range $arg 10 end]
12266 default {
12267 lappend revtreeargs $arg
12270 incr i
12273 if {$selecthead eq "HEAD"} {
12274 set selecthead {}
12277 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12278 # no -- on command line, but some arguments (other than --argscmd)
12279 if {[catch {
12280 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12281 set cmdline_files [split $f "\n"]
12282 set n [llength $cmdline_files]
12283 set revtreeargs [lrange $revtreeargs 0 end-$n]
12284 # Unfortunately git rev-parse doesn't produce an error when
12285 # something is both a revision and a filename. To be consistent
12286 # with git log and git rev-list, check revtreeargs for filenames.
12287 foreach arg $revtreeargs {
12288 if {[file exists $arg]} {
12289 show_error {} . [mc "Ambiguous argument '%s': both revision\
12290 and filename" $arg]
12291 exit 1
12294 } err]} {
12295 # unfortunately we get both stdout and stderr in $err,
12296 # so look for "fatal:".
12297 set i [string first "fatal:" $err]
12298 if {$i > 0} {
12299 set err [string range $err [expr {$i + 6}] end]
12301 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12302 exit 1
12306 set nullid "0000000000000000000000000000000000000000"
12307 set nullid2 "0000000000000000000000000000000000000001"
12308 set nullfile "/dev/null"
12310 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12311 if {![info exists have_ttk]} {
12312 set have_ttk [llength [info commands ::ttk::style]]
12314 set use_ttk [expr {$have_ttk && $want_ttk}]
12315 set NS [expr {$use_ttk ? "ttk" : ""}]
12317 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12319 set show_notes {}
12320 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12321 set show_notes "--show-notes"
12324 set appname "gitk"
12326 set runq {}
12327 set history {}
12328 set historyindex 0
12329 set fh_serial 0
12330 set nhl_names {}
12331 set highlight_paths {}
12332 set findpattern {}
12333 set searchdirn -forwards
12334 set boldids {}
12335 set boldnameids {}
12336 set diffelide {0 0}
12337 set markingmatches 0
12338 set linkentercount 0
12339 set need_redisplay 0
12340 set nrows_drawn 0
12341 set firsttabstop 0
12343 set nextviewnum 1
12344 set curview 0
12345 set selectedview 0
12346 set selectedhlview [mc "None"]
12347 set highlight_related [mc "None"]
12348 set highlight_files {}
12349 set viewfiles(0) {}
12350 set viewperm(0) 0
12351 set viewchanged(0) 0
12352 set viewargs(0) {}
12353 set viewargscmd(0) {}
12355 set selectedline {}
12356 set numcommits 0
12357 set loginstance 0
12358 set cmdlineok 0
12359 set stopped 0
12360 set stuffsaved 0
12361 set patchnum 0
12362 set lserial 0
12363 set hasworktree [hasworktree]
12364 set cdup {}
12365 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12366 set cdup [exec git rev-parse --show-cdup]
12368 set worktree [exec git rev-parse --show-toplevel]
12369 setcoords
12370 makewindow
12371 catch {
12372 image create photo gitlogo -width 16 -height 16
12374 image create photo gitlogominus -width 4 -height 2
12375 gitlogominus put #C00000 -to 0 0 4 2
12376 gitlogo copy gitlogominus -to 1 5
12377 gitlogo copy gitlogominus -to 6 5
12378 gitlogo copy gitlogominus -to 11 5
12379 image delete gitlogominus
12381 image create photo gitlogoplus -width 4 -height 4
12382 gitlogoplus put #008000 -to 1 0 3 4
12383 gitlogoplus put #008000 -to 0 1 4 3
12384 gitlogo copy gitlogoplus -to 1 9
12385 gitlogo copy gitlogoplus -to 6 9
12386 gitlogo copy gitlogoplus -to 11 9
12387 image delete gitlogoplus
12389 image create photo gitlogo32 -width 32 -height 32
12390 gitlogo32 copy gitlogo -zoom 2 2
12392 wm iconphoto . -default gitlogo gitlogo32
12394 # wait for the window to become visible
12395 tkwait visibility .
12396 wm title . "$appname: [reponame]"
12397 update
12398 readrefs
12400 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12401 # create a view for the files/dirs specified on the command line
12402 set curview 1
12403 set selectedview 1
12404 set nextviewnum 2
12405 set viewname(1) [mc "Command line"]
12406 set viewfiles(1) $cmdline_files
12407 set viewargs(1) $revtreeargs
12408 set viewargscmd(1) $revtreeargscmd
12409 set viewperm(1) 0
12410 set viewchanged(1) 0
12411 set vdatemode(1) 0
12412 addviewmenu 1
12413 .bar.view entryconf [mca "Edit view..."] -state normal
12414 .bar.view entryconf [mca "Delete view"] -state normal
12417 if {[info exists permviews]} {
12418 foreach v $permviews {
12419 set n $nextviewnum
12420 incr nextviewnum
12421 set viewname($n) [lindex $v 0]
12422 set viewfiles($n) [lindex $v 1]
12423 set viewargs($n) [lindex $v 2]
12424 set viewargscmd($n) [lindex $v 3]
12425 set viewperm($n) 1
12426 set viewchanged($n) 0
12427 addviewmenu $n
12431 if {[tk windowingsystem] eq "win32"} {
12432 focus -force .
12435 getcommits {}
12437 # Local variables:
12438 # mode: tcl
12439 # indent-tabs-mode: t
12440 # tab-width: 8
12441 # End: