gitk: Only write changed configuration variables
[git/gitster.git] / gitk
blob3425066fa8dcf633a1266e4de019e1e2ca225877
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_init_trace {name} {
2787 global config_variable_changed config_variable_original
2789 upvar #0 $name var
2790 set config_variable_changed($name) 0
2791 set config_variable_original($name) $var
2794 proc config_variable_change_cb {name name2 op} {
2795 global config_variable_changed config_variable_original
2797 upvar #0 $name var
2798 if {$op eq "write" &&
2799 (![info exists config_variable_original($name)] ||
2800 $config_variable_original($name) ne $var)} {
2801 set config_variable_changed($name) 1
2805 proc savestuff {w} {
2806 global stuffsaved
2807 global config_file config_file_tmp
2808 global config_variables config_variable_changed
2809 global viewchanged
2811 upvar #0 viewname current_viewname
2812 upvar #0 viewfiles current_viewfiles
2813 upvar #0 viewargs current_viewargs
2814 upvar #0 viewargscmd current_viewargscmd
2815 upvar #0 viewperm current_viewperm
2816 upvar #0 nextviewnum current_nextviewnum
2817 upvar #0 use_ttk current_use_ttk
2819 if {$stuffsaved} return
2820 if {![winfo viewable .]} return
2821 catch {
2822 if {[file exists $config_file_tmp]} {
2823 file delete -force $config_file_tmp
2825 set f [open $config_file_tmp w]
2826 if {$::tcl_platform(platform) eq {windows}} {
2827 file attributes $config_file_tmp -hidden true
2829 if {[file exists $config_file]} {
2830 source $config_file
2832 foreach var_name $config_variables {
2833 upvar #0 $var_name var
2834 upvar 0 $var_name old_var
2835 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2836 puts $f [list set $var_name $old_var]
2837 } else {
2838 puts $f [list set $var_name $var]
2842 puts $f "set geometry(main) [wm geometry .]"
2843 puts $f "set geometry(state) [wm state .]"
2844 puts $f "set geometry(topwidth) [winfo width .tf]"
2845 puts $f "set geometry(topheight) [winfo height .tf]"
2846 if {$current_use_ttk} {
2847 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2848 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2849 } else {
2850 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2851 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2853 puts $f "set geometry(botwidth) [winfo width .bleft]"
2854 puts $f "set geometry(botheight) [winfo height .bleft]"
2856 array set view_save {}
2857 array set views {}
2858 if {![info exists permviews]} { set permviews {} }
2859 foreach view $permviews {
2860 set view_save([lindex $view 0]) 1
2861 set views([lindex $view 0]) $view
2863 puts -nonewline $f "set permviews {"
2864 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2865 if {$viewchanged($v)} {
2866 if {$current_viewperm($v)} {
2867 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2868 } else {
2869 set view_save($current_viewname($v)) 0
2873 # write old and updated view to their places and append remaining to the end
2874 foreach view $permviews {
2875 set view_name [lindex $view 0]
2876 if {$view_save($view_name)} {
2877 puts $f "{$views($view_name)}"
2879 unset views($view_name)
2881 foreach view_name [array names views] {
2882 puts $f "{$views($view_name)}"
2884 puts $f "}"
2885 close $f
2886 file rename -force $config_file_tmp $config_file
2888 set stuffsaved 1
2891 proc resizeclistpanes {win w} {
2892 global oldwidth use_ttk
2893 if {[info exists oldwidth($win)]} {
2894 if {$use_ttk} {
2895 set s0 [$win sashpos 0]
2896 set s1 [$win sashpos 1]
2897 } else {
2898 set s0 [$win sash coord 0]
2899 set s1 [$win sash coord 1]
2901 if {$w < 60} {
2902 set sash0 [expr {int($w/2 - 2)}]
2903 set sash1 [expr {int($w*5/6 - 2)}]
2904 } else {
2905 set factor [expr {1.0 * $w / $oldwidth($win)}]
2906 set sash0 [expr {int($factor * [lindex $s0 0])}]
2907 set sash1 [expr {int($factor * [lindex $s1 0])}]
2908 if {$sash0 < 30} {
2909 set sash0 30
2911 if {$sash1 < $sash0 + 20} {
2912 set sash1 [expr {$sash0 + 20}]
2914 if {$sash1 > $w - 10} {
2915 set sash1 [expr {$w - 10}]
2916 if {$sash0 > $sash1 - 20} {
2917 set sash0 [expr {$sash1 - 20}]
2921 if {$use_ttk} {
2922 $win sashpos 0 $sash0
2923 $win sashpos 1 $sash1
2924 } else {
2925 $win sash place 0 $sash0 [lindex $s0 1]
2926 $win sash place 1 $sash1 [lindex $s1 1]
2929 set oldwidth($win) $w
2932 proc resizecdetpanes {win w} {
2933 global oldwidth use_ttk
2934 if {[info exists oldwidth($win)]} {
2935 if {$use_ttk} {
2936 set s0 [$win sashpos 0]
2937 } else {
2938 set s0 [$win sash coord 0]
2940 if {$w < 60} {
2941 set sash0 [expr {int($w*3/4 - 2)}]
2942 } else {
2943 set factor [expr {1.0 * $w / $oldwidth($win)}]
2944 set sash0 [expr {int($factor * [lindex $s0 0])}]
2945 if {$sash0 < 45} {
2946 set sash0 45
2948 if {$sash0 > $w - 15} {
2949 set sash0 [expr {$w - 15}]
2952 if {$use_ttk} {
2953 $win sashpos 0 $sash0
2954 } else {
2955 $win sash place 0 $sash0 [lindex $s0 1]
2958 set oldwidth($win) $w
2961 proc allcanvs args {
2962 global canv canv2 canv3
2963 eval $canv $args
2964 eval $canv2 $args
2965 eval $canv3 $args
2968 proc bindall {event action} {
2969 global canv canv2 canv3
2970 bind $canv $event $action
2971 bind $canv2 $event $action
2972 bind $canv3 $event $action
2975 proc about {} {
2976 global uifont NS
2977 set w .about
2978 if {[winfo exists $w]} {
2979 raise $w
2980 return
2982 ttk_toplevel $w
2983 wm title $w [mc "About gitk"]
2984 make_transient $w .
2985 message $w.m -text [mc "
2986 Gitk - a commit viewer for git
2988 Copyright \u00a9 2005-2014 Paul Mackerras
2990 Use and redistribute under the terms of the GNU General Public License"] \
2991 -justify center -aspect 400 -border 2 -bg white -relief groove
2992 pack $w.m -side top -fill x -padx 2 -pady 2
2993 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2994 pack $w.ok -side bottom
2995 bind $w <Visibility> "focus $w.ok"
2996 bind $w <Key-Escape> "destroy $w"
2997 bind $w <Key-Return> "destroy $w"
2998 tk::PlaceWindow $w widget .
3001 proc keys {} {
3002 global NS
3003 set w .keys
3004 if {[winfo exists $w]} {
3005 raise $w
3006 return
3008 if {[tk windowingsystem] eq {aqua}} {
3009 set M1T Cmd
3010 } else {
3011 set M1T Ctrl
3013 ttk_toplevel $w
3014 wm title $w [mc "Gitk key bindings"]
3015 make_transient $w .
3016 message $w.m -text "
3017 [mc "Gitk key bindings:"]
3019 [mc "<%s-Q> Quit" $M1T]
3020 [mc "<%s-W> Close window" $M1T]
3021 [mc "<Home> Move to first commit"]
3022 [mc "<End> Move to last commit"]
3023 [mc "<Up>, p, k Move up one commit"]
3024 [mc "<Down>, n, j Move down one commit"]
3025 [mc "<Left>, z, h Go back in history list"]
3026 [mc "<Right>, x, l Go forward in history list"]
3027 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3028 [mc "<PageUp> Move up one page in commit list"]
3029 [mc "<PageDown> Move down one page in commit list"]
3030 [mc "<%s-Home> Scroll to top of commit list" $M1T]
3031 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
3032 [mc "<%s-Up> Scroll commit list up one line" $M1T]
3033 [mc "<%s-Down> Scroll commit list down one line" $M1T]
3034 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3035 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3036 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3037 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3038 [mc "<Delete>, b Scroll diff view up one page"]
3039 [mc "<Backspace> Scroll diff view up one page"]
3040 [mc "<Space> Scroll diff view down one page"]
3041 [mc "u Scroll diff view up 18 lines"]
3042 [mc "d Scroll diff view down 18 lines"]
3043 [mc "<%s-F> Find" $M1T]
3044 [mc "<%s-G> Move to next find hit" $M1T]
3045 [mc "<Return> Move to next find hit"]
3046 [mc "/ Focus the search box"]
3047 [mc "? Move to previous find hit"]
3048 [mc "f Scroll diff view to next file"]
3049 [mc "<%s-S> Search for next hit in diff view" $M1T]
3050 [mc "<%s-R> Search for previous hit in diff view" $M1T]
3051 [mc "<%s-KP+> Increase font size" $M1T]
3052 [mc "<%s-plus> Increase font size" $M1T]
3053 [mc "<%s-KP-> Decrease font size" $M1T]
3054 [mc "<%s-minus> Decrease font size" $M1T]
3055 [mc "<F5> Update"]
3057 -justify left -bg white -border 2 -relief groove
3058 pack $w.m -side top -fill both -padx 2 -pady 2
3059 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3060 bind $w <Key-Escape> [list destroy $w]
3061 pack $w.ok -side bottom
3062 bind $w <Visibility> "focus $w.ok"
3063 bind $w <Key-Escape> "destroy $w"
3064 bind $w <Key-Return> "destroy $w"
3067 # Procedures for manipulating the file list window at the
3068 # bottom right of the overall window.
3070 proc treeview {w l openlevs} {
3071 global treecontents treediropen treeheight treeparent treeindex
3073 set ix 0
3074 set treeindex() 0
3075 set lev 0
3076 set prefix {}
3077 set prefixend -1
3078 set prefendstack {}
3079 set htstack {}
3080 set ht 0
3081 set treecontents() {}
3082 $w conf -state normal
3083 foreach f $l {
3084 while {[string range $f 0 $prefixend] ne $prefix} {
3085 if {$lev <= $openlevs} {
3086 $w mark set e:$treeindex($prefix) "end -1c"
3087 $w mark gravity e:$treeindex($prefix) left
3089 set treeheight($prefix) $ht
3090 incr ht [lindex $htstack end]
3091 set htstack [lreplace $htstack end end]
3092 set prefixend [lindex $prefendstack end]
3093 set prefendstack [lreplace $prefendstack end end]
3094 set prefix [string range $prefix 0 $prefixend]
3095 incr lev -1
3097 set tail [string range $f [expr {$prefixend+1}] end]
3098 while {[set slash [string first "/" $tail]] >= 0} {
3099 lappend htstack $ht
3100 set ht 0
3101 lappend prefendstack $prefixend
3102 incr prefixend [expr {$slash + 1}]
3103 set d [string range $tail 0 $slash]
3104 lappend treecontents($prefix) $d
3105 set oldprefix $prefix
3106 append prefix $d
3107 set treecontents($prefix) {}
3108 set treeindex($prefix) [incr ix]
3109 set treeparent($prefix) $oldprefix
3110 set tail [string range $tail [expr {$slash+1}] end]
3111 if {$lev <= $openlevs} {
3112 set ht 1
3113 set treediropen($prefix) [expr {$lev < $openlevs}]
3114 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3115 $w mark set d:$ix "end -1c"
3116 $w mark gravity d:$ix left
3117 set str "\n"
3118 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3119 $w insert end $str
3120 $w image create end -align center -image $bm -padx 1 \
3121 -name a:$ix
3122 $w insert end $d [highlight_tag $prefix]
3123 $w mark set s:$ix "end -1c"
3124 $w mark gravity s:$ix left
3126 incr lev
3128 if {$tail ne {}} {
3129 if {$lev <= $openlevs} {
3130 incr ht
3131 set str "\n"
3132 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3133 $w insert end $str
3134 $w insert end $tail [highlight_tag $f]
3136 lappend treecontents($prefix) $tail
3139 while {$htstack ne {}} {
3140 set treeheight($prefix) $ht
3141 incr ht [lindex $htstack end]
3142 set htstack [lreplace $htstack end end]
3143 set prefixend [lindex $prefendstack end]
3144 set prefendstack [lreplace $prefendstack end end]
3145 set prefix [string range $prefix 0 $prefixend]
3147 $w conf -state disabled
3150 proc linetoelt {l} {
3151 global treeheight treecontents
3153 set y 2
3154 set prefix {}
3155 while {1} {
3156 foreach e $treecontents($prefix) {
3157 if {$y == $l} {
3158 return "$prefix$e"
3160 set n 1
3161 if {[string index $e end] eq "/"} {
3162 set n $treeheight($prefix$e)
3163 if {$y + $n > $l} {
3164 append prefix $e
3165 incr y
3166 break
3169 incr y $n
3174 proc highlight_tree {y prefix} {
3175 global treeheight treecontents cflist
3177 foreach e $treecontents($prefix) {
3178 set path $prefix$e
3179 if {[highlight_tag $path] ne {}} {
3180 $cflist tag add bold $y.0 "$y.0 lineend"
3182 incr y
3183 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3184 set y [highlight_tree $y $path]
3187 return $y
3190 proc treeclosedir {w dir} {
3191 global treediropen treeheight treeparent treeindex
3193 set ix $treeindex($dir)
3194 $w conf -state normal
3195 $w delete s:$ix e:$ix
3196 set treediropen($dir) 0
3197 $w image configure a:$ix -image tri-rt
3198 $w conf -state disabled
3199 set n [expr {1 - $treeheight($dir)}]
3200 while {$dir ne {}} {
3201 incr treeheight($dir) $n
3202 set dir $treeparent($dir)
3206 proc treeopendir {w dir} {
3207 global treediropen treeheight treeparent treecontents treeindex
3209 set ix $treeindex($dir)
3210 $w conf -state normal
3211 $w image configure a:$ix -image tri-dn
3212 $w mark set e:$ix s:$ix
3213 $w mark gravity e:$ix right
3214 set lev 0
3215 set str "\n"
3216 set n [llength $treecontents($dir)]
3217 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3218 incr lev
3219 append str "\t"
3220 incr treeheight($x) $n
3222 foreach e $treecontents($dir) {
3223 set de $dir$e
3224 if {[string index $e end] eq "/"} {
3225 set iy $treeindex($de)
3226 $w mark set d:$iy e:$ix
3227 $w mark gravity d:$iy left
3228 $w insert e:$ix $str
3229 set treediropen($de) 0
3230 $w image create e:$ix -align center -image tri-rt -padx 1 \
3231 -name a:$iy
3232 $w insert e:$ix $e [highlight_tag $de]
3233 $w mark set s:$iy e:$ix
3234 $w mark gravity s:$iy left
3235 set treeheight($de) 1
3236 } else {
3237 $w insert e:$ix $str
3238 $w insert e:$ix $e [highlight_tag $de]
3241 $w mark gravity e:$ix right
3242 $w conf -state disabled
3243 set treediropen($dir) 1
3244 set top [lindex [split [$w index @0,0] .] 0]
3245 set ht [$w cget -height]
3246 set l [lindex [split [$w index s:$ix] .] 0]
3247 if {$l < $top} {
3248 $w yview $l.0
3249 } elseif {$l + $n + 1 > $top + $ht} {
3250 set top [expr {$l + $n + 2 - $ht}]
3251 if {$l < $top} {
3252 set top $l
3254 $w yview $top.0
3258 proc treeclick {w x y} {
3259 global treediropen cmitmode ctext cflist cflist_top
3261 if {$cmitmode ne "tree"} return
3262 if {![info exists cflist_top]} return
3263 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3264 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3265 $cflist tag add highlight $l.0 "$l.0 lineend"
3266 set cflist_top $l
3267 if {$l == 1} {
3268 $ctext yview 1.0
3269 return
3271 set e [linetoelt $l]
3272 if {[string index $e end] ne "/"} {
3273 showfile $e
3274 } elseif {$treediropen($e)} {
3275 treeclosedir $w $e
3276 } else {
3277 treeopendir $w $e
3281 proc setfilelist {id} {
3282 global treefilelist cflist jump_to_here
3284 treeview $cflist $treefilelist($id) 0
3285 if {$jump_to_here ne {}} {
3286 set f [lindex $jump_to_here 0]
3287 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3288 showfile $f
3293 image create bitmap tri-rt -background black -foreground blue -data {
3294 #define tri-rt_width 13
3295 #define tri-rt_height 13
3296 static unsigned char tri-rt_bits[] = {
3297 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3298 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3299 0x00, 0x00};
3300 } -maskdata {
3301 #define tri-rt-mask_width 13
3302 #define tri-rt-mask_height 13
3303 static unsigned char tri-rt-mask_bits[] = {
3304 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3305 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3306 0x08, 0x00};
3308 image create bitmap tri-dn -background black -foreground blue -data {
3309 #define tri-dn_width 13
3310 #define tri-dn_height 13
3311 static unsigned char tri-dn_bits[] = {
3312 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3313 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3314 0x00, 0x00};
3315 } -maskdata {
3316 #define tri-dn-mask_width 13
3317 #define tri-dn-mask_height 13
3318 static unsigned char tri-dn-mask_bits[] = {
3319 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3320 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3321 0x00, 0x00};
3324 image create bitmap reficon-T -background black -foreground yellow -data {
3325 #define tagicon_width 13
3326 #define tagicon_height 9
3327 static unsigned char tagicon_bits[] = {
3328 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3329 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3330 } -maskdata {
3331 #define tagicon-mask_width 13
3332 #define tagicon-mask_height 9
3333 static unsigned char tagicon-mask_bits[] = {
3334 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3335 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3337 set rectdata {
3338 #define headicon_width 13
3339 #define headicon_height 9
3340 static unsigned char headicon_bits[] = {
3341 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3342 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3344 set rectmask {
3345 #define headicon-mask_width 13
3346 #define headicon-mask_height 9
3347 static unsigned char headicon-mask_bits[] = {
3348 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3349 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3351 image create bitmap reficon-H -background black -foreground green \
3352 -data $rectdata -maskdata $rectmask
3353 image create bitmap reficon-o -background black -foreground "#ddddff" \
3354 -data $rectdata -maskdata $rectmask
3356 proc init_flist {first} {
3357 global cflist cflist_top difffilestart
3359 $cflist conf -state normal
3360 $cflist delete 0.0 end
3361 if {$first ne {}} {
3362 $cflist insert end $first
3363 set cflist_top 1
3364 $cflist tag add highlight 1.0 "1.0 lineend"
3365 } else {
3366 catch {unset cflist_top}
3368 $cflist conf -state disabled
3369 set difffilestart {}
3372 proc highlight_tag {f} {
3373 global highlight_paths
3375 foreach p $highlight_paths {
3376 if {[string match $p $f]} {
3377 return "bold"
3380 return {}
3383 proc highlight_filelist {} {
3384 global cmitmode cflist
3386 $cflist conf -state normal
3387 if {$cmitmode ne "tree"} {
3388 set end [lindex [split [$cflist index end] .] 0]
3389 for {set l 2} {$l < $end} {incr l} {
3390 set line [$cflist get $l.0 "$l.0 lineend"]
3391 if {[highlight_tag $line] ne {}} {
3392 $cflist tag add bold $l.0 "$l.0 lineend"
3395 } else {
3396 highlight_tree 2 {}
3398 $cflist conf -state disabled
3401 proc unhighlight_filelist {} {
3402 global cflist
3404 $cflist conf -state normal
3405 $cflist tag remove bold 1.0 end
3406 $cflist conf -state disabled
3409 proc add_flist {fl} {
3410 global cflist
3412 $cflist conf -state normal
3413 foreach f $fl {
3414 $cflist insert end "\n"
3415 $cflist insert end $f [highlight_tag $f]
3417 $cflist conf -state disabled
3420 proc sel_flist {w x y} {
3421 global ctext difffilestart cflist cflist_top cmitmode
3423 if {$cmitmode eq "tree"} return
3424 if {![info exists cflist_top]} return
3425 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3426 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3427 $cflist tag add highlight $l.0 "$l.0 lineend"
3428 set cflist_top $l
3429 if {$l == 1} {
3430 $ctext yview 1.0
3431 } else {
3432 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3434 suppress_highlighting_file_for_current_scrollpos
3437 proc pop_flist_menu {w X Y x y} {
3438 global ctext cflist cmitmode flist_menu flist_menu_file
3439 global treediffs diffids
3441 stopfinding
3442 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3443 if {$l <= 1} return
3444 if {$cmitmode eq "tree"} {
3445 set e [linetoelt $l]
3446 if {[string index $e end] eq "/"} return
3447 } else {
3448 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3450 set flist_menu_file $e
3451 set xdiffstate "normal"
3452 if {$cmitmode eq "tree"} {
3453 set xdiffstate "disabled"
3455 # Disable "External diff" item in tree mode
3456 $flist_menu entryconf 2 -state $xdiffstate
3457 tk_popup $flist_menu $X $Y
3460 proc find_ctext_fileinfo {line} {
3461 global ctext_file_names ctext_file_lines
3463 set ok [bsearch $ctext_file_lines $line]
3464 set tline [lindex $ctext_file_lines $ok]
3466 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3467 return {}
3468 } else {
3469 return [list [lindex $ctext_file_names $ok] $tline]
3473 proc pop_diff_menu {w X Y x y} {
3474 global ctext diff_menu flist_menu_file
3475 global diff_menu_txtpos diff_menu_line
3476 global diff_menu_filebase
3478 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3479 set diff_menu_line [lindex $diff_menu_txtpos 0]
3480 # don't pop up the menu on hunk-separator or file-separator lines
3481 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3482 return
3484 stopfinding
3485 set f [find_ctext_fileinfo $diff_menu_line]
3486 if {$f eq {}} return
3487 set flist_menu_file [lindex $f 0]
3488 set diff_menu_filebase [lindex $f 1]
3489 tk_popup $diff_menu $X $Y
3492 proc flist_hl {only} {
3493 global flist_menu_file findstring gdttype
3495 set x [shellquote $flist_menu_file]
3496 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3497 set findstring $x
3498 } else {
3499 append findstring " " $x
3501 set gdttype [mc "touching paths:"]
3504 proc gitknewtmpdir {} {
3505 global diffnum gitktmpdir gitdir env
3507 if {![info exists gitktmpdir]} {
3508 if {[info exists env(GITK_TMPDIR)]} {
3509 set tmpdir $env(GITK_TMPDIR)
3510 } elseif {[info exists env(TMPDIR)]} {
3511 set tmpdir $env(TMPDIR)
3512 } else {
3513 set tmpdir $gitdir
3515 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3516 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3517 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3519 if {[catch {file mkdir $gitktmpdir} err]} {
3520 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3521 unset gitktmpdir
3522 return {}
3524 set diffnum 0
3526 incr diffnum
3527 set diffdir [file join $gitktmpdir $diffnum]
3528 if {[catch {file mkdir $diffdir} err]} {
3529 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3530 return {}
3532 return $diffdir
3535 proc save_file_from_commit {filename output what} {
3536 global nullfile
3538 if {[catch {exec git show $filename -- > $output} err]} {
3539 if {[string match "fatal: bad revision *" $err]} {
3540 return $nullfile
3542 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3543 return {}
3545 return $output
3548 proc external_diff_get_one_file {diffid filename diffdir} {
3549 global nullid nullid2 nullfile
3550 global worktree
3552 if {$diffid == $nullid} {
3553 set difffile [file join $worktree $filename]
3554 if {[file exists $difffile]} {
3555 return $difffile
3557 return $nullfile
3559 if {$diffid == $nullid2} {
3560 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3561 return [save_file_from_commit :$filename $difffile index]
3563 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3564 return [save_file_from_commit $diffid:$filename $difffile \
3565 "revision $diffid"]
3568 proc external_diff {} {
3569 global nullid nullid2
3570 global flist_menu_file
3571 global diffids
3572 global extdifftool
3574 if {[llength $diffids] == 1} {
3575 # no reference commit given
3576 set diffidto [lindex $diffids 0]
3577 if {$diffidto eq $nullid} {
3578 # diffing working copy with index
3579 set diffidfrom $nullid2
3580 } elseif {$diffidto eq $nullid2} {
3581 # diffing index with HEAD
3582 set diffidfrom "HEAD"
3583 } else {
3584 # use first parent commit
3585 global parentlist selectedline
3586 set diffidfrom [lindex $parentlist $selectedline 0]
3588 } else {
3589 set diffidfrom [lindex $diffids 0]
3590 set diffidto [lindex $diffids 1]
3593 # make sure that several diffs wont collide
3594 set diffdir [gitknewtmpdir]
3595 if {$diffdir eq {}} return
3597 # gather files to diff
3598 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3599 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3601 if {$difffromfile ne {} && $difftofile ne {}} {
3602 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3603 if {[catch {set fl [open |$cmd r]} err]} {
3604 file delete -force $diffdir
3605 error_popup "$extdifftool: [mc "command failed:"] $err"
3606 } else {
3607 fconfigure $fl -blocking 0
3608 filerun $fl [list delete_at_eof $fl $diffdir]
3613 proc find_hunk_blamespec {base line} {
3614 global ctext
3616 # Find and parse the hunk header
3617 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3618 if {$s_lix eq {}} return
3620 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3621 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3622 s_line old_specs osz osz1 new_line nsz]} {
3623 return
3626 # base lines for the parents
3627 set base_lines [list $new_line]
3628 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3629 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3630 old_spec old_line osz]} {
3631 return
3633 lappend base_lines $old_line
3636 # Now scan the lines to determine offset within the hunk
3637 set max_parent [expr {[llength $base_lines]-2}]
3638 set dline 0
3639 set s_lno [lindex [split $s_lix "."] 0]
3641 # Determine if the line is removed
3642 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3643 if {[string match {[-+ ]*} $chunk]} {
3644 set removed_idx [string first "-" $chunk]
3645 # Choose a parent index
3646 if {$removed_idx >= 0} {
3647 set parent $removed_idx
3648 } else {
3649 set unchanged_idx [string first " " $chunk]
3650 if {$unchanged_idx >= 0} {
3651 set parent $unchanged_idx
3652 } else {
3653 # blame the current commit
3654 set parent -1
3657 # then count other lines that belong to it
3658 for {set i $line} {[incr i -1] > $s_lno} {} {
3659 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3660 # Determine if the line is removed
3661 set removed_idx [string first "-" $chunk]
3662 if {$parent >= 0} {
3663 set code [string index $chunk $parent]
3664 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3665 incr dline
3667 } else {
3668 if {$removed_idx < 0} {
3669 incr dline
3673 incr parent
3674 } else {
3675 set parent 0
3678 incr dline [lindex $base_lines $parent]
3679 return [list $parent $dline]
3682 proc external_blame_diff {} {
3683 global currentid cmitmode
3684 global diff_menu_txtpos diff_menu_line
3685 global diff_menu_filebase flist_menu_file
3687 if {$cmitmode eq "tree"} {
3688 set parent_idx 0
3689 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3690 } else {
3691 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3692 if {$hinfo ne {}} {
3693 set parent_idx [lindex $hinfo 0]
3694 set line [lindex $hinfo 1]
3695 } else {
3696 set parent_idx 0
3697 set line 0
3701 external_blame $parent_idx $line
3704 # Find the SHA1 ID of the blob for file $fname in the index
3705 # at stage 0 or 2
3706 proc index_sha1 {fname} {
3707 set f [open [list | git ls-files -s $fname] r]
3708 while {[gets $f line] >= 0} {
3709 set info [lindex [split $line "\t"] 0]
3710 set stage [lindex $info 2]
3711 if {$stage eq "0" || $stage eq "2"} {
3712 close $f
3713 return [lindex $info 1]
3716 close $f
3717 return {}
3720 # Turn an absolute path into one relative to the current directory
3721 proc make_relative {f} {
3722 if {[file pathtype $f] eq "relative"} {
3723 return $f
3725 set elts [file split $f]
3726 set here [file split [pwd]]
3727 set ei 0
3728 set hi 0
3729 set res {}
3730 foreach d $here {
3731 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3732 lappend res ".."
3733 } else {
3734 incr ei
3736 incr hi
3738 set elts [concat $res [lrange $elts $ei end]]
3739 return [eval file join $elts]
3742 proc external_blame {parent_idx {line {}}} {
3743 global flist_menu_file cdup
3744 global nullid nullid2
3745 global parentlist selectedline currentid
3747 if {$parent_idx > 0} {
3748 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3749 } else {
3750 set base_commit $currentid
3753 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3754 error_popup [mc "No such commit"]
3755 return
3758 set cmdline [list git gui blame]
3759 if {$line ne {} && $line > 1} {
3760 lappend cmdline "--line=$line"
3762 set f [file join $cdup $flist_menu_file]
3763 # Unfortunately it seems git gui blame doesn't like
3764 # being given an absolute path...
3765 set f [make_relative $f]
3766 lappend cmdline $base_commit $f
3767 if {[catch {eval exec $cmdline &} err]} {
3768 error_popup "[mc "git gui blame: command failed:"] $err"
3772 proc show_line_source {} {
3773 global cmitmode currentid parents curview blamestuff blameinst
3774 global diff_menu_line diff_menu_filebase flist_menu_file
3775 global nullid nullid2 gitdir cdup
3777 set from_index {}
3778 if {$cmitmode eq "tree"} {
3779 set id $currentid
3780 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3781 } else {
3782 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3783 if {$h eq {}} return
3784 set pi [lindex $h 0]
3785 if {$pi == 0} {
3786 mark_ctext_line $diff_menu_line
3787 return
3789 incr pi -1
3790 if {$currentid eq $nullid} {
3791 if {$pi > 0} {
3792 # must be a merge in progress...
3793 if {[catch {
3794 # get the last line from .git/MERGE_HEAD
3795 set f [open [file join $gitdir MERGE_HEAD] r]
3796 set id [lindex [split [read $f] "\n"] end-1]
3797 close $f
3798 } err]} {
3799 error_popup [mc "Couldn't read merge head: %s" $err]
3800 return
3802 } elseif {$parents($curview,$currentid) eq $nullid2} {
3803 # need to do the blame from the index
3804 if {[catch {
3805 set from_index [index_sha1 $flist_menu_file]
3806 } err]} {
3807 error_popup [mc "Error reading index: %s" $err]
3808 return
3810 } else {
3811 set id $parents($curview,$currentid)
3813 } else {
3814 set id [lindex $parents($curview,$currentid) $pi]
3816 set line [lindex $h 1]
3818 set blameargs {}
3819 if {$from_index ne {}} {
3820 lappend blameargs | git cat-file blob $from_index
3822 lappend blameargs | git blame -p -L$line,+1
3823 if {$from_index ne {}} {
3824 lappend blameargs --contents -
3825 } else {
3826 lappend blameargs $id
3828 lappend blameargs -- [file join $cdup $flist_menu_file]
3829 if {[catch {
3830 set f [open $blameargs r]
3831 } err]} {
3832 error_popup [mc "Couldn't start git blame: %s" $err]
3833 return
3835 nowbusy blaming [mc "Searching"]
3836 fconfigure $f -blocking 0
3837 set i [reg_instance $f]
3838 set blamestuff($i) {}
3839 set blameinst $i
3840 filerun $f [list read_line_source $f $i]
3843 proc stopblaming {} {
3844 global blameinst
3846 if {[info exists blameinst]} {
3847 stop_instance $blameinst
3848 unset blameinst
3849 notbusy blaming
3853 proc read_line_source {fd inst} {
3854 global blamestuff curview commfd blameinst nullid nullid2
3856 while {[gets $fd line] >= 0} {
3857 lappend blamestuff($inst) $line
3859 if {![eof $fd]} {
3860 return 1
3862 unset commfd($inst)
3863 unset blameinst
3864 notbusy blaming
3865 fconfigure $fd -blocking 1
3866 if {[catch {close $fd} err]} {
3867 error_popup [mc "Error running git blame: %s" $err]
3868 return 0
3871 set fname {}
3872 set line [split [lindex $blamestuff($inst) 0] " "]
3873 set id [lindex $line 0]
3874 set lnum [lindex $line 1]
3875 if {[string length $id] == 40 && [string is xdigit $id] &&
3876 [string is digit -strict $lnum]} {
3877 # look for "filename" line
3878 foreach l $blamestuff($inst) {
3879 if {[string match "filename *" $l]} {
3880 set fname [string range $l 9 end]
3881 break
3885 if {$fname ne {}} {
3886 # all looks good, select it
3887 if {$id eq $nullid} {
3888 # blame uses all-zeroes to mean not committed,
3889 # which would mean a change in the index
3890 set id $nullid2
3892 if {[commitinview $id $curview]} {
3893 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3894 } else {
3895 error_popup [mc "That line comes from commit %s, \
3896 which is not in this view" [shortids $id]]
3898 } else {
3899 puts "oops couldn't parse git blame output"
3901 return 0
3904 # delete $dir when we see eof on $f (presumably because the child has exited)
3905 proc delete_at_eof {f dir} {
3906 while {[gets $f line] >= 0} {}
3907 if {[eof $f]} {
3908 if {[catch {close $f} err]} {
3909 error_popup "[mc "External diff viewer failed:"] $err"
3911 file delete -force $dir
3912 return 0
3914 return 1
3917 # Functions for adding and removing shell-type quoting
3919 proc shellquote {str} {
3920 if {![string match "*\['\"\\ \t]*" $str]} {
3921 return $str
3923 if {![string match "*\['\"\\]*" $str]} {
3924 return "\"$str\""
3926 if {![string match "*'*" $str]} {
3927 return "'$str'"
3929 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3932 proc shellarglist {l} {
3933 set str {}
3934 foreach a $l {
3935 if {$str ne {}} {
3936 append str " "
3938 append str [shellquote $a]
3940 return $str
3943 proc shelldequote {str} {
3944 set ret {}
3945 set used -1
3946 while {1} {
3947 incr used
3948 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3949 append ret [string range $str $used end]
3950 set used [string length $str]
3951 break
3953 set first [lindex $first 0]
3954 set ch [string index $str $first]
3955 if {$first > $used} {
3956 append ret [string range $str $used [expr {$first - 1}]]
3957 set used $first
3959 if {$ch eq " " || $ch eq "\t"} break
3960 incr used
3961 if {$ch eq "'"} {
3962 set first [string first "'" $str $used]
3963 if {$first < 0} {
3964 error "unmatched single-quote"
3966 append ret [string range $str $used [expr {$first - 1}]]
3967 set used $first
3968 continue
3970 if {$ch eq "\\"} {
3971 if {$used >= [string length $str]} {
3972 error "trailing backslash"
3974 append ret [string index $str $used]
3975 continue
3977 # here ch == "\""
3978 while {1} {
3979 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3980 error "unmatched double-quote"
3982 set first [lindex $first 0]
3983 set ch [string index $str $first]
3984 if {$first > $used} {
3985 append ret [string range $str $used [expr {$first - 1}]]
3986 set used $first
3988 if {$ch eq "\""} break
3989 incr used
3990 append ret [string index $str $used]
3991 incr used
3994 return [list $used $ret]
3997 proc shellsplit {str} {
3998 set l {}
3999 while {1} {
4000 set str [string trimleft $str]
4001 if {$str eq {}} break
4002 set dq [shelldequote $str]
4003 set n [lindex $dq 0]
4004 set word [lindex $dq 1]
4005 set str [string range $str $n end]
4006 lappend l $word
4008 return $l
4011 # Code to implement multiple views
4013 proc newview {ishighlight} {
4014 global nextviewnum newviewname newishighlight
4015 global revtreeargs viewargscmd newviewopts curview
4017 set newishighlight $ishighlight
4018 set top .gitkview
4019 if {[winfo exists $top]} {
4020 raise $top
4021 return
4023 decode_view_opts $nextviewnum $revtreeargs
4024 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4025 set newviewopts($nextviewnum,perm) 0
4026 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4027 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4030 set known_view_options {
4031 {perm b . {} {mc "Remember this view"}}
4032 {reflabel l + {} {mc "References (space separated list):"}}
4033 {refs t15 .. {} {mc "Branches & tags:"}}
4034 {allrefs b *. "--all" {mc "All refs"}}
4035 {branches b . "--branches" {mc "All (local) branches"}}
4036 {tags b . "--tags" {mc "All tags"}}
4037 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4038 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4039 {author t15 .. "--author=*" {mc "Author:"}}
4040 {committer t15 . "--committer=*" {mc "Committer:"}}
4041 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4042 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4043 {changes_l l + {} {mc "Changes to Files:"}}
4044 {pickaxe_s r0 . {} {mc "Fixed String"}}
4045 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4046 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4047 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4048 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4049 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4050 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4051 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4052 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4053 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4054 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4055 {lright b . "--left-right" {mc "Mark branch sides"}}
4056 {first b . "--first-parent" {mc "Limit to first parent"}}
4057 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4058 {args t50 *. {} {mc "Additional arguments to git log:"}}
4059 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4060 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4063 # Convert $newviewopts($n, ...) into args for git log.
4064 proc encode_view_opts {n} {
4065 global known_view_options newviewopts
4067 set rargs [list]
4068 foreach opt $known_view_options {
4069 set patterns [lindex $opt 3]
4070 if {$patterns eq {}} continue
4071 set pattern [lindex $patterns 0]
4073 if {[lindex $opt 1] eq "b"} {
4074 set val $newviewopts($n,[lindex $opt 0])
4075 if {$val} {
4076 lappend rargs $pattern
4078 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4079 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4080 set val $newviewopts($n,$button_id)
4081 if {$val eq $value} {
4082 lappend rargs $pattern
4084 } else {
4085 set val $newviewopts($n,[lindex $opt 0])
4086 set val [string trim $val]
4087 if {$val ne {}} {
4088 set pfix [string range $pattern 0 end-1]
4089 lappend rargs $pfix$val
4093 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4094 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4097 # Fill $newviewopts($n, ...) based on args for git log.
4098 proc decode_view_opts {n view_args} {
4099 global known_view_options newviewopts
4101 foreach opt $known_view_options {
4102 set id [lindex $opt 0]
4103 if {[lindex $opt 1] eq "b"} {
4104 # Checkboxes
4105 set val 0
4106 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4107 # Radiobuttons
4108 regexp {^(.*_)} $id uselessvar id
4109 set val 0
4110 } else {
4111 # Text fields
4112 set val {}
4114 set newviewopts($n,$id) $val
4116 set oargs [list]
4117 set refargs [list]
4118 foreach arg $view_args {
4119 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4120 && ![info exists found(limit)]} {
4121 set newviewopts($n,limit) $cnt
4122 set found(limit) 1
4123 continue
4125 catch { unset val }
4126 foreach opt $known_view_options {
4127 set id [lindex $opt 0]
4128 if {[info exists found($id)]} continue
4129 foreach pattern [lindex $opt 3] {
4130 if {![string match $pattern $arg]} continue
4131 if {[lindex $opt 1] eq "b"} {
4132 # Check buttons
4133 set val 1
4134 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4135 # Radio buttons
4136 regexp {^(.*_)} $id uselessvar id
4137 set val $num
4138 } else {
4139 # Text input fields
4140 set size [string length $pattern]
4141 set val [string range $arg [expr {$size-1}] end]
4143 set newviewopts($n,$id) $val
4144 set found($id) 1
4145 break
4147 if {[info exists val]} break
4149 if {[info exists val]} continue
4150 if {[regexp {^-} $arg]} {
4151 lappend oargs $arg
4152 } else {
4153 lappend refargs $arg
4156 set newviewopts($n,refs) [shellarglist $refargs]
4157 set newviewopts($n,args) [shellarglist $oargs]
4160 proc edit_or_newview {} {
4161 global curview
4163 if {$curview > 0} {
4164 editview
4165 } else {
4166 newview 0
4170 proc editview {} {
4171 global curview
4172 global viewname viewperm newviewname newviewopts
4173 global viewargs viewargscmd
4175 set top .gitkvedit-$curview
4176 if {[winfo exists $top]} {
4177 raise $top
4178 return
4180 decode_view_opts $curview $viewargs($curview)
4181 set newviewname($curview) $viewname($curview)
4182 set newviewopts($curview,perm) $viewperm($curview)
4183 set newviewopts($curview,cmd) $viewargscmd($curview)
4184 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4187 proc vieweditor {top n title} {
4188 global newviewname newviewopts viewfiles bgcolor
4189 global known_view_options NS
4191 ttk_toplevel $top
4192 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4193 make_transient $top .
4195 # View name
4196 ${NS}::frame $top.nfr
4197 ${NS}::label $top.nl -text [mc "View Name"]
4198 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4199 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4200 pack $top.nl -in $top.nfr -side left -padx {0 5}
4201 pack $top.name -in $top.nfr -side left -padx {0 25}
4203 # View options
4204 set cframe $top.nfr
4205 set cexpand 0
4206 set cnt 0
4207 foreach opt $known_view_options {
4208 set id [lindex $opt 0]
4209 set type [lindex $opt 1]
4210 set flags [lindex $opt 2]
4211 set title [eval [lindex $opt 4]]
4212 set lxpad 0
4214 if {$flags eq "+" || $flags eq "*"} {
4215 set cframe $top.fr$cnt
4216 incr cnt
4217 ${NS}::frame $cframe
4218 pack $cframe -in $top -fill x -pady 3 -padx 3
4219 set cexpand [expr {$flags eq "*"}]
4220 } elseif {$flags eq ".." || $flags eq "*."} {
4221 set cframe $top.fr$cnt
4222 incr cnt
4223 ${NS}::frame $cframe
4224 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4225 set cexpand [expr {$flags eq "*."}]
4226 } else {
4227 set lxpad 5
4230 if {$type eq "l"} {
4231 ${NS}::label $cframe.l_$id -text $title
4232 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4233 } elseif {$type eq "b"} {
4234 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4235 pack $cframe.c_$id -in $cframe -side left \
4236 -padx [list $lxpad 0] -expand $cexpand -anchor w
4237 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4238 regexp {^(.*_)} $id uselessvar button_id
4239 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4240 pack $cframe.c_$id -in $cframe -side left \
4241 -padx [list $lxpad 0] -expand $cexpand -anchor w
4242 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4243 ${NS}::label $cframe.l_$id -text $title
4244 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4245 -textvariable newviewopts($n,$id)
4246 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4247 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4248 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4249 ${NS}::label $cframe.l_$id -text $title
4250 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4251 -textvariable newviewopts($n,$id)
4252 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4253 pack $cframe.e_$id -in $cframe -side top -fill x
4254 } elseif {$type eq "path"} {
4255 ${NS}::label $top.l -text $title
4256 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4257 text $top.t -width 40 -height 5 -background $bgcolor
4258 if {[info exists viewfiles($n)]} {
4259 foreach f $viewfiles($n) {
4260 $top.t insert end $f
4261 $top.t insert end "\n"
4263 $top.t delete {end - 1c} end
4264 $top.t mark set insert 0.0
4266 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4270 ${NS}::frame $top.buts
4271 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4272 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4273 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4274 bind $top <Control-Return> [list newviewok $top $n]
4275 bind $top <F5> [list newviewok $top $n 1]
4276 bind $top <Escape> [list destroy $top]
4277 grid $top.buts.ok $top.buts.apply $top.buts.can
4278 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4279 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4280 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4281 pack $top.buts -in $top -side top -fill x
4282 focus $top.t
4285 proc doviewmenu {m first cmd op argv} {
4286 set nmenu [$m index end]
4287 for {set i $first} {$i <= $nmenu} {incr i} {
4288 if {[$m entrycget $i -command] eq $cmd} {
4289 eval $m $op $i $argv
4290 break
4295 proc allviewmenus {n op args} {
4296 # global viewhlmenu
4298 doviewmenu .bar.view 5 [list showview $n] $op $args
4299 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4302 proc newviewok {top n {apply 0}} {
4303 global nextviewnum newviewperm newviewname newishighlight
4304 global viewname viewfiles viewperm viewchanged selectedview curview
4305 global viewargs viewargscmd newviewopts viewhlmenu
4307 if {[catch {
4308 set newargs [encode_view_opts $n]
4309 } err]} {
4310 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4311 return
4313 set files {}
4314 foreach f [split [$top.t get 0.0 end] "\n"] {
4315 set ft [string trim $f]
4316 if {$ft ne {}} {
4317 lappend files $ft
4320 if {![info exists viewfiles($n)]} {
4321 # creating a new view
4322 incr nextviewnum
4323 set viewname($n) $newviewname($n)
4324 set viewperm($n) $newviewopts($n,perm)
4325 set viewchanged($n) 1
4326 set viewfiles($n) $files
4327 set viewargs($n) $newargs
4328 set viewargscmd($n) $newviewopts($n,cmd)
4329 addviewmenu $n
4330 if {!$newishighlight} {
4331 run showview $n
4332 } else {
4333 run addvhighlight $n
4335 } else {
4336 # editing an existing view
4337 set viewperm($n) $newviewopts($n,perm)
4338 set viewchanged($n) 1
4339 if {$newviewname($n) ne $viewname($n)} {
4340 set viewname($n) $newviewname($n)
4341 doviewmenu .bar.view 5 [list showview $n] \
4342 entryconf [list -label $viewname($n)]
4343 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4344 # entryconf [list -label $viewname($n) -value $viewname($n)]
4346 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4347 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4348 set viewfiles($n) $files
4349 set viewargs($n) $newargs
4350 set viewargscmd($n) $newviewopts($n,cmd)
4351 if {$curview == $n} {
4352 run reloadcommits
4356 if {$apply} return
4357 catch {destroy $top}
4360 proc delview {} {
4361 global curview viewperm hlview selectedhlview viewchanged
4363 if {$curview == 0} return
4364 if {[info exists hlview] && $hlview == $curview} {
4365 set selectedhlview [mc "None"]
4366 unset hlview
4368 allviewmenus $curview delete
4369 set viewperm($curview) 0
4370 set viewchanged($curview) 1
4371 showview 0
4374 proc addviewmenu {n} {
4375 global viewname viewhlmenu
4377 .bar.view add radiobutton -label $viewname($n) \
4378 -command [list showview $n] -variable selectedview -value $n
4379 #$viewhlmenu add radiobutton -label $viewname($n) \
4380 # -command [list addvhighlight $n] -variable selectedhlview
4383 proc showview {n} {
4384 global curview cached_commitrow ordertok
4385 global displayorder parentlist rowidlist rowisopt rowfinal
4386 global colormap rowtextx nextcolor canvxmax
4387 global numcommits viewcomplete
4388 global selectedline currentid canv canvy0
4389 global treediffs
4390 global pending_select mainheadid
4391 global commitidx
4392 global selectedview
4393 global hlview selectedhlview commitinterest
4395 if {$n == $curview} return
4396 set selid {}
4397 set ymax [lindex [$canv cget -scrollregion] 3]
4398 set span [$canv yview]
4399 set ytop [expr {[lindex $span 0] * $ymax}]
4400 set ybot [expr {[lindex $span 1] * $ymax}]
4401 set yscreen [expr {($ybot - $ytop) / 2}]
4402 if {$selectedline ne {}} {
4403 set selid $currentid
4404 set y [yc $selectedline]
4405 if {$ytop < $y && $y < $ybot} {
4406 set yscreen [expr {$y - $ytop}]
4408 } elseif {[info exists pending_select]} {
4409 set selid $pending_select
4410 unset pending_select
4412 unselectline
4413 normalline
4414 catch {unset treediffs}
4415 clear_display
4416 if {[info exists hlview] && $hlview == $n} {
4417 unset hlview
4418 set selectedhlview [mc "None"]
4420 catch {unset commitinterest}
4421 catch {unset cached_commitrow}
4422 catch {unset ordertok}
4424 set curview $n
4425 set selectedview $n
4426 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4427 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4429 run refill_reflist
4430 if {![info exists viewcomplete($n)]} {
4431 getcommits $selid
4432 return
4435 set displayorder {}
4436 set parentlist {}
4437 set rowidlist {}
4438 set rowisopt {}
4439 set rowfinal {}
4440 set numcommits $commitidx($n)
4442 catch {unset colormap}
4443 catch {unset rowtextx}
4444 set nextcolor 0
4445 set canvxmax [$canv cget -width]
4446 set curview $n
4447 set row 0
4448 setcanvscroll
4449 set yf 0
4450 set row {}
4451 if {$selid ne {} && [commitinview $selid $n]} {
4452 set row [rowofcommit $selid]
4453 # try to get the selected row in the same position on the screen
4454 set ymax [lindex [$canv cget -scrollregion] 3]
4455 set ytop [expr {[yc $row] - $yscreen}]
4456 if {$ytop < 0} {
4457 set ytop 0
4459 set yf [expr {$ytop * 1.0 / $ymax}]
4461 allcanvs yview moveto $yf
4462 drawvisible
4463 if {$row ne {}} {
4464 selectline $row 0
4465 } elseif {!$viewcomplete($n)} {
4466 reset_pending_select $selid
4467 } else {
4468 reset_pending_select {}
4470 if {[commitinview $pending_select $curview]} {
4471 selectline [rowofcommit $pending_select] 1
4472 } else {
4473 set row [first_real_row]
4474 if {$row < $numcommits} {
4475 selectline $row 0
4479 if {!$viewcomplete($n)} {
4480 if {$numcommits == 0} {
4481 show_status [mc "Reading commits..."]
4483 } elseif {$numcommits == 0} {
4484 show_status [mc "No commits selected"]
4488 # Stuff relating to the highlighting facility
4490 proc ishighlighted {id} {
4491 global vhighlights fhighlights nhighlights rhighlights
4493 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4494 return $nhighlights($id)
4496 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4497 return $vhighlights($id)
4499 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4500 return $fhighlights($id)
4502 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4503 return $rhighlights($id)
4505 return 0
4508 proc bolden {id font} {
4509 global canv linehtag currentid boldids need_redisplay markedid
4511 # need_redisplay = 1 means the display is stale and about to be redrawn
4512 if {$need_redisplay} return
4513 lappend boldids $id
4514 $canv itemconf $linehtag($id) -font $font
4515 if {[info exists currentid] && $id eq $currentid} {
4516 $canv delete secsel
4517 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4518 -outline {{}} -tags secsel \
4519 -fill [$canv cget -selectbackground]]
4520 $canv lower $t
4522 if {[info exists markedid] && $id eq $markedid} {
4523 make_idmark $id
4527 proc bolden_name {id font} {
4528 global canv2 linentag currentid boldnameids need_redisplay
4530 if {$need_redisplay} return
4531 lappend boldnameids $id
4532 $canv2 itemconf $linentag($id) -font $font
4533 if {[info exists currentid] && $id eq $currentid} {
4534 $canv2 delete secsel
4535 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4536 -outline {{}} -tags secsel \
4537 -fill [$canv2 cget -selectbackground]]
4538 $canv2 lower $t
4542 proc unbolden {} {
4543 global boldids
4545 set stillbold {}
4546 foreach id $boldids {
4547 if {![ishighlighted $id]} {
4548 bolden $id mainfont
4549 } else {
4550 lappend stillbold $id
4553 set boldids $stillbold
4556 proc addvhighlight {n} {
4557 global hlview viewcomplete curview vhl_done commitidx
4559 if {[info exists hlview]} {
4560 delvhighlight
4562 set hlview $n
4563 if {$n != $curview && ![info exists viewcomplete($n)]} {
4564 start_rev_list $n
4566 set vhl_done $commitidx($hlview)
4567 if {$vhl_done > 0} {
4568 drawvisible
4572 proc delvhighlight {} {
4573 global hlview vhighlights
4575 if {![info exists hlview]} return
4576 unset hlview
4577 catch {unset vhighlights}
4578 unbolden
4581 proc vhighlightmore {} {
4582 global hlview vhl_done commitidx vhighlights curview
4584 set max $commitidx($hlview)
4585 set vr [visiblerows]
4586 set r0 [lindex $vr 0]
4587 set r1 [lindex $vr 1]
4588 for {set i $vhl_done} {$i < $max} {incr i} {
4589 set id [commitonrow $i $hlview]
4590 if {[commitinview $id $curview]} {
4591 set row [rowofcommit $id]
4592 if {$r0 <= $row && $row <= $r1} {
4593 if {![highlighted $row]} {
4594 bolden $id mainfontbold
4596 set vhighlights($id) 1
4600 set vhl_done $max
4601 return 0
4604 proc askvhighlight {row id} {
4605 global hlview vhighlights iddrawn
4607 if {[commitinview $id $hlview]} {
4608 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4609 bolden $id mainfontbold
4611 set vhighlights($id) 1
4612 } else {
4613 set vhighlights($id) 0
4617 proc hfiles_change {} {
4618 global highlight_files filehighlight fhighlights fh_serial
4619 global highlight_paths
4621 if {[info exists filehighlight]} {
4622 # delete previous highlights
4623 catch {close $filehighlight}
4624 unset filehighlight
4625 catch {unset fhighlights}
4626 unbolden
4627 unhighlight_filelist
4629 set highlight_paths {}
4630 after cancel do_file_hl $fh_serial
4631 incr fh_serial
4632 if {$highlight_files ne {}} {
4633 after 300 do_file_hl $fh_serial
4637 proc gdttype_change {name ix op} {
4638 global gdttype highlight_files findstring findpattern
4640 stopfinding
4641 if {$findstring ne {}} {
4642 if {$gdttype eq [mc "containing:"]} {
4643 if {$highlight_files ne {}} {
4644 set highlight_files {}
4645 hfiles_change
4647 findcom_change
4648 } else {
4649 if {$findpattern ne {}} {
4650 set findpattern {}
4651 findcom_change
4653 set highlight_files $findstring
4654 hfiles_change
4656 drawvisible
4658 # enable/disable findtype/findloc menus too
4661 proc find_change {name ix op} {
4662 global gdttype findstring highlight_files
4664 stopfinding
4665 if {$gdttype eq [mc "containing:"]} {
4666 findcom_change
4667 } else {
4668 if {$highlight_files ne $findstring} {
4669 set highlight_files $findstring
4670 hfiles_change
4673 drawvisible
4676 proc findcom_change args {
4677 global nhighlights boldnameids
4678 global findpattern findtype findstring gdttype
4680 stopfinding
4681 # delete previous highlights, if any
4682 foreach id $boldnameids {
4683 bolden_name $id mainfont
4685 set boldnameids {}
4686 catch {unset nhighlights}
4687 unbolden
4688 unmarkmatches
4689 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4690 set findpattern {}
4691 } elseif {$findtype eq [mc "Regexp"]} {
4692 set findpattern $findstring
4693 } else {
4694 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4695 $findstring]
4696 set findpattern "*$e*"
4700 proc makepatterns {l} {
4701 set ret {}
4702 foreach e $l {
4703 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4704 if {[string index $ee end] eq "/"} {
4705 lappend ret "$ee*"
4706 } else {
4707 lappend ret $ee
4708 lappend ret "$ee/*"
4711 return $ret
4714 proc do_file_hl {serial} {
4715 global highlight_files filehighlight highlight_paths gdttype fhl_list
4716 global cdup findtype
4718 if {$gdttype eq [mc "touching paths:"]} {
4719 # If "exact" match then convert backslashes to forward slashes.
4720 # Most useful to support Windows-flavoured file paths.
4721 if {$findtype eq [mc "Exact"]} {
4722 set highlight_files [string map {"\\" "/"} $highlight_files]
4724 if {[catch {set paths [shellsplit $highlight_files]}]} return
4725 set highlight_paths [makepatterns $paths]
4726 highlight_filelist
4727 set relative_paths {}
4728 foreach path $paths {
4729 lappend relative_paths [file join $cdup $path]
4731 set gdtargs [concat -- $relative_paths]
4732 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4733 set gdtargs [list "-S$highlight_files"]
4734 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4735 set gdtargs [list "-G$highlight_files"]
4736 } else {
4737 # must be "containing:", i.e. we're searching commit info
4738 return
4740 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4741 set filehighlight [open $cmd r+]
4742 fconfigure $filehighlight -blocking 0
4743 filerun $filehighlight readfhighlight
4744 set fhl_list {}
4745 drawvisible
4746 flushhighlights
4749 proc flushhighlights {} {
4750 global filehighlight fhl_list
4752 if {[info exists filehighlight]} {
4753 lappend fhl_list {}
4754 puts $filehighlight ""
4755 flush $filehighlight
4759 proc askfilehighlight {row id} {
4760 global filehighlight fhighlights fhl_list
4762 lappend fhl_list $id
4763 set fhighlights($id) -1
4764 puts $filehighlight $id
4767 proc readfhighlight {} {
4768 global filehighlight fhighlights curview iddrawn
4769 global fhl_list find_dirn
4771 if {![info exists filehighlight]} {
4772 return 0
4774 set nr 0
4775 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4776 set line [string trim $line]
4777 set i [lsearch -exact $fhl_list $line]
4778 if {$i < 0} continue
4779 for {set j 0} {$j < $i} {incr j} {
4780 set id [lindex $fhl_list $j]
4781 set fhighlights($id) 0
4783 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4784 if {$line eq {}} continue
4785 if {![commitinview $line $curview]} continue
4786 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4787 bolden $line mainfontbold
4789 set fhighlights($line) 1
4791 if {[eof $filehighlight]} {
4792 # strange...
4793 puts "oops, git diff-tree died"
4794 catch {close $filehighlight}
4795 unset filehighlight
4796 return 0
4798 if {[info exists find_dirn]} {
4799 run findmore
4801 return 1
4804 proc doesmatch {f} {
4805 global findtype findpattern
4807 if {$findtype eq [mc "Regexp"]} {
4808 return [regexp $findpattern $f]
4809 } elseif {$findtype eq [mc "IgnCase"]} {
4810 return [string match -nocase $findpattern $f]
4811 } else {
4812 return [string match $findpattern $f]
4816 proc askfindhighlight {row id} {
4817 global nhighlights commitinfo iddrawn
4818 global findloc
4819 global markingmatches
4821 if {![info exists commitinfo($id)]} {
4822 getcommit $id
4824 set info $commitinfo($id)
4825 set isbold 0
4826 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4827 foreach f $info ty $fldtypes {
4828 if {$ty eq ""} continue
4829 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4830 [doesmatch $f]} {
4831 if {$ty eq [mc "Author"]} {
4832 set isbold 2
4833 break
4835 set isbold 1
4838 if {$isbold && [info exists iddrawn($id)]} {
4839 if {![ishighlighted $id]} {
4840 bolden $id mainfontbold
4841 if {$isbold > 1} {
4842 bolden_name $id mainfontbold
4845 if {$markingmatches} {
4846 markrowmatches $row $id
4849 set nhighlights($id) $isbold
4852 proc markrowmatches {row id} {
4853 global canv canv2 linehtag linentag commitinfo findloc
4855 set headline [lindex $commitinfo($id) 0]
4856 set author [lindex $commitinfo($id) 1]
4857 $canv delete match$row
4858 $canv2 delete match$row
4859 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4860 set m [findmatches $headline]
4861 if {$m ne {}} {
4862 markmatches $canv $row $headline $linehtag($id) $m \
4863 [$canv itemcget $linehtag($id) -font] $row
4866 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4867 set m [findmatches $author]
4868 if {$m ne {}} {
4869 markmatches $canv2 $row $author $linentag($id) $m \
4870 [$canv2 itemcget $linentag($id) -font] $row
4875 proc vrel_change {name ix op} {
4876 global highlight_related
4878 rhighlight_none
4879 if {$highlight_related ne [mc "None"]} {
4880 run drawvisible
4884 # prepare for testing whether commits are descendents or ancestors of a
4885 proc rhighlight_sel {a} {
4886 global descendent desc_todo ancestor anc_todo
4887 global highlight_related
4889 catch {unset descendent}
4890 set desc_todo [list $a]
4891 catch {unset ancestor}
4892 set anc_todo [list $a]
4893 if {$highlight_related ne [mc "None"]} {
4894 rhighlight_none
4895 run drawvisible
4899 proc rhighlight_none {} {
4900 global rhighlights
4902 catch {unset rhighlights}
4903 unbolden
4906 proc is_descendent {a} {
4907 global curview children descendent desc_todo
4909 set v $curview
4910 set la [rowofcommit $a]
4911 set todo $desc_todo
4912 set leftover {}
4913 set done 0
4914 for {set i 0} {$i < [llength $todo]} {incr i} {
4915 set do [lindex $todo $i]
4916 if {[rowofcommit $do] < $la} {
4917 lappend leftover $do
4918 continue
4920 foreach nk $children($v,$do) {
4921 if {![info exists descendent($nk)]} {
4922 set descendent($nk) 1
4923 lappend todo $nk
4924 if {$nk eq $a} {
4925 set done 1
4929 if {$done} {
4930 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4931 return
4934 set descendent($a) 0
4935 set desc_todo $leftover
4938 proc is_ancestor {a} {
4939 global curview parents ancestor anc_todo
4941 set v $curview
4942 set la [rowofcommit $a]
4943 set todo $anc_todo
4944 set leftover {}
4945 set done 0
4946 for {set i 0} {$i < [llength $todo]} {incr i} {
4947 set do [lindex $todo $i]
4948 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4949 lappend leftover $do
4950 continue
4952 foreach np $parents($v,$do) {
4953 if {![info exists ancestor($np)]} {
4954 set ancestor($np) 1
4955 lappend todo $np
4956 if {$np eq $a} {
4957 set done 1
4961 if {$done} {
4962 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4963 return
4966 set ancestor($a) 0
4967 set anc_todo $leftover
4970 proc askrelhighlight {row id} {
4971 global descendent highlight_related iddrawn rhighlights
4972 global selectedline ancestor
4974 if {$selectedline eq {}} return
4975 set isbold 0
4976 if {$highlight_related eq [mc "Descendant"] ||
4977 $highlight_related eq [mc "Not descendant"]} {
4978 if {![info exists descendent($id)]} {
4979 is_descendent $id
4981 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4982 set isbold 1
4984 } elseif {$highlight_related eq [mc "Ancestor"] ||
4985 $highlight_related eq [mc "Not ancestor"]} {
4986 if {![info exists ancestor($id)]} {
4987 is_ancestor $id
4989 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4990 set isbold 1
4993 if {[info exists iddrawn($id)]} {
4994 if {$isbold && ![ishighlighted $id]} {
4995 bolden $id mainfontbold
4998 set rhighlights($id) $isbold
5001 # Graph layout functions
5003 proc shortids {ids} {
5004 set res {}
5005 foreach id $ids {
5006 if {[llength $id] > 1} {
5007 lappend res [shortids $id]
5008 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5009 lappend res [string range $id 0 7]
5010 } else {
5011 lappend res $id
5014 return $res
5017 proc ntimes {n o} {
5018 set ret {}
5019 set o [list $o]
5020 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5021 if {($n & $mask) != 0} {
5022 set ret [concat $ret $o]
5024 set o [concat $o $o]
5026 return $ret
5029 proc ordertoken {id} {
5030 global ordertok curview varcid varcstart varctok curview parents children
5031 global nullid nullid2
5033 if {[info exists ordertok($id)]} {
5034 return $ordertok($id)
5036 set origid $id
5037 set todo {}
5038 while {1} {
5039 if {[info exists varcid($curview,$id)]} {
5040 set a $varcid($curview,$id)
5041 set p [lindex $varcstart($curview) $a]
5042 } else {
5043 set p [lindex $children($curview,$id) 0]
5045 if {[info exists ordertok($p)]} {
5046 set tok $ordertok($p)
5047 break
5049 set id [first_real_child $curview,$p]
5050 if {$id eq {}} {
5051 # it's a root
5052 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5053 break
5055 if {[llength $parents($curview,$id)] == 1} {
5056 lappend todo [list $p {}]
5057 } else {
5058 set j [lsearch -exact $parents($curview,$id) $p]
5059 if {$j < 0} {
5060 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5062 lappend todo [list $p [strrep $j]]
5065 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5066 set p [lindex $todo $i 0]
5067 append tok [lindex $todo $i 1]
5068 set ordertok($p) $tok
5070 set ordertok($origid) $tok
5071 return $tok
5074 # Work out where id should go in idlist so that order-token
5075 # values increase from left to right
5076 proc idcol {idlist id {i 0}} {
5077 set t [ordertoken $id]
5078 if {$i < 0} {
5079 set i 0
5081 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5082 if {$i > [llength $idlist]} {
5083 set i [llength $idlist]
5085 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5086 incr i
5087 } else {
5088 if {$t > [ordertoken [lindex $idlist $i]]} {
5089 while {[incr i] < [llength $idlist] &&
5090 $t >= [ordertoken [lindex $idlist $i]]} {}
5093 return $i
5096 proc initlayout {} {
5097 global rowidlist rowisopt rowfinal displayorder parentlist
5098 global numcommits canvxmax canv
5099 global nextcolor
5100 global colormap rowtextx
5102 set numcommits 0
5103 set displayorder {}
5104 set parentlist {}
5105 set nextcolor 0
5106 set rowidlist {}
5107 set rowisopt {}
5108 set rowfinal {}
5109 set canvxmax [$canv cget -width]
5110 catch {unset colormap}
5111 catch {unset rowtextx}
5112 setcanvscroll
5115 proc setcanvscroll {} {
5116 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5117 global lastscrollset lastscrollrows
5119 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5120 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5121 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5122 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5123 set lastscrollset [clock clicks -milliseconds]
5124 set lastscrollrows $numcommits
5127 proc visiblerows {} {
5128 global canv numcommits linespc
5130 set ymax [lindex [$canv cget -scrollregion] 3]
5131 if {$ymax eq {} || $ymax == 0} return
5132 set f [$canv yview]
5133 set y0 [expr {int([lindex $f 0] * $ymax)}]
5134 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5135 if {$r0 < 0} {
5136 set r0 0
5138 set y1 [expr {int([lindex $f 1] * $ymax)}]
5139 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5140 if {$r1 >= $numcommits} {
5141 set r1 [expr {$numcommits - 1}]
5143 return [list $r0 $r1]
5146 proc layoutmore {} {
5147 global commitidx viewcomplete curview
5148 global numcommits pending_select curview
5149 global lastscrollset lastscrollrows
5151 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5152 [clock clicks -milliseconds] - $lastscrollset > 500} {
5153 setcanvscroll
5155 if {[info exists pending_select] &&
5156 [commitinview $pending_select $curview]} {
5157 update
5158 selectline [rowofcommit $pending_select] 1
5160 drawvisible
5163 # With path limiting, we mightn't get the actual HEAD commit,
5164 # so ask git rev-list what is the first ancestor of HEAD that
5165 # touches a file in the path limit.
5166 proc get_viewmainhead {view} {
5167 global viewmainheadid vfilelimit viewinstances mainheadid
5169 catch {
5170 set rfd [open [concat | git rev-list -1 $mainheadid \
5171 -- $vfilelimit($view)] r]
5172 set j [reg_instance $rfd]
5173 lappend viewinstances($view) $j
5174 fconfigure $rfd -blocking 0
5175 filerun $rfd [list getviewhead $rfd $j $view]
5176 set viewmainheadid($curview) {}
5180 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5181 proc getviewhead {fd inst view} {
5182 global viewmainheadid commfd curview viewinstances showlocalchanges
5184 set id {}
5185 if {[gets $fd line] < 0} {
5186 if {![eof $fd]} {
5187 return 1
5189 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5190 set id $line
5192 set viewmainheadid($view) $id
5193 close $fd
5194 unset commfd($inst)
5195 set i [lsearch -exact $viewinstances($view) $inst]
5196 if {$i >= 0} {
5197 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5199 if {$showlocalchanges && $id ne {} && $view == $curview} {
5200 doshowlocalchanges
5202 return 0
5205 proc doshowlocalchanges {} {
5206 global curview viewmainheadid
5208 if {$viewmainheadid($curview) eq {}} return
5209 if {[commitinview $viewmainheadid($curview) $curview]} {
5210 dodiffindex
5211 } else {
5212 interestedin $viewmainheadid($curview) dodiffindex
5216 proc dohidelocalchanges {} {
5217 global nullid nullid2 lserial curview
5219 if {[commitinview $nullid $curview]} {
5220 removefakerow $nullid
5222 if {[commitinview $nullid2 $curview]} {
5223 removefakerow $nullid2
5225 incr lserial
5228 # spawn off a process to do git diff-index --cached HEAD
5229 proc dodiffindex {} {
5230 global lserial showlocalchanges vfilelimit curview
5231 global hasworktree git_version
5233 if {!$showlocalchanges || !$hasworktree} return
5234 incr lserial
5235 if {[package vcompare $git_version "1.7.2"] >= 0} {
5236 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5237 } else {
5238 set cmd "|git diff-index --cached HEAD"
5240 if {$vfilelimit($curview) ne {}} {
5241 set cmd [concat $cmd -- $vfilelimit($curview)]
5243 set fd [open $cmd r]
5244 fconfigure $fd -blocking 0
5245 set i [reg_instance $fd]
5246 filerun $fd [list readdiffindex $fd $lserial $i]
5249 proc readdiffindex {fd serial inst} {
5250 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5251 global vfilelimit
5253 set isdiff 1
5254 if {[gets $fd line] < 0} {
5255 if {![eof $fd]} {
5256 return 1
5258 set isdiff 0
5260 # we only need to see one line and we don't really care what it says...
5261 stop_instance $inst
5263 if {$serial != $lserial} {
5264 return 0
5267 # now see if there are any local changes not checked in to the index
5268 set cmd "|git diff-files"
5269 if {$vfilelimit($curview) ne {}} {
5270 set cmd [concat $cmd -- $vfilelimit($curview)]
5272 set fd [open $cmd r]
5273 fconfigure $fd -blocking 0
5274 set i [reg_instance $fd]
5275 filerun $fd [list readdifffiles $fd $serial $i]
5277 if {$isdiff && ![commitinview $nullid2 $curview]} {
5278 # add the line for the changes in the index to the graph
5279 set hl [mc "Local changes checked in to index but not committed"]
5280 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5281 set commitdata($nullid2) "\n $hl\n"
5282 if {[commitinview $nullid $curview]} {
5283 removefakerow $nullid
5285 insertfakerow $nullid2 $viewmainheadid($curview)
5286 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5287 if {[commitinview $nullid $curview]} {
5288 removefakerow $nullid
5290 removefakerow $nullid2
5292 return 0
5295 proc readdifffiles {fd serial inst} {
5296 global viewmainheadid nullid nullid2 curview
5297 global commitinfo commitdata lserial
5299 set isdiff 1
5300 if {[gets $fd line] < 0} {
5301 if {![eof $fd]} {
5302 return 1
5304 set isdiff 0
5306 # we only need to see one line and we don't really care what it says...
5307 stop_instance $inst
5309 if {$serial != $lserial} {
5310 return 0
5313 if {$isdiff && ![commitinview $nullid $curview]} {
5314 # add the line for the local diff to the graph
5315 set hl [mc "Local uncommitted changes, not checked in to index"]
5316 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5317 set commitdata($nullid) "\n $hl\n"
5318 if {[commitinview $nullid2 $curview]} {
5319 set p $nullid2
5320 } else {
5321 set p $viewmainheadid($curview)
5323 insertfakerow $nullid $p
5324 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5325 removefakerow $nullid
5327 return 0
5330 proc nextuse {id row} {
5331 global curview children
5333 if {[info exists children($curview,$id)]} {
5334 foreach kid $children($curview,$id) {
5335 if {![commitinview $kid $curview]} {
5336 return -1
5338 if {[rowofcommit $kid] > $row} {
5339 return [rowofcommit $kid]
5343 if {[commitinview $id $curview]} {
5344 return [rowofcommit $id]
5346 return -1
5349 proc prevuse {id row} {
5350 global curview children
5352 set ret -1
5353 if {[info exists children($curview,$id)]} {
5354 foreach kid $children($curview,$id) {
5355 if {![commitinview $kid $curview]} break
5356 if {[rowofcommit $kid] < $row} {
5357 set ret [rowofcommit $kid]
5361 return $ret
5364 proc make_idlist {row} {
5365 global displayorder parentlist uparrowlen downarrowlen mingaplen
5366 global commitidx curview children
5368 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5369 if {$r < 0} {
5370 set r 0
5372 set ra [expr {$row - $downarrowlen}]
5373 if {$ra < 0} {
5374 set ra 0
5376 set rb [expr {$row + $uparrowlen}]
5377 if {$rb > $commitidx($curview)} {
5378 set rb $commitidx($curview)
5380 make_disporder $r [expr {$rb + 1}]
5381 set ids {}
5382 for {} {$r < $ra} {incr r} {
5383 set nextid [lindex $displayorder [expr {$r + 1}]]
5384 foreach p [lindex $parentlist $r] {
5385 if {$p eq $nextid} continue
5386 set rn [nextuse $p $r]
5387 if {$rn >= $row &&
5388 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5389 lappend ids [list [ordertoken $p] $p]
5393 for {} {$r < $row} {incr r} {
5394 set nextid [lindex $displayorder [expr {$r + 1}]]
5395 foreach p [lindex $parentlist $r] {
5396 if {$p eq $nextid} continue
5397 set rn [nextuse $p $r]
5398 if {$rn < 0 || $rn >= $row} {
5399 lappend ids [list [ordertoken $p] $p]
5403 set id [lindex $displayorder $row]
5404 lappend ids [list [ordertoken $id] $id]
5405 while {$r < $rb} {
5406 foreach p [lindex $parentlist $r] {
5407 set firstkid [lindex $children($curview,$p) 0]
5408 if {[rowofcommit $firstkid] < $row} {
5409 lappend ids [list [ordertoken $p] $p]
5412 incr r
5413 set id [lindex $displayorder $r]
5414 if {$id ne {}} {
5415 set firstkid [lindex $children($curview,$id) 0]
5416 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5417 lappend ids [list [ordertoken $id] $id]
5421 set idlist {}
5422 foreach idx [lsort -unique $ids] {
5423 lappend idlist [lindex $idx 1]
5425 return $idlist
5428 proc rowsequal {a b} {
5429 while {[set i [lsearch -exact $a {}]] >= 0} {
5430 set a [lreplace $a $i $i]
5432 while {[set i [lsearch -exact $b {}]] >= 0} {
5433 set b [lreplace $b $i $i]
5435 return [expr {$a eq $b}]
5438 proc makeupline {id row rend col} {
5439 global rowidlist uparrowlen downarrowlen mingaplen
5441 for {set r $rend} {1} {set r $rstart} {
5442 set rstart [prevuse $id $r]
5443 if {$rstart < 0} return
5444 if {$rstart < $row} break
5446 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5447 set rstart [expr {$rend - $uparrowlen - 1}]
5449 for {set r $rstart} {[incr r] <= $row} {} {
5450 set idlist [lindex $rowidlist $r]
5451 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5452 set col [idcol $idlist $id $col]
5453 lset rowidlist $r [linsert $idlist $col $id]
5454 changedrow $r
5459 proc layoutrows {row endrow} {
5460 global rowidlist rowisopt rowfinal displayorder
5461 global uparrowlen downarrowlen maxwidth mingaplen
5462 global children parentlist
5463 global commitidx viewcomplete curview
5465 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5466 set idlist {}
5467 if {$row > 0} {
5468 set rm1 [expr {$row - 1}]
5469 foreach id [lindex $rowidlist $rm1] {
5470 if {$id ne {}} {
5471 lappend idlist $id
5474 set final [lindex $rowfinal $rm1]
5476 for {} {$row < $endrow} {incr row} {
5477 set rm1 [expr {$row - 1}]
5478 if {$rm1 < 0 || $idlist eq {}} {
5479 set idlist [make_idlist $row]
5480 set final 1
5481 } else {
5482 set id [lindex $displayorder $rm1]
5483 set col [lsearch -exact $idlist $id]
5484 set idlist [lreplace $idlist $col $col]
5485 foreach p [lindex $parentlist $rm1] {
5486 if {[lsearch -exact $idlist $p] < 0} {
5487 set col [idcol $idlist $p $col]
5488 set idlist [linsert $idlist $col $p]
5489 # if not the first child, we have to insert a line going up
5490 if {$id ne [lindex $children($curview,$p) 0]} {
5491 makeupline $p $rm1 $row $col
5495 set id [lindex $displayorder $row]
5496 if {$row > $downarrowlen} {
5497 set termrow [expr {$row - $downarrowlen - 1}]
5498 foreach p [lindex $parentlist $termrow] {
5499 set i [lsearch -exact $idlist $p]
5500 if {$i < 0} continue
5501 set nr [nextuse $p $termrow]
5502 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5503 set idlist [lreplace $idlist $i $i]
5507 set col [lsearch -exact $idlist $id]
5508 if {$col < 0} {
5509 set col [idcol $idlist $id]
5510 set idlist [linsert $idlist $col $id]
5511 if {$children($curview,$id) ne {}} {
5512 makeupline $id $rm1 $row $col
5515 set r [expr {$row + $uparrowlen - 1}]
5516 if {$r < $commitidx($curview)} {
5517 set x $col
5518 foreach p [lindex $parentlist $r] {
5519 if {[lsearch -exact $idlist $p] >= 0} continue
5520 set fk [lindex $children($curview,$p) 0]
5521 if {[rowofcommit $fk] < $row} {
5522 set x [idcol $idlist $p $x]
5523 set idlist [linsert $idlist $x $p]
5526 if {[incr r] < $commitidx($curview)} {
5527 set p [lindex $displayorder $r]
5528 if {[lsearch -exact $idlist $p] < 0} {
5529 set fk [lindex $children($curview,$p) 0]
5530 if {$fk ne {} && [rowofcommit $fk] < $row} {
5531 set x [idcol $idlist $p $x]
5532 set idlist [linsert $idlist $x $p]
5538 if {$final && !$viewcomplete($curview) &&
5539 $row + $uparrowlen + $mingaplen + $downarrowlen
5540 >= $commitidx($curview)} {
5541 set final 0
5543 set l [llength $rowidlist]
5544 if {$row == $l} {
5545 lappend rowidlist $idlist
5546 lappend rowisopt 0
5547 lappend rowfinal $final
5548 } elseif {$row < $l} {
5549 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5550 lset rowidlist $row $idlist
5551 changedrow $row
5553 lset rowfinal $row $final
5554 } else {
5555 set pad [ntimes [expr {$row - $l}] {}]
5556 set rowidlist [concat $rowidlist $pad]
5557 lappend rowidlist $idlist
5558 set rowfinal [concat $rowfinal $pad]
5559 lappend rowfinal $final
5560 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5563 return $row
5566 proc changedrow {row} {
5567 global displayorder iddrawn rowisopt need_redisplay
5569 set l [llength $rowisopt]
5570 if {$row < $l} {
5571 lset rowisopt $row 0
5572 if {$row + 1 < $l} {
5573 lset rowisopt [expr {$row + 1}] 0
5574 if {$row + 2 < $l} {
5575 lset rowisopt [expr {$row + 2}] 0
5579 set id [lindex $displayorder $row]
5580 if {[info exists iddrawn($id)]} {
5581 set need_redisplay 1
5585 proc insert_pad {row col npad} {
5586 global rowidlist
5588 set pad [ntimes $npad {}]
5589 set idlist [lindex $rowidlist $row]
5590 set bef [lrange $idlist 0 [expr {$col - 1}]]
5591 set aft [lrange $idlist $col end]
5592 set i [lsearch -exact $aft {}]
5593 if {$i > 0} {
5594 set aft [lreplace $aft $i $i]
5596 lset rowidlist $row [concat $bef $pad $aft]
5597 changedrow $row
5600 proc optimize_rows {row col endrow} {
5601 global rowidlist rowisopt displayorder curview children
5603 if {$row < 1} {
5604 set row 1
5606 for {} {$row < $endrow} {incr row; set col 0} {
5607 if {[lindex $rowisopt $row]} continue
5608 set haspad 0
5609 set y0 [expr {$row - 1}]
5610 set ym [expr {$row - 2}]
5611 set idlist [lindex $rowidlist $row]
5612 set previdlist [lindex $rowidlist $y0]
5613 if {$idlist eq {} || $previdlist eq {}} continue
5614 if {$ym >= 0} {
5615 set pprevidlist [lindex $rowidlist $ym]
5616 if {$pprevidlist eq {}} continue
5617 } else {
5618 set pprevidlist {}
5620 set x0 -1
5621 set xm -1
5622 for {} {$col < [llength $idlist]} {incr col} {
5623 set id [lindex $idlist $col]
5624 if {[lindex $previdlist $col] eq $id} continue
5625 if {$id eq {}} {
5626 set haspad 1
5627 continue
5629 set x0 [lsearch -exact $previdlist $id]
5630 if {$x0 < 0} continue
5631 set z [expr {$x0 - $col}]
5632 set isarrow 0
5633 set z0 {}
5634 if {$ym >= 0} {
5635 set xm [lsearch -exact $pprevidlist $id]
5636 if {$xm >= 0} {
5637 set z0 [expr {$xm - $x0}]
5640 if {$z0 eq {}} {
5641 # if row y0 is the first child of $id then it's not an arrow
5642 if {[lindex $children($curview,$id) 0] ne
5643 [lindex $displayorder $y0]} {
5644 set isarrow 1
5647 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5648 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5649 set isarrow 1
5651 # Looking at lines from this row to the previous row,
5652 # make them go straight up if they end in an arrow on
5653 # the previous row; otherwise make them go straight up
5654 # or at 45 degrees.
5655 if {$z < -1 || ($z < 0 && $isarrow)} {
5656 # Line currently goes left too much;
5657 # insert pads in the previous row, then optimize it
5658 set npad [expr {-1 - $z + $isarrow}]
5659 insert_pad $y0 $x0 $npad
5660 if {$y0 > 0} {
5661 optimize_rows $y0 $x0 $row
5663 set previdlist [lindex $rowidlist $y0]
5664 set x0 [lsearch -exact $previdlist $id]
5665 set z [expr {$x0 - $col}]
5666 if {$z0 ne {}} {
5667 set pprevidlist [lindex $rowidlist $ym]
5668 set xm [lsearch -exact $pprevidlist $id]
5669 set z0 [expr {$xm - $x0}]
5671 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5672 # Line currently goes right too much;
5673 # insert pads in this line
5674 set npad [expr {$z - 1 + $isarrow}]
5675 insert_pad $row $col $npad
5676 set idlist [lindex $rowidlist $row]
5677 incr col $npad
5678 set z [expr {$x0 - $col}]
5679 set haspad 1
5681 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5682 # this line links to its first child on row $row-2
5683 set id [lindex $displayorder $ym]
5684 set xc [lsearch -exact $pprevidlist $id]
5685 if {$xc >= 0} {
5686 set z0 [expr {$xc - $x0}]
5689 # avoid lines jigging left then immediately right
5690 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5691 insert_pad $y0 $x0 1
5692 incr x0
5693 optimize_rows $y0 $x0 $row
5694 set previdlist [lindex $rowidlist $y0]
5697 if {!$haspad} {
5698 # Find the first column that doesn't have a line going right
5699 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5700 set id [lindex $idlist $col]
5701 if {$id eq {}} break
5702 set x0 [lsearch -exact $previdlist $id]
5703 if {$x0 < 0} {
5704 # check if this is the link to the first child
5705 set kid [lindex $displayorder $y0]
5706 if {[lindex $children($curview,$id) 0] eq $kid} {
5707 # it is, work out offset to child
5708 set x0 [lsearch -exact $previdlist $kid]
5711 if {$x0 <= $col} break
5713 # Insert a pad at that column as long as it has a line and
5714 # isn't the last column
5715 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5716 set idlist [linsert $idlist $col {}]
5717 lset rowidlist $row $idlist
5718 changedrow $row
5724 proc xc {row col} {
5725 global canvx0 linespc
5726 return [expr {$canvx0 + $col * $linespc}]
5729 proc yc {row} {
5730 global canvy0 linespc
5731 return [expr {$canvy0 + $row * $linespc}]
5734 proc linewidth {id} {
5735 global thickerline lthickness
5737 set wid $lthickness
5738 if {[info exists thickerline] && $id eq $thickerline} {
5739 set wid [expr {2 * $lthickness}]
5741 return $wid
5744 proc rowranges {id} {
5745 global curview children uparrowlen downarrowlen
5746 global rowidlist
5748 set kids $children($curview,$id)
5749 if {$kids eq {}} {
5750 return {}
5752 set ret {}
5753 lappend kids $id
5754 foreach child $kids {
5755 if {![commitinview $child $curview]} break
5756 set row [rowofcommit $child]
5757 if {![info exists prev]} {
5758 lappend ret [expr {$row + 1}]
5759 } else {
5760 if {$row <= $prevrow} {
5761 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5763 # see if the line extends the whole way from prevrow to row
5764 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5765 [lsearch -exact [lindex $rowidlist \
5766 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5767 # it doesn't, see where it ends
5768 set r [expr {$prevrow + $downarrowlen}]
5769 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5770 while {[incr r -1] > $prevrow &&
5771 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5772 } else {
5773 while {[incr r] <= $row &&
5774 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5775 incr r -1
5777 lappend ret $r
5778 # see where it starts up again
5779 set r [expr {$row - $uparrowlen}]
5780 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5781 while {[incr r] < $row &&
5782 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5783 } else {
5784 while {[incr r -1] >= $prevrow &&
5785 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5786 incr r
5788 lappend ret $r
5791 if {$child eq $id} {
5792 lappend ret $row
5794 set prev $child
5795 set prevrow $row
5797 return $ret
5800 proc drawlineseg {id row endrow arrowlow} {
5801 global rowidlist displayorder iddrawn linesegs
5802 global canv colormap linespc curview maxlinelen parentlist
5804 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5805 set le [expr {$row + 1}]
5806 set arrowhigh 1
5807 while {1} {
5808 set c [lsearch -exact [lindex $rowidlist $le] $id]
5809 if {$c < 0} {
5810 incr le -1
5811 break
5813 lappend cols $c
5814 set x [lindex $displayorder $le]
5815 if {$x eq $id} {
5816 set arrowhigh 0
5817 break
5819 if {[info exists iddrawn($x)] || $le == $endrow} {
5820 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5821 if {$c >= 0} {
5822 lappend cols $c
5823 set arrowhigh 0
5825 break
5827 incr le
5829 if {$le <= $row} {
5830 return $row
5833 set lines {}
5834 set i 0
5835 set joinhigh 0
5836 if {[info exists linesegs($id)]} {
5837 set lines $linesegs($id)
5838 foreach li $lines {
5839 set r0 [lindex $li 0]
5840 if {$r0 > $row} {
5841 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5842 set joinhigh 1
5844 break
5846 incr i
5849 set joinlow 0
5850 if {$i > 0} {
5851 set li [lindex $lines [expr {$i-1}]]
5852 set r1 [lindex $li 1]
5853 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5854 set joinlow 1
5858 set x [lindex $cols [expr {$le - $row}]]
5859 set xp [lindex $cols [expr {$le - 1 - $row}]]
5860 set dir [expr {$xp - $x}]
5861 if {$joinhigh} {
5862 set ith [lindex $lines $i 2]
5863 set coords [$canv coords $ith]
5864 set ah [$canv itemcget $ith -arrow]
5865 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5866 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5867 if {$x2 ne {} && $x - $x2 == $dir} {
5868 set coords [lrange $coords 0 end-2]
5870 } else {
5871 set coords [list [xc $le $x] [yc $le]]
5873 if {$joinlow} {
5874 set itl [lindex $lines [expr {$i-1}] 2]
5875 set al [$canv itemcget $itl -arrow]
5876 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5877 } elseif {$arrowlow} {
5878 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5879 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5880 set arrowlow 0
5883 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5884 for {set y $le} {[incr y -1] > $row} {} {
5885 set x $xp
5886 set xp [lindex $cols [expr {$y - 1 - $row}]]
5887 set ndir [expr {$xp - $x}]
5888 if {$dir != $ndir || $xp < 0} {
5889 lappend coords [xc $y $x] [yc $y]
5891 set dir $ndir
5893 if {!$joinlow} {
5894 if {$xp < 0} {
5895 # join parent line to first child
5896 set ch [lindex $displayorder $row]
5897 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5898 if {$xc < 0} {
5899 puts "oops: drawlineseg: child $ch not on row $row"
5900 } elseif {$xc != $x} {
5901 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5902 set d [expr {int(0.5 * $linespc)}]
5903 set x1 [xc $row $x]
5904 if {$xc < $x} {
5905 set x2 [expr {$x1 - $d}]
5906 } else {
5907 set x2 [expr {$x1 + $d}]
5909 set y2 [yc $row]
5910 set y1 [expr {$y2 + $d}]
5911 lappend coords $x1 $y1 $x2 $y2
5912 } elseif {$xc < $x - 1} {
5913 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5914 } elseif {$xc > $x + 1} {
5915 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5917 set x $xc
5919 lappend coords [xc $row $x] [yc $row]
5920 } else {
5921 set xn [xc $row $xp]
5922 set yn [yc $row]
5923 lappend coords $xn $yn
5925 if {!$joinhigh} {
5926 assigncolor $id
5927 set t [$canv create line $coords -width [linewidth $id] \
5928 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5929 $canv lower $t
5930 bindline $t $id
5931 set lines [linsert $lines $i [list $row $le $t]]
5932 } else {
5933 $canv coords $ith $coords
5934 if {$arrow ne $ah} {
5935 $canv itemconf $ith -arrow $arrow
5937 lset lines $i 0 $row
5939 } else {
5940 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5941 set ndir [expr {$xo - $xp}]
5942 set clow [$canv coords $itl]
5943 if {$dir == $ndir} {
5944 set clow [lrange $clow 2 end]
5946 set coords [concat $coords $clow]
5947 if {!$joinhigh} {
5948 lset lines [expr {$i-1}] 1 $le
5949 } else {
5950 # coalesce two pieces
5951 $canv delete $ith
5952 set b [lindex $lines [expr {$i-1}] 0]
5953 set e [lindex $lines $i 1]
5954 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5956 $canv coords $itl $coords
5957 if {$arrow ne $al} {
5958 $canv itemconf $itl -arrow $arrow
5962 set linesegs($id) $lines
5963 return $le
5966 proc drawparentlinks {id row} {
5967 global rowidlist canv colormap curview parentlist
5968 global idpos linespc
5970 set rowids [lindex $rowidlist $row]
5971 set col [lsearch -exact $rowids $id]
5972 if {$col < 0} return
5973 set olds [lindex $parentlist $row]
5974 set row2 [expr {$row + 1}]
5975 set x [xc $row $col]
5976 set y [yc $row]
5977 set y2 [yc $row2]
5978 set d [expr {int(0.5 * $linespc)}]
5979 set ymid [expr {$y + $d}]
5980 set ids [lindex $rowidlist $row2]
5981 # rmx = right-most X coord used
5982 set rmx 0
5983 foreach p $olds {
5984 set i [lsearch -exact $ids $p]
5985 if {$i < 0} {
5986 puts "oops, parent $p of $id not in list"
5987 continue
5989 set x2 [xc $row2 $i]
5990 if {$x2 > $rmx} {
5991 set rmx $x2
5993 set j [lsearch -exact $rowids $p]
5994 if {$j < 0} {
5995 # drawlineseg will do this one for us
5996 continue
5998 assigncolor $p
5999 # should handle duplicated parents here...
6000 set coords [list $x $y]
6001 if {$i != $col} {
6002 # if attaching to a vertical segment, draw a smaller
6003 # slant for visual distinctness
6004 if {$i == $j} {
6005 if {$i < $col} {
6006 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6007 } else {
6008 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6010 } elseif {$i < $col && $i < $j} {
6011 # segment slants towards us already
6012 lappend coords [xc $row $j] $y
6013 } else {
6014 if {$i < $col - 1} {
6015 lappend coords [expr {$x2 + $linespc}] $y
6016 } elseif {$i > $col + 1} {
6017 lappend coords [expr {$x2 - $linespc}] $y
6019 lappend coords $x2 $y2
6021 } else {
6022 lappend coords $x2 $y2
6024 set t [$canv create line $coords -width [linewidth $p] \
6025 -fill $colormap($p) -tags lines.$p]
6026 $canv lower $t
6027 bindline $t $p
6029 if {$rmx > [lindex $idpos($id) 1]} {
6030 lset idpos($id) 1 $rmx
6031 redrawtags $id
6035 proc drawlines {id} {
6036 global canv
6038 $canv itemconf lines.$id -width [linewidth $id]
6041 proc drawcmittext {id row col} {
6042 global linespc canv canv2 canv3 fgcolor curview
6043 global cmitlisted commitinfo rowidlist parentlist
6044 global rowtextx idpos idtags idheads idotherrefs
6045 global linehtag linentag linedtag selectedline
6046 global canvxmax boldids boldnameids fgcolor markedid
6047 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6048 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6049 global circleoutlinecolor
6051 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6052 set listed $cmitlisted($curview,$id)
6053 if {$id eq $nullid} {
6054 set ofill $workingfilescirclecolor
6055 } elseif {$id eq $nullid2} {
6056 set ofill $indexcirclecolor
6057 } elseif {$id eq $mainheadid} {
6058 set ofill $mainheadcirclecolor
6059 } else {
6060 set ofill [lindex $circlecolors $listed]
6062 set x [xc $row $col]
6063 set y [yc $row]
6064 set orad [expr {$linespc / 3}]
6065 if {$listed <= 2} {
6066 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6067 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6068 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6069 } elseif {$listed == 3} {
6070 # triangle pointing left for left-side commits
6071 set t [$canv create polygon \
6072 [expr {$x - $orad}] $y \
6073 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6074 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6075 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6076 } else {
6077 # triangle pointing right for right-side commits
6078 set t [$canv create polygon \
6079 [expr {$x + $orad - 1}] $y \
6080 [expr {$x - $orad}] [expr {$y - $orad}] \
6081 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6082 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6084 set circleitem($row) $t
6085 $canv raise $t
6086 $canv bind $t <1> {selcanvline {} %x %y}
6087 set rmx [llength [lindex $rowidlist $row]]
6088 set olds [lindex $parentlist $row]
6089 if {$olds ne {}} {
6090 set nextids [lindex $rowidlist [expr {$row + 1}]]
6091 foreach p $olds {
6092 set i [lsearch -exact $nextids $p]
6093 if {$i > $rmx} {
6094 set rmx $i
6098 set xt [xc $row $rmx]
6099 set rowtextx($row) $xt
6100 set idpos($id) [list $x $xt $y]
6101 if {[info exists idtags($id)] || [info exists idheads($id)]
6102 || [info exists idotherrefs($id)]} {
6103 set xt [drawtags $id $x $xt $y]
6105 if {[lindex $commitinfo($id) 6] > 0} {
6106 set xt [drawnotesign $xt $y]
6108 set headline [lindex $commitinfo($id) 0]
6109 set name [lindex $commitinfo($id) 1]
6110 set date [lindex $commitinfo($id) 2]
6111 set date [formatdate $date]
6112 set font mainfont
6113 set nfont mainfont
6114 set isbold [ishighlighted $id]
6115 if {$isbold > 0} {
6116 lappend boldids $id
6117 set font mainfontbold
6118 if {$isbold > 1} {
6119 lappend boldnameids $id
6120 set nfont mainfontbold
6123 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6124 -text $headline -font $font -tags text]
6125 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6126 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6127 -text $name -font $nfont -tags text]
6128 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6129 -text $date -font mainfont -tags text]
6130 if {$selectedline == $row} {
6131 make_secsel $id
6133 if {[info exists markedid] && $markedid eq $id} {
6134 make_idmark $id
6136 set xr [expr {$xt + [font measure $font $headline]}]
6137 if {$xr > $canvxmax} {
6138 set canvxmax $xr
6139 setcanvscroll
6143 proc drawcmitrow {row} {
6144 global displayorder rowidlist nrows_drawn
6145 global iddrawn markingmatches
6146 global commitinfo numcommits
6147 global filehighlight fhighlights findpattern nhighlights
6148 global hlview vhighlights
6149 global highlight_related rhighlights
6151 if {$row >= $numcommits} return
6153 set id [lindex $displayorder $row]
6154 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6155 askvhighlight $row $id
6157 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6158 askfilehighlight $row $id
6160 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6161 askfindhighlight $row $id
6163 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6164 askrelhighlight $row $id
6166 if {![info exists iddrawn($id)]} {
6167 set col [lsearch -exact [lindex $rowidlist $row] $id]
6168 if {$col < 0} {
6169 puts "oops, row $row id $id not in list"
6170 return
6172 if {![info exists commitinfo($id)]} {
6173 getcommit $id
6175 assigncolor $id
6176 drawcmittext $id $row $col
6177 set iddrawn($id) 1
6178 incr nrows_drawn
6180 if {$markingmatches} {
6181 markrowmatches $row $id
6185 proc drawcommits {row {endrow {}}} {
6186 global numcommits iddrawn displayorder curview need_redisplay
6187 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6189 if {$row < 0} {
6190 set row 0
6192 if {$endrow eq {}} {
6193 set endrow $row
6195 if {$endrow >= $numcommits} {
6196 set endrow [expr {$numcommits - 1}]
6199 set rl1 [expr {$row - $downarrowlen - 3}]
6200 if {$rl1 < 0} {
6201 set rl1 0
6203 set ro1 [expr {$row - 3}]
6204 if {$ro1 < 0} {
6205 set ro1 0
6207 set r2 [expr {$endrow + $uparrowlen + 3}]
6208 if {$r2 > $numcommits} {
6209 set r2 $numcommits
6211 for {set r $rl1} {$r < $r2} {incr r} {
6212 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6213 if {$rl1 < $r} {
6214 layoutrows $rl1 $r
6216 set rl1 [expr {$r + 1}]
6219 if {$rl1 < $r} {
6220 layoutrows $rl1 $r
6222 optimize_rows $ro1 0 $r2
6223 if {$need_redisplay || $nrows_drawn > 2000} {
6224 clear_display
6227 # make the lines join to already-drawn rows either side
6228 set r [expr {$row - 1}]
6229 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6230 set r $row
6232 set er [expr {$endrow + 1}]
6233 if {$er >= $numcommits ||
6234 ![info exists iddrawn([lindex $displayorder $er])]} {
6235 set er $endrow
6237 for {} {$r <= $er} {incr r} {
6238 set id [lindex $displayorder $r]
6239 set wasdrawn [info exists iddrawn($id)]
6240 drawcmitrow $r
6241 if {$r == $er} break
6242 set nextid [lindex $displayorder [expr {$r + 1}]]
6243 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6244 drawparentlinks $id $r
6246 set rowids [lindex $rowidlist $r]
6247 foreach lid $rowids {
6248 if {$lid eq {}} continue
6249 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6250 if {$lid eq $id} {
6251 # see if this is the first child of any of its parents
6252 foreach p [lindex $parentlist $r] {
6253 if {[lsearch -exact $rowids $p] < 0} {
6254 # make this line extend up to the child
6255 set lineend($p) [drawlineseg $p $r $er 0]
6258 } else {
6259 set lineend($lid) [drawlineseg $lid $r $er 1]
6265 proc undolayout {row} {
6266 global uparrowlen mingaplen downarrowlen
6267 global rowidlist rowisopt rowfinal need_redisplay
6269 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6270 if {$r < 0} {
6271 set r 0
6273 if {[llength $rowidlist] > $r} {
6274 incr r -1
6275 set rowidlist [lrange $rowidlist 0 $r]
6276 set rowfinal [lrange $rowfinal 0 $r]
6277 set rowisopt [lrange $rowisopt 0 $r]
6278 set need_redisplay 1
6279 run drawvisible
6283 proc drawvisible {} {
6284 global canv linespc curview vrowmod selectedline targetrow targetid
6285 global need_redisplay cscroll numcommits
6287 set fs [$canv yview]
6288 set ymax [lindex [$canv cget -scrollregion] 3]
6289 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6290 set f0 [lindex $fs 0]
6291 set f1 [lindex $fs 1]
6292 set y0 [expr {int($f0 * $ymax)}]
6293 set y1 [expr {int($f1 * $ymax)}]
6295 if {[info exists targetid]} {
6296 if {[commitinview $targetid $curview]} {
6297 set r [rowofcommit $targetid]
6298 if {$r != $targetrow} {
6299 # Fix up the scrollregion and change the scrolling position
6300 # now that our target row has moved.
6301 set diff [expr {($r - $targetrow) * $linespc}]
6302 set targetrow $r
6303 setcanvscroll
6304 set ymax [lindex [$canv cget -scrollregion] 3]
6305 incr y0 $diff
6306 incr y1 $diff
6307 set f0 [expr {$y0 / $ymax}]
6308 set f1 [expr {$y1 / $ymax}]
6309 allcanvs yview moveto $f0
6310 $cscroll set $f0 $f1
6311 set need_redisplay 1
6313 } else {
6314 unset targetid
6318 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6319 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6320 if {$endrow >= $vrowmod($curview)} {
6321 update_arcrows $curview
6323 if {$selectedline ne {} &&
6324 $row <= $selectedline && $selectedline <= $endrow} {
6325 set targetrow $selectedline
6326 } elseif {[info exists targetid]} {
6327 set targetrow [expr {int(($row + $endrow) / 2)}]
6329 if {[info exists targetrow]} {
6330 if {$targetrow >= $numcommits} {
6331 set targetrow [expr {$numcommits - 1}]
6333 set targetid [commitonrow $targetrow]
6335 drawcommits $row $endrow
6338 proc clear_display {} {
6339 global iddrawn linesegs need_redisplay nrows_drawn
6340 global vhighlights fhighlights nhighlights rhighlights
6341 global linehtag linentag linedtag boldids boldnameids
6343 allcanvs delete all
6344 catch {unset iddrawn}
6345 catch {unset linesegs}
6346 catch {unset linehtag}
6347 catch {unset linentag}
6348 catch {unset linedtag}
6349 set boldids {}
6350 set boldnameids {}
6351 catch {unset vhighlights}
6352 catch {unset fhighlights}
6353 catch {unset nhighlights}
6354 catch {unset rhighlights}
6355 set need_redisplay 0
6356 set nrows_drawn 0
6359 proc findcrossings {id} {
6360 global rowidlist parentlist numcommits displayorder
6362 set cross {}
6363 set ccross {}
6364 foreach {s e} [rowranges $id] {
6365 if {$e >= $numcommits} {
6366 set e [expr {$numcommits - 1}]
6368 if {$e <= $s} continue
6369 for {set row $e} {[incr row -1] >= $s} {} {
6370 set x [lsearch -exact [lindex $rowidlist $row] $id]
6371 if {$x < 0} break
6372 set olds [lindex $parentlist $row]
6373 set kid [lindex $displayorder $row]
6374 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6375 if {$kidx < 0} continue
6376 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6377 foreach p $olds {
6378 set px [lsearch -exact $nextrow $p]
6379 if {$px < 0} continue
6380 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6381 if {[lsearch -exact $ccross $p] >= 0} continue
6382 if {$x == $px + ($kidx < $px? -1: 1)} {
6383 lappend ccross $p
6384 } elseif {[lsearch -exact $cross $p] < 0} {
6385 lappend cross $p
6391 return [concat $ccross {{}} $cross]
6394 proc assigncolor {id} {
6395 global colormap colors nextcolor
6396 global parents children children curview
6398 if {[info exists colormap($id)]} return
6399 set ncolors [llength $colors]
6400 if {[info exists children($curview,$id)]} {
6401 set kids $children($curview,$id)
6402 } else {
6403 set kids {}
6405 if {[llength $kids] == 1} {
6406 set child [lindex $kids 0]
6407 if {[info exists colormap($child)]
6408 && [llength $parents($curview,$child)] == 1} {
6409 set colormap($id) $colormap($child)
6410 return
6413 set badcolors {}
6414 set origbad {}
6415 foreach x [findcrossings $id] {
6416 if {$x eq {}} {
6417 # delimiter between corner crossings and other crossings
6418 if {[llength $badcolors] >= $ncolors - 1} break
6419 set origbad $badcolors
6421 if {[info exists colormap($x)]
6422 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6423 lappend badcolors $colormap($x)
6426 if {[llength $badcolors] >= $ncolors} {
6427 set badcolors $origbad
6429 set origbad $badcolors
6430 if {[llength $badcolors] < $ncolors - 1} {
6431 foreach child $kids {
6432 if {[info exists colormap($child)]
6433 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6434 lappend badcolors $colormap($child)
6436 foreach p $parents($curview,$child) {
6437 if {[info exists colormap($p)]
6438 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6439 lappend badcolors $colormap($p)
6443 if {[llength $badcolors] >= $ncolors} {
6444 set badcolors $origbad
6447 for {set i 0} {$i <= $ncolors} {incr i} {
6448 set c [lindex $colors $nextcolor]
6449 if {[incr nextcolor] >= $ncolors} {
6450 set nextcolor 0
6452 if {[lsearch -exact $badcolors $c]} break
6454 set colormap($id) $c
6457 proc bindline {t id} {
6458 global canv
6460 $canv bind $t <Enter> "lineenter %x %y $id"
6461 $canv bind $t <Motion> "linemotion %x %y $id"
6462 $canv bind $t <Leave> "lineleave $id"
6463 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6466 proc graph_pane_width {} {
6467 global use_ttk
6469 if {$use_ttk} {
6470 set g [.tf.histframe.pwclist sashpos 0]
6471 } else {
6472 set g [.tf.histframe.pwclist sash coord 0]
6474 return [lindex $g 0]
6477 proc totalwidth {l font extra} {
6478 set tot 0
6479 foreach str $l {
6480 set tot [expr {$tot + [font measure $font $str] + $extra}]
6482 return $tot
6485 proc drawtags {id x xt y1} {
6486 global idtags idheads idotherrefs mainhead
6487 global linespc lthickness
6488 global canv rowtextx curview fgcolor bgcolor ctxbut
6489 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6490 global tagbgcolor tagfgcolor tagoutlinecolor
6491 global reflinecolor
6493 set marks {}
6494 set ntags 0
6495 set nheads 0
6496 set singletag 0
6497 set maxtags 3
6498 set maxtagpct 25
6499 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6500 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6501 set extra [expr {$delta + $lthickness + $linespc}]
6503 if {[info exists idtags($id)]} {
6504 set marks $idtags($id)
6505 set ntags [llength $marks]
6506 if {$ntags > $maxtags ||
6507 [totalwidth $marks mainfont $extra] > $maxwidth} {
6508 # show just a single "n tags..." tag
6509 set singletag 1
6510 if {$ntags == 1} {
6511 set marks [list "tag..."]
6512 } else {
6513 set marks [list [format "%d tags..." $ntags]]
6515 set ntags 1
6518 if {[info exists idheads($id)]} {
6519 set marks [concat $marks $idheads($id)]
6520 set nheads [llength $idheads($id)]
6522 if {[info exists idotherrefs($id)]} {
6523 set marks [concat $marks $idotherrefs($id)]
6525 if {$marks eq {}} {
6526 return $xt
6529 set yt [expr {$y1 - 0.5 * $linespc}]
6530 set yb [expr {$yt + $linespc - 1}]
6531 set xvals {}
6532 set wvals {}
6533 set i -1
6534 foreach tag $marks {
6535 incr i
6536 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6537 set wid [font measure mainfontbold $tag]
6538 } else {
6539 set wid [font measure mainfont $tag]
6541 lappend xvals $xt
6542 lappend wvals $wid
6543 set xt [expr {$xt + $wid + $extra}]
6545 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6546 -width $lthickness -fill $reflinecolor -tags tag.$id]
6547 $canv lower $t
6548 foreach tag $marks x $xvals wid $wvals {
6549 set tag_quoted [string map {% %%} $tag]
6550 set xl [expr {$x + $delta}]
6551 set xr [expr {$x + $delta + $wid + $lthickness}]
6552 set font mainfont
6553 if {[incr ntags -1] >= 0} {
6554 # draw a tag
6555 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6556 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6557 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6558 -tags tag.$id]
6559 if {$singletag} {
6560 set tagclick [list showtags $id 1]
6561 } else {
6562 set tagclick [list showtag $tag_quoted 1]
6564 $canv bind $t <1> $tagclick
6565 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6566 } else {
6567 # draw a head or other ref
6568 if {[incr nheads -1] >= 0} {
6569 set col $headbgcolor
6570 if {$tag eq $mainhead} {
6571 set font mainfontbold
6573 } else {
6574 set col "#ddddff"
6576 set xl [expr {$xl - $delta/2}]
6577 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6578 -width 1 -outline black -fill $col -tags tag.$id
6579 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6580 set rwid [font measure mainfont $remoteprefix]
6581 set xi [expr {$x + 1}]
6582 set yti [expr {$yt + 1}]
6583 set xri [expr {$x + $rwid}]
6584 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6585 -width 0 -fill $remotebgcolor -tags tag.$id
6588 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6589 -font $font -tags [list tag.$id text]]
6590 if {$ntags >= 0} {
6591 $canv bind $t <1> $tagclick
6592 } elseif {$nheads >= 0} {
6593 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6596 return $xt
6599 proc drawnotesign {xt y} {
6600 global linespc canv fgcolor
6602 set orad [expr {$linespc / 3}]
6603 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6604 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6605 -fill yellow -outline $fgcolor -width 1 -tags circle]
6606 set xt [expr {$xt + $orad * 3}]
6607 return $xt
6610 proc xcoord {i level ln} {
6611 global canvx0 xspc1 xspc2
6613 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6614 if {$i > 0 && $i == $level} {
6615 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6616 } elseif {$i > $level} {
6617 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6619 return $x
6622 proc show_status {msg} {
6623 global canv fgcolor
6625 clear_display
6626 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6627 -tags text -fill $fgcolor
6630 # Don't change the text pane cursor if it is currently the hand cursor,
6631 # showing that we are over a sha1 ID link.
6632 proc settextcursor {c} {
6633 global ctext curtextcursor
6635 if {[$ctext cget -cursor] == $curtextcursor} {
6636 $ctext config -cursor $c
6638 set curtextcursor $c
6641 proc nowbusy {what {name {}}} {
6642 global isbusy busyname statusw
6644 if {[array names isbusy] eq {}} {
6645 . config -cursor watch
6646 settextcursor watch
6648 set isbusy($what) 1
6649 set busyname($what) $name
6650 if {$name ne {}} {
6651 $statusw conf -text $name
6655 proc notbusy {what} {
6656 global isbusy maincursor textcursor busyname statusw
6658 catch {
6659 unset isbusy($what)
6660 if {$busyname($what) ne {} &&
6661 [$statusw cget -text] eq $busyname($what)} {
6662 $statusw conf -text {}
6665 if {[array names isbusy] eq {}} {
6666 . config -cursor $maincursor
6667 settextcursor $textcursor
6671 proc findmatches {f} {
6672 global findtype findstring
6673 if {$findtype == [mc "Regexp"]} {
6674 set matches [regexp -indices -all -inline $findstring $f]
6675 } else {
6676 set fs $findstring
6677 if {$findtype == [mc "IgnCase"]} {
6678 set f [string tolower $f]
6679 set fs [string tolower $fs]
6681 set matches {}
6682 set i 0
6683 set l [string length $fs]
6684 while {[set j [string first $fs $f $i]] >= 0} {
6685 lappend matches [list $j [expr {$j+$l-1}]]
6686 set i [expr {$j + $l}]
6689 return $matches
6692 proc dofind {{dirn 1} {wrap 1}} {
6693 global findstring findstartline findcurline selectedline numcommits
6694 global gdttype filehighlight fh_serial find_dirn findallowwrap
6696 if {[info exists find_dirn]} {
6697 if {$find_dirn == $dirn} return
6698 stopfinding
6700 focus .
6701 if {$findstring eq {} || $numcommits == 0} return
6702 if {$selectedline eq {}} {
6703 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6704 } else {
6705 set findstartline $selectedline
6707 set findcurline $findstartline
6708 nowbusy finding [mc "Searching"]
6709 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6710 after cancel do_file_hl $fh_serial
6711 do_file_hl $fh_serial
6713 set find_dirn $dirn
6714 set findallowwrap $wrap
6715 run findmore
6718 proc stopfinding {} {
6719 global find_dirn findcurline fprogcoord
6721 if {[info exists find_dirn]} {
6722 unset find_dirn
6723 unset findcurline
6724 notbusy finding
6725 set fprogcoord 0
6726 adjustprogress
6728 stopblaming
6731 proc findmore {} {
6732 global commitdata commitinfo numcommits findpattern findloc
6733 global findstartline findcurline findallowwrap
6734 global find_dirn gdttype fhighlights fprogcoord
6735 global curview varcorder vrownum varccommits vrowmod
6737 if {![info exists find_dirn]} {
6738 return 0
6740 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6741 set l $findcurline
6742 set moretodo 0
6743 if {$find_dirn > 0} {
6744 incr l
6745 if {$l >= $numcommits} {
6746 set l 0
6748 if {$l <= $findstartline} {
6749 set lim [expr {$findstartline + 1}]
6750 } else {
6751 set lim $numcommits
6752 set moretodo $findallowwrap
6754 } else {
6755 if {$l == 0} {
6756 set l $numcommits
6758 incr l -1
6759 if {$l >= $findstartline} {
6760 set lim [expr {$findstartline - 1}]
6761 } else {
6762 set lim -1
6763 set moretodo $findallowwrap
6766 set n [expr {($lim - $l) * $find_dirn}]
6767 if {$n > 500} {
6768 set n 500
6769 set moretodo 1
6771 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6772 update_arcrows $curview
6774 set found 0
6775 set domore 1
6776 set ai [bsearch $vrownum($curview) $l]
6777 set a [lindex $varcorder($curview) $ai]
6778 set arow [lindex $vrownum($curview) $ai]
6779 set ids [lindex $varccommits($curview,$a)]
6780 set arowend [expr {$arow + [llength $ids]}]
6781 if {$gdttype eq [mc "containing:"]} {
6782 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6783 if {$l < $arow || $l >= $arowend} {
6784 incr ai $find_dirn
6785 set a [lindex $varcorder($curview) $ai]
6786 set arow [lindex $vrownum($curview) $ai]
6787 set ids [lindex $varccommits($curview,$a)]
6788 set arowend [expr {$arow + [llength $ids]}]
6790 set id [lindex $ids [expr {$l - $arow}]]
6791 # shouldn't happen unless git log doesn't give all the commits...
6792 if {![info exists commitdata($id)] ||
6793 ![doesmatch $commitdata($id)]} {
6794 continue
6796 if {![info exists commitinfo($id)]} {
6797 getcommit $id
6799 set info $commitinfo($id)
6800 foreach f $info ty $fldtypes {
6801 if {$ty eq ""} continue
6802 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6803 [doesmatch $f]} {
6804 set found 1
6805 break
6808 if {$found} break
6810 } else {
6811 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6812 if {$l < $arow || $l >= $arowend} {
6813 incr ai $find_dirn
6814 set a [lindex $varcorder($curview) $ai]
6815 set arow [lindex $vrownum($curview) $ai]
6816 set ids [lindex $varccommits($curview,$a)]
6817 set arowend [expr {$arow + [llength $ids]}]
6819 set id [lindex $ids [expr {$l - $arow}]]
6820 if {![info exists fhighlights($id)]} {
6821 # this sets fhighlights($id) to -1
6822 askfilehighlight $l $id
6824 if {$fhighlights($id) > 0} {
6825 set found $domore
6826 break
6828 if {$fhighlights($id) < 0} {
6829 if {$domore} {
6830 set domore 0
6831 set findcurline [expr {$l - $find_dirn}]
6836 if {$found || ($domore && !$moretodo)} {
6837 unset findcurline
6838 unset find_dirn
6839 notbusy finding
6840 set fprogcoord 0
6841 adjustprogress
6842 if {$found} {
6843 findselectline $l
6844 } else {
6845 bell
6847 return 0
6849 if {!$domore} {
6850 flushhighlights
6851 } else {
6852 set findcurline [expr {$l - $find_dirn}]
6854 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6855 if {$n < 0} {
6856 incr n $numcommits
6858 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6859 adjustprogress
6860 return $domore
6863 proc findselectline {l} {
6864 global findloc commentend ctext findcurline markingmatches gdttype
6866 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6867 set findcurline $l
6868 selectline $l 1
6869 if {$markingmatches &&
6870 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6871 # highlight the matches in the comments
6872 set f [$ctext get 1.0 $commentend]
6873 set matches [findmatches $f]
6874 foreach match $matches {
6875 set start [lindex $match 0]
6876 set end [expr {[lindex $match 1] + 1}]
6877 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6880 drawvisible
6883 # mark the bits of a headline or author that match a find string
6884 proc markmatches {canv l str tag matches font row} {
6885 global selectedline
6887 set bbox [$canv bbox $tag]
6888 set x0 [lindex $bbox 0]
6889 set y0 [lindex $bbox 1]
6890 set y1 [lindex $bbox 3]
6891 foreach match $matches {
6892 set start [lindex $match 0]
6893 set end [lindex $match 1]
6894 if {$start > $end} continue
6895 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6896 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6897 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6898 [expr {$x0+$xlen+2}] $y1 \
6899 -outline {} -tags [list match$l matches] -fill yellow]
6900 $canv lower $t
6901 if {$row == $selectedline} {
6902 $canv raise $t secsel
6907 proc unmarkmatches {} {
6908 global markingmatches
6910 allcanvs delete matches
6911 set markingmatches 0
6912 stopfinding
6915 proc selcanvline {w x y} {
6916 global canv canvy0 ctext linespc
6917 global rowtextx
6918 set ymax [lindex [$canv cget -scrollregion] 3]
6919 if {$ymax == {}} return
6920 set yfrac [lindex [$canv yview] 0]
6921 set y [expr {$y + $yfrac * $ymax}]
6922 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6923 if {$l < 0} {
6924 set l 0
6926 if {$w eq $canv} {
6927 set xmax [lindex [$canv cget -scrollregion] 2]
6928 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6929 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6931 unmarkmatches
6932 selectline $l 1
6935 proc commit_descriptor {p} {
6936 global commitinfo
6937 if {![info exists commitinfo($p)]} {
6938 getcommit $p
6940 set l "..."
6941 if {[llength $commitinfo($p)] > 1} {
6942 set l [lindex $commitinfo($p) 0]
6944 return "$p ($l)\n"
6947 # append some text to the ctext widget, and make any SHA1 ID
6948 # that we know about be a clickable link.
6949 proc appendwithlinks {text tags} {
6950 global ctext linknum curview
6952 set start [$ctext index "end - 1c"]
6953 $ctext insert end $text $tags
6954 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6955 foreach l $links {
6956 set s [lindex $l 0]
6957 set e [lindex $l 1]
6958 set linkid [string range $text $s $e]
6959 incr e
6960 $ctext tag delete link$linknum
6961 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6962 setlink $linkid link$linknum
6963 incr linknum
6967 proc setlink {id lk} {
6968 global curview ctext pendinglinks
6969 global linkfgcolor
6971 if {[string range $id 0 1] eq "-g"} {
6972 set id [string range $id 2 end]
6975 set known 0
6976 if {[string length $id] < 40} {
6977 set matches [longid $id]
6978 if {[llength $matches] > 0} {
6979 if {[llength $matches] > 1} return
6980 set known 1
6981 set id [lindex $matches 0]
6983 } else {
6984 set known [commitinview $id $curview]
6986 if {$known} {
6987 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
6988 $ctext tag bind $lk <1> [list selbyid $id]
6989 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6990 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6991 } else {
6992 lappend pendinglinks($id) $lk
6993 interestedin $id {makelink %P}
6997 proc appendshortlink {id {pre {}} {post {}}} {
6998 global ctext linknum
7000 $ctext insert end $pre
7001 $ctext tag delete link$linknum
7002 $ctext insert end [string range $id 0 7] link$linknum
7003 $ctext insert end $post
7004 setlink $id link$linknum
7005 incr linknum
7008 proc makelink {id} {
7009 global pendinglinks
7011 if {![info exists pendinglinks($id)]} return
7012 foreach lk $pendinglinks($id) {
7013 setlink $id $lk
7015 unset pendinglinks($id)
7018 proc linkcursor {w inc} {
7019 global linkentercount curtextcursor
7021 if {[incr linkentercount $inc] > 0} {
7022 $w configure -cursor hand2
7023 } else {
7024 $w configure -cursor $curtextcursor
7025 if {$linkentercount < 0} {
7026 set linkentercount 0
7031 proc viewnextline {dir} {
7032 global canv linespc
7034 $canv delete hover
7035 set ymax [lindex [$canv cget -scrollregion] 3]
7036 set wnow [$canv yview]
7037 set wtop [expr {[lindex $wnow 0] * $ymax}]
7038 set newtop [expr {$wtop + $dir * $linespc}]
7039 if {$newtop < 0} {
7040 set newtop 0
7041 } elseif {$newtop > $ymax} {
7042 set newtop $ymax
7044 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7047 # add a list of tag or branch names at position pos
7048 # returns the number of names inserted
7049 proc appendrefs {pos ids var} {
7050 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7052 if {[catch {$ctext index $pos}]} {
7053 return 0
7055 $ctext conf -state normal
7056 $ctext delete $pos "$pos lineend"
7057 set tags {}
7058 foreach id $ids {
7059 foreach tag [set $var\($id\)] {
7060 lappend tags [list $tag $id]
7064 set sep {}
7065 set tags [lsort -index 0 -decreasing $tags]
7066 set nutags 0
7068 if {[llength $tags] > $maxrefs} {
7069 # If we are displaying heads, and there are too many,
7070 # see if there are some important heads to display.
7071 # Currently that are the current head and heads listed in $visiblerefs option
7072 set itags {}
7073 if {$var eq "idheads"} {
7074 set utags {}
7075 foreach ti $tags {
7076 set hname [lindex $ti 0]
7077 set id [lindex $ti 1]
7078 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7079 [llength $itags] < $maxrefs} {
7080 lappend itags $ti
7081 } else {
7082 lappend utags $ti
7085 set tags $utags
7087 if {$itags ne {}} {
7088 set str [mc "and many more"]
7089 set sep " "
7090 } else {
7091 set str [mc "many"]
7093 $ctext insert $pos "$str ([llength $tags])"
7094 set nutags [llength $tags]
7095 set tags $itags
7098 foreach ti $tags {
7099 set id [lindex $ti 1]
7100 set lk link$linknum
7101 incr linknum
7102 $ctext tag delete $lk
7103 $ctext insert $pos $sep
7104 $ctext insert $pos [lindex $ti 0] $lk
7105 setlink $id $lk
7106 set sep ", "
7108 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7109 $ctext conf -state disabled
7110 return [expr {[llength $tags] + $nutags}]
7113 # called when we have finished computing the nearby tags
7114 proc dispneartags {delay} {
7115 global selectedline currentid showneartags tagphase
7117 if {$selectedline eq {} || !$showneartags} return
7118 after cancel dispnexttag
7119 if {$delay} {
7120 after 200 dispnexttag
7121 set tagphase -1
7122 } else {
7123 after idle dispnexttag
7124 set tagphase 0
7128 proc dispnexttag {} {
7129 global selectedline currentid showneartags tagphase ctext
7131 if {$selectedline eq {} || !$showneartags} return
7132 switch -- $tagphase {
7134 set dtags [desctags $currentid]
7135 if {$dtags ne {}} {
7136 appendrefs precedes $dtags idtags
7140 set atags [anctags $currentid]
7141 if {$atags ne {}} {
7142 appendrefs follows $atags idtags
7146 set dheads [descheads $currentid]
7147 if {$dheads ne {}} {
7148 if {[appendrefs branch $dheads idheads] > 1
7149 && [$ctext get "branch -3c"] eq "h"} {
7150 # turn "Branch" into "Branches"
7151 $ctext conf -state normal
7152 $ctext insert "branch -2c" "es"
7153 $ctext conf -state disabled
7158 if {[incr tagphase] <= 2} {
7159 after idle dispnexttag
7163 proc make_secsel {id} {
7164 global linehtag linentag linedtag canv canv2 canv3
7166 if {![info exists linehtag($id)]} return
7167 $canv delete secsel
7168 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7169 -tags secsel -fill [$canv cget -selectbackground]]
7170 $canv lower $t
7171 $canv2 delete secsel
7172 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7173 -tags secsel -fill [$canv2 cget -selectbackground]]
7174 $canv2 lower $t
7175 $canv3 delete secsel
7176 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7177 -tags secsel -fill [$canv3 cget -selectbackground]]
7178 $canv3 lower $t
7181 proc make_idmark {id} {
7182 global linehtag canv fgcolor
7184 if {![info exists linehtag($id)]} return
7185 $canv delete markid
7186 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7187 -tags markid -outline $fgcolor]
7188 $canv raise $t
7191 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7192 global canv ctext commitinfo selectedline
7193 global canvy0 linespc parents children curview
7194 global currentid sha1entry
7195 global commentend idtags linknum
7196 global mergemax numcommits pending_select
7197 global cmitmode showneartags allcommits
7198 global targetrow targetid lastscrollrows
7199 global autoselect autosellen jump_to_here
7200 global vinlinediff
7202 catch {unset pending_select}
7203 $canv delete hover
7204 normalline
7205 unsel_reflist
7206 stopfinding
7207 if {$l < 0 || $l >= $numcommits} return
7208 set id [commitonrow $l]
7209 set targetid $id
7210 set targetrow $l
7211 set selectedline $l
7212 set currentid $id
7213 if {$lastscrollrows < $numcommits} {
7214 setcanvscroll
7217 if {$cmitmode ne "patch" && $switch_to_patch} {
7218 set cmitmode "patch"
7221 set y [expr {$canvy0 + $l * $linespc}]
7222 set ymax [lindex [$canv cget -scrollregion] 3]
7223 set ytop [expr {$y - $linespc - 1}]
7224 set ybot [expr {$y + $linespc + 1}]
7225 set wnow [$canv yview]
7226 set wtop [expr {[lindex $wnow 0] * $ymax}]
7227 set wbot [expr {[lindex $wnow 1] * $ymax}]
7228 set wh [expr {$wbot - $wtop}]
7229 set newtop $wtop
7230 if {$ytop < $wtop} {
7231 if {$ybot < $wtop} {
7232 set newtop [expr {$y - $wh / 2.0}]
7233 } else {
7234 set newtop $ytop
7235 if {$newtop > $wtop - $linespc} {
7236 set newtop [expr {$wtop - $linespc}]
7239 } elseif {$ybot > $wbot} {
7240 if {$ytop > $wbot} {
7241 set newtop [expr {$y - $wh / 2.0}]
7242 } else {
7243 set newtop [expr {$ybot - $wh}]
7244 if {$newtop < $wtop + $linespc} {
7245 set newtop [expr {$wtop + $linespc}]
7249 if {$newtop != $wtop} {
7250 if {$newtop < 0} {
7251 set newtop 0
7253 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7254 drawvisible
7257 make_secsel $id
7259 if {$isnew} {
7260 addtohistory [list selbyid $id 0] savecmitpos
7263 $sha1entry delete 0 end
7264 $sha1entry insert 0 $id
7265 if {$autoselect} {
7266 $sha1entry selection range 0 $autosellen
7268 rhighlight_sel $id
7270 $ctext conf -state normal
7271 clear_ctext
7272 set linknum 0
7273 if {![info exists commitinfo($id)]} {
7274 getcommit $id
7276 set info $commitinfo($id)
7277 set date [formatdate [lindex $info 2]]
7278 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7279 set date [formatdate [lindex $info 4]]
7280 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7281 if {[info exists idtags($id)]} {
7282 $ctext insert end [mc "Tags:"]
7283 foreach tag $idtags($id) {
7284 $ctext insert end " $tag"
7286 $ctext insert end "\n"
7289 set headers {}
7290 set olds $parents($curview,$id)
7291 if {[llength $olds] > 1} {
7292 set np 0
7293 foreach p $olds {
7294 if {$np >= $mergemax} {
7295 set tag mmax
7296 } else {
7297 set tag m$np
7299 $ctext insert end "[mc "Parent"]: " $tag
7300 appendwithlinks [commit_descriptor $p] {}
7301 incr np
7303 } else {
7304 foreach p $olds {
7305 append headers "[mc "Parent"]: [commit_descriptor $p]"
7309 foreach c $children($curview,$id) {
7310 append headers "[mc "Child"]: [commit_descriptor $c]"
7313 # make anything that looks like a SHA1 ID be a clickable link
7314 appendwithlinks $headers {}
7315 if {$showneartags} {
7316 if {![info exists allcommits]} {
7317 getallcommits
7319 $ctext insert end "[mc "Branch"]: "
7320 $ctext mark set branch "end -1c"
7321 $ctext mark gravity branch left
7322 $ctext insert end "\n[mc "Follows"]: "
7323 $ctext mark set follows "end -1c"
7324 $ctext mark gravity follows left
7325 $ctext insert end "\n[mc "Precedes"]: "
7326 $ctext mark set precedes "end -1c"
7327 $ctext mark gravity precedes left
7328 $ctext insert end "\n"
7329 dispneartags 1
7331 $ctext insert end "\n"
7332 set comment [lindex $info 5]
7333 if {[string first "\r" $comment] >= 0} {
7334 set comment [string map {"\r" "\n "} $comment]
7336 appendwithlinks $comment {comment}
7338 $ctext tag remove found 1.0 end
7339 $ctext conf -state disabled
7340 set commentend [$ctext index "end - 1c"]
7342 set jump_to_here $desired_loc
7343 init_flist [mc "Comments"]
7344 if {$cmitmode eq "tree"} {
7345 gettree $id
7346 } elseif {$vinlinediff($curview) == 1} {
7347 showinlinediff $id
7348 } elseif {[llength $olds] <= 1} {
7349 startdiff $id
7350 } else {
7351 mergediff $id
7355 proc selfirstline {} {
7356 unmarkmatches
7357 selectline 0 1
7360 proc sellastline {} {
7361 global numcommits
7362 unmarkmatches
7363 set l [expr {$numcommits - 1}]
7364 selectline $l 1
7367 proc selnextline {dir} {
7368 global selectedline
7369 focus .
7370 if {$selectedline eq {}} return
7371 set l [expr {$selectedline + $dir}]
7372 unmarkmatches
7373 selectline $l 1
7376 proc selnextpage {dir} {
7377 global canv linespc selectedline numcommits
7379 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7380 if {$lpp < 1} {
7381 set lpp 1
7383 allcanvs yview scroll [expr {$dir * $lpp}] units
7384 drawvisible
7385 if {$selectedline eq {}} return
7386 set l [expr {$selectedline + $dir * $lpp}]
7387 if {$l < 0} {
7388 set l 0
7389 } elseif {$l >= $numcommits} {
7390 set l [expr $numcommits - 1]
7392 unmarkmatches
7393 selectline $l 1
7396 proc unselectline {} {
7397 global selectedline currentid
7399 set selectedline {}
7400 catch {unset currentid}
7401 allcanvs delete secsel
7402 rhighlight_none
7405 proc reselectline {} {
7406 global selectedline
7408 if {$selectedline ne {}} {
7409 selectline $selectedline 0
7413 proc addtohistory {cmd {saveproc {}}} {
7414 global history historyindex curview
7416 unset_posvars
7417 save_position
7418 set elt [list $curview $cmd $saveproc {}]
7419 if {$historyindex > 0
7420 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7421 return
7424 if {$historyindex < [llength $history]} {
7425 set history [lreplace $history $historyindex end $elt]
7426 } else {
7427 lappend history $elt
7429 incr historyindex
7430 if {$historyindex > 1} {
7431 .tf.bar.leftbut conf -state normal
7432 } else {
7433 .tf.bar.leftbut conf -state disabled
7435 .tf.bar.rightbut conf -state disabled
7438 # save the scrolling position of the diff display pane
7439 proc save_position {} {
7440 global historyindex history
7442 if {$historyindex < 1} return
7443 set hi [expr {$historyindex - 1}]
7444 set fn [lindex $history $hi 2]
7445 if {$fn ne {}} {
7446 lset history $hi 3 [eval $fn]
7450 proc unset_posvars {} {
7451 global last_posvars
7453 if {[info exists last_posvars]} {
7454 foreach {var val} $last_posvars {
7455 global $var
7456 catch {unset $var}
7458 unset last_posvars
7462 proc godo {elt} {
7463 global curview last_posvars
7465 set view [lindex $elt 0]
7466 set cmd [lindex $elt 1]
7467 set pv [lindex $elt 3]
7468 if {$curview != $view} {
7469 showview $view
7471 unset_posvars
7472 foreach {var val} $pv {
7473 global $var
7474 set $var $val
7476 set last_posvars $pv
7477 eval $cmd
7480 proc goback {} {
7481 global history historyindex
7482 focus .
7484 if {$historyindex > 1} {
7485 save_position
7486 incr historyindex -1
7487 godo [lindex $history [expr {$historyindex - 1}]]
7488 .tf.bar.rightbut conf -state normal
7490 if {$historyindex <= 1} {
7491 .tf.bar.leftbut conf -state disabled
7495 proc goforw {} {
7496 global history historyindex
7497 focus .
7499 if {$historyindex < [llength $history]} {
7500 save_position
7501 set cmd [lindex $history $historyindex]
7502 incr historyindex
7503 godo $cmd
7504 .tf.bar.leftbut conf -state normal
7506 if {$historyindex >= [llength $history]} {
7507 .tf.bar.rightbut conf -state disabled
7511 proc go_to_parent {i} {
7512 global parents curview targetid
7513 set ps $parents($curview,$targetid)
7514 if {[llength $ps] >= $i} {
7515 selbyid [lindex $ps [expr $i - 1]]
7519 proc gettree {id} {
7520 global treefilelist treeidlist diffids diffmergeid treepending
7521 global nullid nullid2
7523 set diffids $id
7524 catch {unset diffmergeid}
7525 if {![info exists treefilelist($id)]} {
7526 if {![info exists treepending]} {
7527 if {$id eq $nullid} {
7528 set cmd [list | git ls-files]
7529 } elseif {$id eq $nullid2} {
7530 set cmd [list | git ls-files --stage -t]
7531 } else {
7532 set cmd [list | git ls-tree -r $id]
7534 if {[catch {set gtf [open $cmd r]}]} {
7535 return
7537 set treepending $id
7538 set treefilelist($id) {}
7539 set treeidlist($id) {}
7540 fconfigure $gtf -blocking 0 -encoding binary
7541 filerun $gtf [list gettreeline $gtf $id]
7543 } else {
7544 setfilelist $id
7548 proc gettreeline {gtf id} {
7549 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7551 set nl 0
7552 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7553 if {$diffids eq $nullid} {
7554 set fname $line
7555 } else {
7556 set i [string first "\t" $line]
7557 if {$i < 0} continue
7558 set fname [string range $line [expr {$i+1}] end]
7559 set line [string range $line 0 [expr {$i-1}]]
7560 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7561 set sha1 [lindex $line 2]
7562 lappend treeidlist($id) $sha1
7564 if {[string index $fname 0] eq "\""} {
7565 set fname [lindex $fname 0]
7567 set fname [encoding convertfrom $fname]
7568 lappend treefilelist($id) $fname
7570 if {![eof $gtf]} {
7571 return [expr {$nl >= 1000? 2: 1}]
7573 close $gtf
7574 unset treepending
7575 if {$cmitmode ne "tree"} {
7576 if {![info exists diffmergeid]} {
7577 gettreediffs $diffids
7579 } elseif {$id ne $diffids} {
7580 gettree $diffids
7581 } else {
7582 setfilelist $id
7584 return 0
7587 proc showfile {f} {
7588 global treefilelist treeidlist diffids nullid nullid2
7589 global ctext_file_names ctext_file_lines
7590 global ctext commentend
7592 set i [lsearch -exact $treefilelist($diffids) $f]
7593 if {$i < 0} {
7594 puts "oops, $f not in list for id $diffids"
7595 return
7597 if {$diffids eq $nullid} {
7598 if {[catch {set bf [open $f r]} err]} {
7599 puts "oops, can't read $f: $err"
7600 return
7602 } else {
7603 set blob [lindex $treeidlist($diffids) $i]
7604 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7605 puts "oops, error reading blob $blob: $err"
7606 return
7609 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7610 filerun $bf [list getblobline $bf $diffids]
7611 $ctext config -state normal
7612 clear_ctext $commentend
7613 lappend ctext_file_names $f
7614 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7615 $ctext insert end "\n"
7616 $ctext insert end "$f\n" filesep
7617 $ctext config -state disabled
7618 $ctext yview $commentend
7619 settabs 0
7622 proc getblobline {bf id} {
7623 global diffids cmitmode ctext
7625 if {$id ne $diffids || $cmitmode ne "tree"} {
7626 catch {close $bf}
7627 return 0
7629 $ctext config -state normal
7630 set nl 0
7631 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7632 $ctext insert end "$line\n"
7634 if {[eof $bf]} {
7635 global jump_to_here ctext_file_names commentend
7637 # delete last newline
7638 $ctext delete "end - 2c" "end - 1c"
7639 close $bf
7640 if {$jump_to_here ne {} &&
7641 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7642 set lnum [expr {[lindex $jump_to_here 1] +
7643 [lindex [split $commentend .] 0]}]
7644 mark_ctext_line $lnum
7646 $ctext config -state disabled
7647 return 0
7649 $ctext config -state disabled
7650 return [expr {$nl >= 1000? 2: 1}]
7653 proc mark_ctext_line {lnum} {
7654 global ctext markbgcolor
7656 $ctext tag delete omark
7657 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7658 $ctext tag conf omark -background $markbgcolor
7659 $ctext see $lnum.0
7662 proc mergediff {id} {
7663 global diffmergeid
7664 global diffids treediffs
7665 global parents curview
7667 set diffmergeid $id
7668 set diffids $id
7669 set treediffs($id) {}
7670 set np [llength $parents($curview,$id)]
7671 settabs $np
7672 getblobdiffs $id
7675 proc startdiff {ids} {
7676 global treediffs diffids treepending diffmergeid nullid nullid2
7678 settabs 1
7679 set diffids $ids
7680 catch {unset diffmergeid}
7681 if {![info exists treediffs($ids)] ||
7682 [lsearch -exact $ids $nullid] >= 0 ||
7683 [lsearch -exact $ids $nullid2] >= 0} {
7684 if {![info exists treepending]} {
7685 gettreediffs $ids
7687 } else {
7688 addtocflist $ids
7692 proc showinlinediff {ids} {
7693 global commitinfo commitdata ctext
7694 global treediffs
7696 set info $commitinfo($ids)
7697 set diff [lindex $info 7]
7698 set difflines [split $diff "\n"]
7700 initblobdiffvars
7701 set treediff {}
7703 set inhdr 0
7704 foreach line $difflines {
7705 if {![string compare -length 5 "diff " $line]} {
7706 set inhdr 1
7707 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7708 # offset also accounts for the b/ prefix
7709 lappend treediff [string range $line 6 end]
7710 set inhdr 0
7714 set treediffs($ids) $treediff
7715 add_flist $treediff
7717 $ctext conf -state normal
7718 foreach line $difflines {
7719 parseblobdiffline $ids $line
7721 maybe_scroll_ctext 1
7722 $ctext conf -state disabled
7725 # If the filename (name) is under any of the passed filter paths
7726 # then return true to include the file in the listing.
7727 proc path_filter {filter name} {
7728 set worktree [gitworktree]
7729 foreach p $filter {
7730 set fq_p [file normalize $p]
7731 set fq_n [file normalize [file join $worktree $name]]
7732 if {[string match [file normalize $fq_p]* $fq_n]} {
7733 return 1
7736 return 0
7739 proc addtocflist {ids} {
7740 global treediffs
7742 add_flist $treediffs($ids)
7743 getblobdiffs $ids
7746 proc diffcmd {ids flags} {
7747 global log_showroot nullid nullid2 git_version
7749 set i [lsearch -exact $ids $nullid]
7750 set j [lsearch -exact $ids $nullid2]
7751 if {$i >= 0} {
7752 if {[llength $ids] > 1 && $j < 0} {
7753 # comparing working directory with some specific revision
7754 set cmd [concat | git diff-index $flags]
7755 if {$i == 0} {
7756 lappend cmd -R [lindex $ids 1]
7757 } else {
7758 lappend cmd [lindex $ids 0]
7760 } else {
7761 # comparing working directory with index
7762 set cmd [concat | git diff-files $flags]
7763 if {$j == 1} {
7764 lappend cmd -R
7767 } elseif {$j >= 0} {
7768 if {[package vcompare $git_version "1.7.2"] >= 0} {
7769 set flags "$flags --ignore-submodules=dirty"
7771 set cmd [concat | git diff-index --cached $flags]
7772 if {[llength $ids] > 1} {
7773 # comparing index with specific revision
7774 if {$j == 0} {
7775 lappend cmd -R [lindex $ids 1]
7776 } else {
7777 lappend cmd [lindex $ids 0]
7779 } else {
7780 # comparing index with HEAD
7781 lappend cmd HEAD
7783 } else {
7784 if {$log_showroot} {
7785 lappend flags --root
7787 set cmd [concat | git diff-tree -r $flags $ids]
7789 return $cmd
7792 proc gettreediffs {ids} {
7793 global treediff treepending limitdiffs vfilelimit curview
7795 set cmd [diffcmd $ids {--no-commit-id}]
7796 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7797 set cmd [concat $cmd -- $vfilelimit($curview)]
7799 if {[catch {set gdtf [open $cmd r]}]} return
7801 set treepending $ids
7802 set treediff {}
7803 fconfigure $gdtf -blocking 0 -encoding binary
7804 filerun $gdtf [list gettreediffline $gdtf $ids]
7807 proc gettreediffline {gdtf ids} {
7808 global treediff treediffs treepending diffids diffmergeid
7809 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7811 set nr 0
7812 set sublist {}
7813 set max 1000
7814 if {$perfile_attrs} {
7815 # cache_gitattr is slow, and even slower on win32 where we
7816 # have to invoke it for only about 30 paths at a time
7817 set max 500
7818 if {[tk windowingsystem] == "win32"} {
7819 set max 120
7822 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7823 set i [string first "\t" $line]
7824 if {$i >= 0} {
7825 set file [string range $line [expr {$i+1}] end]
7826 if {[string index $file 0] eq "\""} {
7827 set file [lindex $file 0]
7829 set file [encoding convertfrom $file]
7830 if {$file ne [lindex $treediff end]} {
7831 lappend treediff $file
7832 lappend sublist $file
7836 if {$perfile_attrs} {
7837 cache_gitattr encoding $sublist
7839 if {![eof $gdtf]} {
7840 return [expr {$nr >= $max? 2: 1}]
7842 close $gdtf
7843 set treediffs($ids) $treediff
7844 unset treepending
7845 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7846 gettree $diffids
7847 } elseif {$ids != $diffids} {
7848 if {![info exists diffmergeid]} {
7849 gettreediffs $diffids
7851 } else {
7852 addtocflist $ids
7854 return 0
7857 # empty string or positive integer
7858 proc diffcontextvalidate {v} {
7859 return [regexp {^(|[1-9][0-9]*)$} $v]
7862 proc diffcontextchange {n1 n2 op} {
7863 global diffcontextstring diffcontext
7865 if {[string is integer -strict $diffcontextstring]} {
7866 if {$diffcontextstring >= 0} {
7867 set diffcontext $diffcontextstring
7868 reselectline
7873 proc changeignorespace {} {
7874 reselectline
7877 proc changeworddiff {name ix op} {
7878 reselectline
7881 proc initblobdiffvars {} {
7882 global diffencoding targetline diffnparents
7883 global diffinhdr currdiffsubmod diffseehere
7884 set targetline {}
7885 set diffnparents 0
7886 set diffinhdr 0
7887 set diffencoding [get_path_encoding {}]
7888 set currdiffsubmod ""
7889 set diffseehere -1
7892 proc getblobdiffs {ids} {
7893 global blobdifffd diffids env
7894 global treediffs
7895 global diffcontext
7896 global ignorespace
7897 global worddiff
7898 global limitdiffs vfilelimit curview
7899 global git_version
7901 set textconv {}
7902 if {[package vcompare $git_version "1.6.1"] >= 0} {
7903 set textconv "--textconv"
7905 set submodule {}
7906 if {[package vcompare $git_version "1.6.6"] >= 0} {
7907 set submodule "--submodule"
7909 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7910 if {$ignorespace} {
7911 append cmd " -w"
7913 if {$worddiff ne [mc "Line diff"]} {
7914 append cmd " --word-diff=porcelain"
7916 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7917 set cmd [concat $cmd -- $vfilelimit($curview)]
7919 if {[catch {set bdf [open $cmd r]} err]} {
7920 error_popup [mc "Error getting diffs: %s" $err]
7921 return
7923 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7924 set blobdifffd($ids) $bdf
7925 initblobdiffvars
7926 filerun $bdf [list getblobdiffline $bdf $diffids]
7929 proc savecmitpos {} {
7930 global ctext cmitmode
7932 if {$cmitmode eq "tree"} {
7933 return {}
7935 return [list target_scrollpos [$ctext index @0,0]]
7938 proc savectextpos {} {
7939 global ctext
7941 return [list target_scrollpos [$ctext index @0,0]]
7944 proc maybe_scroll_ctext {ateof} {
7945 global ctext target_scrollpos
7947 if {![info exists target_scrollpos]} return
7948 if {!$ateof} {
7949 set nlines [expr {[winfo height $ctext]
7950 / [font metrics textfont -linespace]}]
7951 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7953 $ctext yview $target_scrollpos
7954 unset target_scrollpos
7957 proc setinlist {var i val} {
7958 global $var
7960 while {[llength [set $var]] < $i} {
7961 lappend $var {}
7963 if {[llength [set $var]] == $i} {
7964 lappend $var $val
7965 } else {
7966 lset $var $i $val
7970 proc makediffhdr {fname ids} {
7971 global ctext curdiffstart treediffs diffencoding
7972 global ctext_file_names jump_to_here targetline diffline
7974 set fname [encoding convertfrom $fname]
7975 set diffencoding [get_path_encoding $fname]
7976 set i [lsearch -exact $treediffs($ids) $fname]
7977 if {$i >= 0} {
7978 setinlist difffilestart $i $curdiffstart
7980 lset ctext_file_names end $fname
7981 set l [expr {(78 - [string length $fname]) / 2}]
7982 set pad [string range "----------------------------------------" 1 $l]
7983 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7984 set targetline {}
7985 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7986 set targetline [lindex $jump_to_here 1]
7988 set diffline 0
7991 proc blobdiffmaybeseehere {ateof} {
7992 global diffseehere
7993 if {$diffseehere >= 0} {
7994 mark_ctext_line [lindex [split $diffseehere .] 0]
7996 maybe_scroll_ctext $ateof
7999 proc getblobdiffline {bdf ids} {
8000 global diffids blobdifffd
8001 global ctext
8003 set nr 0
8004 $ctext conf -state normal
8005 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8006 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8007 catch {close $bdf}
8008 return 0
8010 parseblobdiffline $ids $line
8012 $ctext conf -state disabled
8013 blobdiffmaybeseehere [eof $bdf]
8014 if {[eof $bdf]} {
8015 catch {close $bdf}
8016 return 0
8018 return [expr {$nr >= 1000? 2: 1}]
8021 proc parseblobdiffline {ids line} {
8022 global ctext curdiffstart
8023 global diffnexthead diffnextnote difffilestart
8024 global ctext_file_names ctext_file_lines
8025 global diffinhdr treediffs mergemax diffnparents
8026 global diffencoding jump_to_here targetline diffline currdiffsubmod
8027 global worddiff diffseehere
8029 if {![string compare -length 5 "diff " $line]} {
8030 if {![regexp {^diff (--cc|--git) } $line m type]} {
8031 set line [encoding convertfrom $line]
8032 $ctext insert end "$line\n" hunksep
8033 continue
8035 # start of a new file
8036 set diffinhdr 1
8037 $ctext insert end "\n"
8038 set curdiffstart [$ctext index "end - 1c"]
8039 lappend ctext_file_names ""
8040 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8041 $ctext insert end "\n" filesep
8043 if {$type eq "--cc"} {
8044 # start of a new file in a merge diff
8045 set fname [string range $line 10 end]
8046 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8047 lappend treediffs($ids) $fname
8048 add_flist [list $fname]
8051 } else {
8052 set line [string range $line 11 end]
8053 # If the name hasn't changed the length will be odd,
8054 # the middle char will be a space, and the two bits either
8055 # side will be a/name and b/name, or "a/name" and "b/name".
8056 # If the name has changed we'll get "rename from" and
8057 # "rename to" or "copy from" and "copy to" lines following
8058 # this, and we'll use them to get the filenames.
8059 # This complexity is necessary because spaces in the
8060 # filename(s) don't get escaped.
8061 set l [string length $line]
8062 set i [expr {$l / 2}]
8063 if {!(($l & 1) && [string index $line $i] eq " " &&
8064 [string range $line 2 [expr {$i - 1}]] eq \
8065 [string range $line [expr {$i + 3}] end])} {
8066 return
8068 # unescape if quoted and chop off the a/ from the front
8069 if {[string index $line 0] eq "\""} {
8070 set fname [string range [lindex $line 0] 2 end]
8071 } else {
8072 set fname [string range $line 2 [expr {$i - 1}]]
8075 makediffhdr $fname $ids
8077 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8078 set fname [encoding convertfrom [string range $line 16 end]]
8079 $ctext insert end "\n"
8080 set curdiffstart [$ctext index "end - 1c"]
8081 lappend ctext_file_names $fname
8082 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8083 $ctext insert end "$line\n" filesep
8084 set i [lsearch -exact $treediffs($ids) $fname]
8085 if {$i >= 0} {
8086 setinlist difffilestart $i $curdiffstart
8089 } elseif {![string compare -length 2 "@@" $line]} {
8090 regexp {^@@+} $line ats
8091 set line [encoding convertfrom $diffencoding $line]
8092 $ctext insert end "$line\n" hunksep
8093 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8094 set diffline $nl
8096 set diffnparents [expr {[string length $ats] - 1}]
8097 set diffinhdr 0
8099 } elseif {![string compare -length 10 "Submodule " $line]} {
8100 # start of a new submodule
8101 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8102 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8103 } else {
8104 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8106 if {$currdiffsubmod != $fname} {
8107 $ctext insert end "\n"; # Add newline after commit message
8109 set curdiffstart [$ctext index "end - 1c"]
8110 lappend ctext_file_names ""
8111 if {$currdiffsubmod != $fname} {
8112 lappend ctext_file_lines $fname
8113 makediffhdr $fname $ids
8114 set currdiffsubmod $fname
8115 $ctext insert end "\n$line\n" filesep
8116 } else {
8117 $ctext insert end "$line\n" filesep
8119 } elseif {![string compare -length 3 " >" $line]} {
8120 set $currdiffsubmod ""
8121 set line [encoding convertfrom $diffencoding $line]
8122 $ctext insert end "$line\n" dresult
8123 } elseif {![string compare -length 3 " <" $line]} {
8124 set $currdiffsubmod ""
8125 set line [encoding convertfrom $diffencoding $line]
8126 $ctext insert end "$line\n" d0
8127 } elseif {$diffinhdr} {
8128 if {![string compare -length 12 "rename from " $line]} {
8129 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8130 if {[string index $fname 0] eq "\""} {
8131 set fname [lindex $fname 0]
8133 set fname [encoding convertfrom $fname]
8134 set i [lsearch -exact $treediffs($ids) $fname]
8135 if {$i >= 0} {
8136 setinlist difffilestart $i $curdiffstart
8138 } elseif {![string compare -length 10 $line "rename to "] ||
8139 ![string compare -length 8 $line "copy to "]} {
8140 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8141 if {[string index $fname 0] eq "\""} {
8142 set fname [lindex $fname 0]
8144 makediffhdr $fname $ids
8145 } elseif {[string compare -length 3 $line "---"] == 0} {
8146 # do nothing
8147 return
8148 } elseif {[string compare -length 3 $line "+++"] == 0} {
8149 set diffinhdr 0
8150 return
8152 $ctext insert end "$line\n" filesep
8154 } else {
8155 set line [string map {\x1A ^Z} \
8156 [encoding convertfrom $diffencoding $line]]
8157 # parse the prefix - one ' ', '-' or '+' for each parent
8158 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8159 set tag [expr {$diffnparents > 1? "m": "d"}]
8160 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8161 set words_pre_markup ""
8162 set words_post_markup ""
8163 if {[string trim $prefix " -+"] eq {}} {
8164 # prefix only has " ", "-" and "+" in it: normal diff line
8165 set num [string first "-" $prefix]
8166 if {$dowords} {
8167 set line [string range $line 1 end]
8169 if {$num >= 0} {
8170 # removed line, first parent with line is $num
8171 if {$num >= $mergemax} {
8172 set num "max"
8174 if {$dowords && $worddiff eq [mc "Markup words"]} {
8175 $ctext insert end "\[-$line-\]" $tag$num
8176 } else {
8177 $ctext insert end "$line" $tag$num
8179 if {!$dowords} {
8180 $ctext insert end "\n" $tag$num
8182 } else {
8183 set tags {}
8184 if {[string first "+" $prefix] >= 0} {
8185 # added line
8186 lappend tags ${tag}result
8187 if {$diffnparents > 1} {
8188 set num [string first " " $prefix]
8189 if {$num >= 0} {
8190 if {$num >= $mergemax} {
8191 set num "max"
8193 lappend tags m$num
8196 set words_pre_markup "{+"
8197 set words_post_markup "+}"
8199 if {$targetline ne {}} {
8200 if {$diffline == $targetline} {
8201 set diffseehere [$ctext index "end - 1 chars"]
8202 set targetline {}
8203 } else {
8204 incr diffline
8207 if {$dowords && $worddiff eq [mc "Markup words"]} {
8208 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8209 } else {
8210 $ctext insert end "$line" $tags
8212 if {!$dowords} {
8213 $ctext insert end "\n" $tags
8216 } elseif {$dowords && $prefix eq "~"} {
8217 $ctext insert end "\n" {}
8218 } else {
8219 # "\ No newline at end of file",
8220 # or something else we don't recognize
8221 $ctext insert end "$line\n" hunksep
8226 proc changediffdisp {} {
8227 global ctext diffelide
8229 $ctext tag conf d0 -elide [lindex $diffelide 0]
8230 $ctext tag conf dresult -elide [lindex $diffelide 1]
8233 proc highlightfile {cline} {
8234 global cflist cflist_top
8236 if {![info exists cflist_top]} return
8238 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8239 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8240 $cflist see $cline.0
8241 set cflist_top $cline
8244 proc highlightfile_for_scrollpos {topidx} {
8245 global cmitmode difffilestart
8247 if {$cmitmode eq "tree"} return
8248 if {![info exists difffilestart]} return
8250 set top [lindex [split $topidx .] 0]
8251 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8252 highlightfile 0
8253 } else {
8254 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8258 proc prevfile {} {
8259 global difffilestart ctext cmitmode
8261 if {$cmitmode eq "tree"} return
8262 set prev 0.0
8263 set here [$ctext index @0,0]
8264 foreach loc $difffilestart {
8265 if {[$ctext compare $loc >= $here]} {
8266 $ctext yview $prev
8267 return
8269 set prev $loc
8271 $ctext yview $prev
8274 proc nextfile {} {
8275 global difffilestart ctext cmitmode
8277 if {$cmitmode eq "tree"} return
8278 set here [$ctext index @0,0]
8279 foreach loc $difffilestart {
8280 if {[$ctext compare $loc > $here]} {
8281 $ctext yview $loc
8282 return
8287 proc clear_ctext {{first 1.0}} {
8288 global ctext smarktop smarkbot
8289 global ctext_file_names ctext_file_lines
8290 global pendinglinks
8292 set l [lindex [split $first .] 0]
8293 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8294 set smarktop $l
8296 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8297 set smarkbot $l
8299 $ctext delete $first end
8300 if {$first eq "1.0"} {
8301 catch {unset pendinglinks}
8303 set ctext_file_names {}
8304 set ctext_file_lines {}
8307 proc settabs {{firstab {}}} {
8308 global firsttabstop tabstop ctext have_tk85
8310 if {$firstab ne {} && $have_tk85} {
8311 set firsttabstop $firstab
8313 set w [font measure textfont "0"]
8314 if {$firsttabstop != 0} {
8315 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8316 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8317 } elseif {$have_tk85 || $tabstop != 8} {
8318 $ctext conf -tabs [expr {$tabstop * $w}]
8319 } else {
8320 $ctext conf -tabs {}
8324 proc incrsearch {name ix op} {
8325 global ctext searchstring searchdirn
8327 if {[catch {$ctext index anchor}]} {
8328 # no anchor set, use start of selection, or of visible area
8329 set sel [$ctext tag ranges sel]
8330 if {$sel ne {}} {
8331 $ctext mark set anchor [lindex $sel 0]
8332 } elseif {$searchdirn eq "-forwards"} {
8333 $ctext mark set anchor @0,0
8334 } else {
8335 $ctext mark set anchor @0,[winfo height $ctext]
8338 if {$searchstring ne {}} {
8339 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8340 if {$here ne {}} {
8341 $ctext see $here
8342 set mend "$here + $mlen c"
8343 $ctext tag remove sel 1.0 end
8344 $ctext tag add sel $here $mend
8345 suppress_highlighting_file_for_current_scrollpos
8346 highlightfile_for_scrollpos $here
8349 rehighlight_search_results
8352 proc dosearch {} {
8353 global sstring ctext searchstring searchdirn
8355 focus $sstring
8356 $sstring icursor end
8357 set searchdirn -forwards
8358 if {$searchstring ne {}} {
8359 set sel [$ctext tag ranges sel]
8360 if {$sel ne {}} {
8361 set start "[lindex $sel 0] + 1c"
8362 } elseif {[catch {set start [$ctext index anchor]}]} {
8363 set start "@0,0"
8365 set match [$ctext search -count mlen -- $searchstring $start]
8366 $ctext tag remove sel 1.0 end
8367 if {$match eq {}} {
8368 bell
8369 return
8371 $ctext see $match
8372 suppress_highlighting_file_for_current_scrollpos
8373 highlightfile_for_scrollpos $match
8374 set mend "$match + $mlen c"
8375 $ctext tag add sel $match $mend
8376 $ctext mark unset anchor
8377 rehighlight_search_results
8381 proc dosearchback {} {
8382 global sstring ctext searchstring searchdirn
8384 focus $sstring
8385 $sstring icursor end
8386 set searchdirn -backwards
8387 if {$searchstring ne {}} {
8388 set sel [$ctext tag ranges sel]
8389 if {$sel ne {}} {
8390 set start [lindex $sel 0]
8391 } elseif {[catch {set start [$ctext index anchor]}]} {
8392 set start @0,[winfo height $ctext]
8394 set match [$ctext search -backwards -count ml -- $searchstring $start]
8395 $ctext tag remove sel 1.0 end
8396 if {$match eq {}} {
8397 bell
8398 return
8400 $ctext see $match
8401 suppress_highlighting_file_for_current_scrollpos
8402 highlightfile_for_scrollpos $match
8403 set mend "$match + $ml c"
8404 $ctext tag add sel $match $mend
8405 $ctext mark unset anchor
8406 rehighlight_search_results
8410 proc rehighlight_search_results {} {
8411 global ctext searchstring
8413 $ctext tag remove found 1.0 end
8414 $ctext tag remove currentsearchhit 1.0 end
8416 if {$searchstring ne {}} {
8417 searchmarkvisible 1
8421 proc searchmark {first last} {
8422 global ctext searchstring
8424 set sel [$ctext tag ranges sel]
8426 set mend $first.0
8427 while {1} {
8428 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8429 if {$match eq {}} break
8430 set mend "$match + $mlen c"
8431 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8432 $ctext tag add currentsearchhit $match $mend
8433 } else {
8434 $ctext tag add found $match $mend
8439 proc searchmarkvisible {doall} {
8440 global ctext smarktop smarkbot
8442 set topline [lindex [split [$ctext index @0,0] .] 0]
8443 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8444 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8445 # no overlap with previous
8446 searchmark $topline $botline
8447 set smarktop $topline
8448 set smarkbot $botline
8449 } else {
8450 if {$topline < $smarktop} {
8451 searchmark $topline [expr {$smarktop-1}]
8452 set smarktop $topline
8454 if {$botline > $smarkbot} {
8455 searchmark [expr {$smarkbot+1}] $botline
8456 set smarkbot $botline
8461 proc suppress_highlighting_file_for_current_scrollpos {} {
8462 global ctext suppress_highlighting_file_for_this_scrollpos
8464 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8467 proc scrolltext {f0 f1} {
8468 global searchstring cmitmode ctext
8469 global suppress_highlighting_file_for_this_scrollpos
8471 set topidx [$ctext index @0,0]
8472 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8473 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8474 highlightfile_for_scrollpos $topidx
8477 catch {unset suppress_highlighting_file_for_this_scrollpos}
8479 .bleft.bottom.sb set $f0 $f1
8480 if {$searchstring ne {}} {
8481 searchmarkvisible 0
8485 proc setcoords {} {
8486 global linespc charspc canvx0 canvy0
8487 global xspc1 xspc2 lthickness
8489 set linespc [font metrics mainfont -linespace]
8490 set charspc [font measure mainfont "m"]
8491 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8492 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8493 set lthickness [expr {int($linespc / 9) + 1}]
8494 set xspc1(0) $linespc
8495 set xspc2 $linespc
8498 proc redisplay {} {
8499 global canv
8500 global selectedline
8502 set ymax [lindex [$canv cget -scrollregion] 3]
8503 if {$ymax eq {} || $ymax == 0} return
8504 set span [$canv yview]
8505 clear_display
8506 setcanvscroll
8507 allcanvs yview moveto [lindex $span 0]
8508 drawvisible
8509 if {$selectedline ne {}} {
8510 selectline $selectedline 0
8511 allcanvs yview moveto [lindex $span 0]
8515 proc parsefont {f n} {
8516 global fontattr
8518 set fontattr($f,family) [lindex $n 0]
8519 set s [lindex $n 1]
8520 if {$s eq {} || $s == 0} {
8521 set s 10
8522 } elseif {$s < 0} {
8523 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8525 set fontattr($f,size) $s
8526 set fontattr($f,weight) normal
8527 set fontattr($f,slant) roman
8528 foreach style [lrange $n 2 end] {
8529 switch -- $style {
8530 "normal" -
8531 "bold" {set fontattr($f,weight) $style}
8532 "roman" -
8533 "italic" {set fontattr($f,slant) $style}
8538 proc fontflags {f {isbold 0}} {
8539 global fontattr
8541 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8542 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8543 -slant $fontattr($f,slant)]
8546 proc fontname {f} {
8547 global fontattr
8549 set n [list $fontattr($f,family) $fontattr($f,size)]
8550 if {$fontattr($f,weight) eq "bold"} {
8551 lappend n "bold"
8553 if {$fontattr($f,slant) eq "italic"} {
8554 lappend n "italic"
8556 return $n
8559 proc incrfont {inc} {
8560 global mainfont textfont ctext canv cflist showrefstop
8561 global stopped entries fontattr
8563 unmarkmatches
8564 set s $fontattr(mainfont,size)
8565 incr s $inc
8566 if {$s < 1} {
8567 set s 1
8569 set fontattr(mainfont,size) $s
8570 font config mainfont -size $s
8571 font config mainfontbold -size $s
8572 set mainfont [fontname mainfont]
8573 set s $fontattr(textfont,size)
8574 incr s $inc
8575 if {$s < 1} {
8576 set s 1
8578 set fontattr(textfont,size) $s
8579 font config textfont -size $s
8580 font config textfontbold -size $s
8581 set textfont [fontname textfont]
8582 setcoords
8583 settabs
8584 redisplay
8587 proc clearsha1 {} {
8588 global sha1entry sha1string
8589 if {[string length $sha1string] == 40} {
8590 $sha1entry delete 0 end
8594 proc sha1change {n1 n2 op} {
8595 global sha1string currentid sha1but
8596 if {$sha1string == {}
8597 || ([info exists currentid] && $sha1string == $currentid)} {
8598 set state disabled
8599 } else {
8600 set state normal
8602 if {[$sha1but cget -state] == $state} return
8603 if {$state == "normal"} {
8604 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8605 } else {
8606 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8610 proc gotocommit {} {
8611 global sha1string tagids headids curview varcid
8613 if {$sha1string == {}
8614 || ([info exists currentid] && $sha1string == $currentid)} return
8615 if {[info exists tagids($sha1string)]} {
8616 set id $tagids($sha1string)
8617 } elseif {[info exists headids($sha1string)]} {
8618 set id $headids($sha1string)
8619 } else {
8620 set id [string tolower $sha1string]
8621 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8622 set matches [longid $id]
8623 if {$matches ne {}} {
8624 if {[llength $matches] > 1} {
8625 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8626 return
8628 set id [lindex $matches 0]
8630 } else {
8631 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8632 error_popup [mc "Revision %s is not known" $sha1string]
8633 return
8637 if {[commitinview $id $curview]} {
8638 selectline [rowofcommit $id] 1
8639 return
8641 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8642 set msg [mc "SHA1 id %s is not known" $sha1string]
8643 } else {
8644 set msg [mc "Revision %s is not in the current view" $sha1string]
8646 error_popup $msg
8649 proc lineenter {x y id} {
8650 global hoverx hovery hoverid hovertimer
8651 global commitinfo canv
8653 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8654 set hoverx $x
8655 set hovery $y
8656 set hoverid $id
8657 if {[info exists hovertimer]} {
8658 after cancel $hovertimer
8660 set hovertimer [after 500 linehover]
8661 $canv delete hover
8664 proc linemotion {x y id} {
8665 global hoverx hovery hoverid hovertimer
8667 if {[info exists hoverid] && $id == $hoverid} {
8668 set hoverx $x
8669 set hovery $y
8670 if {[info exists hovertimer]} {
8671 after cancel $hovertimer
8673 set hovertimer [after 500 linehover]
8677 proc lineleave {id} {
8678 global hoverid hovertimer canv
8680 if {[info exists hoverid] && $id == $hoverid} {
8681 $canv delete hover
8682 if {[info exists hovertimer]} {
8683 after cancel $hovertimer
8684 unset hovertimer
8686 unset hoverid
8690 proc linehover {} {
8691 global hoverx hovery hoverid hovertimer
8692 global canv linespc lthickness
8693 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8695 global commitinfo
8697 set text [lindex $commitinfo($hoverid) 0]
8698 set ymax [lindex [$canv cget -scrollregion] 3]
8699 if {$ymax == {}} return
8700 set yfrac [lindex [$canv yview] 0]
8701 set x [expr {$hoverx + 2 * $linespc}]
8702 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8703 set x0 [expr {$x - 2 * $lthickness}]
8704 set y0 [expr {$y - 2 * $lthickness}]
8705 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8706 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8707 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8708 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8709 -width 1 -tags hover]
8710 $canv raise $t
8711 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8712 -font mainfont -fill $linehoverfgcolor]
8713 $canv raise $t
8716 proc clickisonarrow {id y} {
8717 global lthickness
8719 set ranges [rowranges $id]
8720 set thresh [expr {2 * $lthickness + 6}]
8721 set n [expr {[llength $ranges] - 1}]
8722 for {set i 1} {$i < $n} {incr i} {
8723 set row [lindex $ranges $i]
8724 if {abs([yc $row] - $y) < $thresh} {
8725 return $i
8728 return {}
8731 proc arrowjump {id n y} {
8732 global canv
8734 # 1 <-> 2, 3 <-> 4, etc...
8735 set n [expr {(($n - 1) ^ 1) + 1}]
8736 set row [lindex [rowranges $id] $n]
8737 set yt [yc $row]
8738 set ymax [lindex [$canv cget -scrollregion] 3]
8739 if {$ymax eq {} || $ymax <= 0} return
8740 set view [$canv yview]
8741 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8742 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8743 if {$yfrac < 0} {
8744 set yfrac 0
8746 allcanvs yview moveto $yfrac
8749 proc lineclick {x y id isnew} {
8750 global ctext commitinfo children canv thickerline curview
8752 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8753 unmarkmatches
8754 unselectline
8755 normalline
8756 $canv delete hover
8757 # draw this line thicker than normal
8758 set thickerline $id
8759 drawlines $id
8760 if {$isnew} {
8761 set ymax [lindex [$canv cget -scrollregion] 3]
8762 if {$ymax eq {}} return
8763 set yfrac [lindex [$canv yview] 0]
8764 set y [expr {$y + $yfrac * $ymax}]
8766 set dirn [clickisonarrow $id $y]
8767 if {$dirn ne {}} {
8768 arrowjump $id $dirn $y
8769 return
8772 if {$isnew} {
8773 addtohistory [list lineclick $x $y $id 0] savectextpos
8775 # fill the details pane with info about this line
8776 $ctext conf -state normal
8777 clear_ctext
8778 settabs 0
8779 $ctext insert end "[mc "Parent"]:\t"
8780 $ctext insert end $id link0
8781 setlink $id link0
8782 set info $commitinfo($id)
8783 $ctext insert end "\n\t[lindex $info 0]\n"
8784 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8785 set date [formatdate [lindex $info 2]]
8786 $ctext insert end "\t[mc "Date"]:\t$date\n"
8787 set kids $children($curview,$id)
8788 if {$kids ne {}} {
8789 $ctext insert end "\n[mc "Children"]:"
8790 set i 0
8791 foreach child $kids {
8792 incr i
8793 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8794 set info $commitinfo($child)
8795 $ctext insert end "\n\t"
8796 $ctext insert end $child link$i
8797 setlink $child link$i
8798 $ctext insert end "\n\t[lindex $info 0]"
8799 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8800 set date [formatdate [lindex $info 2]]
8801 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8804 maybe_scroll_ctext 1
8805 $ctext conf -state disabled
8806 init_flist {}
8809 proc normalline {} {
8810 global thickerline
8811 if {[info exists thickerline]} {
8812 set id $thickerline
8813 unset thickerline
8814 drawlines $id
8818 proc selbyid {id {isnew 1}} {
8819 global curview
8820 if {[commitinview $id $curview]} {
8821 selectline [rowofcommit $id] $isnew
8825 proc mstime {} {
8826 global startmstime
8827 if {![info exists startmstime]} {
8828 set startmstime [clock clicks -milliseconds]
8830 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8833 proc rowmenu {x y id} {
8834 global rowctxmenu selectedline rowmenuid curview
8835 global nullid nullid2 fakerowmenu mainhead markedid
8837 stopfinding
8838 set rowmenuid $id
8839 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8840 set state disabled
8841 } else {
8842 set state normal
8844 if {[info exists markedid] && $markedid ne $id} {
8845 set mstate normal
8846 } else {
8847 set mstate disabled
8849 if {$id ne $nullid && $id ne $nullid2} {
8850 set menu $rowctxmenu
8851 if {$mainhead ne {}} {
8852 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8853 } else {
8854 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8856 $menu entryconfigure 9 -state $mstate
8857 $menu entryconfigure 10 -state $mstate
8858 $menu entryconfigure 11 -state $mstate
8859 } else {
8860 set menu $fakerowmenu
8862 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8863 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8864 $menu entryconfigure [mca "Make patch"] -state $state
8865 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8866 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8867 tk_popup $menu $x $y
8870 proc markhere {} {
8871 global rowmenuid markedid canv
8873 set markedid $rowmenuid
8874 make_idmark $markedid
8877 proc gotomark {} {
8878 global markedid
8880 if {[info exists markedid]} {
8881 selbyid $markedid
8885 proc replace_by_kids {l r} {
8886 global curview children
8888 set id [commitonrow $r]
8889 set l [lreplace $l 0 0]
8890 foreach kid $children($curview,$id) {
8891 lappend l [rowofcommit $kid]
8893 return [lsort -integer -decreasing -unique $l]
8896 proc find_common_desc {} {
8897 global markedid rowmenuid curview children
8899 if {![info exists markedid]} return
8900 if {![commitinview $markedid $curview] ||
8901 ![commitinview $rowmenuid $curview]} return
8902 #set t1 [clock clicks -milliseconds]
8903 set l1 [list [rowofcommit $markedid]]
8904 set l2 [list [rowofcommit $rowmenuid]]
8905 while 1 {
8906 set r1 [lindex $l1 0]
8907 set r2 [lindex $l2 0]
8908 if {$r1 eq {} || $r2 eq {}} break
8909 if {$r1 == $r2} {
8910 selectline $r1 1
8911 break
8913 if {$r1 > $r2} {
8914 set l1 [replace_by_kids $l1 $r1]
8915 } else {
8916 set l2 [replace_by_kids $l2 $r2]
8919 #set t2 [clock clicks -milliseconds]
8920 #puts "took [expr {$t2-$t1}]ms"
8923 proc compare_commits {} {
8924 global markedid rowmenuid curview children
8926 if {![info exists markedid]} return
8927 if {![commitinview $markedid $curview]} return
8928 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8929 do_cmp_commits $markedid $rowmenuid
8932 proc getpatchid {id} {
8933 global patchids
8935 if {![info exists patchids($id)]} {
8936 set cmd [diffcmd [list $id] {-p --root}]
8937 # trim off the initial "|"
8938 set cmd [lrange $cmd 1 end]
8939 if {[catch {
8940 set x [eval exec $cmd | git patch-id]
8941 set patchids($id) [lindex $x 0]
8942 }]} {
8943 set patchids($id) "error"
8946 return $patchids($id)
8949 proc do_cmp_commits {a b} {
8950 global ctext curview parents children patchids commitinfo
8952 $ctext conf -state normal
8953 clear_ctext
8954 init_flist {}
8955 for {set i 0} {$i < 100} {incr i} {
8956 set skipa 0
8957 set skipb 0
8958 if {[llength $parents($curview,$a)] > 1} {
8959 appendshortlink $a [mc "Skipping merge commit "] "\n"
8960 set skipa 1
8961 } else {
8962 set patcha [getpatchid $a]
8964 if {[llength $parents($curview,$b)] > 1} {
8965 appendshortlink $b [mc "Skipping merge commit "] "\n"
8966 set skipb 1
8967 } else {
8968 set patchb [getpatchid $b]
8970 if {!$skipa && !$skipb} {
8971 set heada [lindex $commitinfo($a) 0]
8972 set headb [lindex $commitinfo($b) 0]
8973 if {$patcha eq "error"} {
8974 appendshortlink $a [mc "Error getting patch ID for "] \
8975 [mc " - stopping\n"]
8976 break
8978 if {$patchb eq "error"} {
8979 appendshortlink $b [mc "Error getting patch ID for "] \
8980 [mc " - stopping\n"]
8981 break
8983 if {$patcha eq $patchb} {
8984 if {$heada eq $headb} {
8985 appendshortlink $a [mc "Commit "]
8986 appendshortlink $b " == " " $heada\n"
8987 } else {
8988 appendshortlink $a [mc "Commit "] " $heada\n"
8989 appendshortlink $b [mc " is the same patch as\n "] \
8990 " $headb\n"
8992 set skipa 1
8993 set skipb 1
8994 } else {
8995 $ctext insert end "\n"
8996 appendshortlink $a [mc "Commit "] " $heada\n"
8997 appendshortlink $b [mc " differs from\n "] \
8998 " $headb\n"
8999 $ctext insert end [mc "Diff of commits:\n\n"]
9000 $ctext conf -state disabled
9001 update
9002 diffcommits $a $b
9003 return
9006 if {$skipa} {
9007 set kids [real_children $curview,$a]
9008 if {[llength $kids] != 1} {
9009 $ctext insert end "\n"
9010 appendshortlink $a [mc "Commit "] \
9011 [mc " has %s children - stopping\n" [llength $kids]]
9012 break
9014 set a [lindex $kids 0]
9016 if {$skipb} {
9017 set kids [real_children $curview,$b]
9018 if {[llength $kids] != 1} {
9019 appendshortlink $b [mc "Commit "] \
9020 [mc " has %s children - stopping\n" [llength $kids]]
9021 break
9023 set b [lindex $kids 0]
9026 $ctext conf -state disabled
9029 proc diffcommits {a b} {
9030 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9032 set tmpdir [gitknewtmpdir]
9033 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9034 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9035 if {[catch {
9036 exec git diff-tree -p --pretty $a >$fna
9037 exec git diff-tree -p --pretty $b >$fnb
9038 } err]} {
9039 error_popup [mc "Error writing commit to file: %s" $err]
9040 return
9042 if {[catch {
9043 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9044 } err]} {
9045 error_popup [mc "Error diffing commits: %s" $err]
9046 return
9048 set diffids [list commits $a $b]
9049 set blobdifffd($diffids) $fd
9050 set diffinhdr 0
9051 set currdiffsubmod ""
9052 filerun $fd [list getblobdiffline $fd $diffids]
9055 proc diffvssel {dirn} {
9056 global rowmenuid selectedline
9058 if {$selectedline eq {}} return
9059 if {$dirn} {
9060 set oldid [commitonrow $selectedline]
9061 set newid $rowmenuid
9062 } else {
9063 set oldid $rowmenuid
9064 set newid [commitonrow $selectedline]
9066 addtohistory [list doseldiff $oldid $newid] savectextpos
9067 doseldiff $oldid $newid
9070 proc diffvsmark {dirn} {
9071 global rowmenuid markedid
9073 if {![info exists markedid]} return
9074 if {$dirn} {
9075 set oldid $markedid
9076 set newid $rowmenuid
9077 } else {
9078 set oldid $rowmenuid
9079 set newid $markedid
9081 addtohistory [list doseldiff $oldid $newid] savectextpos
9082 doseldiff $oldid $newid
9085 proc doseldiff {oldid newid} {
9086 global ctext
9087 global commitinfo
9089 $ctext conf -state normal
9090 clear_ctext
9091 init_flist [mc "Top"]
9092 $ctext insert end "[mc "From"] "
9093 $ctext insert end $oldid link0
9094 setlink $oldid link0
9095 $ctext insert end "\n "
9096 $ctext insert end [lindex $commitinfo($oldid) 0]
9097 $ctext insert end "\n\n[mc "To"] "
9098 $ctext insert end $newid link1
9099 setlink $newid link1
9100 $ctext insert end "\n "
9101 $ctext insert end [lindex $commitinfo($newid) 0]
9102 $ctext insert end "\n"
9103 $ctext conf -state disabled
9104 $ctext tag remove found 1.0 end
9105 startdiff [list $oldid $newid]
9108 proc mkpatch {} {
9109 global rowmenuid currentid commitinfo patchtop patchnum NS
9111 if {![info exists currentid]} return
9112 set oldid $currentid
9113 set oldhead [lindex $commitinfo($oldid) 0]
9114 set newid $rowmenuid
9115 set newhead [lindex $commitinfo($newid) 0]
9116 set top .patch
9117 set patchtop $top
9118 catch {destroy $top}
9119 ttk_toplevel $top
9120 make_transient $top .
9121 ${NS}::label $top.title -text [mc "Generate patch"]
9122 grid $top.title - -pady 10
9123 ${NS}::label $top.from -text [mc "From:"]
9124 ${NS}::entry $top.fromsha1 -width 40
9125 $top.fromsha1 insert 0 $oldid
9126 $top.fromsha1 conf -state readonly
9127 grid $top.from $top.fromsha1 -sticky w
9128 ${NS}::entry $top.fromhead -width 60
9129 $top.fromhead insert 0 $oldhead
9130 $top.fromhead conf -state readonly
9131 grid x $top.fromhead -sticky w
9132 ${NS}::label $top.to -text [mc "To:"]
9133 ${NS}::entry $top.tosha1 -width 40
9134 $top.tosha1 insert 0 $newid
9135 $top.tosha1 conf -state readonly
9136 grid $top.to $top.tosha1 -sticky w
9137 ${NS}::entry $top.tohead -width 60
9138 $top.tohead insert 0 $newhead
9139 $top.tohead conf -state readonly
9140 grid x $top.tohead -sticky w
9141 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9142 grid $top.rev x -pady 10 -padx 5
9143 ${NS}::label $top.flab -text [mc "Output file:"]
9144 ${NS}::entry $top.fname -width 60
9145 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9146 incr patchnum
9147 grid $top.flab $top.fname -sticky w
9148 ${NS}::frame $top.buts
9149 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9150 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9151 bind $top <Key-Return> mkpatchgo
9152 bind $top <Key-Escape> mkpatchcan
9153 grid $top.buts.gen $top.buts.can
9154 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9155 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9156 grid $top.buts - -pady 10 -sticky ew
9157 focus $top.fname
9160 proc mkpatchrev {} {
9161 global patchtop
9163 set oldid [$patchtop.fromsha1 get]
9164 set oldhead [$patchtop.fromhead get]
9165 set newid [$patchtop.tosha1 get]
9166 set newhead [$patchtop.tohead get]
9167 foreach e [list fromsha1 fromhead tosha1 tohead] \
9168 v [list $newid $newhead $oldid $oldhead] {
9169 $patchtop.$e conf -state normal
9170 $patchtop.$e delete 0 end
9171 $patchtop.$e insert 0 $v
9172 $patchtop.$e conf -state readonly
9176 proc mkpatchgo {} {
9177 global patchtop nullid nullid2
9179 set oldid [$patchtop.fromsha1 get]
9180 set newid [$patchtop.tosha1 get]
9181 set fname [$patchtop.fname get]
9182 set cmd [diffcmd [list $oldid $newid] -p]
9183 # trim off the initial "|"
9184 set cmd [lrange $cmd 1 end]
9185 lappend cmd >$fname &
9186 if {[catch {eval exec $cmd} err]} {
9187 error_popup "[mc "Error creating patch:"] $err" $patchtop
9189 catch {destroy $patchtop}
9190 unset patchtop
9193 proc mkpatchcan {} {
9194 global patchtop
9196 catch {destroy $patchtop}
9197 unset patchtop
9200 proc mktag {} {
9201 global rowmenuid mktagtop commitinfo NS
9203 set top .maketag
9204 set mktagtop $top
9205 catch {destroy $top}
9206 ttk_toplevel $top
9207 make_transient $top .
9208 ${NS}::label $top.title -text [mc "Create tag"]
9209 grid $top.title - -pady 10
9210 ${NS}::label $top.id -text [mc "ID:"]
9211 ${NS}::entry $top.sha1 -width 40
9212 $top.sha1 insert 0 $rowmenuid
9213 $top.sha1 conf -state readonly
9214 grid $top.id $top.sha1 -sticky w
9215 ${NS}::entry $top.head -width 60
9216 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9217 $top.head conf -state readonly
9218 grid x $top.head -sticky w
9219 ${NS}::label $top.tlab -text [mc "Tag name:"]
9220 ${NS}::entry $top.tag -width 60
9221 grid $top.tlab $top.tag -sticky w
9222 ${NS}::label $top.op -text [mc "Tag message is optional"]
9223 grid $top.op -columnspan 2 -sticky we
9224 ${NS}::label $top.mlab -text [mc "Tag message:"]
9225 ${NS}::entry $top.msg -width 60
9226 grid $top.mlab $top.msg -sticky w
9227 ${NS}::frame $top.buts
9228 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9229 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9230 bind $top <Key-Return> mktaggo
9231 bind $top <Key-Escape> mktagcan
9232 grid $top.buts.gen $top.buts.can
9233 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9234 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9235 grid $top.buts - -pady 10 -sticky ew
9236 focus $top.tag
9239 proc domktag {} {
9240 global mktagtop env tagids idtags
9242 set id [$mktagtop.sha1 get]
9243 set tag [$mktagtop.tag get]
9244 set msg [$mktagtop.msg get]
9245 if {$tag == {}} {
9246 error_popup [mc "No tag name specified"] $mktagtop
9247 return 0
9249 if {[info exists tagids($tag)]} {
9250 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9251 return 0
9253 if {[catch {
9254 if {$msg != {}} {
9255 exec git tag -a -m $msg $tag $id
9256 } else {
9257 exec git tag $tag $id
9259 } err]} {
9260 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9261 return 0
9264 set tagids($tag) $id
9265 lappend idtags($id) $tag
9266 redrawtags $id
9267 addedtag $id
9268 dispneartags 0
9269 run refill_reflist
9270 return 1
9273 proc redrawtags {id} {
9274 global canv linehtag idpos currentid curview cmitlisted markedid
9275 global canvxmax iddrawn circleitem mainheadid circlecolors
9276 global mainheadcirclecolor
9278 if {![commitinview $id $curview]} return
9279 if {![info exists iddrawn($id)]} return
9280 set row [rowofcommit $id]
9281 if {$id eq $mainheadid} {
9282 set ofill $mainheadcirclecolor
9283 } else {
9284 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9286 $canv itemconf $circleitem($row) -fill $ofill
9287 $canv delete tag.$id
9288 set xt [eval drawtags $id $idpos($id)]
9289 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9290 set text [$canv itemcget $linehtag($id) -text]
9291 set font [$canv itemcget $linehtag($id) -font]
9292 set xr [expr {$xt + [font measure $font $text]}]
9293 if {$xr > $canvxmax} {
9294 set canvxmax $xr
9295 setcanvscroll
9297 if {[info exists currentid] && $currentid == $id} {
9298 make_secsel $id
9300 if {[info exists markedid] && $markedid eq $id} {
9301 make_idmark $id
9305 proc mktagcan {} {
9306 global mktagtop
9308 catch {destroy $mktagtop}
9309 unset mktagtop
9312 proc mktaggo {} {
9313 if {![domktag]} return
9314 mktagcan
9317 proc writecommit {} {
9318 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9320 set top .writecommit
9321 set wrcomtop $top
9322 catch {destroy $top}
9323 ttk_toplevel $top
9324 make_transient $top .
9325 ${NS}::label $top.title -text [mc "Write commit to file"]
9326 grid $top.title - -pady 10
9327 ${NS}::label $top.id -text [mc "ID:"]
9328 ${NS}::entry $top.sha1 -width 40
9329 $top.sha1 insert 0 $rowmenuid
9330 $top.sha1 conf -state readonly
9331 grid $top.id $top.sha1 -sticky w
9332 ${NS}::entry $top.head -width 60
9333 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9334 $top.head conf -state readonly
9335 grid x $top.head -sticky w
9336 ${NS}::label $top.clab -text [mc "Command:"]
9337 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9338 grid $top.clab $top.cmd -sticky w -pady 10
9339 ${NS}::label $top.flab -text [mc "Output file:"]
9340 ${NS}::entry $top.fname -width 60
9341 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9342 grid $top.flab $top.fname -sticky w
9343 ${NS}::frame $top.buts
9344 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9345 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9346 bind $top <Key-Return> wrcomgo
9347 bind $top <Key-Escape> wrcomcan
9348 grid $top.buts.gen $top.buts.can
9349 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9350 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9351 grid $top.buts - -pady 10 -sticky ew
9352 focus $top.fname
9355 proc wrcomgo {} {
9356 global wrcomtop
9358 set id [$wrcomtop.sha1 get]
9359 set cmd "echo $id | [$wrcomtop.cmd get]"
9360 set fname [$wrcomtop.fname get]
9361 if {[catch {exec sh -c $cmd >$fname &} err]} {
9362 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9364 catch {destroy $wrcomtop}
9365 unset wrcomtop
9368 proc wrcomcan {} {
9369 global wrcomtop
9371 catch {destroy $wrcomtop}
9372 unset wrcomtop
9375 proc mkbranch {} {
9376 global rowmenuid mkbrtop NS
9378 set top .makebranch
9379 catch {destroy $top}
9380 ttk_toplevel $top
9381 make_transient $top .
9382 ${NS}::label $top.title -text [mc "Create new branch"]
9383 grid $top.title - -pady 10
9384 ${NS}::label $top.id -text [mc "ID:"]
9385 ${NS}::entry $top.sha1 -width 40
9386 $top.sha1 insert 0 $rowmenuid
9387 $top.sha1 conf -state readonly
9388 grid $top.id $top.sha1 -sticky w
9389 ${NS}::label $top.nlab -text [mc "Name:"]
9390 ${NS}::entry $top.name -width 40
9391 grid $top.nlab $top.name -sticky w
9392 ${NS}::frame $top.buts
9393 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9394 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9395 bind $top <Key-Return> [list mkbrgo $top]
9396 bind $top <Key-Escape> "catch {destroy $top}"
9397 grid $top.buts.go $top.buts.can
9398 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9399 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9400 grid $top.buts - -pady 10 -sticky ew
9401 focus $top.name
9404 proc mkbrgo {top} {
9405 global headids idheads
9407 set name [$top.name get]
9408 set id [$top.sha1 get]
9409 set cmdargs {}
9410 set old_id {}
9411 if {$name eq {}} {
9412 error_popup [mc "Please specify a name for the new branch"] $top
9413 return
9415 if {[info exists headids($name)]} {
9416 if {![confirm_popup [mc \
9417 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9418 return
9420 set old_id $headids($name)
9421 lappend cmdargs -f
9423 catch {destroy $top}
9424 lappend cmdargs $name $id
9425 nowbusy newbranch
9426 update
9427 if {[catch {
9428 eval exec git branch $cmdargs
9429 } err]} {
9430 notbusy newbranch
9431 error_popup $err
9432 } else {
9433 notbusy newbranch
9434 if {$old_id ne {}} {
9435 movehead $id $name
9436 movedhead $id $name
9437 redrawtags $old_id
9438 redrawtags $id
9439 } else {
9440 set headids($name) $id
9441 lappend idheads($id) $name
9442 addedhead $id $name
9443 redrawtags $id
9445 dispneartags 0
9446 run refill_reflist
9450 proc exec_citool {tool_args {baseid {}}} {
9451 global commitinfo env
9453 set save_env [array get env GIT_AUTHOR_*]
9455 if {$baseid ne {}} {
9456 if {![info exists commitinfo($baseid)]} {
9457 getcommit $baseid
9459 set author [lindex $commitinfo($baseid) 1]
9460 set date [lindex $commitinfo($baseid) 2]
9461 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9462 $author author name email]
9463 && $date ne {}} {
9464 set env(GIT_AUTHOR_NAME) $name
9465 set env(GIT_AUTHOR_EMAIL) $email
9466 set env(GIT_AUTHOR_DATE) $date
9470 eval exec git citool $tool_args &
9472 array unset env GIT_AUTHOR_*
9473 array set env $save_env
9476 proc cherrypick {} {
9477 global rowmenuid curview
9478 global mainhead mainheadid
9479 global gitdir
9481 set oldhead [exec git rev-parse HEAD]
9482 set dheads [descheads $rowmenuid]
9483 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9484 set ok [confirm_popup [mc "Commit %s is already\
9485 included in branch %s -- really re-apply it?" \
9486 [string range $rowmenuid 0 7] $mainhead]]
9487 if {!$ok} return
9489 nowbusy cherrypick [mc "Cherry-picking"]
9490 update
9491 # Unfortunately git-cherry-pick writes stuff to stderr even when
9492 # no error occurs, and exec takes that as an indication of error...
9493 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9494 notbusy cherrypick
9495 if {[regexp -line \
9496 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9497 $err msg fname]} {
9498 error_popup [mc "Cherry-pick failed because of local changes\
9499 to file '%s'.\nPlease commit, reset or stash\
9500 your changes and try again." $fname]
9501 } elseif {[regexp -line \
9502 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9503 $err]} {
9504 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9505 conflict.\nDo you wish to run git citool to\
9506 resolve it?"]]} {
9507 # Force citool to read MERGE_MSG
9508 file delete [file join $gitdir "GITGUI_MSG"]
9509 exec_citool {} $rowmenuid
9511 } else {
9512 error_popup $err
9514 run updatecommits
9515 return
9517 set newhead [exec git rev-parse HEAD]
9518 if {$newhead eq $oldhead} {
9519 notbusy cherrypick
9520 error_popup [mc "No changes committed"]
9521 return
9523 addnewchild $newhead $oldhead
9524 if {[commitinview $oldhead $curview]} {
9525 # XXX this isn't right if we have a path limit...
9526 insertrow $newhead $oldhead $curview
9527 if {$mainhead ne {}} {
9528 movehead $newhead $mainhead
9529 movedhead $newhead $mainhead
9531 set mainheadid $newhead
9532 redrawtags $oldhead
9533 redrawtags $newhead
9534 selbyid $newhead
9536 notbusy cherrypick
9539 proc revert {} {
9540 global rowmenuid curview
9541 global mainhead mainheadid
9542 global gitdir
9544 set oldhead [exec git rev-parse HEAD]
9545 set dheads [descheads $rowmenuid]
9546 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9547 set ok [confirm_popup [mc "Commit %s is not\
9548 included in branch %s -- really revert it?" \
9549 [string range $rowmenuid 0 7] $mainhead]]
9550 if {!$ok} return
9552 nowbusy revert [mc "Reverting"]
9553 update
9555 if [catch {exec git revert --no-edit $rowmenuid} err] {
9556 notbusy revert
9557 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9558 $err match files] {
9559 regsub {\n( |\t)+} $files "\n" files
9560 error_popup [mc "Revert failed because of local changes to\
9561 the following files:%s Please commit, reset or stash \
9562 your changes and try again." $files]
9563 } elseif [regexp {error: could not revert} $err] {
9564 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9565 Do you wish to run git citool to resolve it?"]] {
9566 # Force citool to read MERGE_MSG
9567 file delete [file join $gitdir "GITGUI_MSG"]
9568 exec_citool {} $rowmenuid
9570 } else { error_popup $err }
9571 run updatecommits
9572 return
9575 set newhead [exec git rev-parse HEAD]
9576 if { $newhead eq $oldhead } {
9577 notbusy revert
9578 error_popup [mc "No changes committed"]
9579 return
9582 addnewchild $newhead $oldhead
9584 if [commitinview $oldhead $curview] {
9585 # XXX this isn't right if we have a path limit...
9586 insertrow $newhead $oldhead $curview
9587 if {$mainhead ne {}} {
9588 movehead $newhead $mainhead
9589 movedhead $newhead $mainhead
9591 set mainheadid $newhead
9592 redrawtags $oldhead
9593 redrawtags $newhead
9594 selbyid $newhead
9597 notbusy revert
9600 proc resethead {} {
9601 global mainhead rowmenuid confirm_ok resettype NS
9603 set confirm_ok 0
9604 set w ".confirmreset"
9605 ttk_toplevel $w
9606 make_transient $w .
9607 wm title $w [mc "Confirm reset"]
9608 ${NS}::label $w.m -text \
9609 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9610 pack $w.m -side top -fill x -padx 20 -pady 20
9611 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9612 set resettype mixed
9613 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9614 -text [mc "Soft: Leave working tree and index untouched"]
9615 grid $w.f.soft -sticky w
9616 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9617 -text [mc "Mixed: Leave working tree untouched, reset index"]
9618 grid $w.f.mixed -sticky w
9619 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9620 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9621 grid $w.f.hard -sticky w
9622 pack $w.f -side top -fill x -padx 4
9623 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9624 pack $w.ok -side left -fill x -padx 20 -pady 20
9625 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9626 bind $w <Key-Escape> [list destroy $w]
9627 pack $w.cancel -side right -fill x -padx 20 -pady 20
9628 bind $w <Visibility> "grab $w; focus $w"
9629 tkwait window $w
9630 if {!$confirm_ok} return
9631 if {[catch {set fd [open \
9632 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9633 error_popup $err
9634 } else {
9635 dohidelocalchanges
9636 filerun $fd [list readresetstat $fd]
9637 nowbusy reset [mc "Resetting"]
9638 selbyid $rowmenuid
9642 proc readresetstat {fd} {
9643 global mainhead mainheadid showlocalchanges rprogcoord
9645 if {[gets $fd line] >= 0} {
9646 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9647 set rprogcoord [expr {1.0 * $m / $n}]
9648 adjustprogress
9650 return 1
9652 set rprogcoord 0
9653 adjustprogress
9654 notbusy reset
9655 if {[catch {close $fd} err]} {
9656 error_popup $err
9658 set oldhead $mainheadid
9659 set newhead [exec git rev-parse HEAD]
9660 if {$newhead ne $oldhead} {
9661 movehead $newhead $mainhead
9662 movedhead $newhead $mainhead
9663 set mainheadid $newhead
9664 redrawtags $oldhead
9665 redrawtags $newhead
9667 if {$showlocalchanges} {
9668 doshowlocalchanges
9670 return 0
9673 # context menu for a head
9674 proc headmenu {x y id head} {
9675 global headmenuid headmenuhead headctxmenu mainhead
9677 stopfinding
9678 set headmenuid $id
9679 set headmenuhead $head
9680 set state normal
9681 if {[string match "remotes/*" $head]} {
9682 set state disabled
9684 if {$head eq $mainhead} {
9685 set state disabled
9687 $headctxmenu entryconfigure 0 -state $state
9688 $headctxmenu entryconfigure 1 -state $state
9689 tk_popup $headctxmenu $x $y
9692 proc cobranch {} {
9693 global headmenuid headmenuhead headids
9694 global showlocalchanges
9696 # check the tree is clean first??
9697 nowbusy checkout [mc "Checking out"]
9698 update
9699 dohidelocalchanges
9700 if {[catch {
9701 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9702 } err]} {
9703 notbusy checkout
9704 error_popup $err
9705 if {$showlocalchanges} {
9706 dodiffindex
9708 } else {
9709 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9713 proc readcheckoutstat {fd newhead newheadid} {
9714 global mainhead mainheadid headids showlocalchanges progresscoords
9715 global viewmainheadid curview
9717 if {[gets $fd line] >= 0} {
9718 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9719 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9720 adjustprogress
9722 return 1
9724 set progresscoords {0 0}
9725 adjustprogress
9726 notbusy checkout
9727 if {[catch {close $fd} err]} {
9728 error_popup $err
9730 set oldmainid $mainheadid
9731 set mainhead $newhead
9732 set mainheadid $newheadid
9733 set viewmainheadid($curview) $newheadid
9734 redrawtags $oldmainid
9735 redrawtags $newheadid
9736 selbyid $newheadid
9737 if {$showlocalchanges} {
9738 dodiffindex
9742 proc rmbranch {} {
9743 global headmenuid headmenuhead mainhead
9744 global idheads
9746 set head $headmenuhead
9747 set id $headmenuid
9748 # this check shouldn't be needed any more...
9749 if {$head eq $mainhead} {
9750 error_popup [mc "Cannot delete the currently checked-out branch"]
9751 return
9753 set dheads [descheads $id]
9754 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9755 # the stuff on this branch isn't on any other branch
9756 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9757 branch.\nReally delete branch %s?" $head $head]]} return
9759 nowbusy rmbranch
9760 update
9761 if {[catch {exec git branch -D $head} err]} {
9762 notbusy rmbranch
9763 error_popup $err
9764 return
9766 removehead $id $head
9767 removedhead $id $head
9768 redrawtags $id
9769 notbusy rmbranch
9770 dispneartags 0
9771 run refill_reflist
9774 # Display a list of tags and heads
9775 proc showrefs {} {
9776 global showrefstop bgcolor fgcolor selectbgcolor NS
9777 global bglist fglist reflistfilter reflist maincursor
9779 set top .showrefs
9780 set showrefstop $top
9781 if {[winfo exists $top]} {
9782 raise $top
9783 refill_reflist
9784 return
9786 ttk_toplevel $top
9787 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9788 make_transient $top .
9789 text $top.list -background $bgcolor -foreground $fgcolor \
9790 -selectbackground $selectbgcolor -font mainfont \
9791 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9792 -width 30 -height 20 -cursor $maincursor \
9793 -spacing1 1 -spacing3 1 -state disabled
9794 $top.list tag configure highlight -background $selectbgcolor
9795 lappend bglist $top.list
9796 lappend fglist $top.list
9797 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9798 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9799 grid $top.list $top.ysb -sticky nsew
9800 grid $top.xsb x -sticky ew
9801 ${NS}::frame $top.f
9802 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9803 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9804 set reflistfilter "*"
9805 trace add variable reflistfilter write reflistfilter_change
9806 pack $top.f.e -side right -fill x -expand 1
9807 pack $top.f.l -side left
9808 grid $top.f - -sticky ew -pady 2
9809 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9810 bind $top <Key-Escape> [list destroy $top]
9811 grid $top.close -
9812 grid columnconfigure $top 0 -weight 1
9813 grid rowconfigure $top 0 -weight 1
9814 bind $top.list <1> {break}
9815 bind $top.list <B1-Motion> {break}
9816 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9817 set reflist {}
9818 refill_reflist
9821 proc sel_reflist {w x y} {
9822 global showrefstop reflist headids tagids otherrefids
9824 if {![winfo exists $showrefstop]} return
9825 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9826 set ref [lindex $reflist [expr {$l-1}]]
9827 set n [lindex $ref 0]
9828 switch -- [lindex $ref 1] {
9829 "H" {selbyid $headids($n)}
9830 "T" {selbyid $tagids($n)}
9831 "o" {selbyid $otherrefids($n)}
9833 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9836 proc unsel_reflist {} {
9837 global showrefstop
9839 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9840 $showrefstop.list tag remove highlight 0.0 end
9843 proc reflistfilter_change {n1 n2 op} {
9844 global reflistfilter
9846 after cancel refill_reflist
9847 after 200 refill_reflist
9850 proc refill_reflist {} {
9851 global reflist reflistfilter showrefstop headids tagids otherrefids
9852 global curview
9854 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9855 set refs {}
9856 foreach n [array names headids] {
9857 if {[string match $reflistfilter $n]} {
9858 if {[commitinview $headids($n) $curview]} {
9859 lappend refs [list $n H]
9860 } else {
9861 interestedin $headids($n) {run refill_reflist}
9865 foreach n [array names tagids] {
9866 if {[string match $reflistfilter $n]} {
9867 if {[commitinview $tagids($n) $curview]} {
9868 lappend refs [list $n T]
9869 } else {
9870 interestedin $tagids($n) {run refill_reflist}
9874 foreach n [array names otherrefids] {
9875 if {[string match $reflistfilter $n]} {
9876 if {[commitinview $otherrefids($n) $curview]} {
9877 lappend refs [list $n o]
9878 } else {
9879 interestedin $otherrefids($n) {run refill_reflist}
9883 set refs [lsort -index 0 $refs]
9884 if {$refs eq $reflist} return
9886 # Update the contents of $showrefstop.list according to the
9887 # differences between $reflist (old) and $refs (new)
9888 $showrefstop.list conf -state normal
9889 $showrefstop.list insert end "\n"
9890 set i 0
9891 set j 0
9892 while {$i < [llength $reflist] || $j < [llength $refs]} {
9893 if {$i < [llength $reflist]} {
9894 if {$j < [llength $refs]} {
9895 set cmp [string compare [lindex $reflist $i 0] \
9896 [lindex $refs $j 0]]
9897 if {$cmp == 0} {
9898 set cmp [string compare [lindex $reflist $i 1] \
9899 [lindex $refs $j 1]]
9901 } else {
9902 set cmp -1
9904 } else {
9905 set cmp 1
9907 switch -- $cmp {
9908 -1 {
9909 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9910 incr i
9913 incr i
9914 incr j
9917 set l [expr {$j + 1}]
9918 $showrefstop.list image create $l.0 -align baseline \
9919 -image reficon-[lindex $refs $j 1] -padx 2
9920 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9921 incr j
9925 set reflist $refs
9926 # delete last newline
9927 $showrefstop.list delete end-2c end-1c
9928 $showrefstop.list conf -state disabled
9931 # Stuff for finding nearby tags
9932 proc getallcommits {} {
9933 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9934 global idheads idtags idotherrefs allparents tagobjid
9935 global gitdir
9937 if {![info exists allcommits]} {
9938 set nextarc 0
9939 set allcommits 0
9940 set seeds {}
9941 set allcwait 0
9942 set cachedarcs 0
9943 set allccache [file join $gitdir "gitk.cache"]
9944 if {![catch {
9945 set f [open $allccache r]
9946 set allcwait 1
9947 getcache $f
9948 }]} return
9951 if {$allcwait} {
9952 return
9954 set cmd [list | git rev-list --parents]
9955 set allcupdate [expr {$seeds ne {}}]
9956 if {!$allcupdate} {
9957 set ids "--all"
9958 } else {
9959 set refs [concat [array names idheads] [array names idtags] \
9960 [array names idotherrefs]]
9961 set ids {}
9962 set tagobjs {}
9963 foreach name [array names tagobjid] {
9964 lappend tagobjs $tagobjid($name)
9966 foreach id [lsort -unique $refs] {
9967 if {![info exists allparents($id)] &&
9968 [lsearch -exact $tagobjs $id] < 0} {
9969 lappend ids $id
9972 if {$ids ne {}} {
9973 foreach id $seeds {
9974 lappend ids "^$id"
9978 if {$ids ne {}} {
9979 set fd [open [concat $cmd $ids] r]
9980 fconfigure $fd -blocking 0
9981 incr allcommits
9982 nowbusy allcommits
9983 filerun $fd [list getallclines $fd]
9984 } else {
9985 dispneartags 0
9989 # Since most commits have 1 parent and 1 child, we group strings of
9990 # such commits into "arcs" joining branch/merge points (BMPs), which
9991 # are commits that either don't have 1 parent or don't have 1 child.
9993 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9994 # arcout(id) - outgoing arcs for BMP
9995 # arcids(a) - list of IDs on arc including end but not start
9996 # arcstart(a) - BMP ID at start of arc
9997 # arcend(a) - BMP ID at end of arc
9998 # growing(a) - arc a is still growing
9999 # arctags(a) - IDs out of arcids (excluding end) that have tags
10000 # archeads(a) - IDs out of arcids (excluding end) that have heads
10001 # The start of an arc is at the descendent end, so "incoming" means
10002 # coming from descendents, and "outgoing" means going towards ancestors.
10004 proc getallclines {fd} {
10005 global allparents allchildren idtags idheads nextarc
10006 global arcnos arcids arctags arcout arcend arcstart archeads growing
10007 global seeds allcommits cachedarcs allcupdate
10009 set nid 0
10010 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10011 set id [lindex $line 0]
10012 if {[info exists allparents($id)]} {
10013 # seen it already
10014 continue
10016 set cachedarcs 0
10017 set olds [lrange $line 1 end]
10018 set allparents($id) $olds
10019 if {![info exists allchildren($id)]} {
10020 set allchildren($id) {}
10021 set arcnos($id) {}
10022 lappend seeds $id
10023 } else {
10024 set a $arcnos($id)
10025 if {[llength $olds] == 1 && [llength $a] == 1} {
10026 lappend arcids($a) $id
10027 if {[info exists idtags($id)]} {
10028 lappend arctags($a) $id
10030 if {[info exists idheads($id)]} {
10031 lappend archeads($a) $id
10033 if {[info exists allparents($olds)]} {
10034 # seen parent already
10035 if {![info exists arcout($olds)]} {
10036 splitarc $olds
10038 lappend arcids($a) $olds
10039 set arcend($a) $olds
10040 unset growing($a)
10042 lappend allchildren($olds) $id
10043 lappend arcnos($olds) $a
10044 continue
10047 foreach a $arcnos($id) {
10048 lappend arcids($a) $id
10049 set arcend($a) $id
10050 unset growing($a)
10053 set ao {}
10054 foreach p $olds {
10055 lappend allchildren($p) $id
10056 set a [incr nextarc]
10057 set arcstart($a) $id
10058 set archeads($a) {}
10059 set arctags($a) {}
10060 set archeads($a) {}
10061 set arcids($a) {}
10062 lappend ao $a
10063 set growing($a) 1
10064 if {[info exists allparents($p)]} {
10065 # seen it already, may need to make a new branch
10066 if {![info exists arcout($p)]} {
10067 splitarc $p
10069 lappend arcids($a) $p
10070 set arcend($a) $p
10071 unset growing($a)
10073 lappend arcnos($p) $a
10075 set arcout($id) $ao
10077 if {$nid > 0} {
10078 global cached_dheads cached_dtags cached_atags
10079 catch {unset cached_dheads}
10080 catch {unset cached_dtags}
10081 catch {unset cached_atags}
10083 if {![eof $fd]} {
10084 return [expr {$nid >= 1000? 2: 1}]
10086 set cacheok 1
10087 if {[catch {
10088 fconfigure $fd -blocking 1
10089 close $fd
10090 } err]} {
10091 # got an error reading the list of commits
10092 # if we were updating, try rereading the whole thing again
10093 if {$allcupdate} {
10094 incr allcommits -1
10095 dropcache $err
10096 return
10098 error_popup "[mc "Error reading commit topology information;\
10099 branch and preceding/following tag information\
10100 will be incomplete."]\n($err)"
10101 set cacheok 0
10103 if {[incr allcommits -1] == 0} {
10104 notbusy allcommits
10105 if {$cacheok} {
10106 run savecache
10109 dispneartags 0
10110 return 0
10113 proc recalcarc {a} {
10114 global arctags archeads arcids idtags idheads
10116 set at {}
10117 set ah {}
10118 foreach id [lrange $arcids($a) 0 end-1] {
10119 if {[info exists idtags($id)]} {
10120 lappend at $id
10122 if {[info exists idheads($id)]} {
10123 lappend ah $id
10126 set arctags($a) $at
10127 set archeads($a) $ah
10130 proc splitarc {p} {
10131 global arcnos arcids nextarc arctags archeads idtags idheads
10132 global arcstart arcend arcout allparents growing
10134 set a $arcnos($p)
10135 if {[llength $a] != 1} {
10136 puts "oops splitarc called but [llength $a] arcs already"
10137 return
10139 set a [lindex $a 0]
10140 set i [lsearch -exact $arcids($a) $p]
10141 if {$i < 0} {
10142 puts "oops splitarc $p not in arc $a"
10143 return
10145 set na [incr nextarc]
10146 if {[info exists arcend($a)]} {
10147 set arcend($na) $arcend($a)
10148 } else {
10149 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10150 set j [lsearch -exact $arcnos($l) $a]
10151 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10153 set tail [lrange $arcids($a) [expr {$i+1}] end]
10154 set arcids($a) [lrange $arcids($a) 0 $i]
10155 set arcend($a) $p
10156 set arcstart($na) $p
10157 set arcout($p) $na
10158 set arcids($na) $tail
10159 if {[info exists growing($a)]} {
10160 set growing($na) 1
10161 unset growing($a)
10164 foreach id $tail {
10165 if {[llength $arcnos($id)] == 1} {
10166 set arcnos($id) $na
10167 } else {
10168 set j [lsearch -exact $arcnos($id) $a]
10169 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10173 # reconstruct tags and heads lists
10174 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10175 recalcarc $a
10176 recalcarc $na
10177 } else {
10178 set arctags($na) {}
10179 set archeads($na) {}
10183 # Update things for a new commit added that is a child of one
10184 # existing commit. Used when cherry-picking.
10185 proc addnewchild {id p} {
10186 global allparents allchildren idtags nextarc
10187 global arcnos arcids arctags arcout arcend arcstart archeads growing
10188 global seeds allcommits
10190 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10191 set allparents($id) [list $p]
10192 set allchildren($id) {}
10193 set arcnos($id) {}
10194 lappend seeds $id
10195 lappend allchildren($p) $id
10196 set a [incr nextarc]
10197 set arcstart($a) $id
10198 set archeads($a) {}
10199 set arctags($a) {}
10200 set arcids($a) [list $p]
10201 set arcend($a) $p
10202 if {![info exists arcout($p)]} {
10203 splitarc $p
10205 lappend arcnos($p) $a
10206 set arcout($id) [list $a]
10209 # This implements a cache for the topology information.
10210 # The cache saves, for each arc, the start and end of the arc,
10211 # the ids on the arc, and the outgoing arcs from the end.
10212 proc readcache {f} {
10213 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10214 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10215 global allcwait
10217 set a $nextarc
10218 set lim $cachedarcs
10219 if {$lim - $a > 500} {
10220 set lim [expr {$a + 500}]
10222 if {[catch {
10223 if {$a == $lim} {
10224 # finish reading the cache and setting up arctags, etc.
10225 set line [gets $f]
10226 if {$line ne "1"} {error "bad final version"}
10227 close $f
10228 foreach id [array names idtags] {
10229 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10230 [llength $allparents($id)] == 1} {
10231 set a [lindex $arcnos($id) 0]
10232 if {$arctags($a) eq {}} {
10233 recalcarc $a
10237 foreach id [array names idheads] {
10238 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10239 [llength $allparents($id)] == 1} {
10240 set a [lindex $arcnos($id) 0]
10241 if {$archeads($a) eq {}} {
10242 recalcarc $a
10246 foreach id [lsort -unique $possible_seeds] {
10247 if {$arcnos($id) eq {}} {
10248 lappend seeds $id
10251 set allcwait 0
10252 } else {
10253 while {[incr a] <= $lim} {
10254 set line [gets $f]
10255 if {[llength $line] != 3} {error "bad line"}
10256 set s [lindex $line 0]
10257 set arcstart($a) $s
10258 lappend arcout($s) $a
10259 if {![info exists arcnos($s)]} {
10260 lappend possible_seeds $s
10261 set arcnos($s) {}
10263 set e [lindex $line 1]
10264 if {$e eq {}} {
10265 set growing($a) 1
10266 } else {
10267 set arcend($a) $e
10268 if {![info exists arcout($e)]} {
10269 set arcout($e) {}
10272 set arcids($a) [lindex $line 2]
10273 foreach id $arcids($a) {
10274 lappend allparents($s) $id
10275 set s $id
10276 lappend arcnos($id) $a
10278 if {![info exists allparents($s)]} {
10279 set allparents($s) {}
10281 set arctags($a) {}
10282 set archeads($a) {}
10284 set nextarc [expr {$a - 1}]
10286 } err]} {
10287 dropcache $err
10288 return 0
10290 if {!$allcwait} {
10291 getallcommits
10293 return $allcwait
10296 proc getcache {f} {
10297 global nextarc cachedarcs possible_seeds
10299 if {[catch {
10300 set line [gets $f]
10301 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10302 # make sure it's an integer
10303 set cachedarcs [expr {int([lindex $line 1])}]
10304 if {$cachedarcs < 0} {error "bad number of arcs"}
10305 set nextarc 0
10306 set possible_seeds {}
10307 run readcache $f
10308 } err]} {
10309 dropcache $err
10311 return 0
10314 proc dropcache {err} {
10315 global allcwait nextarc cachedarcs seeds
10317 #puts "dropping cache ($err)"
10318 foreach v {arcnos arcout arcids arcstart arcend growing \
10319 arctags archeads allparents allchildren} {
10320 global $v
10321 catch {unset $v}
10323 set allcwait 0
10324 set nextarc 0
10325 set cachedarcs 0
10326 set seeds {}
10327 getallcommits
10330 proc writecache {f} {
10331 global cachearc cachedarcs allccache
10332 global arcstart arcend arcnos arcids arcout
10334 set a $cachearc
10335 set lim $cachedarcs
10336 if {$lim - $a > 1000} {
10337 set lim [expr {$a + 1000}]
10339 if {[catch {
10340 while {[incr a] <= $lim} {
10341 if {[info exists arcend($a)]} {
10342 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10343 } else {
10344 puts $f [list $arcstart($a) {} $arcids($a)]
10347 } err]} {
10348 catch {close $f}
10349 catch {file delete $allccache}
10350 #puts "writing cache failed ($err)"
10351 return 0
10353 set cachearc [expr {$a - 1}]
10354 if {$a > $cachedarcs} {
10355 puts $f "1"
10356 close $f
10357 return 0
10359 return 1
10362 proc savecache {} {
10363 global nextarc cachedarcs cachearc allccache
10365 if {$nextarc == $cachedarcs} return
10366 set cachearc 0
10367 set cachedarcs $nextarc
10368 catch {
10369 set f [open $allccache w]
10370 puts $f [list 1 $cachedarcs]
10371 run writecache $f
10375 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10376 # or 0 if neither is true.
10377 proc anc_or_desc {a b} {
10378 global arcout arcstart arcend arcnos cached_isanc
10380 if {$arcnos($a) eq $arcnos($b)} {
10381 # Both are on the same arc(s); either both are the same BMP,
10382 # or if one is not a BMP, the other is also not a BMP or is
10383 # the BMP at end of the arc (and it only has 1 incoming arc).
10384 # Or both can be BMPs with no incoming arcs.
10385 if {$a eq $b || $arcnos($a) eq {}} {
10386 return 0
10388 # assert {[llength $arcnos($a)] == 1}
10389 set arc [lindex $arcnos($a) 0]
10390 set i [lsearch -exact $arcids($arc) $a]
10391 set j [lsearch -exact $arcids($arc) $b]
10392 if {$i < 0 || $i > $j} {
10393 return 1
10394 } else {
10395 return -1
10399 if {![info exists arcout($a)]} {
10400 set arc [lindex $arcnos($a) 0]
10401 if {[info exists arcend($arc)]} {
10402 set aend $arcend($arc)
10403 } else {
10404 set aend {}
10406 set a $arcstart($arc)
10407 } else {
10408 set aend $a
10410 if {![info exists arcout($b)]} {
10411 set arc [lindex $arcnos($b) 0]
10412 if {[info exists arcend($arc)]} {
10413 set bend $arcend($arc)
10414 } else {
10415 set bend {}
10417 set b $arcstart($arc)
10418 } else {
10419 set bend $b
10421 if {$a eq $bend} {
10422 return 1
10424 if {$b eq $aend} {
10425 return -1
10427 if {[info exists cached_isanc($a,$bend)]} {
10428 if {$cached_isanc($a,$bend)} {
10429 return 1
10432 if {[info exists cached_isanc($b,$aend)]} {
10433 if {$cached_isanc($b,$aend)} {
10434 return -1
10436 if {[info exists cached_isanc($a,$bend)]} {
10437 return 0
10441 set todo [list $a $b]
10442 set anc($a) a
10443 set anc($b) b
10444 for {set i 0} {$i < [llength $todo]} {incr i} {
10445 set x [lindex $todo $i]
10446 if {$anc($x) eq {}} {
10447 continue
10449 foreach arc $arcnos($x) {
10450 set xd $arcstart($arc)
10451 if {$xd eq $bend} {
10452 set cached_isanc($a,$bend) 1
10453 set cached_isanc($b,$aend) 0
10454 return 1
10455 } elseif {$xd eq $aend} {
10456 set cached_isanc($b,$aend) 1
10457 set cached_isanc($a,$bend) 0
10458 return -1
10460 if {![info exists anc($xd)]} {
10461 set anc($xd) $anc($x)
10462 lappend todo $xd
10463 } elseif {$anc($xd) ne $anc($x)} {
10464 set anc($xd) {}
10468 set cached_isanc($a,$bend) 0
10469 set cached_isanc($b,$aend) 0
10470 return 0
10473 # This identifies whether $desc has an ancestor that is
10474 # a growing tip of the graph and which is not an ancestor of $anc
10475 # and returns 0 if so and 1 if not.
10476 # If we subsequently discover a tag on such a growing tip, and that
10477 # turns out to be a descendent of $anc (which it could, since we
10478 # don't necessarily see children before parents), then $desc
10479 # isn't a good choice to display as a descendent tag of
10480 # $anc (since it is the descendent of another tag which is
10481 # a descendent of $anc). Similarly, $anc isn't a good choice to
10482 # display as a ancestor tag of $desc.
10484 proc is_certain {desc anc} {
10485 global arcnos arcout arcstart arcend growing problems
10487 set certain {}
10488 if {[llength $arcnos($anc)] == 1} {
10489 # tags on the same arc are certain
10490 if {$arcnos($desc) eq $arcnos($anc)} {
10491 return 1
10493 if {![info exists arcout($anc)]} {
10494 # if $anc is partway along an arc, use the start of the arc instead
10495 set a [lindex $arcnos($anc) 0]
10496 set anc $arcstart($a)
10499 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10500 set x $desc
10501 } else {
10502 set a [lindex $arcnos($desc) 0]
10503 set x $arcend($a)
10505 if {$x == $anc} {
10506 return 1
10508 set anclist [list $x]
10509 set dl($x) 1
10510 set nnh 1
10511 set ngrowanc 0
10512 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10513 set x [lindex $anclist $i]
10514 if {$dl($x)} {
10515 incr nnh -1
10517 set done($x) 1
10518 foreach a $arcout($x) {
10519 if {[info exists growing($a)]} {
10520 if {![info exists growanc($x)] && $dl($x)} {
10521 set growanc($x) 1
10522 incr ngrowanc
10524 } else {
10525 set y $arcend($a)
10526 if {[info exists dl($y)]} {
10527 if {$dl($y)} {
10528 if {!$dl($x)} {
10529 set dl($y) 0
10530 if {![info exists done($y)]} {
10531 incr nnh -1
10533 if {[info exists growanc($x)]} {
10534 incr ngrowanc -1
10536 set xl [list $y]
10537 for {set k 0} {$k < [llength $xl]} {incr k} {
10538 set z [lindex $xl $k]
10539 foreach c $arcout($z) {
10540 if {[info exists arcend($c)]} {
10541 set v $arcend($c)
10542 if {[info exists dl($v)] && $dl($v)} {
10543 set dl($v) 0
10544 if {![info exists done($v)]} {
10545 incr nnh -1
10547 if {[info exists growanc($v)]} {
10548 incr ngrowanc -1
10550 lappend xl $v
10557 } elseif {$y eq $anc || !$dl($x)} {
10558 set dl($y) 0
10559 lappend anclist $y
10560 } else {
10561 set dl($y) 1
10562 lappend anclist $y
10563 incr nnh
10568 foreach x [array names growanc] {
10569 if {$dl($x)} {
10570 return 0
10572 return 0
10574 return 1
10577 proc validate_arctags {a} {
10578 global arctags idtags
10580 set i -1
10581 set na $arctags($a)
10582 foreach id $arctags($a) {
10583 incr i
10584 if {![info exists idtags($id)]} {
10585 set na [lreplace $na $i $i]
10586 incr i -1
10589 set arctags($a) $na
10592 proc validate_archeads {a} {
10593 global archeads idheads
10595 set i -1
10596 set na $archeads($a)
10597 foreach id $archeads($a) {
10598 incr i
10599 if {![info exists idheads($id)]} {
10600 set na [lreplace $na $i $i]
10601 incr i -1
10604 set archeads($a) $na
10607 # Return the list of IDs that have tags that are descendents of id,
10608 # ignoring IDs that are descendents of IDs already reported.
10609 proc desctags {id} {
10610 global arcnos arcstart arcids arctags idtags allparents
10611 global growing cached_dtags
10613 if {![info exists allparents($id)]} {
10614 return {}
10616 set t1 [clock clicks -milliseconds]
10617 set argid $id
10618 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10619 # part-way along an arc; check that arc first
10620 set a [lindex $arcnos($id) 0]
10621 if {$arctags($a) ne {}} {
10622 validate_arctags $a
10623 set i [lsearch -exact $arcids($a) $id]
10624 set tid {}
10625 foreach t $arctags($a) {
10626 set j [lsearch -exact $arcids($a) $t]
10627 if {$j >= $i} break
10628 set tid $t
10630 if {$tid ne {}} {
10631 return $tid
10634 set id $arcstart($a)
10635 if {[info exists idtags($id)]} {
10636 return $id
10639 if {[info exists cached_dtags($id)]} {
10640 return $cached_dtags($id)
10643 set origid $id
10644 set todo [list $id]
10645 set queued($id) 1
10646 set nc 1
10647 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10648 set id [lindex $todo $i]
10649 set done($id) 1
10650 set ta [info exists hastaggedancestor($id)]
10651 if {!$ta} {
10652 incr nc -1
10654 # ignore tags on starting node
10655 if {!$ta && $i > 0} {
10656 if {[info exists idtags($id)]} {
10657 set tagloc($id) $id
10658 set ta 1
10659 } elseif {[info exists cached_dtags($id)]} {
10660 set tagloc($id) $cached_dtags($id)
10661 set ta 1
10664 foreach a $arcnos($id) {
10665 set d $arcstart($a)
10666 if {!$ta && $arctags($a) ne {}} {
10667 validate_arctags $a
10668 if {$arctags($a) ne {}} {
10669 lappend tagloc($id) [lindex $arctags($a) end]
10672 if {$ta || $arctags($a) ne {}} {
10673 set tomark [list $d]
10674 for {set j 0} {$j < [llength $tomark]} {incr j} {
10675 set dd [lindex $tomark $j]
10676 if {![info exists hastaggedancestor($dd)]} {
10677 if {[info exists done($dd)]} {
10678 foreach b $arcnos($dd) {
10679 lappend tomark $arcstart($b)
10681 if {[info exists tagloc($dd)]} {
10682 unset tagloc($dd)
10684 } elseif {[info exists queued($dd)]} {
10685 incr nc -1
10687 set hastaggedancestor($dd) 1
10691 if {![info exists queued($d)]} {
10692 lappend todo $d
10693 set queued($d) 1
10694 if {![info exists hastaggedancestor($d)]} {
10695 incr nc
10700 set tags {}
10701 foreach id [array names tagloc] {
10702 if {![info exists hastaggedancestor($id)]} {
10703 foreach t $tagloc($id) {
10704 if {[lsearch -exact $tags $t] < 0} {
10705 lappend tags $t
10710 set t2 [clock clicks -milliseconds]
10711 set loopix $i
10713 # remove tags that are descendents of other tags
10714 for {set i 0} {$i < [llength $tags]} {incr i} {
10715 set a [lindex $tags $i]
10716 for {set j 0} {$j < $i} {incr j} {
10717 set b [lindex $tags $j]
10718 set r [anc_or_desc $a $b]
10719 if {$r == 1} {
10720 set tags [lreplace $tags $j $j]
10721 incr j -1
10722 incr i -1
10723 } elseif {$r == -1} {
10724 set tags [lreplace $tags $i $i]
10725 incr i -1
10726 break
10731 if {[array names growing] ne {}} {
10732 # graph isn't finished, need to check if any tag could get
10733 # eclipsed by another tag coming later. Simply ignore any
10734 # tags that could later get eclipsed.
10735 set ctags {}
10736 foreach t $tags {
10737 if {[is_certain $t $origid]} {
10738 lappend ctags $t
10741 if {$tags eq $ctags} {
10742 set cached_dtags($origid) $tags
10743 } else {
10744 set tags $ctags
10746 } else {
10747 set cached_dtags($origid) $tags
10749 set t3 [clock clicks -milliseconds]
10750 if {0 && $t3 - $t1 >= 100} {
10751 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10752 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10754 return $tags
10757 proc anctags {id} {
10758 global arcnos arcids arcout arcend arctags idtags allparents
10759 global growing cached_atags
10761 if {![info exists allparents($id)]} {
10762 return {}
10764 set t1 [clock clicks -milliseconds]
10765 set argid $id
10766 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10767 # part-way along an arc; check that arc first
10768 set a [lindex $arcnos($id) 0]
10769 if {$arctags($a) ne {}} {
10770 validate_arctags $a
10771 set i [lsearch -exact $arcids($a) $id]
10772 foreach t $arctags($a) {
10773 set j [lsearch -exact $arcids($a) $t]
10774 if {$j > $i} {
10775 return $t
10779 if {![info exists arcend($a)]} {
10780 return {}
10782 set id $arcend($a)
10783 if {[info exists idtags($id)]} {
10784 return $id
10787 if {[info exists cached_atags($id)]} {
10788 return $cached_atags($id)
10791 set origid $id
10792 set todo [list $id]
10793 set queued($id) 1
10794 set taglist {}
10795 set nc 1
10796 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10797 set id [lindex $todo $i]
10798 set done($id) 1
10799 set td [info exists hastaggeddescendent($id)]
10800 if {!$td} {
10801 incr nc -1
10803 # ignore tags on starting node
10804 if {!$td && $i > 0} {
10805 if {[info exists idtags($id)]} {
10806 set tagloc($id) $id
10807 set td 1
10808 } elseif {[info exists cached_atags($id)]} {
10809 set tagloc($id) $cached_atags($id)
10810 set td 1
10813 foreach a $arcout($id) {
10814 if {!$td && $arctags($a) ne {}} {
10815 validate_arctags $a
10816 if {$arctags($a) ne {}} {
10817 lappend tagloc($id) [lindex $arctags($a) 0]
10820 if {![info exists arcend($a)]} continue
10821 set d $arcend($a)
10822 if {$td || $arctags($a) ne {}} {
10823 set tomark [list $d]
10824 for {set j 0} {$j < [llength $tomark]} {incr j} {
10825 set dd [lindex $tomark $j]
10826 if {![info exists hastaggeddescendent($dd)]} {
10827 if {[info exists done($dd)]} {
10828 foreach b $arcout($dd) {
10829 if {[info exists arcend($b)]} {
10830 lappend tomark $arcend($b)
10833 if {[info exists tagloc($dd)]} {
10834 unset tagloc($dd)
10836 } elseif {[info exists queued($dd)]} {
10837 incr nc -1
10839 set hastaggeddescendent($dd) 1
10843 if {![info exists queued($d)]} {
10844 lappend todo $d
10845 set queued($d) 1
10846 if {![info exists hastaggeddescendent($d)]} {
10847 incr nc
10852 set t2 [clock clicks -milliseconds]
10853 set loopix $i
10854 set tags {}
10855 foreach id [array names tagloc] {
10856 if {![info exists hastaggeddescendent($id)]} {
10857 foreach t $tagloc($id) {
10858 if {[lsearch -exact $tags $t] < 0} {
10859 lappend tags $t
10865 # remove tags that are ancestors of other tags
10866 for {set i 0} {$i < [llength $tags]} {incr i} {
10867 set a [lindex $tags $i]
10868 for {set j 0} {$j < $i} {incr j} {
10869 set b [lindex $tags $j]
10870 set r [anc_or_desc $a $b]
10871 if {$r == -1} {
10872 set tags [lreplace $tags $j $j]
10873 incr j -1
10874 incr i -1
10875 } elseif {$r == 1} {
10876 set tags [lreplace $tags $i $i]
10877 incr i -1
10878 break
10883 if {[array names growing] ne {}} {
10884 # graph isn't finished, need to check if any tag could get
10885 # eclipsed by another tag coming later. Simply ignore any
10886 # tags that could later get eclipsed.
10887 set ctags {}
10888 foreach t $tags {
10889 if {[is_certain $origid $t]} {
10890 lappend ctags $t
10893 if {$tags eq $ctags} {
10894 set cached_atags($origid) $tags
10895 } else {
10896 set tags $ctags
10898 } else {
10899 set cached_atags($origid) $tags
10901 set t3 [clock clicks -milliseconds]
10902 if {0 && $t3 - $t1 >= 100} {
10903 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10904 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10906 return $tags
10909 # Return the list of IDs that have heads that are descendents of id,
10910 # including id itself if it has a head.
10911 proc descheads {id} {
10912 global arcnos arcstart arcids archeads idheads cached_dheads
10913 global allparents arcout
10915 if {![info exists allparents($id)]} {
10916 return {}
10918 set aret {}
10919 if {![info exists arcout($id)]} {
10920 # part-way along an arc; check it first
10921 set a [lindex $arcnos($id) 0]
10922 if {$archeads($a) ne {}} {
10923 validate_archeads $a
10924 set i [lsearch -exact $arcids($a) $id]
10925 foreach t $archeads($a) {
10926 set j [lsearch -exact $arcids($a) $t]
10927 if {$j > $i} break
10928 lappend aret $t
10931 set id $arcstart($a)
10933 set origid $id
10934 set todo [list $id]
10935 set seen($id) 1
10936 set ret {}
10937 for {set i 0} {$i < [llength $todo]} {incr i} {
10938 set id [lindex $todo $i]
10939 if {[info exists cached_dheads($id)]} {
10940 set ret [concat $ret $cached_dheads($id)]
10941 } else {
10942 if {[info exists idheads($id)]} {
10943 lappend ret $id
10945 foreach a $arcnos($id) {
10946 if {$archeads($a) ne {}} {
10947 validate_archeads $a
10948 if {$archeads($a) ne {}} {
10949 set ret [concat $ret $archeads($a)]
10952 set d $arcstart($a)
10953 if {![info exists seen($d)]} {
10954 lappend todo $d
10955 set seen($d) 1
10960 set ret [lsort -unique $ret]
10961 set cached_dheads($origid) $ret
10962 return [concat $ret $aret]
10965 proc addedtag {id} {
10966 global arcnos arcout cached_dtags cached_atags
10968 if {![info exists arcnos($id)]} return
10969 if {![info exists arcout($id)]} {
10970 recalcarc [lindex $arcnos($id) 0]
10972 catch {unset cached_dtags}
10973 catch {unset cached_atags}
10976 proc addedhead {hid head} {
10977 global arcnos arcout cached_dheads
10979 if {![info exists arcnos($hid)]} return
10980 if {![info exists arcout($hid)]} {
10981 recalcarc [lindex $arcnos($hid) 0]
10983 catch {unset cached_dheads}
10986 proc removedhead {hid head} {
10987 global cached_dheads
10989 catch {unset cached_dheads}
10992 proc movedhead {hid head} {
10993 global arcnos arcout cached_dheads
10995 if {![info exists arcnos($hid)]} return
10996 if {![info exists arcout($hid)]} {
10997 recalcarc [lindex $arcnos($hid) 0]
10999 catch {unset cached_dheads}
11002 proc changedrefs {} {
11003 global cached_dheads cached_dtags cached_atags cached_tagcontent
11004 global arctags archeads arcnos arcout idheads idtags
11006 foreach id [concat [array names idheads] [array names idtags]] {
11007 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11008 set a [lindex $arcnos($id) 0]
11009 if {![info exists donearc($a)]} {
11010 recalcarc $a
11011 set donearc($a) 1
11015 catch {unset cached_tagcontent}
11016 catch {unset cached_dtags}
11017 catch {unset cached_atags}
11018 catch {unset cached_dheads}
11021 proc rereadrefs {} {
11022 global idtags idheads idotherrefs mainheadid
11024 set refids [concat [array names idtags] \
11025 [array names idheads] [array names idotherrefs]]
11026 foreach id $refids {
11027 if {![info exists ref($id)]} {
11028 set ref($id) [listrefs $id]
11031 set oldmainhead $mainheadid
11032 readrefs
11033 changedrefs
11034 set refids [lsort -unique [concat $refids [array names idtags] \
11035 [array names idheads] [array names idotherrefs]]]
11036 foreach id $refids {
11037 set v [listrefs $id]
11038 if {![info exists ref($id)] || $ref($id) != $v} {
11039 redrawtags $id
11042 if {$oldmainhead ne $mainheadid} {
11043 redrawtags $oldmainhead
11044 redrawtags $mainheadid
11046 run refill_reflist
11049 proc listrefs {id} {
11050 global idtags idheads idotherrefs
11052 set x {}
11053 if {[info exists idtags($id)]} {
11054 set x $idtags($id)
11056 set y {}
11057 if {[info exists idheads($id)]} {
11058 set y $idheads($id)
11060 set z {}
11061 if {[info exists idotherrefs($id)]} {
11062 set z $idotherrefs($id)
11064 return [list $x $y $z]
11067 proc add_tag_ctext {tag} {
11068 global ctext cached_tagcontent tagids
11070 if {![info exists cached_tagcontent($tag)]} {
11071 catch {
11072 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11075 $ctext insert end "[mc "Tag"]: $tag\n" bold
11076 if {[info exists cached_tagcontent($tag)]} {
11077 set text $cached_tagcontent($tag)
11078 } else {
11079 set text "[mc "Id"]: $tagids($tag)"
11081 appendwithlinks $text {}
11084 proc showtag {tag isnew} {
11085 global ctext cached_tagcontent tagids linknum tagobjid
11087 if {$isnew} {
11088 addtohistory [list showtag $tag 0] savectextpos
11090 $ctext conf -state normal
11091 clear_ctext
11092 settabs 0
11093 set linknum 0
11094 add_tag_ctext $tag
11095 maybe_scroll_ctext 1
11096 $ctext conf -state disabled
11097 init_flist {}
11100 proc showtags {id isnew} {
11101 global idtags ctext linknum
11103 if {$isnew} {
11104 addtohistory [list showtags $id 0] savectextpos
11106 $ctext conf -state normal
11107 clear_ctext
11108 settabs 0
11109 set linknum 0
11110 set sep {}
11111 foreach tag $idtags($id) {
11112 $ctext insert end $sep
11113 add_tag_ctext $tag
11114 set sep "\n\n"
11116 maybe_scroll_ctext 1
11117 $ctext conf -state disabled
11118 init_flist {}
11121 proc doquit {} {
11122 global stopped
11123 global gitktmpdir
11125 set stopped 100
11126 savestuff .
11127 destroy .
11129 if {[info exists gitktmpdir]} {
11130 catch {file delete -force $gitktmpdir}
11134 proc mkfontdisp {font top which} {
11135 global fontattr fontpref $font NS use_ttk
11137 set fontpref($font) [set $font]
11138 ${NS}::button $top.${font}but -text $which \
11139 -command [list choosefont $font $which]
11140 ${NS}::label $top.$font -relief flat -font $font \
11141 -text $fontattr($font,family) -justify left
11142 grid x $top.${font}but $top.$font -sticky w
11145 proc choosefont {font which} {
11146 global fontparam fontlist fonttop fontattr
11147 global prefstop NS
11149 set fontparam(which) $which
11150 set fontparam(font) $font
11151 set fontparam(family) [font actual $font -family]
11152 set fontparam(size) $fontattr($font,size)
11153 set fontparam(weight) $fontattr($font,weight)
11154 set fontparam(slant) $fontattr($font,slant)
11155 set top .gitkfont
11156 set fonttop $top
11157 if {![winfo exists $top]} {
11158 font create sample
11159 eval font config sample [font actual $font]
11160 ttk_toplevel $top
11161 make_transient $top $prefstop
11162 wm title $top [mc "Gitk font chooser"]
11163 ${NS}::label $top.l -textvariable fontparam(which)
11164 pack $top.l -side top
11165 set fontlist [lsort [font families]]
11166 ${NS}::frame $top.f
11167 listbox $top.f.fam -listvariable fontlist \
11168 -yscrollcommand [list $top.f.sb set]
11169 bind $top.f.fam <<ListboxSelect>> selfontfam
11170 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11171 pack $top.f.sb -side right -fill y
11172 pack $top.f.fam -side left -fill both -expand 1
11173 pack $top.f -side top -fill both -expand 1
11174 ${NS}::frame $top.g
11175 spinbox $top.g.size -from 4 -to 40 -width 4 \
11176 -textvariable fontparam(size) \
11177 -validatecommand {string is integer -strict %s}
11178 checkbutton $top.g.bold -padx 5 \
11179 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11180 -variable fontparam(weight) -onvalue bold -offvalue normal
11181 checkbutton $top.g.ital -padx 5 \
11182 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11183 -variable fontparam(slant) -onvalue italic -offvalue roman
11184 pack $top.g.size $top.g.bold $top.g.ital -side left
11185 pack $top.g -side top
11186 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11187 -background white
11188 $top.c create text 100 25 -anchor center -text $which -font sample \
11189 -fill black -tags text
11190 bind $top.c <Configure> [list centertext $top.c]
11191 pack $top.c -side top -fill x
11192 ${NS}::frame $top.buts
11193 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11194 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11195 bind $top <Key-Return> fontok
11196 bind $top <Key-Escape> fontcan
11197 grid $top.buts.ok $top.buts.can
11198 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11199 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11200 pack $top.buts -side bottom -fill x
11201 trace add variable fontparam write chg_fontparam
11202 } else {
11203 raise $top
11204 $top.c itemconf text -text $which
11206 set i [lsearch -exact $fontlist $fontparam(family)]
11207 if {$i >= 0} {
11208 $top.f.fam selection set $i
11209 $top.f.fam see $i
11213 proc centertext {w} {
11214 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11217 proc fontok {} {
11218 global fontparam fontpref prefstop
11220 set f $fontparam(font)
11221 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11222 if {$fontparam(weight) eq "bold"} {
11223 lappend fontpref($f) "bold"
11225 if {$fontparam(slant) eq "italic"} {
11226 lappend fontpref($f) "italic"
11228 set w $prefstop.notebook.fonts.$f
11229 $w conf -text $fontparam(family) -font $fontpref($f)
11231 fontcan
11234 proc fontcan {} {
11235 global fonttop fontparam
11237 if {[info exists fonttop]} {
11238 catch {destroy $fonttop}
11239 catch {font delete sample}
11240 unset fonttop
11241 unset fontparam
11245 if {[package vsatisfies [package provide Tk] 8.6]} {
11246 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11247 # function to make use of it.
11248 proc choosefont {font which} {
11249 tk fontchooser configure -title $which -font $font \
11250 -command [list on_choosefont $font $which]
11251 tk fontchooser show
11253 proc on_choosefont {font which newfont} {
11254 global fontparam
11255 puts stderr "$font $newfont"
11256 array set f [font actual $newfont]
11257 set fontparam(which) $which
11258 set fontparam(font) $font
11259 set fontparam(family) $f(-family)
11260 set fontparam(size) $f(-size)
11261 set fontparam(weight) $f(-weight)
11262 set fontparam(slant) $f(-slant)
11263 fontok
11267 proc selfontfam {} {
11268 global fonttop fontparam
11270 set i [$fonttop.f.fam curselection]
11271 if {$i ne {}} {
11272 set fontparam(family) [$fonttop.f.fam get $i]
11276 proc chg_fontparam {v sub op} {
11277 global fontparam
11279 font config sample -$sub $fontparam($sub)
11282 # Create a property sheet tab page
11283 proc create_prefs_page {w} {
11284 global NS
11285 set parent [join [lrange [split $w .] 0 end-1] .]
11286 if {[winfo class $parent] eq "TNotebook"} {
11287 ${NS}::frame $w
11288 } else {
11289 ${NS}::labelframe $w
11293 proc prefspage_general {notebook} {
11294 global NS maxwidth maxgraphpct showneartags showlocalchanges
11295 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11296 global hideremotes want_ttk have_ttk maxrefs
11298 set page [create_prefs_page $notebook.general]
11300 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11301 grid $page.ldisp - -sticky w -pady 10
11302 ${NS}::label $page.spacer -text " "
11303 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11304 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11305 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11306 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11307 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11308 grid x $page.maxpctl $page.maxpct -sticky w
11309 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11310 -variable showlocalchanges
11311 grid x $page.showlocal -sticky w
11312 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11313 -variable autoselect
11314 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11315 grid x $page.autoselect $page.autosellen -sticky w
11316 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11317 -variable hideremotes
11318 grid x $page.hideremotes -sticky w
11320 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11321 grid $page.ddisp - -sticky w -pady 10
11322 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11323 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11324 grid x $page.tabstopl $page.tabstop -sticky w
11325 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11326 -variable showneartags
11327 grid x $page.ntag -sticky w
11328 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11329 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11330 grid x $page.maxrefsl $page.maxrefs -sticky w
11331 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11332 -variable limitdiffs
11333 grid x $page.ldiff -sticky w
11334 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11335 -variable perfile_attrs
11336 grid x $page.lattr -sticky w
11338 ${NS}::entry $page.extdifft -textvariable extdifftool
11339 ${NS}::frame $page.extdifff
11340 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11341 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11342 pack $page.extdifff.l $page.extdifff.b -side left
11343 pack configure $page.extdifff.l -padx 10
11344 grid x $page.extdifff $page.extdifft -sticky ew
11346 ${NS}::label $page.lgen -text [mc "General options"]
11347 grid $page.lgen - -sticky w -pady 10
11348 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11349 -text [mc "Use themed widgets"]
11350 if {$have_ttk} {
11351 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11352 } else {
11353 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11355 grid x $page.want_ttk $page.ttk_note -sticky w
11356 return $page
11359 proc prefspage_colors {notebook} {
11360 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11362 set page [create_prefs_page $notebook.colors]
11364 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11365 grid $page.cdisp - -sticky w -pady 10
11366 label $page.ui -padx 40 -relief sunk -background $uicolor
11367 ${NS}::button $page.uibut -text [mc "Interface"] \
11368 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11369 grid x $page.uibut $page.ui -sticky w
11370 label $page.bg -padx 40 -relief sunk -background $bgcolor
11371 ${NS}::button $page.bgbut -text [mc "Background"] \
11372 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11373 grid x $page.bgbut $page.bg -sticky w
11374 label $page.fg -padx 40 -relief sunk -background $fgcolor
11375 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11376 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11377 grid x $page.fgbut $page.fg -sticky w
11378 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11379 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11380 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11381 [list $ctext tag conf d0 -foreground]]
11382 grid x $page.diffoldbut $page.diffold -sticky w
11383 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11384 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11385 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11386 [list $ctext tag conf dresult -foreground]]
11387 grid x $page.diffnewbut $page.diffnew -sticky w
11388 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11389 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11390 -command [list choosecolor diffcolors 2 $page.hunksep \
11391 [mc "diff hunk header"] \
11392 [list $ctext tag conf hunksep -foreground]]
11393 grid x $page.hunksepbut $page.hunksep -sticky w
11394 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11395 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11396 -command [list choosecolor markbgcolor {} $page.markbgsep \
11397 [mc "marked line background"] \
11398 [list $ctext tag conf omark -background]]
11399 grid x $page.markbgbut $page.markbgsep -sticky w
11400 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11401 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11402 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11403 grid x $page.selbgbut $page.selbgsep -sticky w
11404 return $page
11407 proc prefspage_fonts {notebook} {
11408 global NS
11409 set page [create_prefs_page $notebook.fonts]
11410 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11411 grid $page.cfont - -sticky w -pady 10
11412 mkfontdisp mainfont $page [mc "Main font"]
11413 mkfontdisp textfont $page [mc "Diff display font"]
11414 mkfontdisp uifont $page [mc "User interface font"]
11415 return $page
11418 proc doprefs {} {
11419 global maxwidth maxgraphpct use_ttk NS
11420 global oldprefs prefstop showneartags showlocalchanges
11421 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11422 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11423 global hideremotes want_ttk have_ttk
11425 set top .gitkprefs
11426 set prefstop $top
11427 if {[winfo exists $top]} {
11428 raise $top
11429 return
11431 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11432 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11433 set oldprefs($v) [set $v]
11435 ttk_toplevel $top
11436 wm title $top [mc "Gitk preferences"]
11437 make_transient $top .
11439 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11440 set notebook [ttk::notebook $top.notebook]
11441 } else {
11442 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11445 lappend pages [prefspage_general $notebook] [mc "General"]
11446 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11447 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11448 set col 0
11449 foreach {page title} $pages {
11450 if {$use_notebook} {
11451 $notebook add $page -text $title
11452 } else {
11453 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11454 -text $title -command [list raise $page]]
11455 $page configure -text $title
11456 grid $btn -row 0 -column [incr col] -sticky w
11457 grid $page -row 1 -column 0 -sticky news -columnspan 100
11461 if {!$use_notebook} {
11462 grid columnconfigure $notebook 0 -weight 1
11463 grid rowconfigure $notebook 1 -weight 1
11464 raise [lindex $pages 0]
11467 grid $notebook -sticky news -padx 2 -pady 2
11468 grid rowconfigure $top 0 -weight 1
11469 grid columnconfigure $top 0 -weight 1
11471 ${NS}::frame $top.buts
11472 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11473 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11474 bind $top <Key-Return> prefsok
11475 bind $top <Key-Escape> prefscan
11476 grid $top.buts.ok $top.buts.can
11477 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11478 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11479 grid $top.buts - - -pady 10 -sticky ew
11480 grid columnconfigure $top 2 -weight 1
11481 bind $top <Visibility> [list focus $top.buts.ok]
11484 proc choose_extdiff {} {
11485 global extdifftool
11487 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11488 if {$prog ne {}} {
11489 set extdifftool $prog
11493 proc choosecolor {v vi w x cmd} {
11494 global $v
11496 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11497 -title [mc "Gitk: choose color for %s" $x]]
11498 if {$c eq {}} return
11499 $w conf -background $c
11500 lset $v $vi $c
11501 eval $cmd $c
11504 proc setselbg {c} {
11505 global bglist cflist
11506 foreach w $bglist {
11507 $w configure -selectbackground $c
11509 $cflist tag configure highlight \
11510 -background [$cflist cget -selectbackground]
11511 allcanvs itemconf secsel -fill $c
11514 # This sets the background color and the color scheme for the whole UI.
11515 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11516 # if we don't specify one ourselves, which makes the checkbuttons and
11517 # radiobuttons look bad. This chooses white for selectColor if the
11518 # background color is light, or black if it is dark.
11519 proc setui {c} {
11520 if {[tk windowingsystem] eq "win32"} { return }
11521 set bg [winfo rgb . $c]
11522 set selc black
11523 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11524 set selc white
11526 tk_setPalette background $c selectColor $selc
11529 proc setbg {c} {
11530 global bglist
11532 foreach w $bglist {
11533 $w conf -background $c
11537 proc setfg {c} {
11538 global fglist canv
11540 foreach w $fglist {
11541 $w conf -foreground $c
11543 allcanvs itemconf text -fill $c
11544 $canv itemconf circle -outline $c
11545 $canv itemconf markid -outline $c
11548 proc prefscan {} {
11549 global oldprefs prefstop
11551 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11552 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11553 global $v
11554 set $v $oldprefs($v)
11556 catch {destroy $prefstop}
11557 unset prefstop
11558 fontcan
11561 proc prefsok {} {
11562 global maxwidth maxgraphpct
11563 global oldprefs prefstop showneartags showlocalchanges
11564 global fontpref mainfont textfont uifont
11565 global limitdiffs treediffs perfile_attrs
11566 global hideremotes
11568 catch {destroy $prefstop}
11569 unset prefstop
11570 fontcan
11571 set fontchanged 0
11572 if {$mainfont ne $fontpref(mainfont)} {
11573 set mainfont $fontpref(mainfont)
11574 parsefont mainfont $mainfont
11575 eval font configure mainfont [fontflags mainfont]
11576 eval font configure mainfontbold [fontflags mainfont 1]
11577 setcoords
11578 set fontchanged 1
11580 if {$textfont ne $fontpref(textfont)} {
11581 set textfont $fontpref(textfont)
11582 parsefont textfont $textfont
11583 eval font configure textfont [fontflags textfont]
11584 eval font configure textfontbold [fontflags textfont 1]
11586 if {$uifont ne $fontpref(uifont)} {
11587 set uifont $fontpref(uifont)
11588 parsefont uifont $uifont
11589 eval font configure uifont [fontflags uifont]
11591 settabs
11592 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11593 if {$showlocalchanges} {
11594 doshowlocalchanges
11595 } else {
11596 dohidelocalchanges
11599 if {$limitdiffs != $oldprefs(limitdiffs) ||
11600 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11601 # treediffs elements are limited by path;
11602 # won't have encodings cached if perfile_attrs was just turned on
11603 catch {unset treediffs}
11605 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11606 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11607 redisplay
11608 } elseif {$showneartags != $oldprefs(showneartags) ||
11609 $limitdiffs != $oldprefs(limitdiffs)} {
11610 reselectline
11612 if {$hideremotes != $oldprefs(hideremotes)} {
11613 rereadrefs
11617 proc formatdate {d} {
11618 global datetimeformat
11619 if {$d ne {}} {
11620 # If $datetimeformat includes a timezone, display in the
11621 # timezone of the argument. Otherwise, display in local time.
11622 if {[string match {*%[zZ]*} $datetimeformat]} {
11623 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11624 # Tcl < 8.5 does not support -timezone. Emulate it by
11625 # setting TZ (e.g. TZ=<-0430>+04:30).
11626 global env
11627 if {[info exists env(TZ)]} {
11628 set savedTZ $env(TZ)
11630 set zone [lindex $d 1]
11631 set sign [string map {+ - - +} [string index $zone 0]]
11632 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11633 set d [clock format [lindex $d 0] -format $datetimeformat]
11634 if {[info exists savedTZ]} {
11635 set env(TZ) $savedTZ
11636 } else {
11637 unset env(TZ)
11640 } else {
11641 set d [clock format [lindex $d 0] -format $datetimeformat]
11644 return $d
11647 # This list of encoding names and aliases is distilled from
11648 # http://www.iana.org/assignments/character-sets.
11649 # Not all of them are supported by Tcl.
11650 set encoding_aliases {
11651 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11652 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11653 { ISO-10646-UTF-1 csISO10646UTF1 }
11654 { ISO_646.basic:1983 ref csISO646basic1983 }
11655 { INVARIANT csINVARIANT }
11656 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11657 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11658 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11659 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11660 { NATS-DANO iso-ir-9-1 csNATSDANO }
11661 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11662 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11663 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11664 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11665 { ISO-2022-KR csISO2022KR }
11666 { EUC-KR csEUCKR }
11667 { ISO-2022-JP csISO2022JP }
11668 { ISO-2022-JP-2 csISO2022JP2 }
11669 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11670 csISO13JISC6220jp }
11671 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11672 { IT iso-ir-15 ISO646-IT csISO15Italian }
11673 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11674 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11675 { greek7-old iso-ir-18 csISO18Greek7Old }
11676 { latin-greek iso-ir-19 csISO19LatinGreek }
11677 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11678 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11679 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11680 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11681 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11682 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11683 { INIS iso-ir-49 csISO49INIS }
11684 { INIS-8 iso-ir-50 csISO50INIS8 }
11685 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11686 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11687 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11688 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11689 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11690 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11691 csISO60Norwegian1 }
11692 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11693 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11694 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11695 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11696 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11697 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11698 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11699 { greek7 iso-ir-88 csISO88Greek7 }
11700 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11701 { iso-ir-90 csISO90 }
11702 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11703 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11704 csISO92JISC62991984b }
11705 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11706 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11707 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11708 csISO95JIS62291984handadd }
11709 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11710 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11711 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11712 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11713 CP819 csISOLatin1 }
11714 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11715 { T.61-7bit iso-ir-102 csISO102T617bit }
11716 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11717 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11718 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11719 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11720 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11721 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11722 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11723 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11724 arabic csISOLatinArabic }
11725 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11726 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11727 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11728 greek greek8 csISOLatinGreek }
11729 { T.101-G2 iso-ir-128 csISO128T101G2 }
11730 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11731 csISOLatinHebrew }
11732 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11733 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11734 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11735 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11736 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11737 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11738 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11739 csISOLatinCyrillic }
11740 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11741 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11742 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11743 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11744 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11745 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11746 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11747 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11748 { ISO_10367-box iso-ir-155 csISO10367Box }
11749 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11750 { latin-lap lap iso-ir-158 csISO158Lap }
11751 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11752 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11753 { us-dk csUSDK }
11754 { dk-us csDKUS }
11755 { JIS_X0201 X0201 csHalfWidthKatakana }
11756 { KSC5636 ISO646-KR csKSC5636 }
11757 { ISO-10646-UCS-2 csUnicode }
11758 { ISO-10646-UCS-4 csUCS4 }
11759 { DEC-MCS dec csDECMCS }
11760 { hp-roman8 roman8 r8 csHPRoman8 }
11761 { macintosh mac csMacintosh }
11762 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11763 csIBM037 }
11764 { IBM038 EBCDIC-INT cp038 csIBM038 }
11765 { IBM273 CP273 csIBM273 }
11766 { IBM274 EBCDIC-BE CP274 csIBM274 }
11767 { IBM275 EBCDIC-BR cp275 csIBM275 }
11768 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11769 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11770 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11771 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11772 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11773 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11774 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11775 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11776 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11777 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11778 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11779 { IBM437 cp437 437 csPC8CodePage437 }
11780 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11781 { IBM775 cp775 csPC775Baltic }
11782 { IBM850 cp850 850 csPC850Multilingual }
11783 { IBM851 cp851 851 csIBM851 }
11784 { IBM852 cp852 852 csPCp852 }
11785 { IBM855 cp855 855 csIBM855 }
11786 { IBM857 cp857 857 csIBM857 }
11787 { IBM860 cp860 860 csIBM860 }
11788 { IBM861 cp861 861 cp-is csIBM861 }
11789 { IBM862 cp862 862 csPC862LatinHebrew }
11790 { IBM863 cp863 863 csIBM863 }
11791 { IBM864 cp864 csIBM864 }
11792 { IBM865 cp865 865 csIBM865 }
11793 { IBM866 cp866 866 csIBM866 }
11794 { IBM868 CP868 cp-ar csIBM868 }
11795 { IBM869 cp869 869 cp-gr csIBM869 }
11796 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11797 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11798 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11799 { IBM891 cp891 csIBM891 }
11800 { IBM903 cp903 csIBM903 }
11801 { IBM904 cp904 904 csIBBM904 }
11802 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11803 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11804 { IBM1026 CP1026 csIBM1026 }
11805 { EBCDIC-AT-DE csIBMEBCDICATDE }
11806 { EBCDIC-AT-DE-A csEBCDICATDEA }
11807 { EBCDIC-CA-FR csEBCDICCAFR }
11808 { EBCDIC-DK-NO csEBCDICDKNO }
11809 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11810 { EBCDIC-FI-SE csEBCDICFISE }
11811 { EBCDIC-FI-SE-A csEBCDICFISEA }
11812 { EBCDIC-FR csEBCDICFR }
11813 { EBCDIC-IT csEBCDICIT }
11814 { EBCDIC-PT csEBCDICPT }
11815 { EBCDIC-ES csEBCDICES }
11816 { EBCDIC-ES-A csEBCDICESA }
11817 { EBCDIC-ES-S csEBCDICESS }
11818 { EBCDIC-UK csEBCDICUK }
11819 { EBCDIC-US csEBCDICUS }
11820 { UNKNOWN-8BIT csUnknown8BiT }
11821 { MNEMONIC csMnemonic }
11822 { MNEM csMnem }
11823 { VISCII csVISCII }
11824 { VIQR csVIQR }
11825 { KOI8-R csKOI8R }
11826 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11827 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11828 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11829 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11830 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11831 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11832 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11833 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11834 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11835 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11836 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11837 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11838 { IBM1047 IBM-1047 }
11839 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11840 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11841 { UNICODE-1-1 csUnicode11 }
11842 { CESU-8 csCESU-8 }
11843 { BOCU-1 csBOCU-1 }
11844 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11845 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11846 l8 }
11847 { ISO-8859-15 ISO_8859-15 Latin-9 }
11848 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11849 { GBK CP936 MS936 windows-936 }
11850 { JIS_Encoding csJISEncoding }
11851 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11852 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11853 EUC-JP }
11854 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11855 { ISO-10646-UCS-Basic csUnicodeASCII }
11856 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11857 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11858 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11859 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11860 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11861 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11862 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11863 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11864 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11865 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11866 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11867 { Ventura-US csVenturaUS }
11868 { Ventura-International csVenturaInternational }
11869 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11870 { PC8-Turkish csPC8Turkish }
11871 { IBM-Symbols csIBMSymbols }
11872 { IBM-Thai csIBMThai }
11873 { HP-Legal csHPLegal }
11874 { HP-Pi-font csHPPiFont }
11875 { HP-Math8 csHPMath8 }
11876 { Adobe-Symbol-Encoding csHPPSMath }
11877 { HP-DeskTop csHPDesktop }
11878 { Ventura-Math csVenturaMath }
11879 { Microsoft-Publishing csMicrosoftPublishing }
11880 { Windows-31J csWindows31J }
11881 { GB2312 csGB2312 }
11882 { Big5 csBig5 }
11885 proc tcl_encoding {enc} {
11886 global encoding_aliases tcl_encoding_cache
11887 if {[info exists tcl_encoding_cache($enc)]} {
11888 return $tcl_encoding_cache($enc)
11890 set names [encoding names]
11891 set lcnames [string tolower $names]
11892 set enc [string tolower $enc]
11893 set i [lsearch -exact $lcnames $enc]
11894 if {$i < 0} {
11895 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11896 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11897 set i [lsearch -exact $lcnames $encx]
11900 if {$i < 0} {
11901 foreach l $encoding_aliases {
11902 set ll [string tolower $l]
11903 if {[lsearch -exact $ll $enc] < 0} continue
11904 # look through the aliases for one that tcl knows about
11905 foreach e $ll {
11906 set i [lsearch -exact $lcnames $e]
11907 if {$i < 0} {
11908 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11909 set i [lsearch -exact $lcnames $ex]
11912 if {$i >= 0} break
11914 break
11917 set tclenc {}
11918 if {$i >= 0} {
11919 set tclenc [lindex $names $i]
11921 set tcl_encoding_cache($enc) $tclenc
11922 return $tclenc
11925 proc gitattr {path attr default} {
11926 global path_attr_cache
11927 if {[info exists path_attr_cache($attr,$path)]} {
11928 set r $path_attr_cache($attr,$path)
11929 } else {
11930 set r "unspecified"
11931 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11932 regexp "(.*): $attr: (.*)" $line m f r
11934 set path_attr_cache($attr,$path) $r
11936 if {$r eq "unspecified"} {
11937 return $default
11939 return $r
11942 proc cache_gitattr {attr pathlist} {
11943 global path_attr_cache
11944 set newlist {}
11945 foreach path $pathlist {
11946 if {![info exists path_attr_cache($attr,$path)]} {
11947 lappend newlist $path
11950 set lim 1000
11951 if {[tk windowingsystem] == "win32"} {
11952 # windows has a 32k limit on the arguments to a command...
11953 set lim 30
11955 while {$newlist ne {}} {
11956 set head [lrange $newlist 0 [expr {$lim - 1}]]
11957 set newlist [lrange $newlist $lim end]
11958 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11959 foreach row [split $rlist "\n"] {
11960 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11961 if {[string index $path 0] eq "\""} {
11962 set path [encoding convertfrom [lindex $path 0]]
11964 set path_attr_cache($attr,$path) $value
11971 proc get_path_encoding {path} {
11972 global gui_encoding perfile_attrs
11973 set tcl_enc $gui_encoding
11974 if {$path ne {} && $perfile_attrs} {
11975 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11976 if {$enc2 ne {}} {
11977 set tcl_enc $enc2
11980 return $tcl_enc
11983 # First check that Tcl/Tk is recent enough
11984 if {[catch {package require Tk 8.4} err]} {
11985 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11986 Gitk requires at least Tcl/Tk 8.4." list
11987 exit 1
11990 # on OSX bring the current Wish process window to front
11991 if {[tk windowingsystem] eq "aqua"} {
11992 exec osascript -e [format {
11993 tell application "System Events"
11994 set frontmost of processes whose unix id is %d to true
11995 end tell
11996 } [pid] ]
11999 # Unset GIT_TRACE var if set
12000 if { [info exists ::env(GIT_TRACE)] } {
12001 unset ::env(GIT_TRACE)
12004 # defaults...
12005 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12007 set gitencoding {}
12008 catch {
12009 set gitencoding [exec git config --get i18n.commitencoding]
12011 catch {
12012 set gitencoding [exec git config --get i18n.logoutputencoding]
12014 if {$gitencoding == ""} {
12015 set gitencoding "utf-8"
12017 set tclencoding [tcl_encoding $gitencoding]
12018 if {$tclencoding == {}} {
12019 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12022 set gui_encoding [encoding system]
12023 catch {
12024 set enc [exec git config --get gui.encoding]
12025 if {$enc ne {}} {
12026 set tclenc [tcl_encoding $enc]
12027 if {$tclenc ne {}} {
12028 set gui_encoding $tclenc
12029 } else {
12030 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12035 set log_showroot true
12036 catch {
12037 set log_showroot [exec git config --bool --get log.showroot]
12040 if {[tk windowingsystem] eq "aqua"} {
12041 set mainfont {{Lucida Grande} 9}
12042 set textfont {Monaco 9}
12043 set uifont {{Lucida Grande} 9 bold}
12044 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12045 # fontconfig!
12046 set mainfont {sans 9}
12047 set textfont {monospace 9}
12048 set uifont {sans 9 bold}
12049 } else {
12050 set mainfont {Helvetica 9}
12051 set textfont {Courier 9}
12052 set uifont {Helvetica 9 bold}
12054 set tabstop 8
12055 set findmergefiles 0
12056 set maxgraphpct 50
12057 set maxwidth 16
12058 set revlistorder 0
12059 set fastdate 0
12060 set uparrowlen 5
12061 set downarrowlen 5
12062 set mingaplen 100
12063 set cmitmode "patch"
12064 set wrapcomment "none"
12065 set showneartags 1
12066 set hideremotes 0
12067 set maxrefs 20
12068 set visiblerefs {"master"}
12069 set maxlinelen 200
12070 set showlocalchanges 1
12071 set limitdiffs 1
12072 set datetimeformat "%Y-%m-%d %H:%M:%S"
12073 set autoselect 1
12074 set autosellen 40
12075 set perfile_attrs 0
12076 set want_ttk 1
12078 if {[tk windowingsystem] eq "aqua"} {
12079 set extdifftool "opendiff"
12080 } else {
12081 set extdifftool "meld"
12084 set colors {green red blue magenta darkgrey brown orange}
12085 if {[tk windowingsystem] eq "win32"} {
12086 set uicolor SystemButtonFace
12087 set uifgcolor SystemButtonText
12088 set uifgdisabledcolor SystemDisabledText
12089 set bgcolor SystemWindow
12090 set fgcolor SystemWindowText
12091 set selectbgcolor SystemHighlight
12092 } else {
12093 set uicolor grey85
12094 set uifgcolor black
12095 set uifgdisabledcolor "#999"
12096 set bgcolor white
12097 set fgcolor black
12098 set selectbgcolor gray85
12100 set diffcolors {red "#00a000" blue}
12101 set diffcontext 3
12102 set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12103 set ignorespace 0
12104 set worddiff ""
12105 set markbgcolor "#e0e0ff"
12107 set headbgcolor green
12108 set headfgcolor black
12109 set headoutlinecolor black
12110 set remotebgcolor #ffddaa
12111 set tagbgcolor yellow
12112 set tagfgcolor black
12113 set tagoutlinecolor black
12114 set reflinecolor black
12115 set filesepbgcolor #aaaaaa
12116 set filesepfgcolor black
12117 set linehoverbgcolor #ffff80
12118 set linehoverfgcolor black
12119 set linehoveroutlinecolor black
12120 set mainheadcirclecolor yellow
12121 set workingfilescirclecolor red
12122 set indexcirclecolor green
12123 set circlecolors {white blue gray blue blue}
12124 set linkfgcolor blue
12125 set circleoutlinecolor $fgcolor
12126 set foundbgcolor yellow
12127 set currentsearchhitbgcolor orange
12129 # button for popping up context menus
12130 if {[tk windowingsystem] eq "aqua"} {
12131 set ctxbut <Button-2>
12132 } else {
12133 set ctxbut <Button-3>
12136 ## For msgcat loading, first locate the installation location.
12137 if { [info exists ::env(GITK_MSGSDIR)] } {
12138 ## Msgsdir was manually set in the environment.
12139 set gitk_msgsdir $::env(GITK_MSGSDIR)
12140 } else {
12141 ## Let's guess the prefix from argv0.
12142 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12143 set gitk_libdir [file join $gitk_prefix share gitk lib]
12144 set gitk_msgsdir [file join $gitk_libdir msgs]
12145 unset gitk_prefix
12148 ## Internationalization (i18n) through msgcat and gettext. See
12149 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12150 package require msgcat
12151 namespace import ::msgcat::mc
12152 ## And eventually load the actual message catalog
12153 ::msgcat::mcload $gitk_msgsdir
12155 catch {
12156 # follow the XDG base directory specification by default. See
12157 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12158 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12159 # XDG_CONFIG_HOME environment variable is set
12160 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12161 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12162 } else {
12163 # default XDG_CONFIG_HOME
12164 set config_file "~/.config/git/gitk"
12165 set config_file_tmp "~/.config/git/gitk-tmp"
12167 if {![file exists $config_file]} {
12168 # for backward compatibility use the old config file if it exists
12169 if {[file exists "~/.gitk"]} {
12170 set config_file "~/.gitk"
12171 set config_file_tmp "~/.gitk-tmp"
12172 } elseif {![file exists [file dirname $config_file]]} {
12173 file mkdir [file dirname $config_file]
12176 source $config_file
12179 set config_variables {
12180 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12181 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12182 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12183 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12184 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12185 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12186 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12187 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12188 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12189 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12191 foreach var $config_variables {
12192 config_init_trace $var
12193 trace add variable $var write config_variable_change_cb
12196 parsefont mainfont $mainfont
12197 eval font create mainfont [fontflags mainfont]
12198 eval font create mainfontbold [fontflags mainfont 1]
12200 parsefont textfont $textfont
12201 eval font create textfont [fontflags textfont]
12202 eval font create textfontbold [fontflags textfont 1]
12204 parsefont uifont $uifont
12205 eval font create uifont [fontflags uifont]
12207 setui $uicolor
12209 setoptions
12211 # check that we can find a .git directory somewhere...
12212 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12213 show_error {} . [mc "Cannot find a git repository here."]
12214 exit 1
12217 set selecthead {}
12218 set selectheadid {}
12220 set revtreeargs {}
12221 set cmdline_files {}
12222 set i 0
12223 set revtreeargscmd {}
12224 foreach arg $argv {
12225 switch -glob -- $arg {
12226 "" { }
12227 "--" {
12228 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12229 break
12231 "--select-commit=*" {
12232 set selecthead [string range $arg 16 end]
12234 "--argscmd=*" {
12235 set revtreeargscmd [string range $arg 10 end]
12237 default {
12238 lappend revtreeargs $arg
12241 incr i
12244 if {$selecthead eq "HEAD"} {
12245 set selecthead {}
12248 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12249 # no -- on command line, but some arguments (other than --argscmd)
12250 if {[catch {
12251 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12252 set cmdline_files [split $f "\n"]
12253 set n [llength $cmdline_files]
12254 set revtreeargs [lrange $revtreeargs 0 end-$n]
12255 # Unfortunately git rev-parse doesn't produce an error when
12256 # something is both a revision and a filename. To be consistent
12257 # with git log and git rev-list, check revtreeargs for filenames.
12258 foreach arg $revtreeargs {
12259 if {[file exists $arg]} {
12260 show_error {} . [mc "Ambiguous argument '%s': both revision\
12261 and filename" $arg]
12262 exit 1
12265 } err]} {
12266 # unfortunately we get both stdout and stderr in $err,
12267 # so look for "fatal:".
12268 set i [string first "fatal:" $err]
12269 if {$i > 0} {
12270 set err [string range $err [expr {$i + 6}] end]
12272 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12273 exit 1
12277 set nullid "0000000000000000000000000000000000000000"
12278 set nullid2 "0000000000000000000000000000000000000001"
12279 set nullfile "/dev/null"
12281 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12282 if {![info exists have_ttk]} {
12283 set have_ttk [llength [info commands ::ttk::style]]
12285 set use_ttk [expr {$have_ttk && $want_ttk}]
12286 set NS [expr {$use_ttk ? "ttk" : ""}]
12288 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12290 set show_notes {}
12291 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12292 set show_notes "--show-notes"
12295 set appname "gitk"
12297 set runq {}
12298 set history {}
12299 set historyindex 0
12300 set fh_serial 0
12301 set nhl_names {}
12302 set highlight_paths {}
12303 set findpattern {}
12304 set searchdirn -forwards
12305 set boldids {}
12306 set boldnameids {}
12307 set diffelide {0 0}
12308 set markingmatches 0
12309 set linkentercount 0
12310 set need_redisplay 0
12311 set nrows_drawn 0
12312 set firsttabstop 0
12314 set nextviewnum 1
12315 set curview 0
12316 set selectedview 0
12317 set selectedhlview [mc "None"]
12318 set highlight_related [mc "None"]
12319 set highlight_files {}
12320 set viewfiles(0) {}
12321 set viewperm(0) 0
12322 set viewchanged(0) 0
12323 set viewargs(0) {}
12324 set viewargscmd(0) {}
12326 set selectedline {}
12327 set numcommits 0
12328 set loginstance 0
12329 set cmdlineok 0
12330 set stopped 0
12331 set stuffsaved 0
12332 set patchnum 0
12333 set lserial 0
12334 set hasworktree [hasworktree]
12335 set cdup {}
12336 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12337 set cdup [exec git rev-parse --show-cdup]
12339 set worktree [exec git rev-parse --show-toplevel]
12340 setcoords
12341 makewindow
12342 catch {
12343 image create photo gitlogo -width 16 -height 16
12345 image create photo gitlogominus -width 4 -height 2
12346 gitlogominus put #C00000 -to 0 0 4 2
12347 gitlogo copy gitlogominus -to 1 5
12348 gitlogo copy gitlogominus -to 6 5
12349 gitlogo copy gitlogominus -to 11 5
12350 image delete gitlogominus
12352 image create photo gitlogoplus -width 4 -height 4
12353 gitlogoplus put #008000 -to 1 0 3 4
12354 gitlogoplus put #008000 -to 0 1 4 3
12355 gitlogo copy gitlogoplus -to 1 9
12356 gitlogo copy gitlogoplus -to 6 9
12357 gitlogo copy gitlogoplus -to 11 9
12358 image delete gitlogoplus
12360 image create photo gitlogo32 -width 32 -height 32
12361 gitlogo32 copy gitlogo -zoom 2 2
12363 wm iconphoto . -default gitlogo gitlogo32
12365 # wait for the window to become visible
12366 tkwait visibility .
12367 wm title . "$appname: [reponame]"
12368 update
12369 readrefs
12371 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12372 # create a view for the files/dirs specified on the command line
12373 set curview 1
12374 set selectedview 1
12375 set nextviewnum 2
12376 set viewname(1) [mc "Command line"]
12377 set viewfiles(1) $cmdline_files
12378 set viewargs(1) $revtreeargs
12379 set viewargscmd(1) $revtreeargscmd
12380 set viewperm(1) 0
12381 set viewchanged(1) 0
12382 set vdatemode(1) 0
12383 addviewmenu 1
12384 .bar.view entryconf [mca "Edit view..."] -state normal
12385 .bar.view entryconf [mca "Delete view"] -state normal
12388 if {[info exists permviews]} {
12389 foreach v $permviews {
12390 set n $nextviewnum
12391 incr nextviewnum
12392 set viewname($n) [lindex $v 0]
12393 set viewfiles($n) [lindex $v 1]
12394 set viewargs($n) [lindex $v 2]
12395 set viewargscmd($n) [lindex $v 3]
12396 set viewperm($n) 1
12397 set viewchanged($n) 0
12398 addviewmenu $n
12402 if {[tk windowingsystem] eq "win32"} {
12403 focus -force .
12406 getcommits {}
12408 # Local variables:
12409 # mode: tcl
12410 # indent-tabs-mode: t
12411 # tab-width: 8
12412 # End: