git-p4: clean up after p4 submit failure
[alt-git.git] / gitk-git / gitk
blob2028b554f48798c87852cdb3c5ab6b558ad6722e
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2014 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 package require Tk
12 proc hasworktree {} {
13 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
14 [exec git rev-parse --is-inside-git-dir] == "false"}]
17 proc reponame {} {
18 global gitdir
19 set n [file normalize $gitdir]
20 if {[string match "*/.git" $n]} {
21 set n [string range $n 0 end-5]
23 return [file tail $n]
26 proc gitworktree {} {
27 variable _gitworktree
28 if {[info exists _gitworktree]} {
29 return $_gitworktree
31 # v1.7.0 introduced --show-toplevel to return the canonical work-tree
32 if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
33 # try to set work tree from environment, core.worktree or use
34 # cdup to obtain a relative path to the top of the worktree. If
35 # run from the top, the ./ prefix ensures normalize expands pwd.
36 if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
37 catch {set _gitworktree [exec git config --get core.worktree]}
38 if {$_gitworktree eq ""} {
39 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
43 return $_gitworktree
46 # A simple scheduler for compute-intensive stuff.
47 # The aim is to make sure that event handlers for GUI actions can
48 # run at least every 50-100 ms. Unfortunately fileevent handlers are
49 # run before X event handlers, so reading from a fast source can
50 # make the GUI completely unresponsive.
51 proc run args {
52 global isonrunq runq currunq
54 set script $args
55 if {[info exists isonrunq($script)]} return
56 if {$runq eq {} && ![info exists currunq]} {
57 after idle dorunq
59 lappend runq [list {} $script]
60 set isonrunq($script) 1
63 proc filerun {fd script} {
64 fileevent $fd readable [list filereadable $fd $script]
67 proc filereadable {fd script} {
68 global runq currunq
70 fileevent $fd readable {}
71 if {$runq eq {} && ![info exists currunq]} {
72 after idle dorunq
74 lappend runq [list $fd $script]
77 proc nukefile {fd} {
78 global runq
80 for {set i 0} {$i < [llength $runq]} {} {
81 if {[lindex $runq $i 0] eq $fd} {
82 set runq [lreplace $runq $i $i]
83 } else {
84 incr i
89 proc dorunq {} {
90 global isonrunq runq currunq
92 set tstart [clock clicks -milliseconds]
93 set t0 $tstart
94 while {[llength $runq] > 0} {
95 set fd [lindex $runq 0 0]
96 set script [lindex $runq 0 1]
97 set currunq [lindex $runq 0]
98 set runq [lrange $runq 1 end]
99 set repeat [eval $script]
100 unset currunq
101 set t1 [clock clicks -milliseconds]
102 set t [expr {$t1 - $t0}]
103 if {$repeat ne {} && $repeat} {
104 if {$fd eq {} || $repeat == 2} {
105 # script returns 1 if it wants to be readded
106 # file readers return 2 if they could do more straight away
107 lappend runq [list $fd $script]
108 } else {
109 fileevent $fd readable [list filereadable $fd $script]
111 } elseif {$fd eq {}} {
112 unset isonrunq($script)
114 set t0 $t1
115 if {$t1 - $tstart >= 80} break
117 if {$runq ne {}} {
118 after idle dorunq
122 proc reg_instance {fd} {
123 global commfd leftover loginstance
125 set i [incr loginstance]
126 set commfd($i) $fd
127 set leftover($i) {}
128 return $i
131 proc unmerged_files {files} {
132 global nr_unmerged
134 # find the list of unmerged files
135 set mlist {}
136 set nr_unmerged 0
137 if {[catch {
138 set fd [open "| git ls-files -u" r]
139 } err]} {
140 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
141 exit 1
143 while {[gets $fd line] >= 0} {
144 set i [string first "\t" $line]
145 if {$i < 0} continue
146 set fname [string range $line [expr {$i+1}] end]
147 if {[lsearch -exact $mlist $fname] >= 0} continue
148 incr nr_unmerged
149 if {$files eq {} || [path_filter $files $fname]} {
150 lappend mlist $fname
153 catch {close $fd}
154 return $mlist
157 proc parseviewargs {n arglist} {
158 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
159 global vinlinediff
160 global worddiff git_version
162 set vdatemode($n) 0
163 set vmergeonly($n) 0
164 set vinlinediff($n) 0
165 set glflags {}
166 set diffargs {}
167 set nextisval 0
168 set revargs {}
169 set origargs $arglist
170 set allknown 1
171 set filtered 0
172 set i -1
173 foreach arg $arglist {
174 incr i
175 if {$nextisval} {
176 lappend glflags $arg
177 set nextisval 0
178 continue
180 switch -glob -- $arg {
181 "-d" -
182 "--date-order" {
183 set vdatemode($n) 1
184 # remove from origargs in case we hit an unknown option
185 set origargs [lreplace $origargs $i $i]
186 incr i -1
188 "-[puabwcrRBMC]" -
189 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
190 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
191 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
192 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
193 "--ignore-space-change" - "-U*" - "--unified=*" {
194 # These request or affect diff output, which we don't want.
195 # Some could be used to set our defaults for diff display.
196 lappend diffargs $arg
198 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
199 "--name-only" - "--name-status" - "--color" -
200 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
201 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
202 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
203 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
204 "--objects" - "--objects-edge" - "--reverse" {
205 # These cause our parsing of git log's output to fail, or else
206 # they're options we want to set ourselves, so ignore them.
208 "--color-words*" - "--word-diff=color" {
209 # These trigger a word diff in the console interface,
210 # so help the user by enabling our own support
211 if {[package vcompare $git_version "1.7.2"] >= 0} {
212 set worddiff [mc "Color words"]
215 "--word-diff*" {
216 if {[package vcompare $git_version "1.7.2"] >= 0} {
217 set worddiff [mc "Markup words"]
220 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
221 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
222 "--full-history" - "--dense" - "--sparse" -
223 "--follow" - "--left-right" - "--encoding=*" {
224 # These are harmless, and some are even useful
225 lappend glflags $arg
227 "--diff-filter=*" - "--no-merges" - "--unpacked" -
228 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
229 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
230 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
231 "--remove-empty" - "--first-parent" - "--cherry-pick" -
232 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
233 "--simplify-by-decoration" {
234 # These mean that we get a subset of the commits
235 set filtered 1
236 lappend glflags $arg
238 "-L*" {
239 # Line-log with 'stuck' argument (unstuck form is
240 # not supported)
241 set filtered 1
242 set vinlinediff($n) 1
243 set allknown 0
244 lappend glflags $arg
246 "-n" {
247 # This appears to be the only one that has a value as a
248 # separate word following it
249 set filtered 1
250 set nextisval 1
251 lappend glflags $arg
253 "--not" - "--all" {
254 lappend revargs $arg
256 "--merge" {
257 set vmergeonly($n) 1
258 # git rev-parse doesn't understand --merge
259 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
261 "--no-replace-objects" {
262 set env(GIT_NO_REPLACE_OBJECTS) "1"
264 "-*" {
265 # Other flag arguments including -<n>
266 if {[string is digit -strict [string range $arg 1 end]]} {
267 set filtered 1
268 } else {
269 # a flag argument that we don't recognize;
270 # that means we can't optimize
271 set allknown 0
273 lappend glflags $arg
275 default {
276 # Non-flag arguments specify commits or ranges of commits
277 if {[string match "*...*" $arg]} {
278 lappend revargs --gitk-symmetric-diff-marker
280 lappend revargs $arg
284 set vdflags($n) $diffargs
285 set vflags($n) $glflags
286 set vrevs($n) $revargs
287 set vfiltered($n) $filtered
288 set vorigargs($n) $origargs
289 return $allknown
292 proc parseviewrevs {view revs} {
293 global vposids vnegids
295 if {$revs eq {}} {
296 set revs HEAD
297 } elseif {[lsearch -exact $revs --all] >= 0} {
298 lappend revs HEAD
300 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
301 # we get stdout followed by stderr in $err
302 # for an unknown rev, git rev-parse echoes it and then errors out
303 set errlines [split $err "\n"]
304 set badrev {}
305 for {set l 0} {$l < [llength $errlines]} {incr l} {
306 set line [lindex $errlines $l]
307 if {!([string length $line] == 40 && [string is xdigit $line])} {
308 if {[string match "fatal:*" $line]} {
309 if {[string match "fatal: ambiguous argument*" $line]
310 && $badrev ne {}} {
311 if {[llength $badrev] == 1} {
312 set err "unknown revision $badrev"
313 } else {
314 set err "unknown revisions: [join $badrev ", "]"
316 } else {
317 set err [join [lrange $errlines $l end] "\n"]
319 break
321 lappend badrev $line
324 error_popup "[mc "Error parsing revisions:"] $err"
325 return {}
327 set ret {}
328 set pos {}
329 set neg {}
330 set sdm 0
331 foreach id [split $ids "\n"] {
332 if {$id eq "--gitk-symmetric-diff-marker"} {
333 set sdm 4
334 } elseif {[string match "^*" $id]} {
335 if {$sdm != 1} {
336 lappend ret $id
337 if {$sdm == 3} {
338 set sdm 0
341 lappend neg [string range $id 1 end]
342 } else {
343 if {$sdm != 2} {
344 lappend ret $id
345 } else {
346 lset ret end $id...[lindex $ret end]
348 lappend pos $id
350 incr sdm -1
352 set vposids($view) $pos
353 set vnegids($view) $neg
354 return $ret
357 # Start off a git log process and arrange to read its output
358 proc start_rev_list {view} {
359 global startmsecs commitidx viewcomplete curview
360 global tclencoding
361 global viewargs viewargscmd viewfiles vfilelimit
362 global showlocalchanges
363 global viewactive viewinstances vmergeonly
364 global mainheadid viewmainheadid viewmainheadid_orig
365 global vcanopt vflags vrevs vorigargs
366 global show_notes
368 set startmsecs [clock clicks -milliseconds]
369 set commitidx($view) 0
370 # these are set this way for the error exits
371 set viewcomplete($view) 1
372 set viewactive($view) 0
373 varcinit $view
375 set args $viewargs($view)
376 if {$viewargscmd($view) ne {}} {
377 if {[catch {
378 set str [exec sh -c $viewargscmd($view)]
379 } err]} {
380 error_popup "[mc "Error executing --argscmd command:"] $err"
381 return 0
383 set args [concat $args [split $str "\n"]]
385 set vcanopt($view) [parseviewargs $view $args]
387 set files $viewfiles($view)
388 if {$vmergeonly($view)} {
389 set files [unmerged_files $files]
390 if {$files eq {}} {
391 global nr_unmerged
392 if {$nr_unmerged == 0} {
393 error_popup [mc "No files selected: --merge specified but\
394 no files are unmerged."]
395 } else {
396 error_popup [mc "No files selected: --merge specified but\
397 no unmerged files are within file limit."]
399 return 0
402 set vfilelimit($view) $files
404 if {$vcanopt($view)} {
405 set revs [parseviewrevs $view $vrevs($view)]
406 if {$revs eq {}} {
407 return 0
409 set args [concat $vflags($view) $revs]
410 } else {
411 set args $vorigargs($view)
414 if {[catch {
415 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
416 --parents --boundary $args "--" $files] r]
417 } err]} {
418 error_popup "[mc "Error executing git log:"] $err"
419 return 0
421 set i [reg_instance $fd]
422 set viewinstances($view) [list $i]
423 set viewmainheadid($view) $mainheadid
424 set viewmainheadid_orig($view) $mainheadid
425 if {$files ne {} && $mainheadid ne {}} {
426 get_viewmainhead $view
428 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
429 interestedin $viewmainheadid($view) dodiffindex
431 fconfigure $fd -blocking 0 -translation lf -eofchar {}
432 if {$tclencoding != {}} {
433 fconfigure $fd -encoding $tclencoding
435 filerun $fd [list getcommitlines $fd $i $view 0]
436 nowbusy $view [mc "Reading"]
437 set viewcomplete($view) 0
438 set viewactive($view) 1
439 return 1
442 proc stop_instance {inst} {
443 global commfd leftover
445 set fd $commfd($inst)
446 catch {
447 set pid [pid $fd]
449 if {$::tcl_platform(platform) eq {windows}} {
450 exec taskkill /pid $pid
451 } else {
452 exec kill $pid
455 catch {close $fd}
456 nukefile $fd
457 unset commfd($inst)
458 unset leftover($inst)
461 proc stop_backends {} {
462 global commfd
464 foreach inst [array names commfd] {
465 stop_instance $inst
469 proc stop_rev_list {view} {
470 global viewinstances
472 foreach inst $viewinstances($view) {
473 stop_instance $inst
475 set viewinstances($view) {}
478 proc reset_pending_select {selid} {
479 global pending_select mainheadid selectheadid
481 if {$selid ne {}} {
482 set pending_select $selid
483 } elseif {$selectheadid ne {}} {
484 set pending_select $selectheadid
485 } else {
486 set pending_select $mainheadid
490 proc getcommits {selid} {
491 global canv curview need_redisplay viewactive
493 initlayout
494 if {[start_rev_list $curview]} {
495 reset_pending_select $selid
496 show_status [mc "Reading commits..."]
497 set need_redisplay 1
498 } else {
499 show_status [mc "No commits selected"]
503 proc updatecommits {} {
504 global curview vcanopt vorigargs vfilelimit viewinstances
505 global viewactive viewcomplete tclencoding
506 global startmsecs showneartags showlocalchanges
507 global mainheadid viewmainheadid viewmainheadid_orig pending_select
508 global hasworktree
509 global varcid vposids vnegids vflags vrevs
510 global show_notes
512 set hasworktree [hasworktree]
513 rereadrefs
514 set view $curview
515 if {$mainheadid ne $viewmainheadid_orig($view)} {
516 if {$showlocalchanges} {
517 dohidelocalchanges
519 set viewmainheadid($view) $mainheadid
520 set viewmainheadid_orig($view) $mainheadid
521 if {$vfilelimit($view) ne {}} {
522 get_viewmainhead $view
525 if {$showlocalchanges} {
526 doshowlocalchanges
528 if {$vcanopt($view)} {
529 set oldpos $vposids($view)
530 set oldneg $vnegids($view)
531 set revs [parseviewrevs $view $vrevs($view)]
532 if {$revs eq {}} {
533 return
535 # note: getting the delta when negative refs change is hard,
536 # and could require multiple git log invocations, so in that
537 # case we ask git log for all the commits (not just the delta)
538 if {$oldneg eq $vnegids($view)} {
539 set newrevs {}
540 set npos 0
541 # take out positive refs that we asked for before or
542 # that we have already seen
543 foreach rev $revs {
544 if {[string length $rev] == 40} {
545 if {[lsearch -exact $oldpos $rev] < 0
546 && ![info exists varcid($view,$rev)]} {
547 lappend newrevs $rev
548 incr npos
550 } else {
551 lappend $newrevs $rev
554 if {$npos == 0} return
555 set revs $newrevs
556 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
558 set args [concat $vflags($view) $revs --not $oldpos]
559 } else {
560 set args $vorigargs($view)
562 if {[catch {
563 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
564 --parents --boundary $args "--" $vfilelimit($view)] r]
565 } err]} {
566 error_popup "[mc "Error executing git log:"] $err"
567 return
569 if {$viewactive($view) == 0} {
570 set startmsecs [clock clicks -milliseconds]
572 set i [reg_instance $fd]
573 lappend viewinstances($view) $i
574 fconfigure $fd -blocking 0 -translation lf -eofchar {}
575 if {$tclencoding != {}} {
576 fconfigure $fd -encoding $tclencoding
578 filerun $fd [list getcommitlines $fd $i $view 1]
579 incr viewactive($view)
580 set viewcomplete($view) 0
581 reset_pending_select {}
582 nowbusy $view [mc "Reading"]
583 if {$showneartags} {
584 getallcommits
588 proc reloadcommits {} {
589 global curview viewcomplete selectedline currentid thickerline
590 global showneartags treediffs commitinterest cached_commitrow
591 global targetid
593 set selid {}
594 if {$selectedline ne {}} {
595 set selid $currentid
598 if {!$viewcomplete($curview)} {
599 stop_rev_list $curview
601 resetvarcs $curview
602 set selectedline {}
603 unset -nocomplain currentid
604 unset -nocomplain thickerline
605 unset -nocomplain treediffs
606 readrefs
607 changedrefs
608 if {$showneartags} {
609 getallcommits
611 clear_display
612 unset -nocomplain commitinterest
613 unset -nocomplain cached_commitrow
614 unset -nocomplain targetid
615 setcanvscroll
616 getcommits $selid
617 return 0
620 # This makes a string representation of a positive integer which
621 # sorts as a string in numerical order
622 proc strrep {n} {
623 if {$n < 16} {
624 return [format "%x" $n]
625 } elseif {$n < 256} {
626 return [format "x%.2x" $n]
627 } elseif {$n < 65536} {
628 return [format "y%.4x" $n]
630 return [format "z%.8x" $n]
633 # Procedures used in reordering commits from git log (without
634 # --topo-order) into the order for display.
636 proc varcinit {view} {
637 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
638 global vtokmod varcmod vrowmod varcix vlastins
640 set varcstart($view) {{}}
641 set vupptr($view) {0}
642 set vdownptr($view) {0}
643 set vleftptr($view) {0}
644 set vbackptr($view) {0}
645 set varctok($view) {{}}
646 set varcrow($view) {{}}
647 set vtokmod($view) {}
648 set varcmod($view) 0
649 set vrowmod($view) 0
650 set varcix($view) {{}}
651 set vlastins($view) {0}
654 proc resetvarcs {view} {
655 global varcid varccommits parents children vseedcount ordertok
656 global vshortids
658 foreach vid [array names varcid $view,*] {
659 unset varcid($vid)
660 unset children($vid)
661 unset parents($vid)
663 foreach vid [array names vshortids $view,*] {
664 unset vshortids($vid)
666 # some commits might have children but haven't been seen yet
667 foreach vid [array names children $view,*] {
668 unset children($vid)
670 foreach va [array names varccommits $view,*] {
671 unset varccommits($va)
673 foreach vd [array names vseedcount $view,*] {
674 unset vseedcount($vd)
676 unset -nocomplain ordertok
679 # returns a list of the commits with no children
680 proc seeds {v} {
681 global vdownptr vleftptr varcstart
683 set ret {}
684 set a [lindex $vdownptr($v) 0]
685 while {$a != 0} {
686 lappend ret [lindex $varcstart($v) $a]
687 set a [lindex $vleftptr($v) $a]
689 return $ret
692 proc newvarc {view id} {
693 global varcid varctok parents children vdatemode
694 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
695 global commitdata commitinfo vseedcount varccommits vlastins
697 set a [llength $varctok($view)]
698 set vid $view,$id
699 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
700 if {![info exists commitinfo($id)]} {
701 parsecommit $id $commitdata($id) 1
703 set cdate [lindex [lindex $commitinfo($id) 4] 0]
704 if {![string is integer -strict $cdate]} {
705 set cdate 0
707 if {![info exists vseedcount($view,$cdate)]} {
708 set vseedcount($view,$cdate) -1
710 set c [incr vseedcount($view,$cdate)]
711 set cdate [expr {$cdate ^ 0xffffffff}]
712 set tok "s[strrep $cdate][strrep $c]"
713 } else {
714 set tok {}
716 set ka 0
717 if {[llength $children($vid)] > 0} {
718 set kid [lindex $children($vid) end]
719 set k $varcid($view,$kid)
720 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
721 set ki $kid
722 set ka $k
723 set tok [lindex $varctok($view) $k]
726 if {$ka != 0} {
727 set i [lsearch -exact $parents($view,$ki) $id]
728 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
729 append tok [strrep $j]
731 set c [lindex $vlastins($view) $ka]
732 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
733 set c $ka
734 set b [lindex $vdownptr($view) $ka]
735 } else {
736 set b [lindex $vleftptr($view) $c]
738 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
739 set c $b
740 set b [lindex $vleftptr($view) $c]
742 if {$c == $ka} {
743 lset vdownptr($view) $ka $a
744 lappend vbackptr($view) 0
745 } else {
746 lset vleftptr($view) $c $a
747 lappend vbackptr($view) $c
749 lset vlastins($view) $ka $a
750 lappend vupptr($view) $ka
751 lappend vleftptr($view) $b
752 if {$b != 0} {
753 lset vbackptr($view) $b $a
755 lappend varctok($view) $tok
756 lappend varcstart($view) $id
757 lappend vdownptr($view) 0
758 lappend varcrow($view) {}
759 lappend varcix($view) {}
760 set varccommits($view,$a) {}
761 lappend vlastins($view) 0
762 return $a
765 proc splitvarc {p v} {
766 global varcid varcstart varccommits varctok vtokmod
767 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
769 set oa $varcid($v,$p)
770 set otok [lindex $varctok($v) $oa]
771 set ac $varccommits($v,$oa)
772 set i [lsearch -exact $varccommits($v,$oa) $p]
773 if {$i <= 0} return
774 set na [llength $varctok($v)]
775 # "%" sorts before "0"...
776 set tok "$otok%[strrep $i]"
777 lappend varctok($v) $tok
778 lappend varcrow($v) {}
779 lappend varcix($v) {}
780 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
781 set varccommits($v,$na) [lrange $ac $i end]
782 lappend varcstart($v) $p
783 foreach id $varccommits($v,$na) {
784 set varcid($v,$id) $na
786 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
787 lappend vlastins($v) [lindex $vlastins($v) $oa]
788 lset vdownptr($v) $oa $na
789 lset vlastins($v) $oa 0
790 lappend vupptr($v) $oa
791 lappend vleftptr($v) 0
792 lappend vbackptr($v) 0
793 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
794 lset vupptr($v) $b $na
796 if {[string compare $otok $vtokmod($v)] <= 0} {
797 modify_arc $v $oa
801 proc renumbervarc {a v} {
802 global parents children varctok varcstart varccommits
803 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
805 set t1 [clock clicks -milliseconds]
806 set todo {}
807 set isrelated($a) 1
808 set kidchanged($a) 1
809 set ntot 0
810 while {$a != 0} {
811 if {[info exists isrelated($a)]} {
812 lappend todo $a
813 set id [lindex $varccommits($v,$a) end]
814 foreach p $parents($v,$id) {
815 if {[info exists varcid($v,$p)]} {
816 set isrelated($varcid($v,$p)) 1
820 incr ntot
821 set b [lindex $vdownptr($v) $a]
822 if {$b == 0} {
823 while {$a != 0} {
824 set b [lindex $vleftptr($v) $a]
825 if {$b != 0} break
826 set a [lindex $vupptr($v) $a]
829 set a $b
831 foreach a $todo {
832 if {![info exists kidchanged($a)]} continue
833 set id [lindex $varcstart($v) $a]
834 if {[llength $children($v,$id)] > 1} {
835 set children($v,$id) [lsort -command [list vtokcmp $v] \
836 $children($v,$id)]
838 set oldtok [lindex $varctok($v) $a]
839 if {!$vdatemode($v)} {
840 set tok {}
841 } else {
842 set tok $oldtok
844 set ka 0
845 set kid [last_real_child $v,$id]
846 if {$kid ne {}} {
847 set k $varcid($v,$kid)
848 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
849 set ki $kid
850 set ka $k
851 set tok [lindex $varctok($v) $k]
854 if {$ka != 0} {
855 set i [lsearch -exact $parents($v,$ki) $id]
856 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
857 append tok [strrep $j]
859 if {$tok eq $oldtok} {
860 continue
862 set id [lindex $varccommits($v,$a) end]
863 foreach p $parents($v,$id) {
864 if {[info exists varcid($v,$p)]} {
865 set kidchanged($varcid($v,$p)) 1
866 } else {
867 set sortkids($p) 1
870 lset varctok($v) $a $tok
871 set b [lindex $vupptr($v) $a]
872 if {$b != $ka} {
873 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
874 modify_arc $v $ka
876 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
877 modify_arc $v $b
879 set c [lindex $vbackptr($v) $a]
880 set d [lindex $vleftptr($v) $a]
881 if {$c == 0} {
882 lset vdownptr($v) $b $d
883 } else {
884 lset vleftptr($v) $c $d
886 if {$d != 0} {
887 lset vbackptr($v) $d $c
889 if {[lindex $vlastins($v) $b] == $a} {
890 lset vlastins($v) $b $c
892 lset vupptr($v) $a $ka
893 set c [lindex $vlastins($v) $ka]
894 if {$c == 0 || \
895 [string compare $tok [lindex $varctok($v) $c]] < 0} {
896 set c $ka
897 set b [lindex $vdownptr($v) $ka]
898 } else {
899 set b [lindex $vleftptr($v) $c]
901 while {$b != 0 && \
902 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
903 set c $b
904 set b [lindex $vleftptr($v) $c]
906 if {$c == $ka} {
907 lset vdownptr($v) $ka $a
908 lset vbackptr($v) $a 0
909 } else {
910 lset vleftptr($v) $c $a
911 lset vbackptr($v) $a $c
913 lset vleftptr($v) $a $b
914 if {$b != 0} {
915 lset vbackptr($v) $b $a
917 lset vlastins($v) $ka $a
920 foreach id [array names sortkids] {
921 if {[llength $children($v,$id)] > 1} {
922 set children($v,$id) [lsort -command [list vtokcmp $v] \
923 $children($v,$id)]
926 set t2 [clock clicks -milliseconds]
927 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
930 # Fix up the graph after we have found out that in view $v,
931 # $p (a commit that we have already seen) is actually the parent
932 # of the last commit in arc $a.
933 proc fix_reversal {p a v} {
934 global varcid varcstart varctok vupptr
936 set pa $varcid($v,$p)
937 if {$p ne [lindex $varcstart($v) $pa]} {
938 splitvarc $p $v
939 set pa $varcid($v,$p)
941 # seeds always need to be renumbered
942 if {[lindex $vupptr($v) $pa] == 0 ||
943 [string compare [lindex $varctok($v) $a] \
944 [lindex $varctok($v) $pa]] > 0} {
945 renumbervarc $pa $v
949 proc insertrow {id p v} {
950 global cmitlisted children parents varcid varctok vtokmod
951 global varccommits ordertok commitidx numcommits curview
952 global targetid targetrow vshortids
954 readcommit $id
955 set vid $v,$id
956 set cmitlisted($vid) 1
957 set children($vid) {}
958 set parents($vid) [list $p]
959 set a [newvarc $v $id]
960 set varcid($vid) $a
961 lappend vshortids($v,[string range $id 0 3]) $id
962 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
963 modify_arc $v $a
965 lappend varccommits($v,$a) $id
966 set vp $v,$p
967 if {[llength [lappend children($vp) $id]] > 1} {
968 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
969 unset -nocomplain ordertok
971 fix_reversal $p $a $v
972 incr commitidx($v)
973 if {$v == $curview} {
974 set numcommits $commitidx($v)
975 setcanvscroll
976 if {[info exists targetid]} {
977 if {![comes_before $targetid $p]} {
978 incr targetrow
984 proc insertfakerow {id p} {
985 global varcid varccommits parents children cmitlisted
986 global commitidx varctok vtokmod targetid targetrow curview numcommits
988 set v $curview
989 set a $varcid($v,$p)
990 set i [lsearch -exact $varccommits($v,$a) $p]
991 if {$i < 0} {
992 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
993 return
995 set children($v,$id) {}
996 set parents($v,$id) [list $p]
997 set varcid($v,$id) $a
998 lappend children($v,$p) $id
999 set cmitlisted($v,$id) 1
1000 set numcommits [incr commitidx($v)]
1001 # note we deliberately don't update varcstart($v) even if $i == 0
1002 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1003 modify_arc $v $a $i
1004 if {[info exists targetid]} {
1005 if {![comes_before $targetid $p]} {
1006 incr targetrow
1009 setcanvscroll
1010 drawvisible
1013 proc removefakerow {id} {
1014 global varcid varccommits parents children commitidx
1015 global varctok vtokmod cmitlisted currentid selectedline
1016 global targetid curview numcommits
1018 set v $curview
1019 if {[llength $parents($v,$id)] != 1} {
1020 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1021 return
1023 set p [lindex $parents($v,$id) 0]
1024 set a $varcid($v,$id)
1025 set i [lsearch -exact $varccommits($v,$a) $id]
1026 if {$i < 0} {
1027 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1028 return
1030 unset varcid($v,$id)
1031 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1032 unset parents($v,$id)
1033 unset children($v,$id)
1034 unset cmitlisted($v,$id)
1035 set numcommits [incr commitidx($v) -1]
1036 set j [lsearch -exact $children($v,$p) $id]
1037 if {$j >= 0} {
1038 set children($v,$p) [lreplace $children($v,$p) $j $j]
1040 modify_arc $v $a $i
1041 if {[info exist currentid] && $id eq $currentid} {
1042 unset currentid
1043 set selectedline {}
1045 if {[info exists targetid] && $targetid eq $id} {
1046 set targetid $p
1048 setcanvscroll
1049 drawvisible
1052 proc real_children {vp} {
1053 global children nullid nullid2
1055 set kids {}
1056 foreach id $children($vp) {
1057 if {$id ne $nullid && $id ne $nullid2} {
1058 lappend kids $id
1061 return $kids
1064 proc first_real_child {vp} {
1065 global children nullid nullid2
1067 foreach id $children($vp) {
1068 if {$id ne $nullid && $id ne $nullid2} {
1069 return $id
1072 return {}
1075 proc last_real_child {vp} {
1076 global children nullid nullid2
1078 set kids $children($vp)
1079 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1080 set id [lindex $kids $i]
1081 if {$id ne $nullid && $id ne $nullid2} {
1082 return $id
1085 return {}
1088 proc vtokcmp {v a b} {
1089 global varctok varcid
1091 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1092 [lindex $varctok($v) $varcid($v,$b)]]
1095 # This assumes that if lim is not given, the caller has checked that
1096 # arc a's token is less than $vtokmod($v)
1097 proc modify_arc {v a {lim {}}} {
1098 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1100 if {$lim ne {}} {
1101 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1102 if {$c > 0} return
1103 if {$c == 0} {
1104 set r [lindex $varcrow($v) $a]
1105 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1108 set vtokmod($v) [lindex $varctok($v) $a]
1109 set varcmod($v) $a
1110 if {$v == $curview} {
1111 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1112 set a [lindex $vupptr($v) $a]
1113 set lim {}
1115 set r 0
1116 if {$a != 0} {
1117 if {$lim eq {}} {
1118 set lim [llength $varccommits($v,$a)]
1120 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1122 set vrowmod($v) $r
1123 undolayout $r
1127 proc update_arcrows {v} {
1128 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1129 global varcid vrownum varcorder varcix varccommits
1130 global vupptr vdownptr vleftptr varctok
1131 global displayorder parentlist curview cached_commitrow
1133 if {$vrowmod($v) == $commitidx($v)} return
1134 if {$v == $curview} {
1135 if {[llength $displayorder] > $vrowmod($v)} {
1136 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1137 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1139 unset -nocomplain cached_commitrow
1141 set narctot [expr {[llength $varctok($v)] - 1}]
1142 set a $varcmod($v)
1143 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1144 # go up the tree until we find something that has a row number,
1145 # or we get to a seed
1146 set a [lindex $vupptr($v) $a]
1148 if {$a == 0} {
1149 set a [lindex $vdownptr($v) 0]
1150 if {$a == 0} return
1151 set vrownum($v) {0}
1152 set varcorder($v) [list $a]
1153 lset varcix($v) $a 0
1154 lset varcrow($v) $a 0
1155 set arcn 0
1156 set row 0
1157 } else {
1158 set arcn [lindex $varcix($v) $a]
1159 if {[llength $vrownum($v)] > $arcn + 1} {
1160 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1161 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1163 set row [lindex $varcrow($v) $a]
1165 while {1} {
1166 set p $a
1167 incr row [llength $varccommits($v,$a)]
1168 # go down if possible
1169 set b [lindex $vdownptr($v) $a]
1170 if {$b == 0} {
1171 # if not, go left, or go up until we can go left
1172 while {$a != 0} {
1173 set b [lindex $vleftptr($v) $a]
1174 if {$b != 0} break
1175 set a [lindex $vupptr($v) $a]
1177 if {$a == 0} break
1179 set a $b
1180 incr arcn
1181 lappend vrownum($v) $row
1182 lappend varcorder($v) $a
1183 lset varcix($v) $a $arcn
1184 lset varcrow($v) $a $row
1186 set vtokmod($v) [lindex $varctok($v) $p]
1187 set varcmod($v) $p
1188 set vrowmod($v) $row
1189 if {[info exists currentid]} {
1190 set selectedline [rowofcommit $currentid]
1194 # Test whether view $v contains commit $id
1195 proc commitinview {id v} {
1196 global varcid
1198 return [info exists varcid($v,$id)]
1201 # Return the row number for commit $id in the current view
1202 proc rowofcommit {id} {
1203 global varcid varccommits varcrow curview cached_commitrow
1204 global varctok vtokmod
1206 set v $curview
1207 if {![info exists varcid($v,$id)]} {
1208 puts "oops rowofcommit no arc for [shortids $id]"
1209 return {}
1211 set a $varcid($v,$id)
1212 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1213 update_arcrows $v
1215 if {[info exists cached_commitrow($id)]} {
1216 return $cached_commitrow($id)
1218 set i [lsearch -exact $varccommits($v,$a) $id]
1219 if {$i < 0} {
1220 puts "oops didn't find commit [shortids $id] in arc $a"
1221 return {}
1223 incr i [lindex $varcrow($v) $a]
1224 set cached_commitrow($id) $i
1225 return $i
1228 # Returns 1 if a is on an earlier row than b, otherwise 0
1229 proc comes_before {a b} {
1230 global varcid varctok curview
1232 set v $curview
1233 if {$a eq $b || ![info exists varcid($v,$a)] || \
1234 ![info exists varcid($v,$b)]} {
1235 return 0
1237 if {$varcid($v,$a) != $varcid($v,$b)} {
1238 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1239 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1241 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1244 proc bsearch {l elt} {
1245 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1246 return 0
1248 set lo 0
1249 set hi [llength $l]
1250 while {$hi - $lo > 1} {
1251 set mid [expr {int(($lo + $hi) / 2)}]
1252 set t [lindex $l $mid]
1253 if {$elt < $t} {
1254 set hi $mid
1255 } elseif {$elt > $t} {
1256 set lo $mid
1257 } else {
1258 return $mid
1261 return $lo
1264 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1265 proc make_disporder {start end} {
1266 global vrownum curview commitidx displayorder parentlist
1267 global varccommits varcorder parents vrowmod varcrow
1268 global d_valid_start d_valid_end
1270 if {$end > $vrowmod($curview)} {
1271 update_arcrows $curview
1273 set ai [bsearch $vrownum($curview) $start]
1274 set start [lindex $vrownum($curview) $ai]
1275 set narc [llength $vrownum($curview)]
1276 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1277 set a [lindex $varcorder($curview) $ai]
1278 set l [llength $displayorder]
1279 set al [llength $varccommits($curview,$a)]
1280 if {$l < $r + $al} {
1281 if {$l < $r} {
1282 set pad [ntimes [expr {$r - $l}] {}]
1283 set displayorder [concat $displayorder $pad]
1284 set parentlist [concat $parentlist $pad]
1285 } elseif {$l > $r} {
1286 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1287 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1289 foreach id $varccommits($curview,$a) {
1290 lappend displayorder $id
1291 lappend parentlist $parents($curview,$id)
1293 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1294 set i $r
1295 foreach id $varccommits($curview,$a) {
1296 lset displayorder $i $id
1297 lset parentlist $i $parents($curview,$id)
1298 incr i
1301 incr r $al
1305 proc commitonrow {row} {
1306 global displayorder
1308 set id [lindex $displayorder $row]
1309 if {$id eq {}} {
1310 make_disporder $row [expr {$row + 1}]
1311 set id [lindex $displayorder $row]
1313 return $id
1316 proc closevarcs {v} {
1317 global varctok varccommits varcid parents children
1318 global cmitlisted commitidx vtokmod
1320 set missing_parents 0
1321 set scripts {}
1322 set narcs [llength $varctok($v)]
1323 for {set a 1} {$a < $narcs} {incr a} {
1324 set id [lindex $varccommits($v,$a) end]
1325 foreach p $parents($v,$id) {
1326 if {[info exists varcid($v,$p)]} continue
1327 # add p as a new commit
1328 incr missing_parents
1329 set cmitlisted($v,$p) 0
1330 set parents($v,$p) {}
1331 if {[llength $children($v,$p)] == 1 &&
1332 [llength $parents($v,$id)] == 1} {
1333 set b $a
1334 } else {
1335 set b [newvarc $v $p]
1337 set varcid($v,$p) $b
1338 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1339 modify_arc $v $b
1341 lappend varccommits($v,$b) $p
1342 incr commitidx($v)
1343 set scripts [check_interest $p $scripts]
1346 if {$missing_parents > 0} {
1347 foreach s $scripts {
1348 eval $s
1353 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1354 # Assumes we already have an arc for $rwid.
1355 proc rewrite_commit {v id rwid} {
1356 global children parents varcid varctok vtokmod varccommits
1358 foreach ch $children($v,$id) {
1359 # make $rwid be $ch's parent in place of $id
1360 set i [lsearch -exact $parents($v,$ch) $id]
1361 if {$i < 0} {
1362 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1364 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1365 # add $ch to $rwid's children and sort the list if necessary
1366 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1367 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1368 $children($v,$rwid)]
1370 # fix the graph after joining $id to $rwid
1371 set a $varcid($v,$ch)
1372 fix_reversal $rwid $a $v
1373 # parentlist is wrong for the last element of arc $a
1374 # even if displayorder is right, hence the 3rd arg here
1375 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1379 # Mechanism for registering a command to be executed when we come
1380 # across a particular commit. To handle the case when only the
1381 # prefix of the commit is known, the commitinterest array is now
1382 # indexed by the first 4 characters of the ID. Each element is a
1383 # list of id, cmd pairs.
1384 proc interestedin {id cmd} {
1385 global commitinterest
1387 lappend commitinterest([string range $id 0 3]) $id $cmd
1390 proc check_interest {id scripts} {
1391 global commitinterest
1393 set prefix [string range $id 0 3]
1394 if {[info exists commitinterest($prefix)]} {
1395 set newlist {}
1396 foreach {i script} $commitinterest($prefix) {
1397 if {[string match "$i*" $id]} {
1398 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1399 } else {
1400 lappend newlist $i $script
1403 if {$newlist ne {}} {
1404 set commitinterest($prefix) $newlist
1405 } else {
1406 unset commitinterest($prefix)
1409 return $scripts
1412 proc getcommitlines {fd inst view updating} {
1413 global cmitlisted leftover
1414 global commitidx commitdata vdatemode
1415 global parents children curview hlview
1416 global idpending ordertok
1417 global varccommits varcid varctok vtokmod vfilelimit vshortids
1419 set stuff [read $fd 500000]
1420 # git log doesn't terminate the last commit with a null...
1421 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1422 set stuff "\0"
1424 if {$stuff == {}} {
1425 if {![eof $fd]} {
1426 return 1
1428 global commfd viewcomplete viewactive viewname
1429 global viewinstances
1430 unset commfd($inst)
1431 set i [lsearch -exact $viewinstances($view) $inst]
1432 if {$i >= 0} {
1433 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1435 # set it blocking so we wait for the process to terminate
1436 fconfigure $fd -blocking 1
1437 if {[catch {close $fd} err]} {
1438 set fv {}
1439 if {$view != $curview} {
1440 set fv " for the \"$viewname($view)\" view"
1442 if {[string range $err 0 4] == "usage"} {
1443 set err "Gitk: error reading commits$fv:\
1444 bad arguments to git log."
1445 if {$viewname($view) eq [mc "Command line"]} {
1446 append err \
1447 " (Note: arguments to gitk are passed to git log\
1448 to allow selection of commits to be displayed.)"
1450 } else {
1451 set err "Error reading commits$fv: $err"
1453 error_popup $err
1455 if {[incr viewactive($view) -1] <= 0} {
1456 set viewcomplete($view) 1
1457 # Check if we have seen any ids listed as parents that haven't
1458 # appeared in the list
1459 closevarcs $view
1460 notbusy $view
1462 if {$view == $curview} {
1463 run chewcommits
1465 return 0
1467 set start 0
1468 set gotsome 0
1469 set scripts {}
1470 while 1 {
1471 set i [string first "\0" $stuff $start]
1472 if {$i < 0} {
1473 append leftover($inst) [string range $stuff $start end]
1474 break
1476 if {$start == 0} {
1477 set cmit $leftover($inst)
1478 append cmit [string range $stuff 0 [expr {$i - 1}]]
1479 set leftover($inst) {}
1480 } else {
1481 set cmit [string range $stuff $start [expr {$i - 1}]]
1483 set start [expr {$i + 1}]
1484 set j [string first "\n" $cmit]
1485 set ok 0
1486 set listed 1
1487 if {$j >= 0 && [string match "commit *" $cmit]} {
1488 set ids [string range $cmit 7 [expr {$j - 1}]]
1489 if {[string match {[-^<>]*} $ids]} {
1490 switch -- [string index $ids 0] {
1491 "-" {set listed 0}
1492 "^" {set listed 2}
1493 "<" {set listed 3}
1494 ">" {set listed 4}
1496 set ids [string range $ids 1 end]
1498 set ok 1
1499 foreach id $ids {
1500 if {[string length $id] != 40} {
1501 set ok 0
1502 break
1506 if {!$ok} {
1507 set shortcmit $cmit
1508 if {[string length $shortcmit] > 80} {
1509 set shortcmit "[string range $shortcmit 0 80]..."
1511 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1512 exit 1
1514 set id [lindex $ids 0]
1515 set vid $view,$id
1517 lappend vshortids($view,[string range $id 0 3]) $id
1519 if {!$listed && $updating && ![info exists varcid($vid)] &&
1520 $vfilelimit($view) ne {}} {
1521 # git log doesn't rewrite parents for unlisted commits
1522 # when doing path limiting, so work around that here
1523 # by working out the rewritten parent with git rev-list
1524 # and if we already know about it, using the rewritten
1525 # parent as a substitute parent for $id's children.
1526 if {![catch {
1527 set rwid [exec git rev-list --first-parent --max-count=1 \
1528 $id -- $vfilelimit($view)]
1529 }]} {
1530 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1531 # use $rwid in place of $id
1532 rewrite_commit $view $id $rwid
1533 continue
1538 set a 0
1539 if {[info exists varcid($vid)]} {
1540 if {$cmitlisted($vid) || !$listed} continue
1541 set a $varcid($vid)
1543 if {$listed} {
1544 set olds [lrange $ids 1 end]
1545 } else {
1546 set olds {}
1548 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1549 set cmitlisted($vid) $listed
1550 set parents($vid) $olds
1551 if {![info exists children($vid)]} {
1552 set children($vid) {}
1553 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1554 set k [lindex $children($vid) 0]
1555 if {[llength $parents($view,$k)] == 1 &&
1556 (!$vdatemode($view) ||
1557 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1558 set a $varcid($view,$k)
1561 if {$a == 0} {
1562 # new arc
1563 set a [newvarc $view $id]
1565 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1566 modify_arc $view $a
1568 if {![info exists varcid($vid)]} {
1569 set varcid($vid) $a
1570 lappend varccommits($view,$a) $id
1571 incr commitidx($view)
1574 set i 0
1575 foreach p $olds {
1576 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1577 set vp $view,$p
1578 if {[llength [lappend children($vp) $id]] > 1 &&
1579 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1580 set children($vp) [lsort -command [list vtokcmp $view] \
1581 $children($vp)]
1582 unset -nocomplain ordertok
1584 if {[info exists varcid($view,$p)]} {
1585 fix_reversal $p $a $view
1588 incr i
1591 set scripts [check_interest $id $scripts]
1592 set gotsome 1
1594 if {$gotsome} {
1595 global numcommits hlview
1597 if {$view == $curview} {
1598 set numcommits $commitidx($view)
1599 run chewcommits
1601 if {[info exists hlview] && $view == $hlview} {
1602 # we never actually get here...
1603 run vhighlightmore
1605 foreach s $scripts {
1606 eval $s
1609 return 2
1612 proc chewcommits {} {
1613 global curview hlview viewcomplete
1614 global pending_select
1616 layoutmore
1617 if {$viewcomplete($curview)} {
1618 global commitidx varctok
1619 global numcommits startmsecs
1621 if {[info exists pending_select]} {
1622 update
1623 reset_pending_select {}
1625 if {[commitinview $pending_select $curview]} {
1626 selectline [rowofcommit $pending_select] 1
1627 } else {
1628 set row [first_real_row]
1629 selectline $row 1
1632 if {$commitidx($curview) > 0} {
1633 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1634 #puts "overall $ms ms for $numcommits commits"
1635 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1636 } else {
1637 show_status [mc "No commits selected"]
1639 notbusy layout
1641 return 0
1644 proc do_readcommit {id} {
1645 global tclencoding
1647 # Invoke git-log to handle automatic encoding conversion
1648 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1649 # Read the results using i18n.logoutputencoding
1650 fconfigure $fd -translation lf -eofchar {}
1651 if {$tclencoding != {}} {
1652 fconfigure $fd -encoding $tclencoding
1654 set contents [read $fd]
1655 close $fd
1656 # Remove the heading line
1657 regsub {^commit [0-9a-f]+\n} $contents {} contents
1659 return $contents
1662 proc readcommit {id} {
1663 if {[catch {set contents [do_readcommit $id]}]} return
1664 parsecommit $id $contents 1
1667 proc parsecommit {id contents listed} {
1668 global commitinfo
1670 set inhdr 1
1671 set comment {}
1672 set headline {}
1673 set auname {}
1674 set audate {}
1675 set comname {}
1676 set comdate {}
1677 set hdrend [string first "\n\n" $contents]
1678 if {$hdrend < 0} {
1679 # should never happen...
1680 set hdrend [string length $contents]
1682 set header [string range $contents 0 [expr {$hdrend - 1}]]
1683 set comment [string range $contents [expr {$hdrend + 2}] end]
1684 foreach line [split $header "\n"] {
1685 set line [split $line " "]
1686 set tag [lindex $line 0]
1687 if {$tag == "author"} {
1688 set audate [lrange $line end-1 end]
1689 set auname [join [lrange $line 1 end-2] " "]
1690 } elseif {$tag == "committer"} {
1691 set comdate [lrange $line end-1 end]
1692 set comname [join [lrange $line 1 end-2] " "]
1695 set headline {}
1696 # take the first non-blank line of the comment as the headline
1697 set headline [string trimleft $comment]
1698 set i [string first "\n" $headline]
1699 if {$i >= 0} {
1700 set headline [string range $headline 0 $i]
1702 set headline [string trimright $headline]
1703 set i [string first "\r" $headline]
1704 if {$i >= 0} {
1705 set headline [string trimright [string range $headline 0 $i]]
1707 if {!$listed} {
1708 # git log indents the comment by 4 spaces;
1709 # if we got this via git cat-file, add the indentation
1710 set newcomment {}
1711 foreach line [split $comment "\n"] {
1712 append newcomment " "
1713 append newcomment $line
1714 append newcomment "\n"
1716 set comment $newcomment
1718 set hasnote [string first "\nNotes:\n" $contents]
1719 set diff ""
1720 # If there is diff output shown in the git-log stream, split it
1721 # out. But get rid of the empty line that always precedes the
1722 # diff.
1723 set i [string first "\n\ndiff" $comment]
1724 if {$i >= 0} {
1725 set diff [string range $comment $i+1 end]
1726 set comment [string range $comment 0 $i-1]
1728 set commitinfo($id) [list $headline $auname $audate \
1729 $comname $comdate $comment $hasnote $diff]
1732 proc getcommit {id} {
1733 global commitdata commitinfo
1735 if {[info exists commitdata($id)]} {
1736 parsecommit $id $commitdata($id) 1
1737 } else {
1738 readcommit $id
1739 if {![info exists commitinfo($id)]} {
1740 set commitinfo($id) [list [mc "No commit information available"]]
1743 return 1
1746 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1747 # and are present in the current view.
1748 # This is fairly slow...
1749 proc longid {prefix} {
1750 global varcid curview vshortids
1752 set ids {}
1753 if {[string length $prefix] >= 4} {
1754 set vshortid $curview,[string range $prefix 0 3]
1755 if {[info exists vshortids($vshortid)]} {
1756 foreach id $vshortids($vshortid) {
1757 if {[string match "$prefix*" $id]} {
1758 if {[lsearch -exact $ids $id] < 0} {
1759 lappend ids $id
1760 if {[llength $ids] >= 2} break
1765 } else {
1766 foreach match [array names varcid "$curview,$prefix*"] {
1767 lappend ids [lindex [split $match ","] 1]
1768 if {[llength $ids] >= 2} break
1771 return $ids
1774 proc readrefs {} {
1775 global tagids idtags headids idheads tagobjid
1776 global otherrefids idotherrefs mainhead mainheadid
1777 global selecthead selectheadid
1778 global hideremotes
1780 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1781 unset -nocomplain $v
1783 set refd [open [list | git show-ref -d] r]
1784 while {[gets $refd line] >= 0} {
1785 if {[string index $line 40] ne " "} continue
1786 set id [string range $line 0 39]
1787 set ref [string range $line 41 end]
1788 if {![string match "refs/*" $ref]} continue
1789 set name [string range $ref 5 end]
1790 if {[string match "remotes/*" $name]} {
1791 if {![string match "*/HEAD" $name] && !$hideremotes} {
1792 set headids($name) $id
1793 lappend idheads($id) $name
1795 } elseif {[string match "heads/*" $name]} {
1796 set name [string range $name 6 end]
1797 set headids($name) $id
1798 lappend idheads($id) $name
1799 } elseif {[string match "tags/*" $name]} {
1800 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1801 # which is what we want since the former is the commit ID
1802 set name [string range $name 5 end]
1803 if {[string match "*^{}" $name]} {
1804 set name [string range $name 0 end-3]
1805 } else {
1806 set tagobjid($name) $id
1808 set tagids($name) $id
1809 lappend idtags($id) $name
1810 } else {
1811 set otherrefids($name) $id
1812 lappend idotherrefs($id) $name
1815 catch {close $refd}
1816 set mainhead {}
1817 set mainheadid {}
1818 catch {
1819 set mainheadid [exec git rev-parse HEAD]
1820 set thehead [exec git symbolic-ref HEAD]
1821 if {[string match "refs/heads/*" $thehead]} {
1822 set mainhead [string range $thehead 11 end]
1825 set selectheadid {}
1826 if {$selecthead ne {}} {
1827 catch {
1828 set selectheadid [exec git rev-parse --verify $selecthead]
1833 # skip over fake commits
1834 proc first_real_row {} {
1835 global nullid nullid2 numcommits
1837 for {set row 0} {$row < $numcommits} {incr row} {
1838 set id [commitonrow $row]
1839 if {$id ne $nullid && $id ne $nullid2} {
1840 break
1843 return $row
1846 # update things for a head moved to a child of its previous location
1847 proc movehead {id name} {
1848 global headids idheads
1850 removehead $headids($name) $name
1851 set headids($name) $id
1852 lappend idheads($id) $name
1855 # update things when a head has been removed
1856 proc removehead {id name} {
1857 global headids idheads
1859 if {$idheads($id) eq $name} {
1860 unset idheads($id)
1861 } else {
1862 set i [lsearch -exact $idheads($id) $name]
1863 if {$i >= 0} {
1864 set idheads($id) [lreplace $idheads($id) $i $i]
1867 unset headids($name)
1870 proc ttk_toplevel {w args} {
1871 global use_ttk
1872 eval [linsert $args 0 ::toplevel $w]
1873 if {$use_ttk} {
1874 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1876 return $w
1879 proc make_transient {window origin} {
1880 global have_tk85
1882 # In MacOS Tk 8.4 transient appears to work by setting
1883 # overrideredirect, which is utterly useless, since the
1884 # windows get no border, and are not even kept above
1885 # the parent.
1886 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1888 wm transient $window $origin
1890 # Windows fails to place transient windows normally, so
1891 # schedule a callback to center them on the parent.
1892 if {[tk windowingsystem] eq {win32}} {
1893 after idle [list tk::PlaceWindow $window widget $origin]
1897 proc show_error {w top msg} {
1898 global NS
1899 if {![info exists NS]} {set NS ""}
1900 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1901 message $w.m -text $msg -justify center -aspect 400
1902 pack $w.m -side top -fill x -padx 20 -pady 20
1903 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1904 pack $w.ok -side bottom -fill x
1905 bind $top <Visibility> "grab $top; focus $top"
1906 bind $top <Key-Return> "destroy $top"
1907 bind $top <Key-space> "destroy $top"
1908 bind $top <Key-Escape> "destroy $top"
1909 tkwait window $top
1912 proc error_popup {msg {owner .}} {
1913 if {[tk windowingsystem] eq "win32"} {
1914 tk_messageBox -icon error -type ok -title [wm title .] \
1915 -parent $owner -message $msg
1916 } else {
1917 set w .error
1918 ttk_toplevel $w
1919 make_transient $w $owner
1920 show_error $w $w $msg
1924 proc confirm_popup {msg {owner .}} {
1925 global confirm_ok NS
1926 set confirm_ok 0
1927 set w .confirm
1928 ttk_toplevel $w
1929 make_transient $w $owner
1930 message $w.m -text $msg -justify center -aspect 400
1931 pack $w.m -side top -fill x -padx 20 -pady 20
1932 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1933 pack $w.ok -side left -fill x
1934 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1935 pack $w.cancel -side right -fill x
1936 bind $w <Visibility> "grab $w; focus $w"
1937 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1938 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1939 bind $w <Key-Escape> "destroy $w"
1940 tk::PlaceWindow $w widget $owner
1941 tkwait window $w
1942 return $confirm_ok
1945 proc setoptions {} {
1946 if {[tk windowingsystem] ne "win32"} {
1947 option add *Panedwindow.showHandle 1 startupFile
1948 option add *Panedwindow.sashRelief raised startupFile
1949 if {[tk windowingsystem] ne "aqua"} {
1950 option add *Menu.font uifont startupFile
1952 } else {
1953 option add *Menu.TearOff 0 startupFile
1955 option add *Button.font uifont startupFile
1956 option add *Checkbutton.font uifont startupFile
1957 option add *Radiobutton.font uifont startupFile
1958 option add *Menubutton.font uifont startupFile
1959 option add *Label.font uifont startupFile
1960 option add *Message.font uifont startupFile
1961 option add *Entry.font textfont startupFile
1962 option add *Text.font textfont startupFile
1963 option add *Labelframe.font uifont startupFile
1964 option add *Spinbox.font textfont startupFile
1965 option add *Listbox.font mainfont startupFile
1968 # Make a menu and submenus.
1969 # m is the window name for the menu, items is the list of menu items to add.
1970 # Each item is a list {mc label type description options...}
1971 # mc is ignored; it's so we can put mc there to alert xgettext
1972 # label is the string that appears in the menu
1973 # type is cascade, command or radiobutton (should add checkbutton)
1974 # description depends on type; it's the sublist for cascade, the
1975 # command to invoke for command, or {variable value} for radiobutton
1976 proc makemenu {m items} {
1977 menu $m
1978 if {[tk windowingsystem] eq {aqua}} {
1979 set Meta1 Cmd
1980 } else {
1981 set Meta1 Ctrl
1983 foreach i $items {
1984 set name [mc [lindex $i 1]]
1985 set type [lindex $i 2]
1986 set thing [lindex $i 3]
1987 set params [list $type]
1988 if {$name ne {}} {
1989 set u [string first "&" [string map {&& x} $name]]
1990 lappend params -label [string map {&& & & {}} $name]
1991 if {$u >= 0} {
1992 lappend params -underline $u
1995 switch -- $type {
1996 "cascade" {
1997 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1998 lappend params -menu $m.$submenu
2000 "command" {
2001 lappend params -command $thing
2003 "radiobutton" {
2004 lappend params -variable [lindex $thing 0] \
2005 -value [lindex $thing 1]
2008 set tail [lrange $i 4 end]
2009 regsub -all {\yMeta1\y} $tail $Meta1 tail
2010 eval $m add $params $tail
2011 if {$type eq "cascade"} {
2012 makemenu $m.$submenu $thing
2017 # translate string and remove ampersands
2018 proc mca {str} {
2019 return [string map {&& & & {}} [mc $str]]
2022 proc cleardropsel {w} {
2023 $w selection clear
2025 proc makedroplist {w varname args} {
2026 global use_ttk
2027 if {$use_ttk} {
2028 set width 0
2029 foreach label $args {
2030 set cx [string length $label]
2031 if {$cx > $width} {set width $cx}
2033 set gm [ttk::combobox $w -width $width -state readonly\
2034 -textvariable $varname -values $args \
2035 -exportselection false]
2036 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2037 } else {
2038 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2040 return $gm
2043 proc makewindow {} {
2044 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2045 global tabstop
2046 global findtype findtypemenu findloc findstring fstring geometry
2047 global entries sha1entry sha1string sha1but
2048 global diffcontextstring diffcontext
2049 global ignorespace
2050 global maincursor textcursor curtextcursor
2051 global rowctxmenu fakerowmenu mergemax wrapcomment
2052 global highlight_files gdttype
2053 global searchstring sstring
2054 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2055 global uifgcolor uifgdisabledcolor
2056 global filesepbgcolor filesepfgcolor
2057 global mergecolors foundbgcolor currentsearchhitbgcolor
2058 global headctxmenu progresscanv progressitem progresscoords statusw
2059 global fprogitem fprogcoord lastprogupdate progupdatepending
2060 global rprogitem rprogcoord rownumsel numcommits
2061 global have_tk85 use_ttk NS
2062 global git_version
2063 global worddiff
2065 # The "mc" arguments here are purely so that xgettext
2066 # sees the following string as needing to be translated
2067 set file {
2068 mc "&File" cascade {
2069 {mc "&Update" command updatecommits -accelerator F5}
2070 {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2071 {mc "Reread re&ferences" command rereadrefs}
2072 {mc "&List references" command showrefs -accelerator F2}
2073 {xx "" separator}
2074 {mc "Start git &gui" command {exec git gui &}}
2075 {xx "" separator}
2076 {mc "&Quit" command doquit -accelerator Meta1-Q}
2078 set edit {
2079 mc "&Edit" cascade {
2080 {mc "&Preferences" command doprefs}
2082 set view {
2083 mc "&View" cascade {
2084 {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2085 {mc "&Edit view..." command editview -state disabled -accelerator F4}
2086 {mc "&Delete view" command delview -state disabled}
2087 {xx "" separator}
2088 {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2090 if {[tk windowingsystem] ne "aqua"} {
2091 set help {
2092 mc "&Help" cascade {
2093 {mc "&About gitk" command about}
2094 {mc "&Key bindings" command keys}
2096 set bar [list $file $edit $view $help]
2097 } else {
2098 proc ::tk::mac::ShowPreferences {} {doprefs}
2099 proc ::tk::mac::Quit {} {doquit}
2100 lset file end [lreplace [lindex $file end] end-1 end]
2101 set apple {
2102 xx "&Apple" cascade {
2103 {mc "&About gitk" command about}
2104 {xx "" separator}
2106 set help {
2107 mc "&Help" cascade {
2108 {mc "&Key bindings" command keys}
2110 set bar [list $apple $file $view $help]
2112 makemenu .bar $bar
2113 . configure -menu .bar
2115 if {$use_ttk} {
2116 # cover the non-themed toplevel with a themed frame.
2117 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2120 # the gui has upper and lower half, parts of a paned window.
2121 ${NS}::panedwindow .ctop -orient vertical
2123 # possibly use assumed geometry
2124 if {![info exists geometry(pwsash0)]} {
2125 set geometry(topheight) [expr {15 * $linespc}]
2126 set geometry(topwidth) [expr {80 * $charspc}]
2127 set geometry(botheight) [expr {15 * $linespc}]
2128 set geometry(botwidth) [expr {50 * $charspc}]
2129 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2130 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2133 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2134 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2135 ${NS}::frame .tf.histframe
2136 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2137 if {!$use_ttk} {
2138 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2141 # create three canvases
2142 set cscroll .tf.histframe.csb
2143 set canv .tf.histframe.pwclist.canv
2144 canvas $canv \
2145 -selectbackground $selectbgcolor \
2146 -background $bgcolor -bd 0 \
2147 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2148 .tf.histframe.pwclist add $canv
2149 set canv2 .tf.histframe.pwclist.canv2
2150 canvas $canv2 \
2151 -selectbackground $selectbgcolor \
2152 -background $bgcolor -bd 0 -yscrollincr $linespc
2153 .tf.histframe.pwclist add $canv2
2154 set canv3 .tf.histframe.pwclist.canv3
2155 canvas $canv3 \
2156 -selectbackground $selectbgcolor \
2157 -background $bgcolor -bd 0 -yscrollincr $linespc
2158 .tf.histframe.pwclist add $canv3
2159 if {$use_ttk} {
2160 bind .tf.histframe.pwclist <Map> {
2161 bind %W <Map> {}
2162 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2163 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2165 } else {
2166 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2167 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2170 # a scroll bar to rule them
2171 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2172 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2173 pack $cscroll -side right -fill y
2174 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2175 lappend bglist $canv $canv2 $canv3
2176 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2178 # we have two button bars at bottom of top frame. Bar 1
2179 ${NS}::frame .tf.bar
2180 ${NS}::frame .tf.lbar -height 15
2182 set sha1entry .tf.bar.sha1
2183 set entries $sha1entry
2184 set sha1but .tf.bar.sha1label
2185 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2186 -command gotocommit -width 8
2187 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2188 pack .tf.bar.sha1label -side left
2189 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2190 trace add variable sha1string write sha1change
2191 pack $sha1entry -side left -pady 2
2193 set bm_left_data {
2194 #define left_width 16
2195 #define left_height 16
2196 static unsigned char left_bits[] = {
2197 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2198 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2199 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2201 set bm_right_data {
2202 #define right_width 16
2203 #define right_height 16
2204 static unsigned char right_bits[] = {
2205 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2206 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2207 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2209 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2210 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2211 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2212 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2214 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2215 if {$use_ttk} {
2216 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2217 } else {
2218 .tf.bar.leftbut configure -image bm-left
2220 pack .tf.bar.leftbut -side left -fill y
2221 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2222 if {$use_ttk} {
2223 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2224 } else {
2225 .tf.bar.rightbut configure -image bm-right
2227 pack .tf.bar.rightbut -side left -fill y
2229 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2230 set rownumsel {}
2231 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2232 -relief sunken -anchor e
2233 ${NS}::label .tf.bar.rowlabel2 -text "/"
2234 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2235 -relief sunken -anchor e
2236 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2237 -side left
2238 if {!$use_ttk} {
2239 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2241 global selectedline
2242 trace add variable selectedline write selectedline_change
2244 # Status label and progress bar
2245 set statusw .tf.bar.status
2246 ${NS}::label $statusw -width 15 -relief sunken
2247 pack $statusw -side left -padx 5
2248 if {$use_ttk} {
2249 set progresscanv [ttk::progressbar .tf.bar.progress]
2250 } else {
2251 set h [expr {[font metrics uifont -linespace] + 2}]
2252 set progresscanv .tf.bar.progress
2253 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2254 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2255 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2256 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2258 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2259 set progresscoords {0 0}
2260 set fprogcoord 0
2261 set rprogcoord 0
2262 bind $progresscanv <Configure> adjustprogress
2263 set lastprogupdate [clock clicks -milliseconds]
2264 set progupdatepending 0
2266 # build up the bottom bar of upper window
2267 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2269 set bm_down_data {
2270 #define down_width 16
2271 #define down_height 16
2272 static unsigned char down_bits[] = {
2273 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2274 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2275 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2276 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2278 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2279 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2280 .tf.lbar.fnext configure -image bm-down
2282 set bm_up_data {
2283 #define up_width 16
2284 #define up_height 16
2285 static unsigned char up_bits[] = {
2286 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2287 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2288 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2289 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2291 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2292 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2293 .tf.lbar.fprev configure -image bm-up
2295 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2297 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2298 -side left -fill y
2299 set gdttype [mc "containing:"]
2300 set gm [makedroplist .tf.lbar.gdttype gdttype \
2301 [mc "containing:"] \
2302 [mc "touching paths:"] \
2303 [mc "adding/removing string:"] \
2304 [mc "changing lines matching:"]]
2305 trace add variable gdttype write gdttype_change
2306 pack .tf.lbar.gdttype -side left -fill y
2308 set findstring {}
2309 set fstring .tf.lbar.findstring
2310 lappend entries $fstring
2311 ${NS}::entry $fstring -width 30 -textvariable findstring
2312 trace add variable findstring write find_change
2313 set findtype [mc "Exact"]
2314 set findtypemenu [makedroplist .tf.lbar.findtype \
2315 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2316 trace add variable findtype write findcom_change
2317 set findloc [mc "All fields"]
2318 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2319 [mc "Comments"] [mc "Author"] [mc "Committer"]
2320 trace add variable findloc write find_change
2321 pack .tf.lbar.findloc -side right
2322 pack .tf.lbar.findtype -side right
2323 pack $fstring -side left -expand 1 -fill x
2325 # Finish putting the upper half of the viewer together
2326 pack .tf.lbar -in .tf -side bottom -fill x
2327 pack .tf.bar -in .tf -side bottom -fill x
2328 pack .tf.histframe -fill both -side top -expand 1
2329 .ctop add .tf
2330 if {!$use_ttk} {
2331 .ctop paneconfigure .tf -height $geometry(topheight)
2332 .ctop paneconfigure .tf -width $geometry(topwidth)
2335 # now build up the bottom
2336 ${NS}::panedwindow .pwbottom -orient horizontal
2338 # lower left, a text box over search bar, scroll bar to the right
2339 # if we know window height, then that will set the lower text height, otherwise
2340 # we set lower text height which will drive window height
2341 if {[info exists geometry(main)]} {
2342 ${NS}::frame .bleft -width $geometry(botwidth)
2343 } else {
2344 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2346 ${NS}::frame .bleft.top
2347 ${NS}::frame .bleft.mid
2348 ${NS}::frame .bleft.bottom
2350 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2351 pack .bleft.top.search -side left -padx 5
2352 set sstring .bleft.top.sstring
2353 set searchstring ""
2354 ${NS}::entry $sstring -width 20 -textvariable searchstring
2355 lappend entries $sstring
2356 trace add variable searchstring write incrsearch
2357 pack $sstring -side left -expand 1 -fill x
2358 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2359 -command changediffdisp -variable diffelide -value {0 0}
2360 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2361 -command changediffdisp -variable diffelide -value {0 1}
2362 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2363 -command changediffdisp -variable diffelide -value {1 0}
2364 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2365 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2366 spinbox .bleft.mid.diffcontext -width 5 \
2367 -from 0 -increment 1 -to 10000000 \
2368 -validate all -validatecommand "diffcontextvalidate %P" \
2369 -textvariable diffcontextstring
2370 .bleft.mid.diffcontext set $diffcontext
2371 trace add variable diffcontextstring write diffcontextchange
2372 lappend entries .bleft.mid.diffcontext
2373 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2374 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2375 -command changeignorespace -variable ignorespace
2376 pack .bleft.mid.ignspace -side left -padx 5
2378 set worddiff [mc "Line diff"]
2379 if {[package vcompare $git_version "1.7.2"] >= 0} {
2380 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2381 [mc "Markup words"] [mc "Color words"]
2382 trace add variable worddiff write changeworddiff
2383 pack .bleft.mid.worddiff -side left -padx 5
2386 set ctext .bleft.bottom.ctext
2387 text $ctext -background $bgcolor -foreground $fgcolor \
2388 -state disabled -font textfont \
2389 -yscrollcommand scrolltext -wrap none \
2390 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2391 if {$have_tk85} {
2392 $ctext conf -tabstyle wordprocessor
2394 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2395 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2396 pack .bleft.top -side top -fill x
2397 pack .bleft.mid -side top -fill x
2398 grid $ctext .bleft.bottom.sb -sticky nsew
2399 grid .bleft.bottom.sbhorizontal -sticky ew
2400 grid columnconfigure .bleft.bottom 0 -weight 1
2401 grid rowconfigure .bleft.bottom 0 -weight 1
2402 grid rowconfigure .bleft.bottom 1 -weight 0
2403 pack .bleft.bottom -side top -fill both -expand 1
2404 lappend bglist $ctext
2405 lappend fglist $ctext
2407 $ctext tag conf comment -wrap $wrapcomment
2408 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2409 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2410 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2411 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2412 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2413 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2414 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2415 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2416 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2417 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2418 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2419 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2420 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2421 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2422 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2423 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2424 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2425 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2426 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2427 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2428 $ctext tag conf mmax -fore darkgrey
2429 set mergemax 16
2430 $ctext tag conf mresult -font textfontbold
2431 $ctext tag conf msep -font textfontbold
2432 $ctext tag conf found -back $foundbgcolor
2433 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2434 $ctext tag conf wwrap -wrap word -lmargin2 1c
2435 $ctext tag conf bold -font textfontbold
2437 .pwbottom add .bleft
2438 if {!$use_ttk} {
2439 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2442 # lower right
2443 ${NS}::frame .bright
2444 ${NS}::frame .bright.mode
2445 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2446 -command reselectline -variable cmitmode -value "patch"
2447 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2448 -command reselectline -variable cmitmode -value "tree"
2449 grid .bright.mode.patch .bright.mode.tree -sticky ew
2450 pack .bright.mode -side top -fill x
2451 set cflist .bright.cfiles
2452 set indent [font measure mainfont "nn"]
2453 text $cflist \
2454 -selectbackground $selectbgcolor \
2455 -background $bgcolor -foreground $fgcolor \
2456 -font mainfont \
2457 -tabs [list $indent [expr {2 * $indent}]] \
2458 -yscrollcommand ".bright.sb set" \
2459 -cursor [. cget -cursor] \
2460 -spacing1 1 -spacing3 1
2461 lappend bglist $cflist
2462 lappend fglist $cflist
2463 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2464 pack .bright.sb -side right -fill y
2465 pack $cflist -side left -fill both -expand 1
2466 $cflist tag configure highlight \
2467 -background [$cflist cget -selectbackground]
2468 $cflist tag configure bold -font mainfontbold
2470 .pwbottom add .bright
2471 .ctop add .pwbottom
2473 # restore window width & height if known
2474 if {[info exists geometry(main)]} {
2475 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2476 if {$w > [winfo screenwidth .]} {
2477 set w [winfo screenwidth .]
2479 if {$h > [winfo screenheight .]} {
2480 set h [winfo screenheight .]
2482 wm geometry . "${w}x$h"
2486 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2487 wm state . $geometry(state)
2490 if {[tk windowingsystem] eq {aqua}} {
2491 set M1B M1
2492 set ::BM "3"
2493 } else {
2494 set M1B Control
2495 set ::BM "2"
2498 if {$use_ttk} {
2499 bind .ctop <Map> {
2500 bind %W <Map> {}
2501 %W sashpos 0 $::geometry(topheight)
2503 bind .pwbottom <Map> {
2504 bind %W <Map> {}
2505 %W sashpos 0 $::geometry(botwidth)
2509 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2510 pack .ctop -fill both -expand 1
2511 bindall <1> {selcanvline %W %x %y}
2512 #bindall <B1-Motion> {selcanvline %W %x %y}
2513 if {[tk windowingsystem] == "win32"} {
2514 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2515 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2516 } else {
2517 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2518 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2519 bind $ctext <Button> {
2520 if {"%b" eq 6} {
2521 $ctext xview scroll -5 units
2522 } elseif {"%b" eq 7} {
2523 $ctext xview scroll 5 units
2526 if {[tk windowingsystem] eq "aqua"} {
2527 bindall <MouseWheel> {
2528 set delta [expr {- (%D)}]
2529 allcanvs yview scroll $delta units
2531 bindall <Shift-MouseWheel> {
2532 set delta [expr {- (%D)}]
2533 $canv xview scroll $delta units
2537 bindall <$::BM> "canvscan mark %W %x %y"
2538 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2539 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2540 bind . <$M1B-Key-w> doquit
2541 bindkey <Home> selfirstline
2542 bindkey <End> sellastline
2543 bind . <Key-Up> "selnextline -1"
2544 bind . <Key-Down> "selnextline 1"
2545 bind . <Shift-Key-Up> "dofind -1 0"
2546 bind . <Shift-Key-Down> "dofind 1 0"
2547 bindkey <Key-Right> "goforw"
2548 bindkey <Key-Left> "goback"
2549 bind . <Key-Prior> "selnextpage -1"
2550 bind . <Key-Next> "selnextpage 1"
2551 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2552 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2553 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2554 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2555 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2556 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2557 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2558 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2559 bindkey <Key-space> "$ctext yview scroll 1 pages"
2560 bindkey p "selnextline -1"
2561 bindkey n "selnextline 1"
2562 bindkey z "goback"
2563 bindkey x "goforw"
2564 bindkey k "selnextline -1"
2565 bindkey j "selnextline 1"
2566 bindkey h "goback"
2567 bindkey l "goforw"
2568 bindkey b prevfile
2569 bindkey d "$ctext yview scroll 18 units"
2570 bindkey u "$ctext yview scroll -18 units"
2571 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2572 bindkey / {focus $fstring}
2573 bindkey <Key-KP_Divide> {focus $fstring}
2574 bindkey <Key-Return> {dofind 1 1}
2575 bindkey ? {dofind -1 1}
2576 bindkey f nextfile
2577 bind . <F5> updatecommits
2578 bindmodfunctionkey Shift 5 reloadcommits
2579 bind . <F2> showrefs
2580 bindmodfunctionkey Shift 4 {newview 0}
2581 bind . <F4> edit_or_newview
2582 bind . <$M1B-q> doquit
2583 bind . <$M1B-f> {dofind 1 1}
2584 bind . <$M1B-g> {dofind 1 0}
2585 bind . <$M1B-r> dosearchback
2586 bind . <$M1B-s> dosearch
2587 bind . <$M1B-equal> {incrfont 1}
2588 bind . <$M1B-plus> {incrfont 1}
2589 bind . <$M1B-KP_Add> {incrfont 1}
2590 bind . <$M1B-minus> {incrfont -1}
2591 bind . <$M1B-KP_Subtract> {incrfont -1}
2592 wm protocol . WM_DELETE_WINDOW doquit
2593 bind . <Destroy> {stop_backends}
2594 bind . <Button-1> "click %W"
2595 bind $fstring <Key-Return> {dofind 1 1}
2596 bind $sha1entry <Key-Return> {gotocommit; break}
2597 bind $sha1entry <<PasteSelection>> clearsha1
2598 bind $sha1entry <<Paste>> clearsha1
2599 bind $cflist <1> {sel_flist %W %x %y; break}
2600 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2601 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2602 global ctxbut
2603 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2604 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2605 bind $ctext <Button-1> {focus %W}
2606 bind $ctext <<Selection>> rehighlight_search_results
2607 for {set i 1} {$i < 10} {incr i} {
2608 bind . <$M1B-Key-$i> [list go_to_parent $i]
2611 set maincursor [. cget -cursor]
2612 set textcursor [$ctext cget -cursor]
2613 set curtextcursor $textcursor
2615 set rowctxmenu .rowctxmenu
2616 makemenu $rowctxmenu {
2617 {mc "Diff this -> selected" command {diffvssel 0}}
2618 {mc "Diff selected -> this" command {diffvssel 1}}
2619 {mc "Make patch" command mkpatch}
2620 {mc "Create tag" command mktag}
2621 {mc "Copy commit summary" command copysummary}
2622 {mc "Write commit to file" command writecommit}
2623 {mc "Create new branch" command mkbranch}
2624 {mc "Cherry-pick this commit" command cherrypick}
2625 {mc "Reset HEAD branch to here" command resethead}
2626 {mc "Mark this commit" command markhere}
2627 {mc "Return to mark" command gotomark}
2628 {mc "Find descendant of this and mark" command find_common_desc}
2629 {mc "Compare with marked commit" command compare_commits}
2630 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2631 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2632 {mc "Revert this commit" command revert}
2634 $rowctxmenu configure -tearoff 0
2636 set fakerowmenu .fakerowmenu
2637 makemenu $fakerowmenu {
2638 {mc "Diff this -> selected" command {diffvssel 0}}
2639 {mc "Diff selected -> this" command {diffvssel 1}}
2640 {mc "Make patch" command mkpatch}
2641 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2642 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2644 $fakerowmenu configure -tearoff 0
2646 set headctxmenu .headctxmenu
2647 makemenu $headctxmenu {
2648 {mc "Check out this branch" command cobranch}
2649 {mc "Remove this branch" command rmbranch}
2650 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2652 $headctxmenu configure -tearoff 0
2654 global flist_menu
2655 set flist_menu .flistctxmenu
2656 makemenu $flist_menu {
2657 {mc "Highlight this too" command {flist_hl 0}}
2658 {mc "Highlight this only" command {flist_hl 1}}
2659 {mc "External diff" command {external_diff}}
2660 {mc "Blame parent commit" command {external_blame 1}}
2661 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2663 $flist_menu configure -tearoff 0
2665 global diff_menu
2666 set diff_menu .diffctxmenu
2667 makemenu $diff_menu {
2668 {mc "Show origin of this line" command show_line_source}
2669 {mc "Run git gui blame on this line" command {external_blame_diff}}
2671 $diff_menu configure -tearoff 0
2674 # Windows sends all mouse wheel events to the current focused window, not
2675 # the one where the mouse hovers, so bind those events here and redirect
2676 # to the correct window
2677 proc windows_mousewheel_redirector {W X Y D} {
2678 global canv canv2 canv3
2679 set w [winfo containing -displayof $W $X $Y]
2680 if {$w ne ""} {
2681 set u [expr {$D < 0 ? 5 : -5}]
2682 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2683 allcanvs yview scroll $u units
2684 } else {
2685 catch {
2686 $w yview scroll $u units
2692 # Update row number label when selectedline changes
2693 proc selectedline_change {n1 n2 op} {
2694 global selectedline rownumsel
2696 if {$selectedline eq {}} {
2697 set rownumsel {}
2698 } else {
2699 set rownumsel [expr {$selectedline + 1}]
2703 # mouse-2 makes all windows scan vertically, but only the one
2704 # the cursor is in scans horizontally
2705 proc canvscan {op w x y} {
2706 global canv canv2 canv3
2707 foreach c [list $canv $canv2 $canv3] {
2708 if {$c == $w} {
2709 $c scan $op $x $y
2710 } else {
2711 $c scan $op 0 $y
2716 proc scrollcanv {cscroll f0 f1} {
2717 $cscroll set $f0 $f1
2718 drawvisible
2719 flushhighlights
2722 # when we make a key binding for the toplevel, make sure
2723 # it doesn't get triggered when that key is pressed in the
2724 # find string entry widget.
2725 proc bindkey {ev script} {
2726 global entries
2727 bind . $ev $script
2728 set escript [bind Entry $ev]
2729 if {$escript == {}} {
2730 set escript [bind Entry <Key>]
2732 foreach e $entries {
2733 bind $e $ev "$escript; break"
2737 proc bindmodfunctionkey {mod n script} {
2738 bind . <$mod-F$n> $script
2739 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2742 # set the focus back to the toplevel for any click outside
2743 # the entry widgets
2744 proc click {w} {
2745 global ctext entries
2746 foreach e [concat $entries $ctext] {
2747 if {$w == $e} return
2749 focus .
2752 # Adjust the progress bar for a change in requested extent or canvas size
2753 proc adjustprogress {} {
2754 global progresscanv progressitem progresscoords
2755 global fprogitem fprogcoord lastprogupdate progupdatepending
2756 global rprogitem rprogcoord use_ttk
2758 if {$use_ttk} {
2759 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2760 return
2763 set w [expr {[winfo width $progresscanv] - 4}]
2764 set x0 [expr {$w * [lindex $progresscoords 0]}]
2765 set x1 [expr {$w * [lindex $progresscoords 1]}]
2766 set h [winfo height $progresscanv]
2767 $progresscanv coords $progressitem $x0 0 $x1 $h
2768 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2769 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2770 set now [clock clicks -milliseconds]
2771 if {$now >= $lastprogupdate + 100} {
2772 set progupdatepending 0
2773 update
2774 } elseif {!$progupdatepending} {
2775 set progupdatepending 1
2776 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2780 proc doprogupdate {} {
2781 global lastprogupdate progupdatepending
2783 if {$progupdatepending} {
2784 set progupdatepending 0
2785 set lastprogupdate [clock clicks -milliseconds]
2786 update
2790 proc config_check_tmp_exists {tries_left} {
2791 global config_file_tmp
2793 if {[file exists $config_file_tmp]} {
2794 incr tries_left -1
2795 if {$tries_left > 0} {
2796 after 100 [list config_check_tmp_exists $tries_left]
2797 } else {
2798 error_popup "There appears to be a stale $config_file_tmp\
2799 file, which will prevent gitk from saving its configuration on exit.\
2800 Please remove it if it is not being used by any existing gitk process."
2805 proc config_init_trace {name} {
2806 global config_variable_changed config_variable_original
2808 upvar #0 $name var
2809 set config_variable_changed($name) 0
2810 set config_variable_original($name) $var
2813 proc config_variable_change_cb {name name2 op} {
2814 global config_variable_changed config_variable_original
2816 upvar #0 $name var
2817 if {$op eq "write" &&
2818 (![info exists config_variable_original($name)] ||
2819 $config_variable_original($name) ne $var)} {
2820 set config_variable_changed($name) 1
2824 proc savestuff {w} {
2825 global stuffsaved
2826 global config_file config_file_tmp
2827 global config_variables config_variable_changed
2828 global viewchanged
2830 upvar #0 viewname current_viewname
2831 upvar #0 viewfiles current_viewfiles
2832 upvar #0 viewargs current_viewargs
2833 upvar #0 viewargscmd current_viewargscmd
2834 upvar #0 viewperm current_viewperm
2835 upvar #0 nextviewnum current_nextviewnum
2836 upvar #0 use_ttk current_use_ttk
2838 if {$stuffsaved} return
2839 if {![winfo viewable .]} return
2840 set remove_tmp 0
2841 if {[catch {
2842 set try_count 0
2843 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2844 if {[incr try_count] > 50} {
2845 error "Unable to write config file: $config_file_tmp exists"
2847 after 100
2849 set remove_tmp 1
2850 if {$::tcl_platform(platform) eq {windows}} {
2851 file attributes $config_file_tmp -hidden true
2853 if {[file exists $config_file]} {
2854 source $config_file
2856 foreach var_name $config_variables {
2857 upvar #0 $var_name var
2858 upvar 0 $var_name old_var
2859 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2860 puts $f [list set $var_name $old_var]
2861 } else {
2862 puts $f [list set $var_name $var]
2866 puts $f "set geometry(main) [wm geometry .]"
2867 puts $f "set geometry(state) [wm state .]"
2868 puts $f "set geometry(topwidth) [winfo width .tf]"
2869 puts $f "set geometry(topheight) [winfo height .tf]"
2870 if {$current_use_ttk} {
2871 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2872 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2873 } else {
2874 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2875 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2877 puts $f "set geometry(botwidth) [winfo width .bleft]"
2878 puts $f "set geometry(botheight) [winfo height .bleft]"
2880 array set view_save {}
2881 array set views {}
2882 if {![info exists permviews]} { set permviews {} }
2883 foreach view $permviews {
2884 set view_save([lindex $view 0]) 1
2885 set views([lindex $view 0]) $view
2887 puts -nonewline $f "set permviews {"
2888 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2889 if {$viewchanged($v)} {
2890 if {$current_viewperm($v)} {
2891 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2892 } else {
2893 set view_save($current_viewname($v)) 0
2897 # write old and updated view to their places and append remaining to the end
2898 foreach view $permviews {
2899 set view_name [lindex $view 0]
2900 if {$view_save($view_name)} {
2901 puts $f "{$views($view_name)}"
2903 unset views($view_name)
2905 foreach view_name [array names views] {
2906 puts $f "{$views($view_name)}"
2908 puts $f "}"
2909 close $f
2910 file rename -force $config_file_tmp $config_file
2911 set remove_tmp 0
2912 } err]} {
2913 puts "Error saving config: $err"
2915 if {$remove_tmp} {
2916 file delete -force $config_file_tmp
2918 set stuffsaved 1
2921 proc resizeclistpanes {win w} {
2922 global oldwidth use_ttk
2923 if {[info exists oldwidth($win)]} {
2924 if {$use_ttk} {
2925 set s0 [$win sashpos 0]
2926 set s1 [$win sashpos 1]
2927 } else {
2928 set s0 [$win sash coord 0]
2929 set s1 [$win sash coord 1]
2931 if {$w < 60} {
2932 set sash0 [expr {int($w/2 - 2)}]
2933 set sash1 [expr {int($w*5/6 - 2)}]
2934 } else {
2935 set factor [expr {1.0 * $w / $oldwidth($win)}]
2936 set sash0 [expr {int($factor * [lindex $s0 0])}]
2937 set sash1 [expr {int($factor * [lindex $s1 0])}]
2938 if {$sash0 < 30} {
2939 set sash0 30
2941 if {$sash1 < $sash0 + 20} {
2942 set sash1 [expr {$sash0 + 20}]
2944 if {$sash1 > $w - 10} {
2945 set sash1 [expr {$w - 10}]
2946 if {$sash0 > $sash1 - 20} {
2947 set sash0 [expr {$sash1 - 20}]
2951 if {$use_ttk} {
2952 $win sashpos 0 $sash0
2953 $win sashpos 1 $sash1
2954 } else {
2955 $win sash place 0 $sash0 [lindex $s0 1]
2956 $win sash place 1 $sash1 [lindex $s1 1]
2959 set oldwidth($win) $w
2962 proc resizecdetpanes {win w} {
2963 global oldwidth use_ttk
2964 if {[info exists oldwidth($win)]} {
2965 if {$use_ttk} {
2966 set s0 [$win sashpos 0]
2967 } else {
2968 set s0 [$win sash coord 0]
2970 if {$w < 60} {
2971 set sash0 [expr {int($w*3/4 - 2)}]
2972 } else {
2973 set factor [expr {1.0 * $w / $oldwidth($win)}]
2974 set sash0 [expr {int($factor * [lindex $s0 0])}]
2975 if {$sash0 < 45} {
2976 set sash0 45
2978 if {$sash0 > $w - 15} {
2979 set sash0 [expr {$w - 15}]
2982 if {$use_ttk} {
2983 $win sashpos 0 $sash0
2984 } else {
2985 $win sash place 0 $sash0 [lindex $s0 1]
2988 set oldwidth($win) $w
2991 proc allcanvs args {
2992 global canv canv2 canv3
2993 eval $canv $args
2994 eval $canv2 $args
2995 eval $canv3 $args
2998 proc bindall {event action} {
2999 global canv canv2 canv3
3000 bind $canv $event $action
3001 bind $canv2 $event $action
3002 bind $canv3 $event $action
3005 proc about {} {
3006 global uifont NS
3007 set w .about
3008 if {[winfo exists $w]} {
3009 raise $w
3010 return
3012 ttk_toplevel $w
3013 wm title $w [mc "About gitk"]
3014 make_transient $w .
3015 message $w.m -text [mc "
3016 Gitk - a commit viewer for git
3018 Copyright \u00a9 2005-2014 Paul Mackerras
3020 Use and redistribute under the terms of the GNU General Public License"] \
3021 -justify center -aspect 400 -border 2 -bg white -relief groove
3022 pack $w.m -side top -fill x -padx 2 -pady 2
3023 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3024 pack $w.ok -side bottom
3025 bind $w <Visibility> "focus $w.ok"
3026 bind $w <Key-Escape> "destroy $w"
3027 bind $w <Key-Return> "destroy $w"
3028 tk::PlaceWindow $w widget .
3031 proc keys {} {
3032 global NS
3033 set w .keys
3034 if {[winfo exists $w]} {
3035 raise $w
3036 return
3038 if {[tk windowingsystem] eq {aqua}} {
3039 set M1T Cmd
3040 } else {
3041 set M1T Ctrl
3043 ttk_toplevel $w
3044 wm title $w [mc "Gitk key bindings"]
3045 make_transient $w .
3046 message $w.m -text "
3047 [mc "Gitk key bindings:"]
3049 [mc "<%s-Q> Quit" $M1T]
3050 [mc "<%s-W> Close window" $M1T]
3051 [mc "<Home> Move to first commit"]
3052 [mc "<End> Move to last commit"]
3053 [mc "<Up>, p, k Move up one commit"]
3054 [mc "<Down>, n, j Move down one commit"]
3055 [mc "<Left>, z, h Go back in history list"]
3056 [mc "<Right>, x, l Go forward in history list"]
3057 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3058 [mc "<PageUp> Move up one page in commit list"]
3059 [mc "<PageDown> Move down one page in commit list"]
3060 [mc "<%s-Home> Scroll to top of commit list" $M1T]
3061 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
3062 [mc "<%s-Up> Scroll commit list up one line" $M1T]
3063 [mc "<%s-Down> Scroll commit list down one line" $M1T]
3064 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3065 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3066 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3067 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3068 [mc "<Delete>, b Scroll diff view up one page"]
3069 [mc "<Backspace> Scroll diff view up one page"]
3070 [mc "<Space> Scroll diff view down one page"]
3071 [mc "u Scroll diff view up 18 lines"]
3072 [mc "d Scroll diff view down 18 lines"]
3073 [mc "<%s-F> Find" $M1T]
3074 [mc "<%s-G> Move to next find hit" $M1T]
3075 [mc "<Return> Move to next find hit"]
3076 [mc "g Go to commit"]
3077 [mc "/ Focus the search box"]
3078 [mc "? Move to previous find hit"]
3079 [mc "f Scroll diff view to next file"]
3080 [mc "<%s-S> Search for next hit in diff view" $M1T]
3081 [mc "<%s-R> Search for previous hit in diff view" $M1T]
3082 [mc "<%s-KP+> Increase font size" $M1T]
3083 [mc "<%s-plus> Increase font size" $M1T]
3084 [mc "<%s-KP-> Decrease font size" $M1T]
3085 [mc "<%s-minus> Decrease font size" $M1T]
3086 [mc "<F5> Update"]
3088 -justify left -bg white -border 2 -relief groove
3089 pack $w.m -side top -fill both -padx 2 -pady 2
3090 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3091 bind $w <Key-Escape> [list destroy $w]
3092 pack $w.ok -side bottom
3093 bind $w <Visibility> "focus $w.ok"
3094 bind $w <Key-Escape> "destroy $w"
3095 bind $w <Key-Return> "destroy $w"
3098 # Procedures for manipulating the file list window at the
3099 # bottom right of the overall window.
3101 proc treeview {w l openlevs} {
3102 global treecontents treediropen treeheight treeparent treeindex
3104 set ix 0
3105 set treeindex() 0
3106 set lev 0
3107 set prefix {}
3108 set prefixend -1
3109 set prefendstack {}
3110 set htstack {}
3111 set ht 0
3112 set treecontents() {}
3113 $w conf -state normal
3114 foreach f $l {
3115 while {[string range $f 0 $prefixend] ne $prefix} {
3116 if {$lev <= $openlevs} {
3117 $w mark set e:$treeindex($prefix) "end -1c"
3118 $w mark gravity e:$treeindex($prefix) left
3120 set treeheight($prefix) $ht
3121 incr ht [lindex $htstack end]
3122 set htstack [lreplace $htstack end end]
3123 set prefixend [lindex $prefendstack end]
3124 set prefendstack [lreplace $prefendstack end end]
3125 set prefix [string range $prefix 0 $prefixend]
3126 incr lev -1
3128 set tail [string range $f [expr {$prefixend+1}] end]
3129 while {[set slash [string first "/" $tail]] >= 0} {
3130 lappend htstack $ht
3131 set ht 0
3132 lappend prefendstack $prefixend
3133 incr prefixend [expr {$slash + 1}]
3134 set d [string range $tail 0 $slash]
3135 lappend treecontents($prefix) $d
3136 set oldprefix $prefix
3137 append prefix $d
3138 set treecontents($prefix) {}
3139 set treeindex($prefix) [incr ix]
3140 set treeparent($prefix) $oldprefix
3141 set tail [string range $tail [expr {$slash+1}] end]
3142 if {$lev <= $openlevs} {
3143 set ht 1
3144 set treediropen($prefix) [expr {$lev < $openlevs}]
3145 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3146 $w mark set d:$ix "end -1c"
3147 $w mark gravity d:$ix left
3148 set str "\n"
3149 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3150 $w insert end $str
3151 $w image create end -align center -image $bm -padx 1 \
3152 -name a:$ix
3153 $w insert end $d [highlight_tag $prefix]
3154 $w mark set s:$ix "end -1c"
3155 $w mark gravity s:$ix left
3157 incr lev
3159 if {$tail ne {}} {
3160 if {$lev <= $openlevs} {
3161 incr ht
3162 set str "\n"
3163 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3164 $w insert end $str
3165 $w insert end $tail [highlight_tag $f]
3167 lappend treecontents($prefix) $tail
3170 while {$htstack ne {}} {
3171 set treeheight($prefix) $ht
3172 incr ht [lindex $htstack end]
3173 set htstack [lreplace $htstack end end]
3174 set prefixend [lindex $prefendstack end]
3175 set prefendstack [lreplace $prefendstack end end]
3176 set prefix [string range $prefix 0 $prefixend]
3178 $w conf -state disabled
3181 proc linetoelt {l} {
3182 global treeheight treecontents
3184 set y 2
3185 set prefix {}
3186 while {1} {
3187 foreach e $treecontents($prefix) {
3188 if {$y == $l} {
3189 return "$prefix$e"
3191 set n 1
3192 if {[string index $e end] eq "/"} {
3193 set n $treeheight($prefix$e)
3194 if {$y + $n > $l} {
3195 append prefix $e
3196 incr y
3197 break
3200 incr y $n
3205 proc highlight_tree {y prefix} {
3206 global treeheight treecontents cflist
3208 foreach e $treecontents($prefix) {
3209 set path $prefix$e
3210 if {[highlight_tag $path] ne {}} {
3211 $cflist tag add bold $y.0 "$y.0 lineend"
3213 incr y
3214 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3215 set y [highlight_tree $y $path]
3218 return $y
3221 proc treeclosedir {w dir} {
3222 global treediropen treeheight treeparent treeindex
3224 set ix $treeindex($dir)
3225 $w conf -state normal
3226 $w delete s:$ix e:$ix
3227 set treediropen($dir) 0
3228 $w image configure a:$ix -image tri-rt
3229 $w conf -state disabled
3230 set n [expr {1 - $treeheight($dir)}]
3231 while {$dir ne {}} {
3232 incr treeheight($dir) $n
3233 set dir $treeparent($dir)
3237 proc treeopendir {w dir} {
3238 global treediropen treeheight treeparent treecontents treeindex
3240 set ix $treeindex($dir)
3241 $w conf -state normal
3242 $w image configure a:$ix -image tri-dn
3243 $w mark set e:$ix s:$ix
3244 $w mark gravity e:$ix right
3245 set lev 0
3246 set str "\n"
3247 set n [llength $treecontents($dir)]
3248 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3249 incr lev
3250 append str "\t"
3251 incr treeheight($x) $n
3253 foreach e $treecontents($dir) {
3254 set de $dir$e
3255 if {[string index $e end] eq "/"} {
3256 set iy $treeindex($de)
3257 $w mark set d:$iy e:$ix
3258 $w mark gravity d:$iy left
3259 $w insert e:$ix $str
3260 set treediropen($de) 0
3261 $w image create e:$ix -align center -image tri-rt -padx 1 \
3262 -name a:$iy
3263 $w insert e:$ix $e [highlight_tag $de]
3264 $w mark set s:$iy e:$ix
3265 $w mark gravity s:$iy left
3266 set treeheight($de) 1
3267 } else {
3268 $w insert e:$ix $str
3269 $w insert e:$ix $e [highlight_tag $de]
3272 $w mark gravity e:$ix right
3273 $w conf -state disabled
3274 set treediropen($dir) 1
3275 set top [lindex [split [$w index @0,0] .] 0]
3276 set ht [$w cget -height]
3277 set l [lindex [split [$w index s:$ix] .] 0]
3278 if {$l < $top} {
3279 $w yview $l.0
3280 } elseif {$l + $n + 1 > $top + $ht} {
3281 set top [expr {$l + $n + 2 - $ht}]
3282 if {$l < $top} {
3283 set top $l
3285 $w yview $top.0
3289 proc treeclick {w x y} {
3290 global treediropen cmitmode ctext cflist cflist_top
3292 if {$cmitmode ne "tree"} return
3293 if {![info exists cflist_top]} return
3294 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3295 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3296 $cflist tag add highlight $l.0 "$l.0 lineend"
3297 set cflist_top $l
3298 if {$l == 1} {
3299 $ctext yview 1.0
3300 return
3302 set e [linetoelt $l]
3303 if {[string index $e end] ne "/"} {
3304 showfile $e
3305 } elseif {$treediropen($e)} {
3306 treeclosedir $w $e
3307 } else {
3308 treeopendir $w $e
3312 proc setfilelist {id} {
3313 global treefilelist cflist jump_to_here
3315 treeview $cflist $treefilelist($id) 0
3316 if {$jump_to_here ne {}} {
3317 set f [lindex $jump_to_here 0]
3318 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3319 showfile $f
3324 image create bitmap tri-rt -background black -foreground blue -data {
3325 #define tri-rt_width 13
3326 #define tri-rt_height 13
3327 static unsigned char tri-rt_bits[] = {
3328 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3329 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3330 0x00, 0x00};
3331 } -maskdata {
3332 #define tri-rt-mask_width 13
3333 #define tri-rt-mask_height 13
3334 static unsigned char tri-rt-mask_bits[] = {
3335 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3336 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3337 0x08, 0x00};
3339 image create bitmap tri-dn -background black -foreground blue -data {
3340 #define tri-dn_width 13
3341 #define tri-dn_height 13
3342 static unsigned char tri-dn_bits[] = {
3343 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3344 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3345 0x00, 0x00};
3346 } -maskdata {
3347 #define tri-dn-mask_width 13
3348 #define tri-dn-mask_height 13
3349 static unsigned char tri-dn-mask_bits[] = {
3350 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3351 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3352 0x00, 0x00};
3355 image create bitmap reficon-T -background black -foreground yellow -data {
3356 #define tagicon_width 13
3357 #define tagicon_height 9
3358 static unsigned char tagicon_bits[] = {
3359 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3360 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3361 } -maskdata {
3362 #define tagicon-mask_width 13
3363 #define tagicon-mask_height 9
3364 static unsigned char tagicon-mask_bits[] = {
3365 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3366 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3368 set rectdata {
3369 #define headicon_width 13
3370 #define headicon_height 9
3371 static unsigned char headicon_bits[] = {
3372 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3373 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3375 set rectmask {
3376 #define headicon-mask_width 13
3377 #define headicon-mask_height 9
3378 static unsigned char headicon-mask_bits[] = {
3379 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3380 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3382 image create bitmap reficon-H -background black -foreground green \
3383 -data $rectdata -maskdata $rectmask
3384 image create bitmap reficon-o -background black -foreground "#ddddff" \
3385 -data $rectdata -maskdata $rectmask
3387 proc init_flist {first} {
3388 global cflist cflist_top difffilestart
3390 $cflist conf -state normal
3391 $cflist delete 0.0 end
3392 if {$first ne {}} {
3393 $cflist insert end $first
3394 set cflist_top 1
3395 $cflist tag add highlight 1.0 "1.0 lineend"
3396 } else {
3397 unset -nocomplain cflist_top
3399 $cflist conf -state disabled
3400 set difffilestart {}
3403 proc highlight_tag {f} {
3404 global highlight_paths
3406 foreach p $highlight_paths {
3407 if {[string match $p $f]} {
3408 return "bold"
3411 return {}
3414 proc highlight_filelist {} {
3415 global cmitmode cflist
3417 $cflist conf -state normal
3418 if {$cmitmode ne "tree"} {
3419 set end [lindex [split [$cflist index end] .] 0]
3420 for {set l 2} {$l < $end} {incr l} {
3421 set line [$cflist get $l.0 "$l.0 lineend"]
3422 if {[highlight_tag $line] ne {}} {
3423 $cflist tag add bold $l.0 "$l.0 lineend"
3426 } else {
3427 highlight_tree 2 {}
3429 $cflist conf -state disabled
3432 proc unhighlight_filelist {} {
3433 global cflist
3435 $cflist conf -state normal
3436 $cflist tag remove bold 1.0 end
3437 $cflist conf -state disabled
3440 proc add_flist {fl} {
3441 global cflist
3443 $cflist conf -state normal
3444 foreach f $fl {
3445 $cflist insert end "\n"
3446 $cflist insert end $f [highlight_tag $f]
3448 $cflist conf -state disabled
3451 proc sel_flist {w x y} {
3452 global ctext difffilestart cflist cflist_top cmitmode
3454 if {$cmitmode eq "tree"} return
3455 if {![info exists cflist_top]} return
3456 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3457 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3458 $cflist tag add highlight $l.0 "$l.0 lineend"
3459 set cflist_top $l
3460 if {$l == 1} {
3461 $ctext yview 1.0
3462 } else {
3463 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3465 suppress_highlighting_file_for_current_scrollpos
3468 proc pop_flist_menu {w X Y x y} {
3469 global ctext cflist cmitmode flist_menu flist_menu_file
3470 global treediffs diffids
3472 stopfinding
3473 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3474 if {$l <= 1} return
3475 if {$cmitmode eq "tree"} {
3476 set e [linetoelt $l]
3477 if {[string index $e end] eq "/"} return
3478 } else {
3479 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3481 set flist_menu_file $e
3482 set xdiffstate "normal"
3483 if {$cmitmode eq "tree"} {
3484 set xdiffstate "disabled"
3486 # Disable "External diff" item in tree mode
3487 $flist_menu entryconf 2 -state $xdiffstate
3488 tk_popup $flist_menu $X $Y
3491 proc find_ctext_fileinfo {line} {
3492 global ctext_file_names ctext_file_lines
3494 set ok [bsearch $ctext_file_lines $line]
3495 set tline [lindex $ctext_file_lines $ok]
3497 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3498 return {}
3499 } else {
3500 return [list [lindex $ctext_file_names $ok] $tline]
3504 proc pop_diff_menu {w X Y x y} {
3505 global ctext diff_menu flist_menu_file
3506 global diff_menu_txtpos diff_menu_line
3507 global diff_menu_filebase
3509 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3510 set diff_menu_line [lindex $diff_menu_txtpos 0]
3511 # don't pop up the menu on hunk-separator or file-separator lines
3512 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3513 return
3515 stopfinding
3516 set f [find_ctext_fileinfo $diff_menu_line]
3517 if {$f eq {}} return
3518 set flist_menu_file [lindex $f 0]
3519 set diff_menu_filebase [lindex $f 1]
3520 tk_popup $diff_menu $X $Y
3523 proc flist_hl {only} {
3524 global flist_menu_file findstring gdttype
3526 set x [shellquote $flist_menu_file]
3527 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3528 set findstring $x
3529 } else {
3530 append findstring " " $x
3532 set gdttype [mc "touching paths:"]
3535 proc gitknewtmpdir {} {
3536 global diffnum gitktmpdir gitdir env
3538 if {![info exists gitktmpdir]} {
3539 if {[info exists env(GITK_TMPDIR)]} {
3540 set tmpdir $env(GITK_TMPDIR)
3541 } elseif {[info exists env(TMPDIR)]} {
3542 set tmpdir $env(TMPDIR)
3543 } else {
3544 set tmpdir $gitdir
3546 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3547 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3548 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3550 if {[catch {file mkdir $gitktmpdir} err]} {
3551 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3552 unset gitktmpdir
3553 return {}
3555 set diffnum 0
3557 incr diffnum
3558 set diffdir [file join $gitktmpdir $diffnum]
3559 if {[catch {file mkdir $diffdir} err]} {
3560 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3561 return {}
3563 return $diffdir
3566 proc save_file_from_commit {filename output what} {
3567 global nullfile
3569 if {[catch {exec git show $filename -- > $output} err]} {
3570 if {[string match "fatal: bad revision *" $err]} {
3571 return $nullfile
3573 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3574 return {}
3576 return $output
3579 proc external_diff_get_one_file {diffid filename diffdir} {
3580 global nullid nullid2 nullfile
3581 global worktree
3583 if {$diffid == $nullid} {
3584 set difffile [file join $worktree $filename]
3585 if {[file exists $difffile]} {
3586 return $difffile
3588 return $nullfile
3590 if {$diffid == $nullid2} {
3591 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3592 return [save_file_from_commit :$filename $difffile index]
3594 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3595 return [save_file_from_commit $diffid:$filename $difffile \
3596 "revision $diffid"]
3599 proc external_diff {} {
3600 global nullid nullid2
3601 global flist_menu_file
3602 global diffids
3603 global extdifftool
3605 if {[llength $diffids] == 1} {
3606 # no reference commit given
3607 set diffidto [lindex $diffids 0]
3608 if {$diffidto eq $nullid} {
3609 # diffing working copy with index
3610 set diffidfrom $nullid2
3611 } elseif {$diffidto eq $nullid2} {
3612 # diffing index with HEAD
3613 set diffidfrom "HEAD"
3614 } else {
3615 # use first parent commit
3616 global parentlist selectedline
3617 set diffidfrom [lindex $parentlist $selectedline 0]
3619 } else {
3620 set diffidfrom [lindex $diffids 0]
3621 set diffidto [lindex $diffids 1]
3624 # make sure that several diffs wont collide
3625 set diffdir [gitknewtmpdir]
3626 if {$diffdir eq {}} return
3628 # gather files to diff
3629 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3630 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3632 if {$difffromfile ne {} && $difftofile ne {}} {
3633 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3634 if {[catch {set fl [open |$cmd r]} err]} {
3635 file delete -force $diffdir
3636 error_popup "$extdifftool: [mc "command failed:"] $err"
3637 } else {
3638 fconfigure $fl -blocking 0
3639 filerun $fl [list delete_at_eof $fl $diffdir]
3644 proc find_hunk_blamespec {base line} {
3645 global ctext
3647 # Find and parse the hunk header
3648 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3649 if {$s_lix eq {}} return
3651 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3652 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3653 s_line old_specs osz osz1 new_line nsz]} {
3654 return
3657 # base lines for the parents
3658 set base_lines [list $new_line]
3659 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3660 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3661 old_spec old_line osz]} {
3662 return
3664 lappend base_lines $old_line
3667 # Now scan the lines to determine offset within the hunk
3668 set max_parent [expr {[llength $base_lines]-2}]
3669 set dline 0
3670 set s_lno [lindex [split $s_lix "."] 0]
3672 # Determine if the line is removed
3673 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3674 if {[string match {[-+ ]*} $chunk]} {
3675 set removed_idx [string first "-" $chunk]
3676 # Choose a parent index
3677 if {$removed_idx >= 0} {
3678 set parent $removed_idx
3679 } else {
3680 set unchanged_idx [string first " " $chunk]
3681 if {$unchanged_idx >= 0} {
3682 set parent $unchanged_idx
3683 } else {
3684 # blame the current commit
3685 set parent -1
3688 # then count other lines that belong to it
3689 for {set i $line} {[incr i -1] > $s_lno} {} {
3690 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3691 # Determine if the line is removed
3692 set removed_idx [string first "-" $chunk]
3693 if {$parent >= 0} {
3694 set code [string index $chunk $parent]
3695 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3696 incr dline
3698 } else {
3699 if {$removed_idx < 0} {
3700 incr dline
3704 incr parent
3705 } else {
3706 set parent 0
3709 incr dline [lindex $base_lines $parent]
3710 return [list $parent $dline]
3713 proc external_blame_diff {} {
3714 global currentid cmitmode
3715 global diff_menu_txtpos diff_menu_line
3716 global diff_menu_filebase flist_menu_file
3718 if {$cmitmode eq "tree"} {
3719 set parent_idx 0
3720 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3721 } else {
3722 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3723 if {$hinfo ne {}} {
3724 set parent_idx [lindex $hinfo 0]
3725 set line [lindex $hinfo 1]
3726 } else {
3727 set parent_idx 0
3728 set line 0
3732 external_blame $parent_idx $line
3735 # Find the SHA1 ID of the blob for file $fname in the index
3736 # at stage 0 or 2
3737 proc index_sha1 {fname} {
3738 set f [open [list | git ls-files -s $fname] r]
3739 while {[gets $f line] >= 0} {
3740 set info [lindex [split $line "\t"] 0]
3741 set stage [lindex $info 2]
3742 if {$stage eq "0" || $stage eq "2"} {
3743 close $f
3744 return [lindex $info 1]
3747 close $f
3748 return {}
3751 # Turn an absolute path into one relative to the current directory
3752 proc make_relative {f} {
3753 if {[file pathtype $f] eq "relative"} {
3754 return $f
3756 set elts [file split $f]
3757 set here [file split [pwd]]
3758 set ei 0
3759 set hi 0
3760 set res {}
3761 foreach d $here {
3762 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3763 lappend res ".."
3764 } else {
3765 incr ei
3767 incr hi
3769 set elts [concat $res [lrange $elts $ei end]]
3770 return [eval file join $elts]
3773 proc external_blame {parent_idx {line {}}} {
3774 global flist_menu_file cdup
3775 global nullid nullid2
3776 global parentlist selectedline currentid
3778 if {$parent_idx > 0} {
3779 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3780 } else {
3781 set base_commit $currentid
3784 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3785 error_popup [mc "No such commit"]
3786 return
3789 set cmdline [list git gui blame]
3790 if {$line ne {} && $line > 1} {
3791 lappend cmdline "--line=$line"
3793 set f [file join $cdup $flist_menu_file]
3794 # Unfortunately it seems git gui blame doesn't like
3795 # being given an absolute path...
3796 set f [make_relative $f]
3797 lappend cmdline $base_commit $f
3798 if {[catch {eval exec $cmdline &} err]} {
3799 error_popup "[mc "git gui blame: command failed:"] $err"
3803 proc show_line_source {} {
3804 global cmitmode currentid parents curview blamestuff blameinst
3805 global diff_menu_line diff_menu_filebase flist_menu_file
3806 global nullid nullid2 gitdir cdup
3808 set from_index {}
3809 if {$cmitmode eq "tree"} {
3810 set id $currentid
3811 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3812 } else {
3813 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3814 if {$h eq {}} return
3815 set pi [lindex $h 0]
3816 if {$pi == 0} {
3817 mark_ctext_line $diff_menu_line
3818 return
3820 incr pi -1
3821 if {$currentid eq $nullid} {
3822 if {$pi > 0} {
3823 # must be a merge in progress...
3824 if {[catch {
3825 # get the last line from .git/MERGE_HEAD
3826 set f [open [file join $gitdir MERGE_HEAD] r]
3827 set id [lindex [split [read $f] "\n"] end-1]
3828 close $f
3829 } err]} {
3830 error_popup [mc "Couldn't read merge head: %s" $err]
3831 return
3833 } elseif {$parents($curview,$currentid) eq $nullid2} {
3834 # need to do the blame from the index
3835 if {[catch {
3836 set from_index [index_sha1 $flist_menu_file]
3837 } err]} {
3838 error_popup [mc "Error reading index: %s" $err]
3839 return
3841 } else {
3842 set id $parents($curview,$currentid)
3844 } else {
3845 set id [lindex $parents($curview,$currentid) $pi]
3847 set line [lindex $h 1]
3849 set blameargs {}
3850 if {$from_index ne {}} {
3851 lappend blameargs | git cat-file blob $from_index
3853 lappend blameargs | git blame -p -L$line,+1
3854 if {$from_index ne {}} {
3855 lappend blameargs --contents -
3856 } else {
3857 lappend blameargs $id
3859 lappend blameargs -- [file join $cdup $flist_menu_file]
3860 if {[catch {
3861 set f [open $blameargs r]
3862 } err]} {
3863 error_popup [mc "Couldn't start git blame: %s" $err]
3864 return
3866 nowbusy blaming [mc "Searching"]
3867 fconfigure $f -blocking 0
3868 set i [reg_instance $f]
3869 set blamestuff($i) {}
3870 set blameinst $i
3871 filerun $f [list read_line_source $f $i]
3874 proc stopblaming {} {
3875 global blameinst
3877 if {[info exists blameinst]} {
3878 stop_instance $blameinst
3879 unset blameinst
3880 notbusy blaming
3884 proc read_line_source {fd inst} {
3885 global blamestuff curview commfd blameinst nullid nullid2
3887 while {[gets $fd line] >= 0} {
3888 lappend blamestuff($inst) $line
3890 if {![eof $fd]} {
3891 return 1
3893 unset commfd($inst)
3894 unset blameinst
3895 notbusy blaming
3896 fconfigure $fd -blocking 1
3897 if {[catch {close $fd} err]} {
3898 error_popup [mc "Error running git blame: %s" $err]
3899 return 0
3902 set fname {}
3903 set line [split [lindex $blamestuff($inst) 0] " "]
3904 set id [lindex $line 0]
3905 set lnum [lindex $line 1]
3906 if {[string length $id] == 40 && [string is xdigit $id] &&
3907 [string is digit -strict $lnum]} {
3908 # look for "filename" line
3909 foreach l $blamestuff($inst) {
3910 if {[string match "filename *" $l]} {
3911 set fname [string range $l 9 end]
3912 break
3916 if {$fname ne {}} {
3917 # all looks good, select it
3918 if {$id eq $nullid} {
3919 # blame uses all-zeroes to mean not committed,
3920 # which would mean a change in the index
3921 set id $nullid2
3923 if {[commitinview $id $curview]} {
3924 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3925 } else {
3926 error_popup [mc "That line comes from commit %s, \
3927 which is not in this view" [shortids $id]]
3929 } else {
3930 puts "oops couldn't parse git blame output"
3932 return 0
3935 # delete $dir when we see eof on $f (presumably because the child has exited)
3936 proc delete_at_eof {f dir} {
3937 while {[gets $f line] >= 0} {}
3938 if {[eof $f]} {
3939 if {[catch {close $f} err]} {
3940 error_popup "[mc "External diff viewer failed:"] $err"
3942 file delete -force $dir
3943 return 0
3945 return 1
3948 # Functions for adding and removing shell-type quoting
3950 proc shellquote {str} {
3951 if {![string match "*\['\"\\ \t]*" $str]} {
3952 return $str
3954 if {![string match "*\['\"\\]*" $str]} {
3955 return "\"$str\""
3957 if {![string match "*'*" $str]} {
3958 return "'$str'"
3960 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3963 proc shellarglist {l} {
3964 set str {}
3965 foreach a $l {
3966 if {$str ne {}} {
3967 append str " "
3969 append str [shellquote $a]
3971 return $str
3974 proc shelldequote {str} {
3975 set ret {}
3976 set used -1
3977 while {1} {
3978 incr used
3979 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3980 append ret [string range $str $used end]
3981 set used [string length $str]
3982 break
3984 set first [lindex $first 0]
3985 set ch [string index $str $first]
3986 if {$first > $used} {
3987 append ret [string range $str $used [expr {$first - 1}]]
3988 set used $first
3990 if {$ch eq " " || $ch eq "\t"} break
3991 incr used
3992 if {$ch eq "'"} {
3993 set first [string first "'" $str $used]
3994 if {$first < 0} {
3995 error "unmatched single-quote"
3997 append ret [string range $str $used [expr {$first - 1}]]
3998 set used $first
3999 continue
4001 if {$ch eq "\\"} {
4002 if {$used >= [string length $str]} {
4003 error "trailing backslash"
4005 append ret [string index $str $used]
4006 continue
4008 # here ch == "\""
4009 while {1} {
4010 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4011 error "unmatched double-quote"
4013 set first [lindex $first 0]
4014 set ch [string index $str $first]
4015 if {$first > $used} {
4016 append ret [string range $str $used [expr {$first - 1}]]
4017 set used $first
4019 if {$ch eq "\""} break
4020 incr used
4021 append ret [string index $str $used]
4022 incr used
4025 return [list $used $ret]
4028 proc shellsplit {str} {
4029 set l {}
4030 while {1} {
4031 set str [string trimleft $str]
4032 if {$str eq {}} break
4033 set dq [shelldequote $str]
4034 set n [lindex $dq 0]
4035 set word [lindex $dq 1]
4036 set str [string range $str $n end]
4037 lappend l $word
4039 return $l
4042 proc set_window_title {} {
4043 global appname curview viewname vrevs
4044 set rev [mc "All files"]
4045 if {$curview ne 0} {
4046 if {$viewname($curview) eq [mc "Command line"]} {
4047 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4048 } else {
4049 set rev $viewname($curview)
4052 wm title . "[reponame]: $rev - $appname"
4055 # Code to implement multiple views
4057 proc newview {ishighlight} {
4058 global nextviewnum newviewname newishighlight
4059 global revtreeargs viewargscmd newviewopts curview
4061 set newishighlight $ishighlight
4062 set top .gitkview
4063 if {[winfo exists $top]} {
4064 raise $top
4065 return
4067 decode_view_opts $nextviewnum $revtreeargs
4068 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4069 set newviewopts($nextviewnum,perm) 0
4070 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4071 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4074 set known_view_options {
4075 {perm b . {} {mc "Remember this view"}}
4076 {reflabel l + {} {mc "References (space separated list):"}}
4077 {refs t15 .. {} {mc "Branches & tags:"}}
4078 {allrefs b *. "--all" {mc "All refs"}}
4079 {branches b . "--branches" {mc "All (local) branches"}}
4080 {tags b . "--tags" {mc "All tags"}}
4081 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4082 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4083 {author t15 .. "--author=*" {mc "Author:"}}
4084 {committer t15 . "--committer=*" {mc "Committer:"}}
4085 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4086 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4087 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4088 {changes_l l + {} {mc "Changes to Files:"}}
4089 {pickaxe_s r0 . {} {mc "Fixed String"}}
4090 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4091 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4092 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4093 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4094 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4095 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4096 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4097 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4098 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4099 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4100 {lright b . "--left-right" {mc "Mark branch sides"}}
4101 {first b . "--first-parent" {mc "Limit to first parent"}}
4102 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4103 {args t50 *. {} {mc "Additional arguments to git log:"}}
4104 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4105 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4108 # Convert $newviewopts($n, ...) into args for git log.
4109 proc encode_view_opts {n} {
4110 global known_view_options newviewopts
4112 set rargs [list]
4113 foreach opt $known_view_options {
4114 set patterns [lindex $opt 3]
4115 if {$patterns eq {}} continue
4116 set pattern [lindex $patterns 0]
4118 if {[lindex $opt 1] eq "b"} {
4119 set val $newviewopts($n,[lindex $opt 0])
4120 if {$val} {
4121 lappend rargs $pattern
4123 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4124 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4125 set val $newviewopts($n,$button_id)
4126 if {$val eq $value} {
4127 lappend rargs $pattern
4129 } else {
4130 set val $newviewopts($n,[lindex $opt 0])
4131 set val [string trim $val]
4132 if {$val ne {}} {
4133 set pfix [string range $pattern 0 end-1]
4134 lappend rargs $pfix$val
4138 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4139 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4142 # Fill $newviewopts($n, ...) based on args for git log.
4143 proc decode_view_opts {n view_args} {
4144 global known_view_options newviewopts
4146 foreach opt $known_view_options {
4147 set id [lindex $opt 0]
4148 if {[lindex $opt 1] eq "b"} {
4149 # Checkboxes
4150 set val 0
4151 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4152 # Radiobuttons
4153 regexp {^(.*_)} $id uselessvar id
4154 set val 0
4155 } else {
4156 # Text fields
4157 set val {}
4159 set newviewopts($n,$id) $val
4161 set oargs [list]
4162 set refargs [list]
4163 foreach arg $view_args {
4164 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4165 && ![info exists found(limit)]} {
4166 set newviewopts($n,limit) $cnt
4167 set found(limit) 1
4168 continue
4170 catch { unset val }
4171 foreach opt $known_view_options {
4172 set id [lindex $opt 0]
4173 if {[info exists found($id)]} continue
4174 foreach pattern [lindex $opt 3] {
4175 if {![string match $pattern $arg]} continue
4176 if {[lindex $opt 1] eq "b"} {
4177 # Check buttons
4178 set val 1
4179 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4180 # Radio buttons
4181 regexp {^(.*_)} $id uselessvar id
4182 set val $num
4183 } else {
4184 # Text input fields
4185 set size [string length $pattern]
4186 set val [string range $arg [expr {$size-1}] end]
4188 set newviewopts($n,$id) $val
4189 set found($id) 1
4190 break
4192 if {[info exists val]} break
4194 if {[info exists val]} continue
4195 if {[regexp {^-} $arg]} {
4196 lappend oargs $arg
4197 } else {
4198 lappend refargs $arg
4201 set newviewopts($n,refs) [shellarglist $refargs]
4202 set newviewopts($n,args) [shellarglist $oargs]
4205 proc edit_or_newview {} {
4206 global curview
4208 if {$curview > 0} {
4209 editview
4210 } else {
4211 newview 0
4215 proc editview {} {
4216 global curview
4217 global viewname viewperm newviewname newviewopts
4218 global viewargs viewargscmd
4220 set top .gitkvedit-$curview
4221 if {[winfo exists $top]} {
4222 raise $top
4223 return
4225 decode_view_opts $curview $viewargs($curview)
4226 set newviewname($curview) $viewname($curview)
4227 set newviewopts($curview,perm) $viewperm($curview)
4228 set newviewopts($curview,cmd) $viewargscmd($curview)
4229 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4232 proc vieweditor {top n title} {
4233 global newviewname newviewopts viewfiles bgcolor
4234 global known_view_options NS
4236 ttk_toplevel $top
4237 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4238 make_transient $top .
4240 # View name
4241 ${NS}::frame $top.nfr
4242 ${NS}::label $top.nl -text [mc "View Name"]
4243 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4244 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4245 pack $top.nl -in $top.nfr -side left -padx {0 5}
4246 pack $top.name -in $top.nfr -side left -padx {0 25}
4248 # View options
4249 set cframe $top.nfr
4250 set cexpand 0
4251 set cnt 0
4252 foreach opt $known_view_options {
4253 set id [lindex $opt 0]
4254 set type [lindex $opt 1]
4255 set flags [lindex $opt 2]
4256 set title [eval [lindex $opt 4]]
4257 set lxpad 0
4259 if {$flags eq "+" || $flags eq "*"} {
4260 set cframe $top.fr$cnt
4261 incr cnt
4262 ${NS}::frame $cframe
4263 pack $cframe -in $top -fill x -pady 3 -padx 3
4264 set cexpand [expr {$flags eq "*"}]
4265 } elseif {$flags eq ".." || $flags eq "*."} {
4266 set cframe $top.fr$cnt
4267 incr cnt
4268 ${NS}::frame $cframe
4269 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4270 set cexpand [expr {$flags eq "*."}]
4271 } else {
4272 set lxpad 5
4275 if {$type eq "l"} {
4276 ${NS}::label $cframe.l_$id -text $title
4277 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4278 } elseif {$type eq "b"} {
4279 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4280 pack $cframe.c_$id -in $cframe -side left \
4281 -padx [list $lxpad 0] -expand $cexpand -anchor w
4282 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4283 regexp {^(.*_)} $id uselessvar button_id
4284 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4285 pack $cframe.c_$id -in $cframe -side left \
4286 -padx [list $lxpad 0] -expand $cexpand -anchor w
4287 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4288 ${NS}::label $cframe.l_$id -text $title
4289 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4290 -textvariable newviewopts($n,$id)
4291 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4292 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4293 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4294 ${NS}::label $cframe.l_$id -text $title
4295 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4296 -textvariable newviewopts($n,$id)
4297 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4298 pack $cframe.e_$id -in $cframe -side top -fill x
4299 } elseif {$type eq "path"} {
4300 ${NS}::label $top.l -text $title
4301 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4302 text $top.t -width 40 -height 5 -background $bgcolor
4303 if {[info exists viewfiles($n)]} {
4304 foreach f $viewfiles($n) {
4305 $top.t insert end $f
4306 $top.t insert end "\n"
4308 $top.t delete {end - 1c} end
4309 $top.t mark set insert 0.0
4311 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4315 ${NS}::frame $top.buts
4316 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4317 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4318 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4319 bind $top <Control-Return> [list newviewok $top $n]
4320 bind $top <F5> [list newviewok $top $n 1]
4321 bind $top <Escape> [list destroy $top]
4322 grid $top.buts.ok $top.buts.apply $top.buts.can
4323 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4324 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4325 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4326 pack $top.buts -in $top -side top -fill x
4327 focus $top.t
4330 proc doviewmenu {m first cmd op argv} {
4331 set nmenu [$m index end]
4332 for {set i $first} {$i <= $nmenu} {incr i} {
4333 if {[$m entrycget $i -command] eq $cmd} {
4334 eval $m $op $i $argv
4335 break
4340 proc allviewmenus {n op args} {
4341 # global viewhlmenu
4343 doviewmenu .bar.view 5 [list showview $n] $op $args
4344 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4347 proc newviewok {top n {apply 0}} {
4348 global nextviewnum newviewperm newviewname newishighlight
4349 global viewname viewfiles viewperm viewchanged selectedview curview
4350 global viewargs viewargscmd newviewopts viewhlmenu
4352 if {[catch {
4353 set newargs [encode_view_opts $n]
4354 } err]} {
4355 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4356 return
4358 set files {}
4359 foreach f [split [$top.t get 0.0 end] "\n"] {
4360 set ft [string trim $f]
4361 if {$ft ne {}} {
4362 lappend files $ft
4365 if {![info exists viewfiles($n)]} {
4366 # creating a new view
4367 incr nextviewnum
4368 set viewname($n) $newviewname($n)
4369 set viewperm($n) $newviewopts($n,perm)
4370 set viewchanged($n) 1
4371 set viewfiles($n) $files
4372 set viewargs($n) $newargs
4373 set viewargscmd($n) $newviewopts($n,cmd)
4374 addviewmenu $n
4375 if {!$newishighlight} {
4376 run showview $n
4377 } else {
4378 run addvhighlight $n
4380 } else {
4381 # editing an existing view
4382 set viewperm($n) $newviewopts($n,perm)
4383 set viewchanged($n) 1
4384 if {$newviewname($n) ne $viewname($n)} {
4385 set viewname($n) $newviewname($n)
4386 doviewmenu .bar.view 5 [list showview $n] \
4387 entryconf [list -label $viewname($n)]
4388 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4389 # entryconf [list -label $viewname($n) -value $viewname($n)]
4391 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4392 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4393 set viewfiles($n) $files
4394 set viewargs($n) $newargs
4395 set viewargscmd($n) $newviewopts($n,cmd)
4396 if {$curview == $n} {
4397 run reloadcommits
4401 if {$apply} return
4402 catch {destroy $top}
4405 proc delview {} {
4406 global curview viewperm hlview selectedhlview viewchanged
4408 if {$curview == 0} return
4409 if {[info exists hlview] && $hlview == $curview} {
4410 set selectedhlview [mc "None"]
4411 unset hlview
4413 allviewmenus $curview delete
4414 set viewperm($curview) 0
4415 set viewchanged($curview) 1
4416 showview 0
4419 proc addviewmenu {n} {
4420 global viewname viewhlmenu
4422 .bar.view add radiobutton -label $viewname($n) \
4423 -command [list showview $n] -variable selectedview -value $n
4424 #$viewhlmenu add radiobutton -label $viewname($n) \
4425 # -command [list addvhighlight $n] -variable selectedhlview
4428 proc showview {n} {
4429 global curview cached_commitrow ordertok
4430 global displayorder parentlist rowidlist rowisopt rowfinal
4431 global colormap rowtextx nextcolor canvxmax
4432 global numcommits viewcomplete
4433 global selectedline currentid canv canvy0
4434 global treediffs
4435 global pending_select mainheadid
4436 global commitidx
4437 global selectedview
4438 global hlview selectedhlview commitinterest
4440 if {$n == $curview} return
4441 set selid {}
4442 set ymax [lindex [$canv cget -scrollregion] 3]
4443 set span [$canv yview]
4444 set ytop [expr {[lindex $span 0] * $ymax}]
4445 set ybot [expr {[lindex $span 1] * $ymax}]
4446 set yscreen [expr {($ybot - $ytop) / 2}]
4447 if {$selectedline ne {}} {
4448 set selid $currentid
4449 set y [yc $selectedline]
4450 if {$ytop < $y && $y < $ybot} {
4451 set yscreen [expr {$y - $ytop}]
4453 } elseif {[info exists pending_select]} {
4454 set selid $pending_select
4455 unset pending_select
4457 unselectline
4458 normalline
4459 unset -nocomplain treediffs
4460 clear_display
4461 if {[info exists hlview] && $hlview == $n} {
4462 unset hlview
4463 set selectedhlview [mc "None"]
4465 unset -nocomplain commitinterest
4466 unset -nocomplain cached_commitrow
4467 unset -nocomplain ordertok
4469 set curview $n
4470 set selectedview $n
4471 .bar.view entryconf [mca "&Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4472 .bar.view entryconf [mca "&Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4474 run refill_reflist
4475 if {![info exists viewcomplete($n)]} {
4476 getcommits $selid
4477 return
4480 set displayorder {}
4481 set parentlist {}
4482 set rowidlist {}
4483 set rowisopt {}
4484 set rowfinal {}
4485 set numcommits $commitidx($n)
4487 unset -nocomplain colormap
4488 unset -nocomplain rowtextx
4489 set nextcolor 0
4490 set canvxmax [$canv cget -width]
4491 set curview $n
4492 set row 0
4493 setcanvscroll
4494 set yf 0
4495 set row {}
4496 if {$selid ne {} && [commitinview $selid $n]} {
4497 set row [rowofcommit $selid]
4498 # try to get the selected row in the same position on the screen
4499 set ymax [lindex [$canv cget -scrollregion] 3]
4500 set ytop [expr {[yc $row] - $yscreen}]
4501 if {$ytop < 0} {
4502 set ytop 0
4504 set yf [expr {$ytop * 1.0 / $ymax}]
4506 allcanvs yview moveto $yf
4507 drawvisible
4508 if {$row ne {}} {
4509 selectline $row 0
4510 } elseif {!$viewcomplete($n)} {
4511 reset_pending_select $selid
4512 } else {
4513 reset_pending_select {}
4515 if {[commitinview $pending_select $curview]} {
4516 selectline [rowofcommit $pending_select] 1
4517 } else {
4518 set row [first_real_row]
4519 if {$row < $numcommits} {
4520 selectline $row 0
4524 if {!$viewcomplete($n)} {
4525 if {$numcommits == 0} {
4526 show_status [mc "Reading commits..."]
4528 } elseif {$numcommits == 0} {
4529 show_status [mc "No commits selected"]
4531 set_window_title
4534 # Stuff relating to the highlighting facility
4536 proc ishighlighted {id} {
4537 global vhighlights fhighlights nhighlights rhighlights
4539 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4540 return $nhighlights($id)
4542 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4543 return $vhighlights($id)
4545 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4546 return $fhighlights($id)
4548 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4549 return $rhighlights($id)
4551 return 0
4554 proc bolden {id font} {
4555 global canv linehtag currentid boldids need_redisplay markedid
4557 # need_redisplay = 1 means the display is stale and about to be redrawn
4558 if {$need_redisplay} return
4559 lappend boldids $id
4560 $canv itemconf $linehtag($id) -font $font
4561 if {[info exists currentid] && $id eq $currentid} {
4562 $canv delete secsel
4563 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4564 -outline {{}} -tags secsel \
4565 -fill [$canv cget -selectbackground]]
4566 $canv lower $t
4568 if {[info exists markedid] && $id eq $markedid} {
4569 make_idmark $id
4573 proc bolden_name {id font} {
4574 global canv2 linentag currentid boldnameids need_redisplay
4576 if {$need_redisplay} return
4577 lappend boldnameids $id
4578 $canv2 itemconf $linentag($id) -font $font
4579 if {[info exists currentid] && $id eq $currentid} {
4580 $canv2 delete secsel
4581 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4582 -outline {{}} -tags secsel \
4583 -fill [$canv2 cget -selectbackground]]
4584 $canv2 lower $t
4588 proc unbolden {} {
4589 global boldids
4591 set stillbold {}
4592 foreach id $boldids {
4593 if {![ishighlighted $id]} {
4594 bolden $id mainfont
4595 } else {
4596 lappend stillbold $id
4599 set boldids $stillbold
4602 proc addvhighlight {n} {
4603 global hlview viewcomplete curview vhl_done commitidx
4605 if {[info exists hlview]} {
4606 delvhighlight
4608 set hlview $n
4609 if {$n != $curview && ![info exists viewcomplete($n)]} {
4610 start_rev_list $n
4612 set vhl_done $commitidx($hlview)
4613 if {$vhl_done > 0} {
4614 drawvisible
4618 proc delvhighlight {} {
4619 global hlview vhighlights
4621 if {![info exists hlview]} return
4622 unset hlview
4623 unset -nocomplain vhighlights
4624 unbolden
4627 proc vhighlightmore {} {
4628 global hlview vhl_done commitidx vhighlights curview
4630 set max $commitidx($hlview)
4631 set vr [visiblerows]
4632 set r0 [lindex $vr 0]
4633 set r1 [lindex $vr 1]
4634 for {set i $vhl_done} {$i < $max} {incr i} {
4635 set id [commitonrow $i $hlview]
4636 if {[commitinview $id $curview]} {
4637 set row [rowofcommit $id]
4638 if {$r0 <= $row && $row <= $r1} {
4639 if {![highlighted $row]} {
4640 bolden $id mainfontbold
4642 set vhighlights($id) 1
4646 set vhl_done $max
4647 return 0
4650 proc askvhighlight {row id} {
4651 global hlview vhighlights iddrawn
4653 if {[commitinview $id $hlview]} {
4654 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4655 bolden $id mainfontbold
4657 set vhighlights($id) 1
4658 } else {
4659 set vhighlights($id) 0
4663 proc hfiles_change {} {
4664 global highlight_files filehighlight fhighlights fh_serial
4665 global highlight_paths
4667 if {[info exists filehighlight]} {
4668 # delete previous highlights
4669 catch {close $filehighlight}
4670 unset filehighlight
4671 unset -nocomplain fhighlights
4672 unbolden
4673 unhighlight_filelist
4675 set highlight_paths {}
4676 after cancel do_file_hl $fh_serial
4677 incr fh_serial
4678 if {$highlight_files ne {}} {
4679 after 300 do_file_hl $fh_serial
4683 proc gdttype_change {name ix op} {
4684 global gdttype highlight_files findstring findpattern
4686 stopfinding
4687 if {$findstring ne {}} {
4688 if {$gdttype eq [mc "containing:"]} {
4689 if {$highlight_files ne {}} {
4690 set highlight_files {}
4691 hfiles_change
4693 findcom_change
4694 } else {
4695 if {$findpattern ne {}} {
4696 set findpattern {}
4697 findcom_change
4699 set highlight_files $findstring
4700 hfiles_change
4702 drawvisible
4704 # enable/disable findtype/findloc menus too
4707 proc find_change {name ix op} {
4708 global gdttype findstring highlight_files
4710 stopfinding
4711 if {$gdttype eq [mc "containing:"]} {
4712 findcom_change
4713 } else {
4714 if {$highlight_files ne $findstring} {
4715 set highlight_files $findstring
4716 hfiles_change
4719 drawvisible
4722 proc findcom_change args {
4723 global nhighlights boldnameids
4724 global findpattern findtype findstring gdttype
4726 stopfinding
4727 # delete previous highlights, if any
4728 foreach id $boldnameids {
4729 bolden_name $id mainfont
4731 set boldnameids {}
4732 unset -nocomplain nhighlights
4733 unbolden
4734 unmarkmatches
4735 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4736 set findpattern {}
4737 } elseif {$findtype eq [mc "Regexp"]} {
4738 set findpattern $findstring
4739 } else {
4740 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4741 $findstring]
4742 set findpattern "*$e*"
4746 proc makepatterns {l} {
4747 set ret {}
4748 foreach e $l {
4749 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4750 if {[string index $ee end] eq "/"} {
4751 lappend ret "$ee*"
4752 } else {
4753 lappend ret $ee
4754 lappend ret "$ee/*"
4757 return $ret
4760 proc do_file_hl {serial} {
4761 global highlight_files filehighlight highlight_paths gdttype fhl_list
4762 global cdup findtype
4764 if {$gdttype eq [mc "touching paths:"]} {
4765 # If "exact" match then convert backslashes to forward slashes.
4766 # Most useful to support Windows-flavoured file paths.
4767 if {$findtype eq [mc "Exact"]} {
4768 set highlight_files [string map {"\\" "/"} $highlight_files]
4770 if {[catch {set paths [shellsplit $highlight_files]}]} return
4771 set highlight_paths [makepatterns $paths]
4772 highlight_filelist
4773 set relative_paths {}
4774 foreach path $paths {
4775 lappend relative_paths [file join $cdup $path]
4777 set gdtargs [concat -- $relative_paths]
4778 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4779 set gdtargs [list "-S$highlight_files"]
4780 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4781 set gdtargs [list "-G$highlight_files"]
4782 } else {
4783 # must be "containing:", i.e. we're searching commit info
4784 return
4786 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4787 set filehighlight [open $cmd r+]
4788 fconfigure $filehighlight -blocking 0
4789 filerun $filehighlight readfhighlight
4790 set fhl_list {}
4791 drawvisible
4792 flushhighlights
4795 proc flushhighlights {} {
4796 global filehighlight fhl_list
4798 if {[info exists filehighlight]} {
4799 lappend fhl_list {}
4800 puts $filehighlight ""
4801 flush $filehighlight
4805 proc askfilehighlight {row id} {
4806 global filehighlight fhighlights fhl_list
4808 lappend fhl_list $id
4809 set fhighlights($id) -1
4810 puts $filehighlight $id
4813 proc readfhighlight {} {
4814 global filehighlight fhighlights curview iddrawn
4815 global fhl_list find_dirn
4817 if {![info exists filehighlight]} {
4818 return 0
4820 set nr 0
4821 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4822 set line [string trim $line]
4823 set i [lsearch -exact $fhl_list $line]
4824 if {$i < 0} continue
4825 for {set j 0} {$j < $i} {incr j} {
4826 set id [lindex $fhl_list $j]
4827 set fhighlights($id) 0
4829 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4830 if {$line eq {}} continue
4831 if {![commitinview $line $curview]} continue
4832 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4833 bolden $line mainfontbold
4835 set fhighlights($line) 1
4837 if {[eof $filehighlight]} {
4838 # strange...
4839 puts "oops, git diff-tree died"
4840 catch {close $filehighlight}
4841 unset filehighlight
4842 return 0
4844 if {[info exists find_dirn]} {
4845 run findmore
4847 return 1
4850 proc doesmatch {f} {
4851 global findtype findpattern
4853 if {$findtype eq [mc "Regexp"]} {
4854 return [regexp $findpattern $f]
4855 } elseif {$findtype eq [mc "IgnCase"]} {
4856 return [string match -nocase $findpattern $f]
4857 } else {
4858 return [string match $findpattern $f]
4862 proc askfindhighlight {row id} {
4863 global nhighlights commitinfo iddrawn
4864 global findloc
4865 global markingmatches
4867 if {![info exists commitinfo($id)]} {
4868 getcommit $id
4870 set info $commitinfo($id)
4871 set isbold 0
4872 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4873 foreach f $info ty $fldtypes {
4874 if {$ty eq ""} continue
4875 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4876 [doesmatch $f]} {
4877 if {$ty eq [mc "Author"]} {
4878 set isbold 2
4879 break
4881 set isbold 1
4884 if {$isbold && [info exists iddrawn($id)]} {
4885 if {![ishighlighted $id]} {
4886 bolden $id mainfontbold
4887 if {$isbold > 1} {
4888 bolden_name $id mainfontbold
4891 if {$markingmatches} {
4892 markrowmatches $row $id
4895 set nhighlights($id) $isbold
4898 proc markrowmatches {row id} {
4899 global canv canv2 linehtag linentag commitinfo findloc
4901 set headline [lindex $commitinfo($id) 0]
4902 set author [lindex $commitinfo($id) 1]
4903 $canv delete match$row
4904 $canv2 delete match$row
4905 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4906 set m [findmatches $headline]
4907 if {$m ne {}} {
4908 markmatches $canv $row $headline $linehtag($id) $m \
4909 [$canv itemcget $linehtag($id) -font] $row
4912 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4913 set m [findmatches $author]
4914 if {$m ne {}} {
4915 markmatches $canv2 $row $author $linentag($id) $m \
4916 [$canv2 itemcget $linentag($id) -font] $row
4921 proc vrel_change {name ix op} {
4922 global highlight_related
4924 rhighlight_none
4925 if {$highlight_related ne [mc "None"]} {
4926 run drawvisible
4930 # prepare for testing whether commits are descendents or ancestors of a
4931 proc rhighlight_sel {a} {
4932 global descendent desc_todo ancestor anc_todo
4933 global highlight_related
4935 unset -nocomplain descendent
4936 set desc_todo [list $a]
4937 unset -nocomplain ancestor
4938 set anc_todo [list $a]
4939 if {$highlight_related ne [mc "None"]} {
4940 rhighlight_none
4941 run drawvisible
4945 proc rhighlight_none {} {
4946 global rhighlights
4948 unset -nocomplain rhighlights
4949 unbolden
4952 proc is_descendent {a} {
4953 global curview children descendent desc_todo
4955 set v $curview
4956 set la [rowofcommit $a]
4957 set todo $desc_todo
4958 set leftover {}
4959 set done 0
4960 for {set i 0} {$i < [llength $todo]} {incr i} {
4961 set do [lindex $todo $i]
4962 if {[rowofcommit $do] < $la} {
4963 lappend leftover $do
4964 continue
4966 foreach nk $children($v,$do) {
4967 if {![info exists descendent($nk)]} {
4968 set descendent($nk) 1
4969 lappend todo $nk
4970 if {$nk eq $a} {
4971 set done 1
4975 if {$done} {
4976 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4977 return
4980 set descendent($a) 0
4981 set desc_todo $leftover
4984 proc is_ancestor {a} {
4985 global curview parents ancestor anc_todo
4987 set v $curview
4988 set la [rowofcommit $a]
4989 set todo $anc_todo
4990 set leftover {}
4991 set done 0
4992 for {set i 0} {$i < [llength $todo]} {incr i} {
4993 set do [lindex $todo $i]
4994 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4995 lappend leftover $do
4996 continue
4998 foreach np $parents($v,$do) {
4999 if {![info exists ancestor($np)]} {
5000 set ancestor($np) 1
5001 lappend todo $np
5002 if {$np eq $a} {
5003 set done 1
5007 if {$done} {
5008 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5009 return
5012 set ancestor($a) 0
5013 set anc_todo $leftover
5016 proc askrelhighlight {row id} {
5017 global descendent highlight_related iddrawn rhighlights
5018 global selectedline ancestor
5020 if {$selectedline eq {}} return
5021 set isbold 0
5022 if {$highlight_related eq [mc "Descendant"] ||
5023 $highlight_related eq [mc "Not descendant"]} {
5024 if {![info exists descendent($id)]} {
5025 is_descendent $id
5027 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5028 set isbold 1
5030 } elseif {$highlight_related eq [mc "Ancestor"] ||
5031 $highlight_related eq [mc "Not ancestor"]} {
5032 if {![info exists ancestor($id)]} {
5033 is_ancestor $id
5035 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5036 set isbold 1
5039 if {[info exists iddrawn($id)]} {
5040 if {$isbold && ![ishighlighted $id]} {
5041 bolden $id mainfontbold
5044 set rhighlights($id) $isbold
5047 # Graph layout functions
5049 proc shortids {ids} {
5050 set res {}
5051 foreach id $ids {
5052 if {[llength $id] > 1} {
5053 lappend res [shortids $id]
5054 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5055 lappend res [string range $id 0 7]
5056 } else {
5057 lappend res $id
5060 return $res
5063 proc ntimes {n o} {
5064 set ret {}
5065 set o [list $o]
5066 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5067 if {($n & $mask) != 0} {
5068 set ret [concat $ret $o]
5070 set o [concat $o $o]
5072 return $ret
5075 proc ordertoken {id} {
5076 global ordertok curview varcid varcstart varctok curview parents children
5077 global nullid nullid2
5079 if {[info exists ordertok($id)]} {
5080 return $ordertok($id)
5082 set origid $id
5083 set todo {}
5084 while {1} {
5085 if {[info exists varcid($curview,$id)]} {
5086 set a $varcid($curview,$id)
5087 set p [lindex $varcstart($curview) $a]
5088 } else {
5089 set p [lindex $children($curview,$id) 0]
5091 if {[info exists ordertok($p)]} {
5092 set tok $ordertok($p)
5093 break
5095 set id [first_real_child $curview,$p]
5096 if {$id eq {}} {
5097 # it's a root
5098 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5099 break
5101 if {[llength $parents($curview,$id)] == 1} {
5102 lappend todo [list $p {}]
5103 } else {
5104 set j [lsearch -exact $parents($curview,$id) $p]
5105 if {$j < 0} {
5106 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5108 lappend todo [list $p [strrep $j]]
5111 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5112 set p [lindex $todo $i 0]
5113 append tok [lindex $todo $i 1]
5114 set ordertok($p) $tok
5116 set ordertok($origid) $tok
5117 return $tok
5120 # Work out where id should go in idlist so that order-token
5121 # values increase from left to right
5122 proc idcol {idlist id {i 0}} {
5123 set t [ordertoken $id]
5124 if {$i < 0} {
5125 set i 0
5127 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5128 if {$i > [llength $idlist]} {
5129 set i [llength $idlist]
5131 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5132 incr i
5133 } else {
5134 if {$t > [ordertoken [lindex $idlist $i]]} {
5135 while {[incr i] < [llength $idlist] &&
5136 $t >= [ordertoken [lindex $idlist $i]]} {}
5139 return $i
5142 proc initlayout {} {
5143 global rowidlist rowisopt rowfinal displayorder parentlist
5144 global numcommits canvxmax canv
5145 global nextcolor
5146 global colormap rowtextx
5148 set numcommits 0
5149 set displayorder {}
5150 set parentlist {}
5151 set nextcolor 0
5152 set rowidlist {}
5153 set rowisopt {}
5154 set rowfinal {}
5155 set canvxmax [$canv cget -width]
5156 unset -nocomplain colormap
5157 unset -nocomplain rowtextx
5158 setcanvscroll
5161 proc setcanvscroll {} {
5162 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5163 global lastscrollset lastscrollrows
5165 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5166 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5167 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5168 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5169 set lastscrollset [clock clicks -milliseconds]
5170 set lastscrollrows $numcommits
5173 proc visiblerows {} {
5174 global canv numcommits linespc
5176 set ymax [lindex [$canv cget -scrollregion] 3]
5177 if {$ymax eq {} || $ymax == 0} return
5178 set f [$canv yview]
5179 set y0 [expr {int([lindex $f 0] * $ymax)}]
5180 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5181 if {$r0 < 0} {
5182 set r0 0
5184 set y1 [expr {int([lindex $f 1] * $ymax)}]
5185 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5186 if {$r1 >= $numcommits} {
5187 set r1 [expr {$numcommits - 1}]
5189 return [list $r0 $r1]
5192 proc layoutmore {} {
5193 global commitidx viewcomplete curview
5194 global numcommits pending_select curview
5195 global lastscrollset lastscrollrows
5197 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5198 [clock clicks -milliseconds] - $lastscrollset > 500} {
5199 setcanvscroll
5201 if {[info exists pending_select] &&
5202 [commitinview $pending_select $curview]} {
5203 update
5204 selectline [rowofcommit $pending_select] 1
5206 drawvisible
5209 # With path limiting, we mightn't get the actual HEAD commit,
5210 # so ask git rev-list what is the first ancestor of HEAD that
5211 # touches a file in the path limit.
5212 proc get_viewmainhead {view} {
5213 global viewmainheadid vfilelimit viewinstances mainheadid
5215 catch {
5216 set rfd [open [concat | git rev-list -1 $mainheadid \
5217 -- $vfilelimit($view)] r]
5218 set j [reg_instance $rfd]
5219 lappend viewinstances($view) $j
5220 fconfigure $rfd -blocking 0
5221 filerun $rfd [list getviewhead $rfd $j $view]
5222 set viewmainheadid($curview) {}
5226 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5227 proc getviewhead {fd inst view} {
5228 global viewmainheadid commfd curview viewinstances showlocalchanges
5230 set id {}
5231 if {[gets $fd line] < 0} {
5232 if {![eof $fd]} {
5233 return 1
5235 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5236 set id $line
5238 set viewmainheadid($view) $id
5239 close $fd
5240 unset commfd($inst)
5241 set i [lsearch -exact $viewinstances($view) $inst]
5242 if {$i >= 0} {
5243 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5245 if {$showlocalchanges && $id ne {} && $view == $curview} {
5246 doshowlocalchanges
5248 return 0
5251 proc doshowlocalchanges {} {
5252 global curview viewmainheadid
5254 if {$viewmainheadid($curview) eq {}} return
5255 if {[commitinview $viewmainheadid($curview) $curview]} {
5256 dodiffindex
5257 } else {
5258 interestedin $viewmainheadid($curview) dodiffindex
5262 proc dohidelocalchanges {} {
5263 global nullid nullid2 lserial curview
5265 if {[commitinview $nullid $curview]} {
5266 removefakerow $nullid
5268 if {[commitinview $nullid2 $curview]} {
5269 removefakerow $nullid2
5271 incr lserial
5274 # spawn off a process to do git diff-index --cached HEAD
5275 proc dodiffindex {} {
5276 global lserial showlocalchanges vfilelimit curview
5277 global hasworktree git_version
5279 if {!$showlocalchanges || !$hasworktree} return
5280 incr lserial
5281 if {[package vcompare $git_version "1.7.2"] >= 0} {
5282 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5283 } else {
5284 set cmd "|git diff-index --cached HEAD"
5286 if {$vfilelimit($curview) ne {}} {
5287 set cmd [concat $cmd -- $vfilelimit($curview)]
5289 set fd [open $cmd r]
5290 fconfigure $fd -blocking 0
5291 set i [reg_instance $fd]
5292 filerun $fd [list readdiffindex $fd $lserial $i]
5295 proc readdiffindex {fd serial inst} {
5296 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5297 global vfilelimit
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 # now see if there are any local changes not checked in to the index
5314 set cmd "|git diff-files"
5315 if {$vfilelimit($curview) ne {}} {
5316 set cmd [concat $cmd -- $vfilelimit($curview)]
5318 set fd [open $cmd r]
5319 fconfigure $fd -blocking 0
5320 set i [reg_instance $fd]
5321 filerun $fd [list readdifffiles $fd $serial $i]
5323 if {$isdiff && ![commitinview $nullid2 $curview]} {
5324 # add the line for the changes in the index to the graph
5325 set hl [mc "Local changes checked in to index but not committed"]
5326 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5327 set commitdata($nullid2) "\n $hl\n"
5328 if {[commitinview $nullid $curview]} {
5329 removefakerow $nullid
5331 insertfakerow $nullid2 $viewmainheadid($curview)
5332 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5333 if {[commitinview $nullid $curview]} {
5334 removefakerow $nullid
5336 removefakerow $nullid2
5338 return 0
5341 proc readdifffiles {fd serial inst} {
5342 global viewmainheadid nullid nullid2 curview
5343 global commitinfo commitdata lserial
5345 set isdiff 1
5346 if {[gets $fd line] < 0} {
5347 if {![eof $fd]} {
5348 return 1
5350 set isdiff 0
5352 # we only need to see one line and we don't really care what it says...
5353 stop_instance $inst
5355 if {$serial != $lserial} {
5356 return 0
5359 if {$isdiff && ![commitinview $nullid $curview]} {
5360 # add the line for the local diff to the graph
5361 set hl [mc "Local uncommitted changes, not checked in to index"]
5362 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5363 set commitdata($nullid) "\n $hl\n"
5364 if {[commitinview $nullid2 $curview]} {
5365 set p $nullid2
5366 } else {
5367 set p $viewmainheadid($curview)
5369 insertfakerow $nullid $p
5370 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5371 removefakerow $nullid
5373 return 0
5376 proc nextuse {id row} {
5377 global curview children
5379 if {[info exists children($curview,$id)]} {
5380 foreach kid $children($curview,$id) {
5381 if {![commitinview $kid $curview]} {
5382 return -1
5384 if {[rowofcommit $kid] > $row} {
5385 return [rowofcommit $kid]
5389 if {[commitinview $id $curview]} {
5390 return [rowofcommit $id]
5392 return -1
5395 proc prevuse {id row} {
5396 global curview children
5398 set ret -1
5399 if {[info exists children($curview,$id)]} {
5400 foreach kid $children($curview,$id) {
5401 if {![commitinview $kid $curview]} break
5402 if {[rowofcommit $kid] < $row} {
5403 set ret [rowofcommit $kid]
5407 return $ret
5410 proc make_idlist {row} {
5411 global displayorder parentlist uparrowlen downarrowlen mingaplen
5412 global commitidx curview children
5414 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5415 if {$r < 0} {
5416 set r 0
5418 set ra [expr {$row - $downarrowlen}]
5419 if {$ra < 0} {
5420 set ra 0
5422 set rb [expr {$row + $uparrowlen}]
5423 if {$rb > $commitidx($curview)} {
5424 set rb $commitidx($curview)
5426 make_disporder $r [expr {$rb + 1}]
5427 set ids {}
5428 for {} {$r < $ra} {incr r} {
5429 set nextid [lindex $displayorder [expr {$r + 1}]]
5430 foreach p [lindex $parentlist $r] {
5431 if {$p eq $nextid} continue
5432 set rn [nextuse $p $r]
5433 if {$rn >= $row &&
5434 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5435 lappend ids [list [ordertoken $p] $p]
5439 for {} {$r < $row} {incr r} {
5440 set nextid [lindex $displayorder [expr {$r + 1}]]
5441 foreach p [lindex $parentlist $r] {
5442 if {$p eq $nextid} continue
5443 set rn [nextuse $p $r]
5444 if {$rn < 0 || $rn >= $row} {
5445 lappend ids [list [ordertoken $p] $p]
5449 set id [lindex $displayorder $row]
5450 lappend ids [list [ordertoken $id] $id]
5451 while {$r < $rb} {
5452 foreach p [lindex $parentlist $r] {
5453 set firstkid [lindex $children($curview,$p) 0]
5454 if {[rowofcommit $firstkid] < $row} {
5455 lappend ids [list [ordertoken $p] $p]
5458 incr r
5459 set id [lindex $displayorder $r]
5460 if {$id ne {}} {
5461 set firstkid [lindex $children($curview,$id) 0]
5462 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5463 lappend ids [list [ordertoken $id] $id]
5467 set idlist {}
5468 foreach idx [lsort -unique $ids] {
5469 lappend idlist [lindex $idx 1]
5471 return $idlist
5474 proc rowsequal {a b} {
5475 while {[set i [lsearch -exact $a {}]] >= 0} {
5476 set a [lreplace $a $i $i]
5478 while {[set i [lsearch -exact $b {}]] >= 0} {
5479 set b [lreplace $b $i $i]
5481 return [expr {$a eq $b}]
5484 proc makeupline {id row rend col} {
5485 global rowidlist uparrowlen downarrowlen mingaplen
5487 for {set r $rend} {1} {set r $rstart} {
5488 set rstart [prevuse $id $r]
5489 if {$rstart < 0} return
5490 if {$rstart < $row} break
5492 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5493 set rstart [expr {$rend - $uparrowlen - 1}]
5495 for {set r $rstart} {[incr r] <= $row} {} {
5496 set idlist [lindex $rowidlist $r]
5497 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5498 set col [idcol $idlist $id $col]
5499 lset rowidlist $r [linsert $idlist $col $id]
5500 changedrow $r
5505 proc layoutrows {row endrow} {
5506 global rowidlist rowisopt rowfinal displayorder
5507 global uparrowlen downarrowlen maxwidth mingaplen
5508 global children parentlist
5509 global commitidx viewcomplete curview
5511 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5512 set idlist {}
5513 if {$row > 0} {
5514 set rm1 [expr {$row - 1}]
5515 foreach id [lindex $rowidlist $rm1] {
5516 if {$id ne {}} {
5517 lappend idlist $id
5520 set final [lindex $rowfinal $rm1]
5522 for {} {$row < $endrow} {incr row} {
5523 set rm1 [expr {$row - 1}]
5524 if {$rm1 < 0 || $idlist eq {}} {
5525 set idlist [make_idlist $row]
5526 set final 1
5527 } else {
5528 set id [lindex $displayorder $rm1]
5529 set col [lsearch -exact $idlist $id]
5530 set idlist [lreplace $idlist $col $col]
5531 foreach p [lindex $parentlist $rm1] {
5532 if {[lsearch -exact $idlist $p] < 0} {
5533 set col [idcol $idlist $p $col]
5534 set idlist [linsert $idlist $col $p]
5535 # if not the first child, we have to insert a line going up
5536 if {$id ne [lindex $children($curview,$p) 0]} {
5537 makeupline $p $rm1 $row $col
5541 set id [lindex $displayorder $row]
5542 if {$row > $downarrowlen} {
5543 set termrow [expr {$row - $downarrowlen - 1}]
5544 foreach p [lindex $parentlist $termrow] {
5545 set i [lsearch -exact $idlist $p]
5546 if {$i < 0} continue
5547 set nr [nextuse $p $termrow]
5548 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5549 set idlist [lreplace $idlist $i $i]
5553 set col [lsearch -exact $idlist $id]
5554 if {$col < 0} {
5555 set col [idcol $idlist $id]
5556 set idlist [linsert $idlist $col $id]
5557 if {$children($curview,$id) ne {}} {
5558 makeupline $id $rm1 $row $col
5561 set r [expr {$row + $uparrowlen - 1}]
5562 if {$r < $commitidx($curview)} {
5563 set x $col
5564 foreach p [lindex $parentlist $r] {
5565 if {[lsearch -exact $idlist $p] >= 0} continue
5566 set fk [lindex $children($curview,$p) 0]
5567 if {[rowofcommit $fk] < $row} {
5568 set x [idcol $idlist $p $x]
5569 set idlist [linsert $idlist $x $p]
5572 if {[incr r] < $commitidx($curview)} {
5573 set p [lindex $displayorder $r]
5574 if {[lsearch -exact $idlist $p] < 0} {
5575 set fk [lindex $children($curview,$p) 0]
5576 if {$fk ne {} && [rowofcommit $fk] < $row} {
5577 set x [idcol $idlist $p $x]
5578 set idlist [linsert $idlist $x $p]
5584 if {$final && !$viewcomplete($curview) &&
5585 $row + $uparrowlen + $mingaplen + $downarrowlen
5586 >= $commitidx($curview)} {
5587 set final 0
5589 set l [llength $rowidlist]
5590 if {$row == $l} {
5591 lappend rowidlist $idlist
5592 lappend rowisopt 0
5593 lappend rowfinal $final
5594 } elseif {$row < $l} {
5595 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5596 lset rowidlist $row $idlist
5597 changedrow $row
5599 lset rowfinal $row $final
5600 } else {
5601 set pad [ntimes [expr {$row - $l}] {}]
5602 set rowidlist [concat $rowidlist $pad]
5603 lappend rowidlist $idlist
5604 set rowfinal [concat $rowfinal $pad]
5605 lappend rowfinal $final
5606 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5609 return $row
5612 proc changedrow {row} {
5613 global displayorder iddrawn rowisopt need_redisplay
5615 set l [llength $rowisopt]
5616 if {$row < $l} {
5617 lset rowisopt $row 0
5618 if {$row + 1 < $l} {
5619 lset rowisopt [expr {$row + 1}] 0
5620 if {$row + 2 < $l} {
5621 lset rowisopt [expr {$row + 2}] 0
5625 set id [lindex $displayorder $row]
5626 if {[info exists iddrawn($id)]} {
5627 set need_redisplay 1
5631 proc insert_pad {row col npad} {
5632 global rowidlist
5634 set pad [ntimes $npad {}]
5635 set idlist [lindex $rowidlist $row]
5636 set bef [lrange $idlist 0 [expr {$col - 1}]]
5637 set aft [lrange $idlist $col end]
5638 set i [lsearch -exact $aft {}]
5639 if {$i > 0} {
5640 set aft [lreplace $aft $i $i]
5642 lset rowidlist $row [concat $bef $pad $aft]
5643 changedrow $row
5646 proc optimize_rows {row col endrow} {
5647 global rowidlist rowisopt displayorder curview children
5649 if {$row < 1} {
5650 set row 1
5652 for {} {$row < $endrow} {incr row; set col 0} {
5653 if {[lindex $rowisopt $row]} continue
5654 set haspad 0
5655 set y0 [expr {$row - 1}]
5656 set ym [expr {$row - 2}]
5657 set idlist [lindex $rowidlist $row]
5658 set previdlist [lindex $rowidlist $y0]
5659 if {$idlist eq {} || $previdlist eq {}} continue
5660 if {$ym >= 0} {
5661 set pprevidlist [lindex $rowidlist $ym]
5662 if {$pprevidlist eq {}} continue
5663 } else {
5664 set pprevidlist {}
5666 set x0 -1
5667 set xm -1
5668 for {} {$col < [llength $idlist]} {incr col} {
5669 set id [lindex $idlist $col]
5670 if {[lindex $previdlist $col] eq $id} continue
5671 if {$id eq {}} {
5672 set haspad 1
5673 continue
5675 set x0 [lsearch -exact $previdlist $id]
5676 if {$x0 < 0} continue
5677 set z [expr {$x0 - $col}]
5678 set isarrow 0
5679 set z0 {}
5680 if {$ym >= 0} {
5681 set xm [lsearch -exact $pprevidlist $id]
5682 if {$xm >= 0} {
5683 set z0 [expr {$xm - $x0}]
5686 if {$z0 eq {}} {
5687 # if row y0 is the first child of $id then it's not an arrow
5688 if {[lindex $children($curview,$id) 0] ne
5689 [lindex $displayorder $y0]} {
5690 set isarrow 1
5693 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5694 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5695 set isarrow 1
5697 # Looking at lines from this row to the previous row,
5698 # make them go straight up if they end in an arrow on
5699 # the previous row; otherwise make them go straight up
5700 # or at 45 degrees.
5701 if {$z < -1 || ($z < 0 && $isarrow)} {
5702 # Line currently goes left too much;
5703 # insert pads in the previous row, then optimize it
5704 set npad [expr {-1 - $z + $isarrow}]
5705 insert_pad $y0 $x0 $npad
5706 if {$y0 > 0} {
5707 optimize_rows $y0 $x0 $row
5709 set previdlist [lindex $rowidlist $y0]
5710 set x0 [lsearch -exact $previdlist $id]
5711 set z [expr {$x0 - $col}]
5712 if {$z0 ne {}} {
5713 set pprevidlist [lindex $rowidlist $ym]
5714 set xm [lsearch -exact $pprevidlist $id]
5715 set z0 [expr {$xm - $x0}]
5717 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5718 # Line currently goes right too much;
5719 # insert pads in this line
5720 set npad [expr {$z - 1 + $isarrow}]
5721 insert_pad $row $col $npad
5722 set idlist [lindex $rowidlist $row]
5723 incr col $npad
5724 set z [expr {$x0 - $col}]
5725 set haspad 1
5727 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5728 # this line links to its first child on row $row-2
5729 set id [lindex $displayorder $ym]
5730 set xc [lsearch -exact $pprevidlist $id]
5731 if {$xc >= 0} {
5732 set z0 [expr {$xc - $x0}]
5735 # avoid lines jigging left then immediately right
5736 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5737 insert_pad $y0 $x0 1
5738 incr x0
5739 optimize_rows $y0 $x0 $row
5740 set previdlist [lindex $rowidlist $y0]
5743 if {!$haspad} {
5744 # Find the first column that doesn't have a line going right
5745 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5746 set id [lindex $idlist $col]
5747 if {$id eq {}} break
5748 set x0 [lsearch -exact $previdlist $id]
5749 if {$x0 < 0} {
5750 # check if this is the link to the first child
5751 set kid [lindex $displayorder $y0]
5752 if {[lindex $children($curview,$id) 0] eq $kid} {
5753 # it is, work out offset to child
5754 set x0 [lsearch -exact $previdlist $kid]
5757 if {$x0 <= $col} break
5759 # Insert a pad at that column as long as it has a line and
5760 # isn't the last column
5761 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5762 set idlist [linsert $idlist $col {}]
5763 lset rowidlist $row $idlist
5764 changedrow $row
5770 proc xc {row col} {
5771 global canvx0 linespc
5772 return [expr {$canvx0 + $col * $linespc}]
5775 proc yc {row} {
5776 global canvy0 linespc
5777 return [expr {$canvy0 + $row * $linespc}]
5780 proc linewidth {id} {
5781 global thickerline lthickness
5783 set wid $lthickness
5784 if {[info exists thickerline] && $id eq $thickerline} {
5785 set wid [expr {2 * $lthickness}]
5787 return $wid
5790 proc rowranges {id} {
5791 global curview children uparrowlen downarrowlen
5792 global rowidlist
5794 set kids $children($curview,$id)
5795 if {$kids eq {}} {
5796 return {}
5798 set ret {}
5799 lappend kids $id
5800 foreach child $kids {
5801 if {![commitinview $child $curview]} break
5802 set row [rowofcommit $child]
5803 if {![info exists prev]} {
5804 lappend ret [expr {$row + 1}]
5805 } else {
5806 if {$row <= $prevrow} {
5807 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5809 # see if the line extends the whole way from prevrow to row
5810 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5811 [lsearch -exact [lindex $rowidlist \
5812 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5813 # it doesn't, see where it ends
5814 set r [expr {$prevrow + $downarrowlen}]
5815 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5816 while {[incr r -1] > $prevrow &&
5817 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5818 } else {
5819 while {[incr r] <= $row &&
5820 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5821 incr r -1
5823 lappend ret $r
5824 # see where it starts up again
5825 set r [expr {$row - $uparrowlen}]
5826 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5827 while {[incr r] < $row &&
5828 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5829 } else {
5830 while {[incr r -1] >= $prevrow &&
5831 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5832 incr r
5834 lappend ret $r
5837 if {$child eq $id} {
5838 lappend ret $row
5840 set prev $child
5841 set prevrow $row
5843 return $ret
5846 proc drawlineseg {id row endrow arrowlow} {
5847 global rowidlist displayorder iddrawn linesegs
5848 global canv colormap linespc curview maxlinelen parentlist
5850 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5851 set le [expr {$row + 1}]
5852 set arrowhigh 1
5853 while {1} {
5854 set c [lsearch -exact [lindex $rowidlist $le] $id]
5855 if {$c < 0} {
5856 incr le -1
5857 break
5859 lappend cols $c
5860 set x [lindex $displayorder $le]
5861 if {$x eq $id} {
5862 set arrowhigh 0
5863 break
5865 if {[info exists iddrawn($x)] || $le == $endrow} {
5866 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5867 if {$c >= 0} {
5868 lappend cols $c
5869 set arrowhigh 0
5871 break
5873 incr le
5875 if {$le <= $row} {
5876 return $row
5879 set lines {}
5880 set i 0
5881 set joinhigh 0
5882 if {[info exists linesegs($id)]} {
5883 set lines $linesegs($id)
5884 foreach li $lines {
5885 set r0 [lindex $li 0]
5886 if {$r0 > $row} {
5887 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5888 set joinhigh 1
5890 break
5892 incr i
5895 set joinlow 0
5896 if {$i > 0} {
5897 set li [lindex $lines [expr {$i-1}]]
5898 set r1 [lindex $li 1]
5899 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5900 set joinlow 1
5904 set x [lindex $cols [expr {$le - $row}]]
5905 set xp [lindex $cols [expr {$le - 1 - $row}]]
5906 set dir [expr {$xp - $x}]
5907 if {$joinhigh} {
5908 set ith [lindex $lines $i 2]
5909 set coords [$canv coords $ith]
5910 set ah [$canv itemcget $ith -arrow]
5911 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5912 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5913 if {$x2 ne {} && $x - $x2 == $dir} {
5914 set coords [lrange $coords 0 end-2]
5916 } else {
5917 set coords [list [xc $le $x] [yc $le]]
5919 if {$joinlow} {
5920 set itl [lindex $lines [expr {$i-1}] 2]
5921 set al [$canv itemcget $itl -arrow]
5922 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5923 } elseif {$arrowlow} {
5924 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5925 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5926 set arrowlow 0
5929 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5930 for {set y $le} {[incr y -1] > $row} {} {
5931 set x $xp
5932 set xp [lindex $cols [expr {$y - 1 - $row}]]
5933 set ndir [expr {$xp - $x}]
5934 if {$dir != $ndir || $xp < 0} {
5935 lappend coords [xc $y $x] [yc $y]
5937 set dir $ndir
5939 if {!$joinlow} {
5940 if {$xp < 0} {
5941 # join parent line to first child
5942 set ch [lindex $displayorder $row]
5943 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5944 if {$xc < 0} {
5945 puts "oops: drawlineseg: child $ch not on row $row"
5946 } elseif {$xc != $x} {
5947 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5948 set d [expr {int(0.5 * $linespc)}]
5949 set x1 [xc $row $x]
5950 if {$xc < $x} {
5951 set x2 [expr {$x1 - $d}]
5952 } else {
5953 set x2 [expr {$x1 + $d}]
5955 set y2 [yc $row]
5956 set y1 [expr {$y2 + $d}]
5957 lappend coords $x1 $y1 $x2 $y2
5958 } elseif {$xc < $x - 1} {
5959 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5960 } elseif {$xc > $x + 1} {
5961 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5963 set x $xc
5965 lappend coords [xc $row $x] [yc $row]
5966 } else {
5967 set xn [xc $row $xp]
5968 set yn [yc $row]
5969 lappend coords $xn $yn
5971 if {!$joinhigh} {
5972 assigncolor $id
5973 set t [$canv create line $coords -width [linewidth $id] \
5974 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5975 $canv lower $t
5976 bindline $t $id
5977 set lines [linsert $lines $i [list $row $le $t]]
5978 } else {
5979 $canv coords $ith $coords
5980 if {$arrow ne $ah} {
5981 $canv itemconf $ith -arrow $arrow
5983 lset lines $i 0 $row
5985 } else {
5986 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5987 set ndir [expr {$xo - $xp}]
5988 set clow [$canv coords $itl]
5989 if {$dir == $ndir} {
5990 set clow [lrange $clow 2 end]
5992 set coords [concat $coords $clow]
5993 if {!$joinhigh} {
5994 lset lines [expr {$i-1}] 1 $le
5995 } else {
5996 # coalesce two pieces
5997 $canv delete $ith
5998 set b [lindex $lines [expr {$i-1}] 0]
5999 set e [lindex $lines $i 1]
6000 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6002 $canv coords $itl $coords
6003 if {$arrow ne $al} {
6004 $canv itemconf $itl -arrow $arrow
6008 set linesegs($id) $lines
6009 return $le
6012 proc drawparentlinks {id row} {
6013 global rowidlist canv colormap curview parentlist
6014 global idpos linespc
6016 set rowids [lindex $rowidlist $row]
6017 set col [lsearch -exact $rowids $id]
6018 if {$col < 0} return
6019 set olds [lindex $parentlist $row]
6020 set row2 [expr {$row + 1}]
6021 set x [xc $row $col]
6022 set y [yc $row]
6023 set y2 [yc $row2]
6024 set d [expr {int(0.5 * $linespc)}]
6025 set ymid [expr {$y + $d}]
6026 set ids [lindex $rowidlist $row2]
6027 # rmx = right-most X coord used
6028 set rmx 0
6029 foreach p $olds {
6030 set i [lsearch -exact $ids $p]
6031 if {$i < 0} {
6032 puts "oops, parent $p of $id not in list"
6033 continue
6035 set x2 [xc $row2 $i]
6036 if {$x2 > $rmx} {
6037 set rmx $x2
6039 set j [lsearch -exact $rowids $p]
6040 if {$j < 0} {
6041 # drawlineseg will do this one for us
6042 continue
6044 assigncolor $p
6045 # should handle duplicated parents here...
6046 set coords [list $x $y]
6047 if {$i != $col} {
6048 # if attaching to a vertical segment, draw a smaller
6049 # slant for visual distinctness
6050 if {$i == $j} {
6051 if {$i < $col} {
6052 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6053 } else {
6054 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6056 } elseif {$i < $col && $i < $j} {
6057 # segment slants towards us already
6058 lappend coords [xc $row $j] $y
6059 } else {
6060 if {$i < $col - 1} {
6061 lappend coords [expr {$x2 + $linespc}] $y
6062 } elseif {$i > $col + 1} {
6063 lappend coords [expr {$x2 - $linespc}] $y
6065 lappend coords $x2 $y2
6067 } else {
6068 lappend coords $x2 $y2
6070 set t [$canv create line $coords -width [linewidth $p] \
6071 -fill $colormap($p) -tags lines.$p]
6072 $canv lower $t
6073 bindline $t $p
6075 if {$rmx > [lindex $idpos($id) 1]} {
6076 lset idpos($id) 1 $rmx
6077 redrawtags $id
6081 proc drawlines {id} {
6082 global canv
6084 $canv itemconf lines.$id -width [linewidth $id]
6087 proc drawcmittext {id row col} {
6088 global linespc canv canv2 canv3 fgcolor curview
6089 global cmitlisted commitinfo rowidlist parentlist
6090 global rowtextx idpos idtags idheads idotherrefs
6091 global linehtag linentag linedtag selectedline
6092 global canvxmax boldids boldnameids fgcolor markedid
6093 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6094 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6095 global circleoutlinecolor
6097 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6098 set listed $cmitlisted($curview,$id)
6099 if {$id eq $nullid} {
6100 set ofill $workingfilescirclecolor
6101 } elseif {$id eq $nullid2} {
6102 set ofill $indexcirclecolor
6103 } elseif {$id eq $mainheadid} {
6104 set ofill $mainheadcirclecolor
6105 } else {
6106 set ofill [lindex $circlecolors $listed]
6108 set x [xc $row $col]
6109 set y [yc $row]
6110 set orad [expr {$linespc / 3}]
6111 if {$listed <= 2} {
6112 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6113 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6114 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6115 } elseif {$listed == 3} {
6116 # triangle pointing left for left-side commits
6117 set t [$canv create polygon \
6118 [expr {$x - $orad}] $y \
6119 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6120 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6121 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6122 } else {
6123 # triangle pointing right for right-side commits
6124 set t [$canv create polygon \
6125 [expr {$x + $orad - 1}] $y \
6126 [expr {$x - $orad}] [expr {$y - $orad}] \
6127 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6128 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6130 set circleitem($row) $t
6131 $canv raise $t
6132 $canv bind $t <1> {selcanvline {} %x %y}
6133 set rmx [llength [lindex $rowidlist $row]]
6134 set olds [lindex $parentlist $row]
6135 if {$olds ne {}} {
6136 set nextids [lindex $rowidlist [expr {$row + 1}]]
6137 foreach p $olds {
6138 set i [lsearch -exact $nextids $p]
6139 if {$i > $rmx} {
6140 set rmx $i
6144 set xt [xc $row $rmx]
6145 set rowtextx($row) $xt
6146 set idpos($id) [list $x $xt $y]
6147 if {[info exists idtags($id)] || [info exists idheads($id)]
6148 || [info exists idotherrefs($id)]} {
6149 set xt [drawtags $id $x $xt $y]
6151 if {[lindex $commitinfo($id) 6] > 0} {
6152 set xt [drawnotesign $xt $y]
6154 set headline [lindex $commitinfo($id) 0]
6155 set name [lindex $commitinfo($id) 1]
6156 set date [lindex $commitinfo($id) 2]
6157 set date [formatdate $date]
6158 set font mainfont
6159 set nfont mainfont
6160 set isbold [ishighlighted $id]
6161 if {$isbold > 0} {
6162 lappend boldids $id
6163 set font mainfontbold
6164 if {$isbold > 1} {
6165 lappend boldnameids $id
6166 set nfont mainfontbold
6169 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6170 -text $headline -font $font -tags text]
6171 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6172 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6173 -text $name -font $nfont -tags text]
6174 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6175 -text $date -font mainfont -tags text]
6176 if {$selectedline == $row} {
6177 make_secsel $id
6179 if {[info exists markedid] && $markedid eq $id} {
6180 make_idmark $id
6182 set xr [expr {$xt + [font measure $font $headline]}]
6183 if {$xr > $canvxmax} {
6184 set canvxmax $xr
6185 setcanvscroll
6189 proc drawcmitrow {row} {
6190 global displayorder rowidlist nrows_drawn
6191 global iddrawn markingmatches
6192 global commitinfo numcommits
6193 global filehighlight fhighlights findpattern nhighlights
6194 global hlview vhighlights
6195 global highlight_related rhighlights
6197 if {$row >= $numcommits} return
6199 set id [lindex $displayorder $row]
6200 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6201 askvhighlight $row $id
6203 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6204 askfilehighlight $row $id
6206 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6207 askfindhighlight $row $id
6209 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6210 askrelhighlight $row $id
6212 if {![info exists iddrawn($id)]} {
6213 set col [lsearch -exact [lindex $rowidlist $row] $id]
6214 if {$col < 0} {
6215 puts "oops, row $row id $id not in list"
6216 return
6218 if {![info exists commitinfo($id)]} {
6219 getcommit $id
6221 assigncolor $id
6222 drawcmittext $id $row $col
6223 set iddrawn($id) 1
6224 incr nrows_drawn
6226 if {$markingmatches} {
6227 markrowmatches $row $id
6231 proc drawcommits {row {endrow {}}} {
6232 global numcommits iddrawn displayorder curview need_redisplay
6233 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6235 if {$row < 0} {
6236 set row 0
6238 if {$endrow eq {}} {
6239 set endrow $row
6241 if {$endrow >= $numcommits} {
6242 set endrow [expr {$numcommits - 1}]
6245 set rl1 [expr {$row - $downarrowlen - 3}]
6246 if {$rl1 < 0} {
6247 set rl1 0
6249 set ro1 [expr {$row - 3}]
6250 if {$ro1 < 0} {
6251 set ro1 0
6253 set r2 [expr {$endrow + $uparrowlen + 3}]
6254 if {$r2 > $numcommits} {
6255 set r2 $numcommits
6257 for {set r $rl1} {$r < $r2} {incr r} {
6258 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6259 if {$rl1 < $r} {
6260 layoutrows $rl1 $r
6262 set rl1 [expr {$r + 1}]
6265 if {$rl1 < $r} {
6266 layoutrows $rl1 $r
6268 optimize_rows $ro1 0 $r2
6269 if {$need_redisplay || $nrows_drawn > 2000} {
6270 clear_display
6273 # make the lines join to already-drawn rows either side
6274 set r [expr {$row - 1}]
6275 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6276 set r $row
6278 set er [expr {$endrow + 1}]
6279 if {$er >= $numcommits ||
6280 ![info exists iddrawn([lindex $displayorder $er])]} {
6281 set er $endrow
6283 for {} {$r <= $er} {incr r} {
6284 set id [lindex $displayorder $r]
6285 set wasdrawn [info exists iddrawn($id)]
6286 drawcmitrow $r
6287 if {$r == $er} break
6288 set nextid [lindex $displayorder [expr {$r + 1}]]
6289 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6290 drawparentlinks $id $r
6292 set rowids [lindex $rowidlist $r]
6293 foreach lid $rowids {
6294 if {$lid eq {}} continue
6295 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6296 if {$lid eq $id} {
6297 # see if this is the first child of any of its parents
6298 foreach p [lindex $parentlist $r] {
6299 if {[lsearch -exact $rowids $p] < 0} {
6300 # make this line extend up to the child
6301 set lineend($p) [drawlineseg $p $r $er 0]
6304 } else {
6305 set lineend($lid) [drawlineseg $lid $r $er 1]
6311 proc undolayout {row} {
6312 global uparrowlen mingaplen downarrowlen
6313 global rowidlist rowisopt rowfinal need_redisplay
6315 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6316 if {$r < 0} {
6317 set r 0
6319 if {[llength $rowidlist] > $r} {
6320 incr r -1
6321 set rowidlist [lrange $rowidlist 0 $r]
6322 set rowfinal [lrange $rowfinal 0 $r]
6323 set rowisopt [lrange $rowisopt 0 $r]
6324 set need_redisplay 1
6325 run drawvisible
6329 proc drawvisible {} {
6330 global canv linespc curview vrowmod selectedline targetrow targetid
6331 global need_redisplay cscroll numcommits
6333 set fs [$canv yview]
6334 set ymax [lindex [$canv cget -scrollregion] 3]
6335 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6336 set f0 [lindex $fs 0]
6337 set f1 [lindex $fs 1]
6338 set y0 [expr {int($f0 * $ymax)}]
6339 set y1 [expr {int($f1 * $ymax)}]
6341 if {[info exists targetid]} {
6342 if {[commitinview $targetid $curview]} {
6343 set r [rowofcommit $targetid]
6344 if {$r != $targetrow} {
6345 # Fix up the scrollregion and change the scrolling position
6346 # now that our target row has moved.
6347 set diff [expr {($r - $targetrow) * $linespc}]
6348 set targetrow $r
6349 setcanvscroll
6350 set ymax [lindex [$canv cget -scrollregion] 3]
6351 incr y0 $diff
6352 incr y1 $diff
6353 set f0 [expr {$y0 / $ymax}]
6354 set f1 [expr {$y1 / $ymax}]
6355 allcanvs yview moveto $f0
6356 $cscroll set $f0 $f1
6357 set need_redisplay 1
6359 } else {
6360 unset targetid
6364 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6365 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6366 if {$endrow >= $vrowmod($curview)} {
6367 update_arcrows $curview
6369 if {$selectedline ne {} &&
6370 $row <= $selectedline && $selectedline <= $endrow} {
6371 set targetrow $selectedline
6372 } elseif {[info exists targetid]} {
6373 set targetrow [expr {int(($row + $endrow) / 2)}]
6375 if {[info exists targetrow]} {
6376 if {$targetrow >= $numcommits} {
6377 set targetrow [expr {$numcommits - 1}]
6379 set targetid [commitonrow $targetrow]
6381 drawcommits $row $endrow
6384 proc clear_display {} {
6385 global iddrawn linesegs need_redisplay nrows_drawn
6386 global vhighlights fhighlights nhighlights rhighlights
6387 global linehtag linentag linedtag boldids boldnameids
6389 allcanvs delete all
6390 unset -nocomplain iddrawn
6391 unset -nocomplain linesegs
6392 unset -nocomplain linehtag
6393 unset -nocomplain linentag
6394 unset -nocomplain linedtag
6395 set boldids {}
6396 set boldnameids {}
6397 unset -nocomplain vhighlights
6398 unset -nocomplain fhighlights
6399 unset -nocomplain nhighlights
6400 unset -nocomplain rhighlights
6401 set need_redisplay 0
6402 set nrows_drawn 0
6405 proc findcrossings {id} {
6406 global rowidlist parentlist numcommits displayorder
6408 set cross {}
6409 set ccross {}
6410 foreach {s e} [rowranges $id] {
6411 if {$e >= $numcommits} {
6412 set e [expr {$numcommits - 1}]
6414 if {$e <= $s} continue
6415 for {set row $e} {[incr row -1] >= $s} {} {
6416 set x [lsearch -exact [lindex $rowidlist $row] $id]
6417 if {$x < 0} break
6418 set olds [lindex $parentlist $row]
6419 set kid [lindex $displayorder $row]
6420 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6421 if {$kidx < 0} continue
6422 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6423 foreach p $olds {
6424 set px [lsearch -exact $nextrow $p]
6425 if {$px < 0} continue
6426 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6427 if {[lsearch -exact $ccross $p] >= 0} continue
6428 if {$x == $px + ($kidx < $px? -1: 1)} {
6429 lappend ccross $p
6430 } elseif {[lsearch -exact $cross $p] < 0} {
6431 lappend cross $p
6437 return [concat $ccross {{}} $cross]
6440 proc assigncolor {id} {
6441 global colormap colors nextcolor
6442 global parents children children curview
6444 if {[info exists colormap($id)]} return
6445 set ncolors [llength $colors]
6446 if {[info exists children($curview,$id)]} {
6447 set kids $children($curview,$id)
6448 } else {
6449 set kids {}
6451 if {[llength $kids] == 1} {
6452 set child [lindex $kids 0]
6453 if {[info exists colormap($child)]
6454 && [llength $parents($curview,$child)] == 1} {
6455 set colormap($id) $colormap($child)
6456 return
6459 set badcolors {}
6460 set origbad {}
6461 foreach x [findcrossings $id] {
6462 if {$x eq {}} {
6463 # delimiter between corner crossings and other crossings
6464 if {[llength $badcolors] >= $ncolors - 1} break
6465 set origbad $badcolors
6467 if {[info exists colormap($x)]
6468 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6469 lappend badcolors $colormap($x)
6472 if {[llength $badcolors] >= $ncolors} {
6473 set badcolors $origbad
6475 set origbad $badcolors
6476 if {[llength $badcolors] < $ncolors - 1} {
6477 foreach child $kids {
6478 if {[info exists colormap($child)]
6479 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6480 lappend badcolors $colormap($child)
6482 foreach p $parents($curview,$child) {
6483 if {[info exists colormap($p)]
6484 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6485 lappend badcolors $colormap($p)
6489 if {[llength $badcolors] >= $ncolors} {
6490 set badcolors $origbad
6493 for {set i 0} {$i <= $ncolors} {incr i} {
6494 set c [lindex $colors $nextcolor]
6495 if {[incr nextcolor] >= $ncolors} {
6496 set nextcolor 0
6498 if {[lsearch -exact $badcolors $c]} break
6500 set colormap($id) $c
6503 proc bindline {t id} {
6504 global canv
6506 $canv bind $t <Enter> "lineenter %x %y $id"
6507 $canv bind $t <Motion> "linemotion %x %y $id"
6508 $canv bind $t <Leave> "lineleave $id"
6509 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6512 proc graph_pane_width {} {
6513 global use_ttk
6515 if {$use_ttk} {
6516 set g [.tf.histframe.pwclist sashpos 0]
6517 } else {
6518 set g [.tf.histframe.pwclist sash coord 0]
6520 return [lindex $g 0]
6523 proc totalwidth {l font extra} {
6524 set tot 0
6525 foreach str $l {
6526 set tot [expr {$tot + [font measure $font $str] + $extra}]
6528 return $tot
6531 proc drawtags {id x xt y1} {
6532 global idtags idheads idotherrefs mainhead
6533 global linespc lthickness
6534 global canv rowtextx curview fgcolor bgcolor ctxbut
6535 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6536 global tagbgcolor tagfgcolor tagoutlinecolor
6537 global reflinecolor
6539 set marks {}
6540 set ntags 0
6541 set nheads 0
6542 set singletag 0
6543 set maxtags 3
6544 set maxtagpct 25
6545 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6546 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6547 set extra [expr {$delta + $lthickness + $linespc}]
6549 if {[info exists idtags($id)]} {
6550 set marks $idtags($id)
6551 set ntags [llength $marks]
6552 if {$ntags > $maxtags ||
6553 [totalwidth $marks mainfont $extra] > $maxwidth} {
6554 # show just a single "n tags..." tag
6555 set singletag 1
6556 if {$ntags == 1} {
6557 set marks [list "tag..."]
6558 } else {
6559 set marks [list [format "%d tags..." $ntags]]
6561 set ntags 1
6564 if {[info exists idheads($id)]} {
6565 set marks [concat $marks $idheads($id)]
6566 set nheads [llength $idheads($id)]
6568 if {[info exists idotherrefs($id)]} {
6569 set marks [concat $marks $idotherrefs($id)]
6571 if {$marks eq {}} {
6572 return $xt
6575 set yt [expr {$y1 - 0.5 * $linespc}]
6576 set yb [expr {$yt + $linespc - 1}]
6577 set xvals {}
6578 set wvals {}
6579 set i -1
6580 foreach tag $marks {
6581 incr i
6582 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6583 set wid [font measure mainfontbold $tag]
6584 } else {
6585 set wid [font measure mainfont $tag]
6587 lappend xvals $xt
6588 lappend wvals $wid
6589 set xt [expr {$xt + $wid + $extra}]
6591 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6592 -width $lthickness -fill $reflinecolor -tags tag.$id]
6593 $canv lower $t
6594 foreach tag $marks x $xvals wid $wvals {
6595 set tag_quoted [string map {% %%} $tag]
6596 set xl [expr {$x + $delta}]
6597 set xr [expr {$x + $delta + $wid + $lthickness}]
6598 set font mainfont
6599 if {[incr ntags -1] >= 0} {
6600 # draw a tag
6601 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6602 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6603 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6604 -tags tag.$id]
6605 if {$singletag} {
6606 set tagclick [list showtags $id 1]
6607 } else {
6608 set tagclick [list showtag $tag_quoted 1]
6610 $canv bind $t <1> $tagclick
6611 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6612 } else {
6613 # draw a head or other ref
6614 if {[incr nheads -1] >= 0} {
6615 set col $headbgcolor
6616 if {$tag eq $mainhead} {
6617 set font mainfontbold
6619 } else {
6620 set col "#ddddff"
6622 set xl [expr {$xl - $delta/2}]
6623 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6624 -width 1 -outline black -fill $col -tags tag.$id
6625 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6626 set rwid [font measure mainfont $remoteprefix]
6627 set xi [expr {$x + 1}]
6628 set yti [expr {$yt + 1}]
6629 set xri [expr {$x + $rwid}]
6630 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6631 -width 0 -fill $remotebgcolor -tags tag.$id
6634 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6635 -font $font -tags [list tag.$id text]]
6636 if {$ntags >= 0} {
6637 $canv bind $t <1> $tagclick
6638 } elseif {$nheads >= 0} {
6639 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6642 return $xt
6645 proc drawnotesign {xt y} {
6646 global linespc canv fgcolor
6648 set orad [expr {$linespc / 3}]
6649 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6650 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6651 -fill yellow -outline $fgcolor -width 1 -tags circle]
6652 set xt [expr {$xt + $orad * 3}]
6653 return $xt
6656 proc xcoord {i level ln} {
6657 global canvx0 xspc1 xspc2
6659 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6660 if {$i > 0 && $i == $level} {
6661 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6662 } elseif {$i > $level} {
6663 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6665 return $x
6668 proc show_status {msg} {
6669 global canv fgcolor
6671 clear_display
6672 set_window_title
6673 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6674 -tags text -fill $fgcolor
6677 # Don't change the text pane cursor if it is currently the hand cursor,
6678 # showing that we are over a sha1 ID link.
6679 proc settextcursor {c} {
6680 global ctext curtextcursor
6682 if {[$ctext cget -cursor] == $curtextcursor} {
6683 $ctext config -cursor $c
6685 set curtextcursor $c
6688 proc nowbusy {what {name {}}} {
6689 global isbusy busyname statusw
6691 if {[array names isbusy] eq {}} {
6692 . config -cursor watch
6693 settextcursor watch
6695 set isbusy($what) 1
6696 set busyname($what) $name
6697 if {$name ne {}} {
6698 $statusw conf -text $name
6702 proc notbusy {what} {
6703 global isbusy maincursor textcursor busyname statusw
6705 catch {
6706 unset isbusy($what)
6707 if {$busyname($what) ne {} &&
6708 [$statusw cget -text] eq $busyname($what)} {
6709 $statusw conf -text {}
6712 if {[array names isbusy] eq {}} {
6713 . config -cursor $maincursor
6714 settextcursor $textcursor
6718 proc findmatches {f} {
6719 global findtype findstring
6720 if {$findtype == [mc "Regexp"]} {
6721 set matches [regexp -indices -all -inline $findstring $f]
6722 } else {
6723 set fs $findstring
6724 if {$findtype == [mc "IgnCase"]} {
6725 set f [string tolower $f]
6726 set fs [string tolower $fs]
6728 set matches {}
6729 set i 0
6730 set l [string length $fs]
6731 while {[set j [string first $fs $f $i]] >= 0} {
6732 lappend matches [list $j [expr {$j+$l-1}]]
6733 set i [expr {$j + $l}]
6736 return $matches
6739 proc dofind {{dirn 1} {wrap 1}} {
6740 global findstring findstartline findcurline selectedline numcommits
6741 global gdttype filehighlight fh_serial find_dirn findallowwrap
6743 if {[info exists find_dirn]} {
6744 if {$find_dirn == $dirn} return
6745 stopfinding
6747 focus .
6748 if {$findstring eq {} || $numcommits == 0} return
6749 if {$selectedline eq {}} {
6750 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6751 } else {
6752 set findstartline $selectedline
6754 set findcurline $findstartline
6755 nowbusy finding [mc "Searching"]
6756 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6757 after cancel do_file_hl $fh_serial
6758 do_file_hl $fh_serial
6760 set find_dirn $dirn
6761 set findallowwrap $wrap
6762 run findmore
6765 proc stopfinding {} {
6766 global find_dirn findcurline fprogcoord
6768 if {[info exists find_dirn]} {
6769 unset find_dirn
6770 unset findcurline
6771 notbusy finding
6772 set fprogcoord 0
6773 adjustprogress
6775 stopblaming
6778 proc findmore {} {
6779 global commitdata commitinfo numcommits findpattern findloc
6780 global findstartline findcurline findallowwrap
6781 global find_dirn gdttype fhighlights fprogcoord
6782 global curview varcorder vrownum varccommits vrowmod
6784 if {![info exists find_dirn]} {
6785 return 0
6787 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6788 set l $findcurline
6789 set moretodo 0
6790 if {$find_dirn > 0} {
6791 incr l
6792 if {$l >= $numcommits} {
6793 set l 0
6795 if {$l <= $findstartline} {
6796 set lim [expr {$findstartline + 1}]
6797 } else {
6798 set lim $numcommits
6799 set moretodo $findallowwrap
6801 } else {
6802 if {$l == 0} {
6803 set l $numcommits
6805 incr l -1
6806 if {$l >= $findstartline} {
6807 set lim [expr {$findstartline - 1}]
6808 } else {
6809 set lim -1
6810 set moretodo $findallowwrap
6813 set n [expr {($lim - $l) * $find_dirn}]
6814 if {$n > 500} {
6815 set n 500
6816 set moretodo 1
6818 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6819 update_arcrows $curview
6821 set found 0
6822 set domore 1
6823 set ai [bsearch $vrownum($curview) $l]
6824 set a [lindex $varcorder($curview) $ai]
6825 set arow [lindex $vrownum($curview) $ai]
6826 set ids [lindex $varccommits($curview,$a)]
6827 set arowend [expr {$arow + [llength $ids]}]
6828 if {$gdttype eq [mc "containing:"]} {
6829 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6830 if {$l < $arow || $l >= $arowend} {
6831 incr ai $find_dirn
6832 set a [lindex $varcorder($curview) $ai]
6833 set arow [lindex $vrownum($curview) $ai]
6834 set ids [lindex $varccommits($curview,$a)]
6835 set arowend [expr {$arow + [llength $ids]}]
6837 set id [lindex $ids [expr {$l - $arow}]]
6838 # shouldn't happen unless git log doesn't give all the commits...
6839 if {![info exists commitdata($id)] ||
6840 ![doesmatch $commitdata($id)]} {
6841 continue
6843 if {![info exists commitinfo($id)]} {
6844 getcommit $id
6846 set info $commitinfo($id)
6847 foreach f $info ty $fldtypes {
6848 if {$ty eq ""} continue
6849 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6850 [doesmatch $f]} {
6851 set found 1
6852 break
6855 if {$found} break
6857 } else {
6858 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6859 if {$l < $arow || $l >= $arowend} {
6860 incr ai $find_dirn
6861 set a [lindex $varcorder($curview) $ai]
6862 set arow [lindex $vrownum($curview) $ai]
6863 set ids [lindex $varccommits($curview,$a)]
6864 set arowend [expr {$arow + [llength $ids]}]
6866 set id [lindex $ids [expr {$l - $arow}]]
6867 if {![info exists fhighlights($id)]} {
6868 # this sets fhighlights($id) to -1
6869 askfilehighlight $l $id
6871 if {$fhighlights($id) > 0} {
6872 set found $domore
6873 break
6875 if {$fhighlights($id) < 0} {
6876 if {$domore} {
6877 set domore 0
6878 set findcurline [expr {$l - $find_dirn}]
6883 if {$found || ($domore && !$moretodo)} {
6884 unset findcurline
6885 unset find_dirn
6886 notbusy finding
6887 set fprogcoord 0
6888 adjustprogress
6889 if {$found} {
6890 findselectline $l
6891 } else {
6892 bell
6894 return 0
6896 if {!$domore} {
6897 flushhighlights
6898 } else {
6899 set findcurline [expr {$l - $find_dirn}]
6901 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6902 if {$n < 0} {
6903 incr n $numcommits
6905 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6906 adjustprogress
6907 return $domore
6910 proc findselectline {l} {
6911 global findloc commentend ctext findcurline markingmatches gdttype
6913 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6914 set findcurline $l
6915 selectline $l 1
6916 if {$markingmatches &&
6917 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6918 # highlight the matches in the comments
6919 set f [$ctext get 1.0 $commentend]
6920 set matches [findmatches $f]
6921 foreach match $matches {
6922 set start [lindex $match 0]
6923 set end [expr {[lindex $match 1] + 1}]
6924 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6927 drawvisible
6930 # mark the bits of a headline or author that match a find string
6931 proc markmatches {canv l str tag matches font row} {
6932 global selectedline
6934 set bbox [$canv bbox $tag]
6935 set x0 [lindex $bbox 0]
6936 set y0 [lindex $bbox 1]
6937 set y1 [lindex $bbox 3]
6938 foreach match $matches {
6939 set start [lindex $match 0]
6940 set end [lindex $match 1]
6941 if {$start > $end} continue
6942 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6943 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6944 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6945 [expr {$x0+$xlen+2}] $y1 \
6946 -outline {} -tags [list match$l matches] -fill yellow]
6947 $canv lower $t
6948 if {$row == $selectedline} {
6949 $canv raise $t secsel
6954 proc unmarkmatches {} {
6955 global markingmatches
6957 allcanvs delete matches
6958 set markingmatches 0
6959 stopfinding
6962 proc selcanvline {w x y} {
6963 global canv canvy0 ctext linespc
6964 global rowtextx
6965 set ymax [lindex [$canv cget -scrollregion] 3]
6966 if {$ymax == {}} return
6967 set yfrac [lindex [$canv yview] 0]
6968 set y [expr {$y + $yfrac * $ymax}]
6969 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6970 if {$l < 0} {
6971 set l 0
6973 if {$w eq $canv} {
6974 set xmax [lindex [$canv cget -scrollregion] 2]
6975 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6976 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6978 unmarkmatches
6979 selectline $l 1
6982 proc commit_descriptor {p} {
6983 global commitinfo
6984 if {![info exists commitinfo($p)]} {
6985 getcommit $p
6987 set l "..."
6988 if {[llength $commitinfo($p)] > 1} {
6989 set l [lindex $commitinfo($p) 0]
6991 return "$p ($l)\n"
6994 # append some text to the ctext widget, and make any SHA1 ID
6995 # that we know about be a clickable link.
6996 proc appendwithlinks {text tags} {
6997 global ctext linknum curview
6999 set start [$ctext index "end - 1c"]
7000 $ctext insert end $text $tags
7001 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
7002 foreach l $links {
7003 set s [lindex $l 0]
7004 set e [lindex $l 1]
7005 set linkid [string range $text $s $e]
7006 incr e
7007 $ctext tag delete link$linknum
7008 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7009 setlink $linkid link$linknum
7010 incr linknum
7014 proc setlink {id lk} {
7015 global curview ctext pendinglinks
7016 global linkfgcolor
7018 if {[string range $id 0 1] eq "-g"} {
7019 set id [string range $id 2 end]
7022 set known 0
7023 if {[string length $id] < 40} {
7024 set matches [longid $id]
7025 if {[llength $matches] > 0} {
7026 if {[llength $matches] > 1} return
7027 set known 1
7028 set id [lindex $matches 0]
7030 } else {
7031 set known [commitinview $id $curview]
7033 if {$known} {
7034 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7035 $ctext tag bind $lk <1> [list selbyid $id]
7036 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7037 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7038 } else {
7039 lappend pendinglinks($id) $lk
7040 interestedin $id {makelink %P}
7044 proc appendshortlink {id {pre {}} {post {}}} {
7045 global ctext linknum
7047 $ctext insert end $pre
7048 $ctext tag delete link$linknum
7049 $ctext insert end [string range $id 0 7] link$linknum
7050 $ctext insert end $post
7051 setlink $id link$linknum
7052 incr linknum
7055 proc makelink {id} {
7056 global pendinglinks
7058 if {![info exists pendinglinks($id)]} return
7059 foreach lk $pendinglinks($id) {
7060 setlink $id $lk
7062 unset pendinglinks($id)
7065 proc linkcursor {w inc} {
7066 global linkentercount curtextcursor
7068 if {[incr linkentercount $inc] > 0} {
7069 $w configure -cursor hand2
7070 } else {
7071 $w configure -cursor $curtextcursor
7072 if {$linkentercount < 0} {
7073 set linkentercount 0
7078 proc viewnextline {dir} {
7079 global canv linespc
7081 $canv delete hover
7082 set ymax [lindex [$canv cget -scrollregion] 3]
7083 set wnow [$canv yview]
7084 set wtop [expr {[lindex $wnow 0] * $ymax}]
7085 set newtop [expr {$wtop + $dir * $linespc}]
7086 if {$newtop < 0} {
7087 set newtop 0
7088 } elseif {$newtop > $ymax} {
7089 set newtop $ymax
7091 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7094 # add a list of tag or branch names at position pos
7095 # returns the number of names inserted
7096 proc appendrefs {pos ids var} {
7097 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7099 if {[catch {$ctext index $pos}]} {
7100 return 0
7102 $ctext conf -state normal
7103 $ctext delete $pos "$pos lineend"
7104 set tags {}
7105 foreach id $ids {
7106 foreach tag [set $var\($id\)] {
7107 lappend tags [list $tag $id]
7111 set sep {}
7112 set tags [lsort -index 0 -decreasing $tags]
7113 set nutags 0
7115 if {[llength $tags] > $maxrefs} {
7116 # If we are displaying heads, and there are too many,
7117 # see if there are some important heads to display.
7118 # Currently that are the current head and heads listed in $visiblerefs option
7119 set itags {}
7120 if {$var eq "idheads"} {
7121 set utags {}
7122 foreach ti $tags {
7123 set hname [lindex $ti 0]
7124 set id [lindex $ti 1]
7125 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7126 [llength $itags] < $maxrefs} {
7127 lappend itags $ti
7128 } else {
7129 lappend utags $ti
7132 set tags $utags
7134 if {$itags ne {}} {
7135 set str [mc "and many more"]
7136 set sep " "
7137 } else {
7138 set str [mc "many"]
7140 $ctext insert $pos "$str ([llength $tags])"
7141 set nutags [llength $tags]
7142 set tags $itags
7145 foreach ti $tags {
7146 set id [lindex $ti 1]
7147 set lk link$linknum
7148 incr linknum
7149 $ctext tag delete $lk
7150 $ctext insert $pos $sep
7151 $ctext insert $pos [lindex $ti 0] $lk
7152 setlink $id $lk
7153 set sep ", "
7155 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7156 $ctext conf -state disabled
7157 return [expr {[llength $tags] + $nutags}]
7160 # called when we have finished computing the nearby tags
7161 proc dispneartags {delay} {
7162 global selectedline currentid showneartags tagphase
7164 if {$selectedline eq {} || !$showneartags} return
7165 after cancel dispnexttag
7166 if {$delay} {
7167 after 200 dispnexttag
7168 set tagphase -1
7169 } else {
7170 after idle dispnexttag
7171 set tagphase 0
7175 proc dispnexttag {} {
7176 global selectedline currentid showneartags tagphase ctext
7178 if {$selectedline eq {} || !$showneartags} return
7179 switch -- $tagphase {
7181 set dtags [desctags $currentid]
7182 if {$dtags ne {}} {
7183 appendrefs precedes $dtags idtags
7187 set atags [anctags $currentid]
7188 if {$atags ne {}} {
7189 appendrefs follows $atags idtags
7193 set dheads [descheads $currentid]
7194 if {$dheads ne {}} {
7195 if {[appendrefs branch $dheads idheads] > 1
7196 && [$ctext get "branch -3c"] eq "h"} {
7197 # turn "Branch" into "Branches"
7198 $ctext conf -state normal
7199 $ctext insert "branch -2c" "es"
7200 $ctext conf -state disabled
7205 if {[incr tagphase] <= 2} {
7206 after idle dispnexttag
7210 proc make_secsel {id} {
7211 global linehtag linentag linedtag canv canv2 canv3
7213 if {![info exists linehtag($id)]} return
7214 $canv delete secsel
7215 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7216 -tags secsel -fill [$canv cget -selectbackground]]
7217 $canv lower $t
7218 $canv2 delete secsel
7219 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7220 -tags secsel -fill [$canv2 cget -selectbackground]]
7221 $canv2 lower $t
7222 $canv3 delete secsel
7223 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7224 -tags secsel -fill [$canv3 cget -selectbackground]]
7225 $canv3 lower $t
7228 proc make_idmark {id} {
7229 global linehtag canv fgcolor
7231 if {![info exists linehtag($id)]} return
7232 $canv delete markid
7233 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7234 -tags markid -outline $fgcolor]
7235 $canv raise $t
7238 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7239 global canv ctext commitinfo selectedline
7240 global canvy0 linespc parents children curview
7241 global currentid sha1entry
7242 global commentend idtags linknum
7243 global mergemax numcommits pending_select
7244 global cmitmode showneartags allcommits
7245 global targetrow targetid lastscrollrows
7246 global autoselect autosellen jump_to_here
7247 global vinlinediff
7249 unset -nocomplain pending_select
7250 $canv delete hover
7251 normalline
7252 unsel_reflist
7253 stopfinding
7254 if {$l < 0 || $l >= $numcommits} return
7255 set id [commitonrow $l]
7256 set targetid $id
7257 set targetrow $l
7258 set selectedline $l
7259 set currentid $id
7260 if {$lastscrollrows < $numcommits} {
7261 setcanvscroll
7264 if {$cmitmode ne "patch" && $switch_to_patch} {
7265 set cmitmode "patch"
7268 set y [expr {$canvy0 + $l * $linespc}]
7269 set ymax [lindex [$canv cget -scrollregion] 3]
7270 set ytop [expr {$y - $linespc - 1}]
7271 set ybot [expr {$y + $linespc + 1}]
7272 set wnow [$canv yview]
7273 set wtop [expr {[lindex $wnow 0] * $ymax}]
7274 set wbot [expr {[lindex $wnow 1] * $ymax}]
7275 set wh [expr {$wbot - $wtop}]
7276 set newtop $wtop
7277 if {$ytop < $wtop} {
7278 if {$ybot < $wtop} {
7279 set newtop [expr {$y - $wh / 2.0}]
7280 } else {
7281 set newtop $ytop
7282 if {$newtop > $wtop - $linespc} {
7283 set newtop [expr {$wtop - $linespc}]
7286 } elseif {$ybot > $wbot} {
7287 if {$ytop > $wbot} {
7288 set newtop [expr {$y - $wh / 2.0}]
7289 } else {
7290 set newtop [expr {$ybot - $wh}]
7291 if {$newtop < $wtop + $linespc} {
7292 set newtop [expr {$wtop + $linespc}]
7296 if {$newtop != $wtop} {
7297 if {$newtop < 0} {
7298 set newtop 0
7300 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7301 drawvisible
7304 make_secsel $id
7306 if {$isnew} {
7307 addtohistory [list selbyid $id 0] savecmitpos
7310 $sha1entry delete 0 end
7311 $sha1entry insert 0 $id
7312 if {$autoselect} {
7313 $sha1entry selection range 0 $autosellen
7315 rhighlight_sel $id
7317 $ctext conf -state normal
7318 clear_ctext
7319 set linknum 0
7320 if {![info exists commitinfo($id)]} {
7321 getcommit $id
7323 set info $commitinfo($id)
7324 set date [formatdate [lindex $info 2]]
7325 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7326 set date [formatdate [lindex $info 4]]
7327 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7328 if {[info exists idtags($id)]} {
7329 $ctext insert end [mc "Tags:"]
7330 foreach tag $idtags($id) {
7331 $ctext insert end " $tag"
7333 $ctext insert end "\n"
7336 set headers {}
7337 set olds $parents($curview,$id)
7338 if {[llength $olds] > 1} {
7339 set np 0
7340 foreach p $olds {
7341 if {$np >= $mergemax} {
7342 set tag mmax
7343 } else {
7344 set tag m$np
7346 $ctext insert end "[mc "Parent"]: " $tag
7347 appendwithlinks [commit_descriptor $p] {}
7348 incr np
7350 } else {
7351 foreach p $olds {
7352 append headers "[mc "Parent"]: [commit_descriptor $p]"
7356 foreach c $children($curview,$id) {
7357 append headers "[mc "Child"]: [commit_descriptor $c]"
7360 # make anything that looks like a SHA1 ID be a clickable link
7361 appendwithlinks $headers {}
7362 if {$showneartags} {
7363 if {![info exists allcommits]} {
7364 getallcommits
7366 $ctext insert end "[mc "Branch"]: "
7367 $ctext mark set branch "end -1c"
7368 $ctext mark gravity branch left
7369 $ctext insert end "\n[mc "Follows"]: "
7370 $ctext mark set follows "end -1c"
7371 $ctext mark gravity follows left
7372 $ctext insert end "\n[mc "Precedes"]: "
7373 $ctext mark set precedes "end -1c"
7374 $ctext mark gravity precedes left
7375 $ctext insert end "\n"
7376 dispneartags 1
7378 $ctext insert end "\n"
7379 set comment [lindex $info 5]
7380 if {[string first "\r" $comment] >= 0} {
7381 set comment [string map {"\r" "\n "} $comment]
7383 appendwithlinks $comment {comment}
7385 $ctext tag remove found 1.0 end
7386 $ctext conf -state disabled
7387 set commentend [$ctext index "end - 1c"]
7389 set jump_to_here $desired_loc
7390 init_flist [mc "Comments"]
7391 if {$cmitmode eq "tree"} {
7392 gettree $id
7393 } elseif {$vinlinediff($curview) == 1} {
7394 showinlinediff $id
7395 } elseif {[llength $olds] <= 1} {
7396 startdiff $id
7397 } else {
7398 mergediff $id
7402 proc selfirstline {} {
7403 unmarkmatches
7404 selectline 0 1
7407 proc sellastline {} {
7408 global numcommits
7409 unmarkmatches
7410 set l [expr {$numcommits - 1}]
7411 selectline $l 1
7414 proc selnextline {dir} {
7415 global selectedline
7416 focus .
7417 if {$selectedline eq {}} return
7418 set l [expr {$selectedline + $dir}]
7419 unmarkmatches
7420 selectline $l 1
7423 proc selnextpage {dir} {
7424 global canv linespc selectedline numcommits
7426 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7427 if {$lpp < 1} {
7428 set lpp 1
7430 allcanvs yview scroll [expr {$dir * $lpp}] units
7431 drawvisible
7432 if {$selectedline eq {}} return
7433 set l [expr {$selectedline + $dir * $lpp}]
7434 if {$l < 0} {
7435 set l 0
7436 } elseif {$l >= $numcommits} {
7437 set l [expr $numcommits - 1]
7439 unmarkmatches
7440 selectline $l 1
7443 proc unselectline {} {
7444 global selectedline currentid
7446 set selectedline {}
7447 unset -nocomplain currentid
7448 allcanvs delete secsel
7449 rhighlight_none
7452 proc reselectline {} {
7453 global selectedline
7455 if {$selectedline ne {}} {
7456 selectline $selectedline 0
7460 proc addtohistory {cmd {saveproc {}}} {
7461 global history historyindex curview
7463 unset_posvars
7464 save_position
7465 set elt [list $curview $cmd $saveproc {}]
7466 if {$historyindex > 0
7467 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7468 return
7471 if {$historyindex < [llength $history]} {
7472 set history [lreplace $history $historyindex end $elt]
7473 } else {
7474 lappend history $elt
7476 incr historyindex
7477 if {$historyindex > 1} {
7478 .tf.bar.leftbut conf -state normal
7479 } else {
7480 .tf.bar.leftbut conf -state disabled
7482 .tf.bar.rightbut conf -state disabled
7485 # save the scrolling position of the diff display pane
7486 proc save_position {} {
7487 global historyindex history
7489 if {$historyindex < 1} return
7490 set hi [expr {$historyindex - 1}]
7491 set fn [lindex $history $hi 2]
7492 if {$fn ne {}} {
7493 lset history $hi 3 [eval $fn]
7497 proc unset_posvars {} {
7498 global last_posvars
7500 if {[info exists last_posvars]} {
7501 foreach {var val} $last_posvars {
7502 global $var
7503 unset -nocomplain $var
7505 unset last_posvars
7509 proc godo {elt} {
7510 global curview last_posvars
7512 set view [lindex $elt 0]
7513 set cmd [lindex $elt 1]
7514 set pv [lindex $elt 3]
7515 if {$curview != $view} {
7516 showview $view
7518 unset_posvars
7519 foreach {var val} $pv {
7520 global $var
7521 set $var $val
7523 set last_posvars $pv
7524 eval $cmd
7527 proc goback {} {
7528 global history historyindex
7529 focus .
7531 if {$historyindex > 1} {
7532 save_position
7533 incr historyindex -1
7534 godo [lindex $history [expr {$historyindex - 1}]]
7535 .tf.bar.rightbut conf -state normal
7537 if {$historyindex <= 1} {
7538 .tf.bar.leftbut conf -state disabled
7542 proc goforw {} {
7543 global history historyindex
7544 focus .
7546 if {$historyindex < [llength $history]} {
7547 save_position
7548 set cmd [lindex $history $historyindex]
7549 incr historyindex
7550 godo $cmd
7551 .tf.bar.leftbut conf -state normal
7553 if {$historyindex >= [llength $history]} {
7554 .tf.bar.rightbut conf -state disabled
7558 proc go_to_parent {i} {
7559 global parents curview targetid
7560 set ps $parents($curview,$targetid)
7561 if {[llength $ps] >= $i} {
7562 selbyid [lindex $ps [expr $i - 1]]
7566 proc gettree {id} {
7567 global treefilelist treeidlist diffids diffmergeid treepending
7568 global nullid nullid2
7570 set diffids $id
7571 unset -nocomplain diffmergeid
7572 if {![info exists treefilelist($id)]} {
7573 if {![info exists treepending]} {
7574 if {$id eq $nullid} {
7575 set cmd [list | git ls-files]
7576 } elseif {$id eq $nullid2} {
7577 set cmd [list | git ls-files --stage -t]
7578 } else {
7579 set cmd [list | git ls-tree -r $id]
7581 if {[catch {set gtf [open $cmd r]}]} {
7582 return
7584 set treepending $id
7585 set treefilelist($id) {}
7586 set treeidlist($id) {}
7587 fconfigure $gtf -blocking 0 -encoding binary
7588 filerun $gtf [list gettreeline $gtf $id]
7590 } else {
7591 setfilelist $id
7595 proc gettreeline {gtf id} {
7596 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7598 set nl 0
7599 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7600 if {$diffids eq $nullid} {
7601 set fname $line
7602 } else {
7603 set i [string first "\t" $line]
7604 if {$i < 0} continue
7605 set fname [string range $line [expr {$i+1}] end]
7606 set line [string range $line 0 [expr {$i-1}]]
7607 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7608 set sha1 [lindex $line 2]
7609 lappend treeidlist($id) $sha1
7611 if {[string index $fname 0] eq "\""} {
7612 set fname [lindex $fname 0]
7614 set fname [encoding convertfrom $fname]
7615 lappend treefilelist($id) $fname
7617 if {![eof $gtf]} {
7618 return [expr {$nl >= 1000? 2: 1}]
7620 close $gtf
7621 unset treepending
7622 if {$cmitmode ne "tree"} {
7623 if {![info exists diffmergeid]} {
7624 gettreediffs $diffids
7626 } elseif {$id ne $diffids} {
7627 gettree $diffids
7628 } else {
7629 setfilelist $id
7631 return 0
7634 proc showfile {f} {
7635 global treefilelist treeidlist diffids nullid nullid2
7636 global ctext_file_names ctext_file_lines
7637 global ctext commentend
7639 set i [lsearch -exact $treefilelist($diffids) $f]
7640 if {$i < 0} {
7641 puts "oops, $f not in list for id $diffids"
7642 return
7644 if {$diffids eq $nullid} {
7645 if {[catch {set bf [open $f r]} err]} {
7646 puts "oops, can't read $f: $err"
7647 return
7649 } else {
7650 set blob [lindex $treeidlist($diffids) $i]
7651 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7652 puts "oops, error reading blob $blob: $err"
7653 return
7656 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7657 filerun $bf [list getblobline $bf $diffids]
7658 $ctext config -state normal
7659 clear_ctext $commentend
7660 lappend ctext_file_names $f
7661 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7662 $ctext insert end "\n"
7663 $ctext insert end "$f\n" filesep
7664 $ctext config -state disabled
7665 $ctext yview $commentend
7666 settabs 0
7669 proc getblobline {bf id} {
7670 global diffids cmitmode ctext
7672 if {$id ne $diffids || $cmitmode ne "tree"} {
7673 catch {close $bf}
7674 return 0
7676 $ctext config -state normal
7677 set nl 0
7678 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7679 $ctext insert end "$line\n"
7681 if {[eof $bf]} {
7682 global jump_to_here ctext_file_names commentend
7684 # delete last newline
7685 $ctext delete "end - 2c" "end - 1c"
7686 close $bf
7687 if {$jump_to_here ne {} &&
7688 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7689 set lnum [expr {[lindex $jump_to_here 1] +
7690 [lindex [split $commentend .] 0]}]
7691 mark_ctext_line $lnum
7693 $ctext config -state disabled
7694 return 0
7696 $ctext config -state disabled
7697 return [expr {$nl >= 1000? 2: 1}]
7700 proc mark_ctext_line {lnum} {
7701 global ctext markbgcolor
7703 $ctext tag delete omark
7704 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7705 $ctext tag conf omark -background $markbgcolor
7706 $ctext see $lnum.0
7709 proc mergediff {id} {
7710 global diffmergeid
7711 global diffids treediffs
7712 global parents curview
7714 set diffmergeid $id
7715 set diffids $id
7716 set treediffs($id) {}
7717 set np [llength $parents($curview,$id)]
7718 settabs $np
7719 getblobdiffs $id
7722 proc startdiff {ids} {
7723 global treediffs diffids treepending diffmergeid nullid nullid2
7725 settabs 1
7726 set diffids $ids
7727 unset -nocomplain diffmergeid
7728 if {![info exists treediffs($ids)] ||
7729 [lsearch -exact $ids $nullid] >= 0 ||
7730 [lsearch -exact $ids $nullid2] >= 0} {
7731 if {![info exists treepending]} {
7732 gettreediffs $ids
7734 } else {
7735 addtocflist $ids
7739 proc showinlinediff {ids} {
7740 global commitinfo commitdata ctext
7741 global treediffs
7743 set info $commitinfo($ids)
7744 set diff [lindex $info 7]
7745 set difflines [split $diff "\n"]
7747 initblobdiffvars
7748 set treediff {}
7750 set inhdr 0
7751 foreach line $difflines {
7752 if {![string compare -length 5 "diff " $line]} {
7753 set inhdr 1
7754 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7755 # offset also accounts for the b/ prefix
7756 lappend treediff [string range $line 6 end]
7757 set inhdr 0
7761 set treediffs($ids) $treediff
7762 add_flist $treediff
7764 $ctext conf -state normal
7765 foreach line $difflines {
7766 parseblobdiffline $ids $line
7768 maybe_scroll_ctext 1
7769 $ctext conf -state disabled
7772 # If the filename (name) is under any of the passed filter paths
7773 # then return true to include the file in the listing.
7774 proc path_filter {filter name} {
7775 set worktree [gitworktree]
7776 foreach p $filter {
7777 set fq_p [file normalize $p]
7778 set fq_n [file normalize [file join $worktree $name]]
7779 if {[string match [file normalize $fq_p]* $fq_n]} {
7780 return 1
7783 return 0
7786 proc addtocflist {ids} {
7787 global treediffs
7789 add_flist $treediffs($ids)
7790 getblobdiffs $ids
7793 proc diffcmd {ids flags} {
7794 global log_showroot nullid nullid2 git_version
7796 set i [lsearch -exact $ids $nullid]
7797 set j [lsearch -exact $ids $nullid2]
7798 if {$i >= 0} {
7799 if {[llength $ids] > 1 && $j < 0} {
7800 # comparing working directory with some specific revision
7801 set cmd [concat | git diff-index $flags]
7802 if {$i == 0} {
7803 lappend cmd -R [lindex $ids 1]
7804 } else {
7805 lappend cmd [lindex $ids 0]
7807 } else {
7808 # comparing working directory with index
7809 set cmd [concat | git diff-files $flags]
7810 if {$j == 1} {
7811 lappend cmd -R
7814 } elseif {$j >= 0} {
7815 if {[package vcompare $git_version "1.7.2"] >= 0} {
7816 set flags "$flags --ignore-submodules=dirty"
7818 set cmd [concat | git diff-index --cached $flags]
7819 if {[llength $ids] > 1} {
7820 # comparing index with specific revision
7821 if {$j == 0} {
7822 lappend cmd -R [lindex $ids 1]
7823 } else {
7824 lappend cmd [lindex $ids 0]
7826 } else {
7827 # comparing index with HEAD
7828 lappend cmd HEAD
7830 } else {
7831 if {$log_showroot} {
7832 lappend flags --root
7834 set cmd [concat | git diff-tree -r $flags $ids]
7836 return $cmd
7839 proc gettreediffs {ids} {
7840 global treediff treepending limitdiffs vfilelimit curview
7842 set cmd [diffcmd $ids {--no-commit-id}]
7843 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7844 set cmd [concat $cmd -- $vfilelimit($curview)]
7846 if {[catch {set gdtf [open $cmd r]}]} return
7848 set treepending $ids
7849 set treediff {}
7850 fconfigure $gdtf -blocking 0 -encoding binary
7851 filerun $gdtf [list gettreediffline $gdtf $ids]
7854 proc gettreediffline {gdtf ids} {
7855 global treediff treediffs treepending diffids diffmergeid
7856 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7858 set nr 0
7859 set sublist {}
7860 set max 1000
7861 if {$perfile_attrs} {
7862 # cache_gitattr is slow, and even slower on win32 where we
7863 # have to invoke it for only about 30 paths at a time
7864 set max 500
7865 if {[tk windowingsystem] == "win32"} {
7866 set max 120
7869 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7870 set i [string first "\t" $line]
7871 if {$i >= 0} {
7872 set file [string range $line [expr {$i+1}] end]
7873 if {[string index $file 0] eq "\""} {
7874 set file [lindex $file 0]
7876 set file [encoding convertfrom $file]
7877 if {$file ne [lindex $treediff end]} {
7878 lappend treediff $file
7879 lappend sublist $file
7883 if {$perfile_attrs} {
7884 cache_gitattr encoding $sublist
7886 if {![eof $gdtf]} {
7887 return [expr {$nr >= $max? 2: 1}]
7889 close $gdtf
7890 set treediffs($ids) $treediff
7891 unset treepending
7892 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7893 gettree $diffids
7894 } elseif {$ids != $diffids} {
7895 if {![info exists diffmergeid]} {
7896 gettreediffs $diffids
7898 } else {
7899 addtocflist $ids
7901 return 0
7904 # empty string or positive integer
7905 proc diffcontextvalidate {v} {
7906 return [regexp {^(|[1-9][0-9]*)$} $v]
7909 proc diffcontextchange {n1 n2 op} {
7910 global diffcontextstring diffcontext
7912 if {[string is integer -strict $diffcontextstring]} {
7913 if {$diffcontextstring >= 0} {
7914 set diffcontext $diffcontextstring
7915 reselectline
7920 proc changeignorespace {} {
7921 reselectline
7924 proc changeworddiff {name ix op} {
7925 reselectline
7928 proc initblobdiffvars {} {
7929 global diffencoding targetline diffnparents
7930 global diffinhdr currdiffsubmod diffseehere
7931 set targetline {}
7932 set diffnparents 0
7933 set diffinhdr 0
7934 set diffencoding [get_path_encoding {}]
7935 set currdiffsubmod ""
7936 set diffseehere -1
7939 proc getblobdiffs {ids} {
7940 global blobdifffd diffids env
7941 global treediffs
7942 global diffcontext
7943 global ignorespace
7944 global worddiff
7945 global limitdiffs vfilelimit curview
7946 global git_version
7948 set textconv {}
7949 if {[package vcompare $git_version "1.6.1"] >= 0} {
7950 set textconv "--textconv"
7952 set submodule {}
7953 if {[package vcompare $git_version "1.6.6"] >= 0} {
7954 set submodule "--submodule"
7956 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7957 if {$ignorespace} {
7958 append cmd " -w"
7960 if {$worddiff ne [mc "Line diff"]} {
7961 append cmd " --word-diff=porcelain"
7963 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7964 set cmd [concat $cmd -- $vfilelimit($curview)]
7966 if {[catch {set bdf [open $cmd r]} err]} {
7967 error_popup [mc "Error getting diffs: %s" $err]
7968 return
7970 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7971 set blobdifffd($ids) $bdf
7972 initblobdiffvars
7973 filerun $bdf [list getblobdiffline $bdf $diffids]
7976 proc savecmitpos {} {
7977 global ctext cmitmode
7979 if {$cmitmode eq "tree"} {
7980 return {}
7982 return [list target_scrollpos [$ctext index @0,0]]
7985 proc savectextpos {} {
7986 global ctext
7988 return [list target_scrollpos [$ctext index @0,0]]
7991 proc maybe_scroll_ctext {ateof} {
7992 global ctext target_scrollpos
7994 if {![info exists target_scrollpos]} return
7995 if {!$ateof} {
7996 set nlines [expr {[winfo height $ctext]
7997 / [font metrics textfont -linespace]}]
7998 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
8000 $ctext yview $target_scrollpos
8001 unset target_scrollpos
8004 proc setinlist {var i val} {
8005 global $var
8007 while {[llength [set $var]] < $i} {
8008 lappend $var {}
8010 if {[llength [set $var]] == $i} {
8011 lappend $var $val
8012 } else {
8013 lset $var $i $val
8017 proc makediffhdr {fname ids} {
8018 global ctext curdiffstart treediffs diffencoding
8019 global ctext_file_names jump_to_here targetline diffline
8021 set fname [encoding convertfrom $fname]
8022 set diffencoding [get_path_encoding $fname]
8023 set i [lsearch -exact $treediffs($ids) $fname]
8024 if {$i >= 0} {
8025 setinlist difffilestart $i $curdiffstart
8027 lset ctext_file_names end $fname
8028 set l [expr {(78 - [string length $fname]) / 2}]
8029 set pad [string range "----------------------------------------" 1 $l]
8030 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8031 set targetline {}
8032 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8033 set targetline [lindex $jump_to_here 1]
8035 set diffline 0
8038 proc blobdiffmaybeseehere {ateof} {
8039 global diffseehere
8040 if {$diffseehere >= 0} {
8041 mark_ctext_line [lindex [split $diffseehere .] 0]
8043 maybe_scroll_ctext $ateof
8046 proc getblobdiffline {bdf ids} {
8047 global diffids blobdifffd
8048 global ctext
8050 set nr 0
8051 $ctext conf -state normal
8052 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8053 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8054 catch {close $bdf}
8055 return 0
8057 parseblobdiffline $ids $line
8059 $ctext conf -state disabled
8060 blobdiffmaybeseehere [eof $bdf]
8061 if {[eof $bdf]} {
8062 catch {close $bdf}
8063 return 0
8065 return [expr {$nr >= 1000? 2: 1}]
8068 proc parseblobdiffline {ids line} {
8069 global ctext curdiffstart
8070 global diffnexthead diffnextnote difffilestart
8071 global ctext_file_names ctext_file_lines
8072 global diffinhdr treediffs mergemax diffnparents
8073 global diffencoding jump_to_here targetline diffline currdiffsubmod
8074 global worddiff diffseehere
8076 if {![string compare -length 5 "diff " $line]} {
8077 if {![regexp {^diff (--cc|--git) } $line m type]} {
8078 set line [encoding convertfrom $line]
8079 $ctext insert end "$line\n" hunksep
8080 continue
8082 # start of a new file
8083 set diffinhdr 1
8084 $ctext insert end "\n"
8085 set curdiffstart [$ctext index "end - 1c"]
8086 lappend ctext_file_names ""
8087 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8088 $ctext insert end "\n" filesep
8090 if {$type eq "--cc"} {
8091 # start of a new file in a merge diff
8092 set fname [string range $line 10 end]
8093 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8094 lappend treediffs($ids) $fname
8095 add_flist [list $fname]
8098 } else {
8099 set line [string range $line 11 end]
8100 # If the name hasn't changed the length will be odd,
8101 # the middle char will be a space, and the two bits either
8102 # side will be a/name and b/name, or "a/name" and "b/name".
8103 # If the name has changed we'll get "rename from" and
8104 # "rename to" or "copy from" and "copy to" lines following
8105 # this, and we'll use them to get the filenames.
8106 # This complexity is necessary because spaces in the
8107 # filename(s) don't get escaped.
8108 set l [string length $line]
8109 set i [expr {$l / 2}]
8110 if {!(($l & 1) && [string index $line $i] eq " " &&
8111 [string range $line 2 [expr {$i - 1}]] eq \
8112 [string range $line [expr {$i + 3}] end])} {
8113 return
8115 # unescape if quoted and chop off the a/ from the front
8116 if {[string index $line 0] eq "\""} {
8117 set fname [string range [lindex $line 0] 2 end]
8118 } else {
8119 set fname [string range $line 2 [expr {$i - 1}]]
8122 makediffhdr $fname $ids
8124 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8125 set fname [encoding convertfrom [string range $line 16 end]]
8126 $ctext insert end "\n"
8127 set curdiffstart [$ctext index "end - 1c"]
8128 lappend ctext_file_names $fname
8129 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8130 $ctext insert end "$line\n" filesep
8131 set i [lsearch -exact $treediffs($ids) $fname]
8132 if {$i >= 0} {
8133 setinlist difffilestart $i $curdiffstart
8136 } elseif {![string compare -length 2 "@@" $line]} {
8137 regexp {^@@+} $line ats
8138 set line [encoding convertfrom $diffencoding $line]
8139 $ctext insert end "$line\n" hunksep
8140 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8141 set diffline $nl
8143 set diffnparents [expr {[string length $ats] - 1}]
8144 set diffinhdr 0
8146 } elseif {![string compare -length 10 "Submodule " $line]} {
8147 # start of a new submodule
8148 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8149 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8150 } else {
8151 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8153 if {$currdiffsubmod != $fname} {
8154 $ctext insert end "\n"; # Add newline after commit message
8156 set curdiffstart [$ctext index "end - 1c"]
8157 lappend ctext_file_names ""
8158 if {$currdiffsubmod != $fname} {
8159 lappend ctext_file_lines $fname
8160 makediffhdr $fname $ids
8161 set currdiffsubmod $fname
8162 $ctext insert end "\n$line\n" filesep
8163 } else {
8164 $ctext insert end "$line\n" filesep
8166 } elseif {![string compare -length 3 " >" $line]} {
8167 set $currdiffsubmod ""
8168 set line [encoding convertfrom $diffencoding $line]
8169 $ctext insert end "$line\n" dresult
8170 } elseif {![string compare -length 3 " <" $line]} {
8171 set $currdiffsubmod ""
8172 set line [encoding convertfrom $diffencoding $line]
8173 $ctext insert end "$line\n" d0
8174 } elseif {$diffinhdr} {
8175 if {![string compare -length 12 "rename from " $line]} {
8176 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8177 if {[string index $fname 0] eq "\""} {
8178 set fname [lindex $fname 0]
8180 set fname [encoding convertfrom $fname]
8181 set i [lsearch -exact $treediffs($ids) $fname]
8182 if {$i >= 0} {
8183 setinlist difffilestart $i $curdiffstart
8185 } elseif {![string compare -length 10 $line "rename to "] ||
8186 ![string compare -length 8 $line "copy to "]} {
8187 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8188 if {[string index $fname 0] eq "\""} {
8189 set fname [lindex $fname 0]
8191 makediffhdr $fname $ids
8192 } elseif {[string compare -length 3 $line "---"] == 0} {
8193 # do nothing
8194 return
8195 } elseif {[string compare -length 3 $line "+++"] == 0} {
8196 set diffinhdr 0
8197 return
8199 $ctext insert end "$line\n" filesep
8201 } else {
8202 set line [string map {\x1A ^Z} \
8203 [encoding convertfrom $diffencoding $line]]
8204 # parse the prefix - one ' ', '-' or '+' for each parent
8205 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8206 set tag [expr {$diffnparents > 1? "m": "d"}]
8207 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8208 set words_pre_markup ""
8209 set words_post_markup ""
8210 if {[string trim $prefix " -+"] eq {}} {
8211 # prefix only has " ", "-" and "+" in it: normal diff line
8212 set num [string first "-" $prefix]
8213 if {$dowords} {
8214 set line [string range $line 1 end]
8216 if {$num >= 0} {
8217 # removed line, first parent with line is $num
8218 if {$num >= $mergemax} {
8219 set num "max"
8221 if {$dowords && $worddiff eq [mc "Markup words"]} {
8222 $ctext insert end "\[-$line-\]" $tag$num
8223 } else {
8224 $ctext insert end "$line" $tag$num
8226 if {!$dowords} {
8227 $ctext insert end "\n" $tag$num
8229 } else {
8230 set tags {}
8231 if {[string first "+" $prefix] >= 0} {
8232 # added line
8233 lappend tags ${tag}result
8234 if {$diffnparents > 1} {
8235 set num [string first " " $prefix]
8236 if {$num >= 0} {
8237 if {$num >= $mergemax} {
8238 set num "max"
8240 lappend tags m$num
8243 set words_pre_markup "{+"
8244 set words_post_markup "+}"
8246 if {$targetline ne {}} {
8247 if {$diffline == $targetline} {
8248 set diffseehere [$ctext index "end - 1 chars"]
8249 set targetline {}
8250 } else {
8251 incr diffline
8254 if {$dowords && $worddiff eq [mc "Markup words"]} {
8255 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8256 } else {
8257 $ctext insert end "$line" $tags
8259 if {!$dowords} {
8260 $ctext insert end "\n" $tags
8263 } elseif {$dowords && $prefix eq "~"} {
8264 $ctext insert end "\n" {}
8265 } else {
8266 # "\ No newline at end of file",
8267 # or something else we don't recognize
8268 $ctext insert end "$line\n" hunksep
8273 proc changediffdisp {} {
8274 global ctext diffelide
8276 $ctext tag conf d0 -elide [lindex $diffelide 0]
8277 $ctext tag conf dresult -elide [lindex $diffelide 1]
8280 proc highlightfile {cline} {
8281 global cflist cflist_top
8283 if {![info exists cflist_top]} return
8285 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8286 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8287 $cflist see $cline.0
8288 set cflist_top $cline
8291 proc highlightfile_for_scrollpos {topidx} {
8292 global cmitmode difffilestart
8294 if {$cmitmode eq "tree"} return
8295 if {![info exists difffilestart]} return
8297 set top [lindex [split $topidx .] 0]
8298 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8299 highlightfile 0
8300 } else {
8301 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8305 proc prevfile {} {
8306 global difffilestart ctext cmitmode
8308 if {$cmitmode eq "tree"} return
8309 set prev 0.0
8310 set here [$ctext index @0,0]
8311 foreach loc $difffilestart {
8312 if {[$ctext compare $loc >= $here]} {
8313 $ctext yview $prev
8314 return
8316 set prev $loc
8318 $ctext yview $prev
8321 proc nextfile {} {
8322 global difffilestart ctext cmitmode
8324 if {$cmitmode eq "tree"} return
8325 set here [$ctext index @0,0]
8326 foreach loc $difffilestart {
8327 if {[$ctext compare $loc > $here]} {
8328 $ctext yview $loc
8329 return
8334 proc clear_ctext {{first 1.0}} {
8335 global ctext smarktop smarkbot
8336 global ctext_file_names ctext_file_lines
8337 global pendinglinks
8339 set l [lindex [split $first .] 0]
8340 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8341 set smarktop $l
8343 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8344 set smarkbot $l
8346 $ctext delete $first end
8347 if {$first eq "1.0"} {
8348 unset -nocomplain pendinglinks
8350 set ctext_file_names {}
8351 set ctext_file_lines {}
8354 proc settabs {{firstab {}}} {
8355 global firsttabstop tabstop ctext have_tk85
8357 if {$firstab ne {} && $have_tk85} {
8358 set firsttabstop $firstab
8360 set w [font measure textfont "0"]
8361 if {$firsttabstop != 0} {
8362 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8363 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8364 } elseif {$have_tk85 || $tabstop != 8} {
8365 $ctext conf -tabs [expr {$tabstop * $w}]
8366 } else {
8367 $ctext conf -tabs {}
8371 proc incrsearch {name ix op} {
8372 global ctext searchstring searchdirn
8374 if {[catch {$ctext index anchor}]} {
8375 # no anchor set, use start of selection, or of visible area
8376 set sel [$ctext tag ranges sel]
8377 if {$sel ne {}} {
8378 $ctext mark set anchor [lindex $sel 0]
8379 } elseif {$searchdirn eq "-forwards"} {
8380 $ctext mark set anchor @0,0
8381 } else {
8382 $ctext mark set anchor @0,[winfo height $ctext]
8385 if {$searchstring ne {}} {
8386 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8387 if {$here ne {}} {
8388 $ctext see $here
8389 set mend "$here + $mlen c"
8390 $ctext tag remove sel 1.0 end
8391 $ctext tag add sel $here $mend
8392 suppress_highlighting_file_for_current_scrollpos
8393 highlightfile_for_scrollpos $here
8396 rehighlight_search_results
8399 proc dosearch {} {
8400 global sstring ctext searchstring searchdirn
8402 focus $sstring
8403 $sstring icursor end
8404 set searchdirn -forwards
8405 if {$searchstring ne {}} {
8406 set sel [$ctext tag ranges sel]
8407 if {$sel ne {}} {
8408 set start "[lindex $sel 0] + 1c"
8409 } elseif {[catch {set start [$ctext index anchor]}]} {
8410 set start "@0,0"
8412 set match [$ctext search -count mlen -- $searchstring $start]
8413 $ctext tag remove sel 1.0 end
8414 if {$match eq {}} {
8415 bell
8416 return
8418 $ctext see $match
8419 suppress_highlighting_file_for_current_scrollpos
8420 highlightfile_for_scrollpos $match
8421 set mend "$match + $mlen c"
8422 $ctext tag add sel $match $mend
8423 $ctext mark unset anchor
8424 rehighlight_search_results
8428 proc dosearchback {} {
8429 global sstring ctext searchstring searchdirn
8431 focus $sstring
8432 $sstring icursor end
8433 set searchdirn -backwards
8434 if {$searchstring ne {}} {
8435 set sel [$ctext tag ranges sel]
8436 if {$sel ne {}} {
8437 set start [lindex $sel 0]
8438 } elseif {[catch {set start [$ctext index anchor]}]} {
8439 set start @0,[winfo height $ctext]
8441 set match [$ctext search -backwards -count ml -- $searchstring $start]
8442 $ctext tag remove sel 1.0 end
8443 if {$match eq {}} {
8444 bell
8445 return
8447 $ctext see $match
8448 suppress_highlighting_file_for_current_scrollpos
8449 highlightfile_for_scrollpos $match
8450 set mend "$match + $ml c"
8451 $ctext tag add sel $match $mend
8452 $ctext mark unset anchor
8453 rehighlight_search_results
8457 proc rehighlight_search_results {} {
8458 global ctext searchstring
8460 $ctext tag remove found 1.0 end
8461 $ctext tag remove currentsearchhit 1.0 end
8463 if {$searchstring ne {}} {
8464 searchmarkvisible 1
8468 proc searchmark {first last} {
8469 global ctext searchstring
8471 set sel [$ctext tag ranges sel]
8473 set mend $first.0
8474 while {1} {
8475 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8476 if {$match eq {}} break
8477 set mend "$match + $mlen c"
8478 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8479 $ctext tag add currentsearchhit $match $mend
8480 } else {
8481 $ctext tag add found $match $mend
8486 proc searchmarkvisible {doall} {
8487 global ctext smarktop smarkbot
8489 set topline [lindex [split [$ctext index @0,0] .] 0]
8490 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8491 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8492 # no overlap with previous
8493 searchmark $topline $botline
8494 set smarktop $topline
8495 set smarkbot $botline
8496 } else {
8497 if {$topline < $smarktop} {
8498 searchmark $topline [expr {$smarktop-1}]
8499 set smarktop $topline
8501 if {$botline > $smarkbot} {
8502 searchmark [expr {$smarkbot+1}] $botline
8503 set smarkbot $botline
8508 proc suppress_highlighting_file_for_current_scrollpos {} {
8509 global ctext suppress_highlighting_file_for_this_scrollpos
8511 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8514 proc scrolltext {f0 f1} {
8515 global searchstring cmitmode ctext
8516 global suppress_highlighting_file_for_this_scrollpos
8518 set topidx [$ctext index @0,0]
8519 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8520 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8521 highlightfile_for_scrollpos $topidx
8524 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8526 .bleft.bottom.sb set $f0 $f1
8527 if {$searchstring ne {}} {
8528 searchmarkvisible 0
8532 proc setcoords {} {
8533 global linespc charspc canvx0 canvy0
8534 global xspc1 xspc2 lthickness
8536 set linespc [font metrics mainfont -linespace]
8537 set charspc [font measure mainfont "m"]
8538 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8539 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8540 set lthickness [expr {int($linespc / 9) + 1}]
8541 set xspc1(0) $linespc
8542 set xspc2 $linespc
8545 proc redisplay {} {
8546 global canv
8547 global selectedline
8549 set ymax [lindex [$canv cget -scrollregion] 3]
8550 if {$ymax eq {} || $ymax == 0} return
8551 set span [$canv yview]
8552 clear_display
8553 setcanvscroll
8554 allcanvs yview moveto [lindex $span 0]
8555 drawvisible
8556 if {$selectedline ne {}} {
8557 selectline $selectedline 0
8558 allcanvs yview moveto [lindex $span 0]
8562 proc parsefont {f n} {
8563 global fontattr
8565 set fontattr($f,family) [lindex $n 0]
8566 set s [lindex $n 1]
8567 if {$s eq {} || $s == 0} {
8568 set s 10
8569 } elseif {$s < 0} {
8570 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8572 set fontattr($f,size) $s
8573 set fontattr($f,weight) normal
8574 set fontattr($f,slant) roman
8575 foreach style [lrange $n 2 end] {
8576 switch -- $style {
8577 "normal" -
8578 "bold" {set fontattr($f,weight) $style}
8579 "roman" -
8580 "italic" {set fontattr($f,slant) $style}
8585 proc fontflags {f {isbold 0}} {
8586 global fontattr
8588 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8589 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8590 -slant $fontattr($f,slant)]
8593 proc fontname {f} {
8594 global fontattr
8596 set n [list $fontattr($f,family) $fontattr($f,size)]
8597 if {$fontattr($f,weight) eq "bold"} {
8598 lappend n "bold"
8600 if {$fontattr($f,slant) eq "italic"} {
8601 lappend n "italic"
8603 return $n
8606 proc incrfont {inc} {
8607 global mainfont textfont ctext canv cflist showrefstop
8608 global stopped entries fontattr
8610 unmarkmatches
8611 set s $fontattr(mainfont,size)
8612 incr s $inc
8613 if {$s < 1} {
8614 set s 1
8616 set fontattr(mainfont,size) $s
8617 font config mainfont -size $s
8618 font config mainfontbold -size $s
8619 set mainfont [fontname mainfont]
8620 set s $fontattr(textfont,size)
8621 incr s $inc
8622 if {$s < 1} {
8623 set s 1
8625 set fontattr(textfont,size) $s
8626 font config textfont -size $s
8627 font config textfontbold -size $s
8628 set textfont [fontname textfont]
8629 setcoords
8630 settabs
8631 redisplay
8634 proc clearsha1 {} {
8635 global sha1entry sha1string
8636 if {[string length $sha1string] == 40} {
8637 $sha1entry delete 0 end
8641 proc sha1change {n1 n2 op} {
8642 global sha1string currentid sha1but
8643 if {$sha1string == {}
8644 || ([info exists currentid] && $sha1string == $currentid)} {
8645 set state disabled
8646 } else {
8647 set state normal
8649 if {[$sha1but cget -state] == $state} return
8650 if {$state == "normal"} {
8651 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8652 } else {
8653 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8657 proc gotocommit {} {
8658 global sha1string tagids headids curview varcid
8660 if {$sha1string == {}
8661 || ([info exists currentid] && $sha1string == $currentid)} return
8662 if {[info exists tagids($sha1string)]} {
8663 set id $tagids($sha1string)
8664 } elseif {[info exists headids($sha1string)]} {
8665 set id $headids($sha1string)
8666 } else {
8667 set id [string tolower $sha1string]
8668 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8669 set matches [longid $id]
8670 if {$matches ne {}} {
8671 if {[llength $matches] > 1} {
8672 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8673 return
8675 set id [lindex $matches 0]
8677 } else {
8678 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8679 error_popup [mc "Revision %s is not known" $sha1string]
8680 return
8684 if {[commitinview $id $curview]} {
8685 selectline [rowofcommit $id] 1
8686 return
8688 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8689 set msg [mc "SHA1 id %s is not known" $sha1string]
8690 } else {
8691 set msg [mc "Revision %s is not in the current view" $sha1string]
8693 error_popup $msg
8696 proc lineenter {x y id} {
8697 global hoverx hovery hoverid hovertimer
8698 global commitinfo canv
8700 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8701 set hoverx $x
8702 set hovery $y
8703 set hoverid $id
8704 if {[info exists hovertimer]} {
8705 after cancel $hovertimer
8707 set hovertimer [after 500 linehover]
8708 $canv delete hover
8711 proc linemotion {x y id} {
8712 global hoverx hovery hoverid hovertimer
8714 if {[info exists hoverid] && $id == $hoverid} {
8715 set hoverx $x
8716 set hovery $y
8717 if {[info exists hovertimer]} {
8718 after cancel $hovertimer
8720 set hovertimer [after 500 linehover]
8724 proc lineleave {id} {
8725 global hoverid hovertimer canv
8727 if {[info exists hoverid] && $id == $hoverid} {
8728 $canv delete hover
8729 if {[info exists hovertimer]} {
8730 after cancel $hovertimer
8731 unset hovertimer
8733 unset hoverid
8737 proc linehover {} {
8738 global hoverx hovery hoverid hovertimer
8739 global canv linespc lthickness
8740 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8742 global commitinfo
8744 set text [lindex $commitinfo($hoverid) 0]
8745 set ymax [lindex [$canv cget -scrollregion] 3]
8746 if {$ymax == {}} return
8747 set yfrac [lindex [$canv yview] 0]
8748 set x [expr {$hoverx + 2 * $linespc}]
8749 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8750 set x0 [expr {$x - 2 * $lthickness}]
8751 set y0 [expr {$y - 2 * $lthickness}]
8752 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8753 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8754 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8755 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8756 -width 1 -tags hover]
8757 $canv raise $t
8758 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8759 -font mainfont -fill $linehoverfgcolor]
8760 $canv raise $t
8763 proc clickisonarrow {id y} {
8764 global lthickness
8766 set ranges [rowranges $id]
8767 set thresh [expr {2 * $lthickness + 6}]
8768 set n [expr {[llength $ranges] - 1}]
8769 for {set i 1} {$i < $n} {incr i} {
8770 set row [lindex $ranges $i]
8771 if {abs([yc $row] - $y) < $thresh} {
8772 return $i
8775 return {}
8778 proc arrowjump {id n y} {
8779 global canv
8781 # 1 <-> 2, 3 <-> 4, etc...
8782 set n [expr {(($n - 1) ^ 1) + 1}]
8783 set row [lindex [rowranges $id] $n]
8784 set yt [yc $row]
8785 set ymax [lindex [$canv cget -scrollregion] 3]
8786 if {$ymax eq {} || $ymax <= 0} return
8787 set view [$canv yview]
8788 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8789 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8790 if {$yfrac < 0} {
8791 set yfrac 0
8793 allcanvs yview moveto $yfrac
8796 proc lineclick {x y id isnew} {
8797 global ctext commitinfo children canv thickerline curview
8799 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8800 unmarkmatches
8801 unselectline
8802 normalline
8803 $canv delete hover
8804 # draw this line thicker than normal
8805 set thickerline $id
8806 drawlines $id
8807 if {$isnew} {
8808 set ymax [lindex [$canv cget -scrollregion] 3]
8809 if {$ymax eq {}} return
8810 set yfrac [lindex [$canv yview] 0]
8811 set y [expr {$y + $yfrac * $ymax}]
8813 set dirn [clickisonarrow $id $y]
8814 if {$dirn ne {}} {
8815 arrowjump $id $dirn $y
8816 return
8819 if {$isnew} {
8820 addtohistory [list lineclick $x $y $id 0] savectextpos
8822 # fill the details pane with info about this line
8823 $ctext conf -state normal
8824 clear_ctext
8825 settabs 0
8826 $ctext insert end "[mc "Parent"]:\t"
8827 $ctext insert end $id link0
8828 setlink $id link0
8829 set info $commitinfo($id)
8830 $ctext insert end "\n\t[lindex $info 0]\n"
8831 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8832 set date [formatdate [lindex $info 2]]
8833 $ctext insert end "\t[mc "Date"]:\t$date\n"
8834 set kids $children($curview,$id)
8835 if {$kids ne {}} {
8836 $ctext insert end "\n[mc "Children"]:"
8837 set i 0
8838 foreach child $kids {
8839 incr i
8840 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8841 set info $commitinfo($child)
8842 $ctext insert end "\n\t"
8843 $ctext insert end $child link$i
8844 setlink $child link$i
8845 $ctext insert end "\n\t[lindex $info 0]"
8846 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8847 set date [formatdate [lindex $info 2]]
8848 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8851 maybe_scroll_ctext 1
8852 $ctext conf -state disabled
8853 init_flist {}
8856 proc normalline {} {
8857 global thickerline
8858 if {[info exists thickerline]} {
8859 set id $thickerline
8860 unset thickerline
8861 drawlines $id
8865 proc selbyid {id {isnew 1}} {
8866 global curview
8867 if {[commitinview $id $curview]} {
8868 selectline [rowofcommit $id] $isnew
8872 proc mstime {} {
8873 global startmstime
8874 if {![info exists startmstime]} {
8875 set startmstime [clock clicks -milliseconds]
8877 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8880 proc rowmenu {x y id} {
8881 global rowctxmenu selectedline rowmenuid curview
8882 global nullid nullid2 fakerowmenu mainhead markedid
8884 stopfinding
8885 set rowmenuid $id
8886 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8887 set state disabled
8888 } else {
8889 set state normal
8891 if {[info exists markedid] && $markedid ne $id} {
8892 set mstate normal
8893 } else {
8894 set mstate disabled
8896 if {$id ne $nullid && $id ne $nullid2} {
8897 set menu $rowctxmenu
8898 if {$mainhead ne {}} {
8899 $menu entryconfigure 8 -label [mc "Reset %s branch to here" $mainhead] -state normal
8900 } else {
8901 $menu entryconfigure 8 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8903 $menu entryconfigure 10 -state $mstate
8904 $menu entryconfigure 11 -state $mstate
8905 $menu entryconfigure 12 -state $mstate
8906 } else {
8907 set menu $fakerowmenu
8909 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8910 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8911 $menu entryconfigure [mca "Make patch"] -state $state
8912 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8913 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8914 tk_popup $menu $x $y
8917 proc markhere {} {
8918 global rowmenuid markedid canv
8920 set markedid $rowmenuid
8921 make_idmark $markedid
8924 proc gotomark {} {
8925 global markedid
8927 if {[info exists markedid]} {
8928 selbyid $markedid
8932 proc replace_by_kids {l r} {
8933 global curview children
8935 set id [commitonrow $r]
8936 set l [lreplace $l 0 0]
8937 foreach kid $children($curview,$id) {
8938 lappend l [rowofcommit $kid]
8940 return [lsort -integer -decreasing -unique $l]
8943 proc find_common_desc {} {
8944 global markedid rowmenuid curview children
8946 if {![info exists markedid]} return
8947 if {![commitinview $markedid $curview] ||
8948 ![commitinview $rowmenuid $curview]} return
8949 #set t1 [clock clicks -milliseconds]
8950 set l1 [list [rowofcommit $markedid]]
8951 set l2 [list [rowofcommit $rowmenuid]]
8952 while 1 {
8953 set r1 [lindex $l1 0]
8954 set r2 [lindex $l2 0]
8955 if {$r1 eq {} || $r2 eq {}} break
8956 if {$r1 == $r2} {
8957 selectline $r1 1
8958 break
8960 if {$r1 > $r2} {
8961 set l1 [replace_by_kids $l1 $r1]
8962 } else {
8963 set l2 [replace_by_kids $l2 $r2]
8966 #set t2 [clock clicks -milliseconds]
8967 #puts "took [expr {$t2-$t1}]ms"
8970 proc compare_commits {} {
8971 global markedid rowmenuid curview children
8973 if {![info exists markedid]} return
8974 if {![commitinview $markedid $curview]} return
8975 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8976 do_cmp_commits $markedid $rowmenuid
8979 proc getpatchid {id} {
8980 global patchids
8982 if {![info exists patchids($id)]} {
8983 set cmd [diffcmd [list $id] {-p --root}]
8984 # trim off the initial "|"
8985 set cmd [lrange $cmd 1 end]
8986 if {[catch {
8987 set x [eval exec $cmd | git patch-id]
8988 set patchids($id) [lindex $x 0]
8989 }]} {
8990 set patchids($id) "error"
8993 return $patchids($id)
8996 proc do_cmp_commits {a b} {
8997 global ctext curview parents children patchids commitinfo
8999 $ctext conf -state normal
9000 clear_ctext
9001 init_flist {}
9002 for {set i 0} {$i < 100} {incr i} {
9003 set skipa 0
9004 set skipb 0
9005 if {[llength $parents($curview,$a)] > 1} {
9006 appendshortlink $a [mc "Skipping merge commit "] "\n"
9007 set skipa 1
9008 } else {
9009 set patcha [getpatchid $a]
9011 if {[llength $parents($curview,$b)] > 1} {
9012 appendshortlink $b [mc "Skipping merge commit "] "\n"
9013 set skipb 1
9014 } else {
9015 set patchb [getpatchid $b]
9017 if {!$skipa && !$skipb} {
9018 set heada [lindex $commitinfo($a) 0]
9019 set headb [lindex $commitinfo($b) 0]
9020 if {$patcha eq "error"} {
9021 appendshortlink $a [mc "Error getting patch ID for "] \
9022 [mc " - stopping\n"]
9023 break
9025 if {$patchb eq "error"} {
9026 appendshortlink $b [mc "Error getting patch ID for "] \
9027 [mc " - stopping\n"]
9028 break
9030 if {$patcha eq $patchb} {
9031 if {$heada eq $headb} {
9032 appendshortlink $a [mc "Commit "]
9033 appendshortlink $b " == " " $heada\n"
9034 } else {
9035 appendshortlink $a [mc "Commit "] " $heada\n"
9036 appendshortlink $b [mc " is the same patch as\n "] \
9037 " $headb\n"
9039 set skipa 1
9040 set skipb 1
9041 } else {
9042 $ctext insert end "\n"
9043 appendshortlink $a [mc "Commit "] " $heada\n"
9044 appendshortlink $b [mc " differs from\n "] \
9045 " $headb\n"
9046 $ctext insert end [mc "Diff of commits:\n\n"]
9047 $ctext conf -state disabled
9048 update
9049 diffcommits $a $b
9050 return
9053 if {$skipa} {
9054 set kids [real_children $curview,$a]
9055 if {[llength $kids] != 1} {
9056 $ctext insert end "\n"
9057 appendshortlink $a [mc "Commit "] \
9058 [mc " has %s children - stopping\n" [llength $kids]]
9059 break
9061 set a [lindex $kids 0]
9063 if {$skipb} {
9064 set kids [real_children $curview,$b]
9065 if {[llength $kids] != 1} {
9066 appendshortlink $b [mc "Commit "] \
9067 [mc " has %s children - stopping\n" [llength $kids]]
9068 break
9070 set b [lindex $kids 0]
9073 $ctext conf -state disabled
9076 proc diffcommits {a b} {
9077 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9079 set tmpdir [gitknewtmpdir]
9080 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9081 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9082 if {[catch {
9083 exec git diff-tree -p --pretty $a >$fna
9084 exec git diff-tree -p --pretty $b >$fnb
9085 } err]} {
9086 error_popup [mc "Error writing commit to file: %s" $err]
9087 return
9089 if {[catch {
9090 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9091 } err]} {
9092 error_popup [mc "Error diffing commits: %s" $err]
9093 return
9095 set diffids [list commits $a $b]
9096 set blobdifffd($diffids) $fd
9097 set diffinhdr 0
9098 set currdiffsubmod ""
9099 filerun $fd [list getblobdiffline $fd $diffids]
9102 proc diffvssel {dirn} {
9103 global rowmenuid selectedline
9105 if {$selectedline eq {}} return
9106 if {$dirn} {
9107 set oldid [commitonrow $selectedline]
9108 set newid $rowmenuid
9109 } else {
9110 set oldid $rowmenuid
9111 set newid [commitonrow $selectedline]
9113 addtohistory [list doseldiff $oldid $newid] savectextpos
9114 doseldiff $oldid $newid
9117 proc diffvsmark {dirn} {
9118 global rowmenuid markedid
9120 if {![info exists markedid]} return
9121 if {$dirn} {
9122 set oldid $markedid
9123 set newid $rowmenuid
9124 } else {
9125 set oldid $rowmenuid
9126 set newid $markedid
9128 addtohistory [list doseldiff $oldid $newid] savectextpos
9129 doseldiff $oldid $newid
9132 proc doseldiff {oldid newid} {
9133 global ctext
9134 global commitinfo
9136 $ctext conf -state normal
9137 clear_ctext
9138 init_flist [mc "Top"]
9139 $ctext insert end "[mc "From"] "
9140 $ctext insert end $oldid link0
9141 setlink $oldid link0
9142 $ctext insert end "\n "
9143 $ctext insert end [lindex $commitinfo($oldid) 0]
9144 $ctext insert end "\n\n[mc "To"] "
9145 $ctext insert end $newid link1
9146 setlink $newid link1
9147 $ctext insert end "\n "
9148 $ctext insert end [lindex $commitinfo($newid) 0]
9149 $ctext insert end "\n"
9150 $ctext conf -state disabled
9151 $ctext tag remove found 1.0 end
9152 startdiff [list $oldid $newid]
9155 proc mkpatch {} {
9156 global rowmenuid currentid commitinfo patchtop patchnum NS
9158 if {![info exists currentid]} return
9159 set oldid $currentid
9160 set oldhead [lindex $commitinfo($oldid) 0]
9161 set newid $rowmenuid
9162 set newhead [lindex $commitinfo($newid) 0]
9163 set top .patch
9164 set patchtop $top
9165 catch {destroy $top}
9166 ttk_toplevel $top
9167 make_transient $top .
9168 ${NS}::label $top.title -text [mc "Generate patch"]
9169 grid $top.title - -pady 10
9170 ${NS}::label $top.from -text [mc "From:"]
9171 ${NS}::entry $top.fromsha1 -width 40
9172 $top.fromsha1 insert 0 $oldid
9173 $top.fromsha1 conf -state readonly
9174 grid $top.from $top.fromsha1 -sticky w
9175 ${NS}::entry $top.fromhead -width 60
9176 $top.fromhead insert 0 $oldhead
9177 $top.fromhead conf -state readonly
9178 grid x $top.fromhead -sticky w
9179 ${NS}::label $top.to -text [mc "To:"]
9180 ${NS}::entry $top.tosha1 -width 40
9181 $top.tosha1 insert 0 $newid
9182 $top.tosha1 conf -state readonly
9183 grid $top.to $top.tosha1 -sticky w
9184 ${NS}::entry $top.tohead -width 60
9185 $top.tohead insert 0 $newhead
9186 $top.tohead conf -state readonly
9187 grid x $top.tohead -sticky w
9188 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9189 grid $top.rev x -pady 10 -padx 5
9190 ${NS}::label $top.flab -text [mc "Output file:"]
9191 ${NS}::entry $top.fname -width 60
9192 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9193 incr patchnum
9194 grid $top.flab $top.fname -sticky w
9195 ${NS}::frame $top.buts
9196 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9197 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9198 bind $top <Key-Return> mkpatchgo
9199 bind $top <Key-Escape> mkpatchcan
9200 grid $top.buts.gen $top.buts.can
9201 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9202 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9203 grid $top.buts - -pady 10 -sticky ew
9204 focus $top.fname
9207 proc mkpatchrev {} {
9208 global patchtop
9210 set oldid [$patchtop.fromsha1 get]
9211 set oldhead [$patchtop.fromhead get]
9212 set newid [$patchtop.tosha1 get]
9213 set newhead [$patchtop.tohead get]
9214 foreach e [list fromsha1 fromhead tosha1 tohead] \
9215 v [list $newid $newhead $oldid $oldhead] {
9216 $patchtop.$e conf -state normal
9217 $patchtop.$e delete 0 end
9218 $patchtop.$e insert 0 $v
9219 $patchtop.$e conf -state readonly
9223 proc mkpatchgo {} {
9224 global patchtop nullid nullid2
9226 set oldid [$patchtop.fromsha1 get]
9227 set newid [$patchtop.tosha1 get]
9228 set fname [$patchtop.fname get]
9229 set cmd [diffcmd [list $oldid $newid] -p]
9230 # trim off the initial "|"
9231 set cmd [lrange $cmd 1 end]
9232 lappend cmd >$fname &
9233 if {[catch {eval exec $cmd} err]} {
9234 error_popup "[mc "Error creating patch:"] $err" $patchtop
9236 catch {destroy $patchtop}
9237 unset patchtop
9240 proc mkpatchcan {} {
9241 global patchtop
9243 catch {destroy $patchtop}
9244 unset patchtop
9247 proc mktag {} {
9248 global rowmenuid mktagtop commitinfo NS
9250 set top .maketag
9251 set mktagtop $top
9252 catch {destroy $top}
9253 ttk_toplevel $top
9254 make_transient $top .
9255 ${NS}::label $top.title -text [mc "Create tag"]
9256 grid $top.title - -pady 10
9257 ${NS}::label $top.id -text [mc "ID:"]
9258 ${NS}::entry $top.sha1 -width 40
9259 $top.sha1 insert 0 $rowmenuid
9260 $top.sha1 conf -state readonly
9261 grid $top.id $top.sha1 -sticky w
9262 ${NS}::entry $top.head -width 60
9263 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9264 $top.head conf -state readonly
9265 grid x $top.head -sticky w
9266 ${NS}::label $top.tlab -text [mc "Tag name:"]
9267 ${NS}::entry $top.tag -width 60
9268 grid $top.tlab $top.tag -sticky w
9269 ${NS}::label $top.op -text [mc "Tag message is optional"]
9270 grid $top.op -columnspan 2 -sticky we
9271 ${NS}::label $top.mlab -text [mc "Tag message:"]
9272 ${NS}::entry $top.msg -width 60
9273 grid $top.mlab $top.msg -sticky w
9274 ${NS}::frame $top.buts
9275 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9276 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9277 bind $top <Key-Return> mktaggo
9278 bind $top <Key-Escape> mktagcan
9279 grid $top.buts.gen $top.buts.can
9280 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9281 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9282 grid $top.buts - -pady 10 -sticky ew
9283 focus $top.tag
9286 proc domktag {} {
9287 global mktagtop env tagids idtags
9289 set id [$mktagtop.sha1 get]
9290 set tag [$mktagtop.tag get]
9291 set msg [$mktagtop.msg get]
9292 if {$tag == {}} {
9293 error_popup [mc "No tag name specified"] $mktagtop
9294 return 0
9296 if {[info exists tagids($tag)]} {
9297 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9298 return 0
9300 if {[catch {
9301 if {$msg != {}} {
9302 exec git tag -a -m $msg $tag $id
9303 } else {
9304 exec git tag $tag $id
9306 } err]} {
9307 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9308 return 0
9311 set tagids($tag) $id
9312 lappend idtags($id) $tag
9313 redrawtags $id
9314 addedtag $id
9315 dispneartags 0
9316 run refill_reflist
9317 return 1
9320 proc redrawtags {id} {
9321 global canv linehtag idpos currentid curview cmitlisted markedid
9322 global canvxmax iddrawn circleitem mainheadid circlecolors
9323 global mainheadcirclecolor
9325 if {![commitinview $id $curview]} return
9326 if {![info exists iddrawn($id)]} return
9327 set row [rowofcommit $id]
9328 if {$id eq $mainheadid} {
9329 set ofill $mainheadcirclecolor
9330 } else {
9331 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9333 $canv itemconf $circleitem($row) -fill $ofill
9334 $canv delete tag.$id
9335 set xt [eval drawtags $id $idpos($id)]
9336 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9337 set text [$canv itemcget $linehtag($id) -text]
9338 set font [$canv itemcget $linehtag($id) -font]
9339 set xr [expr {$xt + [font measure $font $text]}]
9340 if {$xr > $canvxmax} {
9341 set canvxmax $xr
9342 setcanvscroll
9344 if {[info exists currentid] && $currentid == $id} {
9345 make_secsel $id
9347 if {[info exists markedid] && $markedid eq $id} {
9348 make_idmark $id
9352 proc mktagcan {} {
9353 global mktagtop
9355 catch {destroy $mktagtop}
9356 unset mktagtop
9359 proc mktaggo {} {
9360 if {![domktag]} return
9361 mktagcan
9364 proc copysummary {} {
9365 global rowmenuid autosellen
9367 set format "%h (\"%s\", %ad)"
9368 set cmd [list git show -s --pretty=format:$format --date=short]
9369 if {$autosellen < 40} {
9370 lappend cmd --abbrev=$autosellen
9372 set summary [eval exec $cmd $rowmenuid]
9374 clipboard clear
9375 clipboard append $summary
9378 proc writecommit {} {
9379 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9381 set top .writecommit
9382 set wrcomtop $top
9383 catch {destroy $top}
9384 ttk_toplevel $top
9385 make_transient $top .
9386 ${NS}::label $top.title -text [mc "Write commit to file"]
9387 grid $top.title - -pady 10
9388 ${NS}::label $top.id -text [mc "ID:"]
9389 ${NS}::entry $top.sha1 -width 40
9390 $top.sha1 insert 0 $rowmenuid
9391 $top.sha1 conf -state readonly
9392 grid $top.id $top.sha1 -sticky w
9393 ${NS}::entry $top.head -width 60
9394 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9395 $top.head conf -state readonly
9396 grid x $top.head -sticky w
9397 ${NS}::label $top.clab -text [mc "Command:"]
9398 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9399 grid $top.clab $top.cmd -sticky w -pady 10
9400 ${NS}::label $top.flab -text [mc "Output file:"]
9401 ${NS}::entry $top.fname -width 60
9402 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9403 grid $top.flab $top.fname -sticky w
9404 ${NS}::frame $top.buts
9405 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9406 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9407 bind $top <Key-Return> wrcomgo
9408 bind $top <Key-Escape> wrcomcan
9409 grid $top.buts.gen $top.buts.can
9410 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9411 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9412 grid $top.buts - -pady 10 -sticky ew
9413 focus $top.fname
9416 proc wrcomgo {} {
9417 global wrcomtop
9419 set id [$wrcomtop.sha1 get]
9420 set cmd "echo $id | [$wrcomtop.cmd get]"
9421 set fname [$wrcomtop.fname get]
9422 if {[catch {exec sh -c $cmd >$fname &} err]} {
9423 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9425 catch {destroy $wrcomtop}
9426 unset wrcomtop
9429 proc wrcomcan {} {
9430 global wrcomtop
9432 catch {destroy $wrcomtop}
9433 unset wrcomtop
9436 proc mkbranch {} {
9437 global rowmenuid mkbrtop NS
9439 set top .makebranch
9440 catch {destroy $top}
9441 ttk_toplevel $top
9442 make_transient $top .
9443 ${NS}::label $top.title -text [mc "Create new branch"]
9444 grid $top.title - -pady 10
9445 ${NS}::label $top.id -text [mc "ID:"]
9446 ${NS}::entry $top.sha1 -width 40
9447 $top.sha1 insert 0 $rowmenuid
9448 $top.sha1 conf -state readonly
9449 grid $top.id $top.sha1 -sticky w
9450 ${NS}::label $top.nlab -text [mc "Name:"]
9451 ${NS}::entry $top.name -width 40
9452 grid $top.nlab $top.name -sticky w
9453 ${NS}::frame $top.buts
9454 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9455 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9456 bind $top <Key-Return> [list mkbrgo $top]
9457 bind $top <Key-Escape> "catch {destroy $top}"
9458 grid $top.buts.go $top.buts.can
9459 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9460 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9461 grid $top.buts - -pady 10 -sticky ew
9462 focus $top.name
9465 proc mkbrgo {top} {
9466 global headids idheads
9468 set name [$top.name get]
9469 set id [$top.sha1 get]
9470 set cmdargs {}
9471 set old_id {}
9472 if {$name eq {}} {
9473 error_popup [mc "Please specify a name for the new branch"] $top
9474 return
9476 if {[info exists headids($name)]} {
9477 if {![confirm_popup [mc \
9478 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9479 return
9481 set old_id $headids($name)
9482 lappend cmdargs -f
9484 catch {destroy $top}
9485 lappend cmdargs $name $id
9486 nowbusy newbranch
9487 update
9488 if {[catch {
9489 eval exec git branch $cmdargs
9490 } err]} {
9491 notbusy newbranch
9492 error_popup $err
9493 } else {
9494 notbusy newbranch
9495 if {$old_id ne {}} {
9496 movehead $id $name
9497 movedhead $id $name
9498 redrawtags $old_id
9499 redrawtags $id
9500 } else {
9501 set headids($name) $id
9502 lappend idheads($id) $name
9503 addedhead $id $name
9504 redrawtags $id
9506 dispneartags 0
9507 run refill_reflist
9511 proc exec_citool {tool_args {baseid {}}} {
9512 global commitinfo env
9514 set save_env [array get env GIT_AUTHOR_*]
9516 if {$baseid ne {}} {
9517 if {![info exists commitinfo($baseid)]} {
9518 getcommit $baseid
9520 set author [lindex $commitinfo($baseid) 1]
9521 set date [lindex $commitinfo($baseid) 2]
9522 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9523 $author author name email]
9524 && $date ne {}} {
9525 set env(GIT_AUTHOR_NAME) $name
9526 set env(GIT_AUTHOR_EMAIL) $email
9527 set env(GIT_AUTHOR_DATE) $date
9531 eval exec git citool $tool_args &
9533 array unset env GIT_AUTHOR_*
9534 array set env $save_env
9537 proc cherrypick {} {
9538 global rowmenuid curview
9539 global mainhead mainheadid
9540 global gitdir
9542 set oldhead [exec git rev-parse HEAD]
9543 set dheads [descheads $rowmenuid]
9544 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9545 set ok [confirm_popup [mc "Commit %s is already\
9546 included in branch %s -- really re-apply it?" \
9547 [string range $rowmenuid 0 7] $mainhead]]
9548 if {!$ok} return
9550 nowbusy cherrypick [mc "Cherry-picking"]
9551 update
9552 # Unfortunately git-cherry-pick writes stuff to stderr even when
9553 # no error occurs, and exec takes that as an indication of error...
9554 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9555 notbusy cherrypick
9556 if {[regexp -line \
9557 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9558 $err msg fname]} {
9559 error_popup [mc "Cherry-pick failed because of local changes\
9560 to file '%s'.\nPlease commit, reset or stash\
9561 your changes and try again." $fname]
9562 } elseif {[regexp -line \
9563 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9564 $err]} {
9565 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9566 conflict.\nDo you wish to run git citool to\
9567 resolve it?"]]} {
9568 # Force citool to read MERGE_MSG
9569 file delete [file join $gitdir "GITGUI_MSG"]
9570 exec_citool {} $rowmenuid
9572 } else {
9573 error_popup $err
9575 run updatecommits
9576 return
9578 set newhead [exec git rev-parse HEAD]
9579 if {$newhead eq $oldhead} {
9580 notbusy cherrypick
9581 error_popup [mc "No changes committed"]
9582 return
9584 addnewchild $newhead $oldhead
9585 if {[commitinview $oldhead $curview]} {
9586 # XXX this isn't right if we have a path limit...
9587 insertrow $newhead $oldhead $curview
9588 if {$mainhead ne {}} {
9589 movehead $newhead $mainhead
9590 movedhead $newhead $mainhead
9592 set mainheadid $newhead
9593 redrawtags $oldhead
9594 redrawtags $newhead
9595 selbyid $newhead
9597 notbusy cherrypick
9600 proc revert {} {
9601 global rowmenuid curview
9602 global mainhead mainheadid
9603 global gitdir
9605 set oldhead [exec git rev-parse HEAD]
9606 set dheads [descheads $rowmenuid]
9607 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9608 set ok [confirm_popup [mc "Commit %s is not\
9609 included in branch %s -- really revert it?" \
9610 [string range $rowmenuid 0 7] $mainhead]]
9611 if {!$ok} return
9613 nowbusy revert [mc "Reverting"]
9614 update
9616 if [catch {exec git revert --no-edit $rowmenuid} err] {
9617 notbusy revert
9618 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9619 $err match files] {
9620 regsub {\n( |\t)+} $files "\n" files
9621 error_popup [mc "Revert failed because of local changes to\
9622 the following files:%s Please commit, reset or stash \
9623 your changes and try again." $files]
9624 } elseif [regexp {error: could not revert} $err] {
9625 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9626 Do you wish to run git citool to resolve it?"]] {
9627 # Force citool to read MERGE_MSG
9628 file delete [file join $gitdir "GITGUI_MSG"]
9629 exec_citool {} $rowmenuid
9631 } else { error_popup $err }
9632 run updatecommits
9633 return
9636 set newhead [exec git rev-parse HEAD]
9637 if { $newhead eq $oldhead } {
9638 notbusy revert
9639 error_popup [mc "No changes committed"]
9640 return
9643 addnewchild $newhead $oldhead
9645 if [commitinview $oldhead $curview] {
9646 # XXX this isn't right if we have a path limit...
9647 insertrow $newhead $oldhead $curview
9648 if {$mainhead ne {}} {
9649 movehead $newhead $mainhead
9650 movedhead $newhead $mainhead
9652 set mainheadid $newhead
9653 redrawtags $oldhead
9654 redrawtags $newhead
9655 selbyid $newhead
9658 notbusy revert
9661 proc resethead {} {
9662 global mainhead rowmenuid confirm_ok resettype NS
9664 set confirm_ok 0
9665 set w ".confirmreset"
9666 ttk_toplevel $w
9667 make_transient $w .
9668 wm title $w [mc "Confirm reset"]
9669 ${NS}::label $w.m -text \
9670 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9671 pack $w.m -side top -fill x -padx 20 -pady 20
9672 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9673 set resettype mixed
9674 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9675 -text [mc "Soft: Leave working tree and index untouched"]
9676 grid $w.f.soft -sticky w
9677 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9678 -text [mc "Mixed: Leave working tree untouched, reset index"]
9679 grid $w.f.mixed -sticky w
9680 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9681 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9682 grid $w.f.hard -sticky w
9683 pack $w.f -side top -fill x -padx 4
9684 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9685 pack $w.ok -side left -fill x -padx 20 -pady 20
9686 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9687 bind $w <Key-Escape> [list destroy $w]
9688 pack $w.cancel -side right -fill x -padx 20 -pady 20
9689 bind $w <Visibility> "grab $w; focus $w"
9690 tkwait window $w
9691 if {!$confirm_ok} return
9692 if {[catch {set fd [open \
9693 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9694 error_popup $err
9695 } else {
9696 dohidelocalchanges
9697 filerun $fd [list readresetstat $fd]
9698 nowbusy reset [mc "Resetting"]
9699 selbyid $rowmenuid
9703 proc readresetstat {fd} {
9704 global mainhead mainheadid showlocalchanges rprogcoord
9706 if {[gets $fd line] >= 0} {
9707 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9708 set rprogcoord [expr {1.0 * $m / $n}]
9709 adjustprogress
9711 return 1
9713 set rprogcoord 0
9714 adjustprogress
9715 notbusy reset
9716 if {[catch {close $fd} err]} {
9717 error_popup $err
9719 set oldhead $mainheadid
9720 set newhead [exec git rev-parse HEAD]
9721 if {$newhead ne $oldhead} {
9722 movehead $newhead $mainhead
9723 movedhead $newhead $mainhead
9724 set mainheadid $newhead
9725 redrawtags $oldhead
9726 redrawtags $newhead
9728 if {$showlocalchanges} {
9729 doshowlocalchanges
9731 return 0
9734 # context menu for a head
9735 proc headmenu {x y id head} {
9736 global headmenuid headmenuhead headctxmenu mainhead
9738 stopfinding
9739 set headmenuid $id
9740 set headmenuhead $head
9741 set state normal
9742 if {[string match "remotes/*" $head]} {
9743 set state disabled
9745 if {$head eq $mainhead} {
9746 set state disabled
9748 $headctxmenu entryconfigure 0 -state $state
9749 $headctxmenu entryconfigure 1 -state $state
9750 tk_popup $headctxmenu $x $y
9753 proc cobranch {} {
9754 global headmenuid headmenuhead headids
9755 global showlocalchanges
9757 # check the tree is clean first??
9758 nowbusy checkout [mc "Checking out"]
9759 update
9760 dohidelocalchanges
9761 if {[catch {
9762 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9763 } err]} {
9764 notbusy checkout
9765 error_popup $err
9766 if {$showlocalchanges} {
9767 dodiffindex
9769 } else {
9770 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9774 proc readcheckoutstat {fd newhead newheadid} {
9775 global mainhead mainheadid headids showlocalchanges progresscoords
9776 global viewmainheadid curview
9778 if {[gets $fd line] >= 0} {
9779 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9780 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9781 adjustprogress
9783 return 1
9785 set progresscoords {0 0}
9786 adjustprogress
9787 notbusy checkout
9788 if {[catch {close $fd} err]} {
9789 error_popup $err
9791 set oldmainid $mainheadid
9792 set mainhead $newhead
9793 set mainheadid $newheadid
9794 set viewmainheadid($curview) $newheadid
9795 redrawtags $oldmainid
9796 redrawtags $newheadid
9797 selbyid $newheadid
9798 if {$showlocalchanges} {
9799 dodiffindex
9803 proc rmbranch {} {
9804 global headmenuid headmenuhead mainhead
9805 global idheads
9807 set head $headmenuhead
9808 set id $headmenuid
9809 # this check shouldn't be needed any more...
9810 if {$head eq $mainhead} {
9811 error_popup [mc "Cannot delete the currently checked-out branch"]
9812 return
9814 set dheads [descheads $id]
9815 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9816 # the stuff on this branch isn't on any other branch
9817 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9818 branch.\nReally delete branch %s?" $head $head]]} return
9820 nowbusy rmbranch
9821 update
9822 if {[catch {exec git branch -D $head} err]} {
9823 notbusy rmbranch
9824 error_popup $err
9825 return
9827 removehead $id $head
9828 removedhead $id $head
9829 redrawtags $id
9830 notbusy rmbranch
9831 dispneartags 0
9832 run refill_reflist
9835 # Display a list of tags and heads
9836 proc showrefs {} {
9837 global showrefstop bgcolor fgcolor selectbgcolor NS
9838 global bglist fglist reflistfilter reflist maincursor
9840 set top .showrefs
9841 set showrefstop $top
9842 if {[winfo exists $top]} {
9843 raise $top
9844 refill_reflist
9845 return
9847 ttk_toplevel $top
9848 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9849 make_transient $top .
9850 text $top.list -background $bgcolor -foreground $fgcolor \
9851 -selectbackground $selectbgcolor -font mainfont \
9852 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9853 -width 30 -height 20 -cursor $maincursor \
9854 -spacing1 1 -spacing3 1 -state disabled
9855 $top.list tag configure highlight -background $selectbgcolor
9856 if {![lsearch -exact $bglist $top.list]} {
9857 lappend bglist $top.list
9858 lappend fglist $top.list
9860 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9861 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9862 grid $top.list $top.ysb -sticky nsew
9863 grid $top.xsb x -sticky ew
9864 ${NS}::frame $top.f
9865 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9866 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9867 set reflistfilter "*"
9868 trace add variable reflistfilter write reflistfilter_change
9869 pack $top.f.e -side right -fill x -expand 1
9870 pack $top.f.l -side left
9871 grid $top.f - -sticky ew -pady 2
9872 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9873 bind $top <Key-Escape> [list destroy $top]
9874 grid $top.close -
9875 grid columnconfigure $top 0 -weight 1
9876 grid rowconfigure $top 0 -weight 1
9877 bind $top.list <1> {break}
9878 bind $top.list <B1-Motion> {break}
9879 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9880 set reflist {}
9881 refill_reflist
9884 proc sel_reflist {w x y} {
9885 global showrefstop reflist headids tagids otherrefids
9887 if {![winfo exists $showrefstop]} return
9888 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9889 set ref [lindex $reflist [expr {$l-1}]]
9890 set n [lindex $ref 0]
9891 switch -- [lindex $ref 1] {
9892 "H" {selbyid $headids($n)}
9893 "T" {selbyid $tagids($n)}
9894 "o" {selbyid $otherrefids($n)}
9896 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9899 proc unsel_reflist {} {
9900 global showrefstop
9902 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9903 $showrefstop.list tag remove highlight 0.0 end
9906 proc reflistfilter_change {n1 n2 op} {
9907 global reflistfilter
9909 after cancel refill_reflist
9910 after 200 refill_reflist
9913 proc refill_reflist {} {
9914 global reflist reflistfilter showrefstop headids tagids otherrefids
9915 global curview
9917 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9918 set refs {}
9919 foreach n [array names headids] {
9920 if {[string match $reflistfilter $n]} {
9921 if {[commitinview $headids($n) $curview]} {
9922 lappend refs [list $n H]
9923 } else {
9924 interestedin $headids($n) {run refill_reflist}
9928 foreach n [array names tagids] {
9929 if {[string match $reflistfilter $n]} {
9930 if {[commitinview $tagids($n) $curview]} {
9931 lappend refs [list $n T]
9932 } else {
9933 interestedin $tagids($n) {run refill_reflist}
9937 foreach n [array names otherrefids] {
9938 if {[string match $reflistfilter $n]} {
9939 if {[commitinview $otherrefids($n) $curview]} {
9940 lappend refs [list $n o]
9941 } else {
9942 interestedin $otherrefids($n) {run refill_reflist}
9946 set refs [lsort -index 0 $refs]
9947 if {$refs eq $reflist} return
9949 # Update the contents of $showrefstop.list according to the
9950 # differences between $reflist (old) and $refs (new)
9951 $showrefstop.list conf -state normal
9952 $showrefstop.list insert end "\n"
9953 set i 0
9954 set j 0
9955 while {$i < [llength $reflist] || $j < [llength $refs]} {
9956 if {$i < [llength $reflist]} {
9957 if {$j < [llength $refs]} {
9958 set cmp [string compare [lindex $reflist $i 0] \
9959 [lindex $refs $j 0]]
9960 if {$cmp == 0} {
9961 set cmp [string compare [lindex $reflist $i 1] \
9962 [lindex $refs $j 1]]
9964 } else {
9965 set cmp -1
9967 } else {
9968 set cmp 1
9970 switch -- $cmp {
9971 -1 {
9972 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9973 incr i
9976 incr i
9977 incr j
9980 set l [expr {$j + 1}]
9981 $showrefstop.list image create $l.0 -align baseline \
9982 -image reficon-[lindex $refs $j 1] -padx 2
9983 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9984 incr j
9988 set reflist $refs
9989 # delete last newline
9990 $showrefstop.list delete end-2c end-1c
9991 $showrefstop.list conf -state disabled
9994 # Stuff for finding nearby tags
9995 proc getallcommits {} {
9996 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9997 global idheads idtags idotherrefs allparents tagobjid
9998 global gitdir
10000 if {![info exists allcommits]} {
10001 set nextarc 0
10002 set allcommits 0
10003 set seeds {}
10004 set allcwait 0
10005 set cachedarcs 0
10006 set allccache [file join $gitdir "gitk.cache"]
10007 if {![catch {
10008 set f [open $allccache r]
10009 set allcwait 1
10010 getcache $f
10011 }]} return
10014 if {$allcwait} {
10015 return
10017 set cmd [list | git rev-list --parents]
10018 set allcupdate [expr {$seeds ne {}}]
10019 if {!$allcupdate} {
10020 set ids "--all"
10021 } else {
10022 set refs [concat [array names idheads] [array names idtags] \
10023 [array names idotherrefs]]
10024 set ids {}
10025 set tagobjs {}
10026 foreach name [array names tagobjid] {
10027 lappend tagobjs $tagobjid($name)
10029 foreach id [lsort -unique $refs] {
10030 if {![info exists allparents($id)] &&
10031 [lsearch -exact $tagobjs $id] < 0} {
10032 lappend ids $id
10035 if {$ids ne {}} {
10036 foreach id $seeds {
10037 lappend ids "^$id"
10041 if {$ids ne {}} {
10042 set fd [open [concat $cmd $ids] r]
10043 fconfigure $fd -blocking 0
10044 incr allcommits
10045 nowbusy allcommits
10046 filerun $fd [list getallclines $fd]
10047 } else {
10048 dispneartags 0
10052 # Since most commits have 1 parent and 1 child, we group strings of
10053 # such commits into "arcs" joining branch/merge points (BMPs), which
10054 # are commits that either don't have 1 parent or don't have 1 child.
10056 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10057 # arcout(id) - outgoing arcs for BMP
10058 # arcids(a) - list of IDs on arc including end but not start
10059 # arcstart(a) - BMP ID at start of arc
10060 # arcend(a) - BMP ID at end of arc
10061 # growing(a) - arc a is still growing
10062 # arctags(a) - IDs out of arcids (excluding end) that have tags
10063 # archeads(a) - IDs out of arcids (excluding end) that have heads
10064 # The start of an arc is at the descendent end, so "incoming" means
10065 # coming from descendents, and "outgoing" means going towards ancestors.
10067 proc getallclines {fd} {
10068 global allparents allchildren idtags idheads nextarc
10069 global arcnos arcids arctags arcout arcend arcstart archeads growing
10070 global seeds allcommits cachedarcs allcupdate
10072 set nid 0
10073 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10074 set id [lindex $line 0]
10075 if {[info exists allparents($id)]} {
10076 # seen it already
10077 continue
10079 set cachedarcs 0
10080 set olds [lrange $line 1 end]
10081 set allparents($id) $olds
10082 if {![info exists allchildren($id)]} {
10083 set allchildren($id) {}
10084 set arcnos($id) {}
10085 lappend seeds $id
10086 } else {
10087 set a $arcnos($id)
10088 if {[llength $olds] == 1 && [llength $a] == 1} {
10089 lappend arcids($a) $id
10090 if {[info exists idtags($id)]} {
10091 lappend arctags($a) $id
10093 if {[info exists idheads($id)]} {
10094 lappend archeads($a) $id
10096 if {[info exists allparents($olds)]} {
10097 # seen parent already
10098 if {![info exists arcout($olds)]} {
10099 splitarc $olds
10101 lappend arcids($a) $olds
10102 set arcend($a) $olds
10103 unset growing($a)
10105 lappend allchildren($olds) $id
10106 lappend arcnos($olds) $a
10107 continue
10110 foreach a $arcnos($id) {
10111 lappend arcids($a) $id
10112 set arcend($a) $id
10113 unset growing($a)
10116 set ao {}
10117 foreach p $olds {
10118 lappend allchildren($p) $id
10119 set a [incr nextarc]
10120 set arcstart($a) $id
10121 set archeads($a) {}
10122 set arctags($a) {}
10123 set archeads($a) {}
10124 set arcids($a) {}
10125 lappend ao $a
10126 set growing($a) 1
10127 if {[info exists allparents($p)]} {
10128 # seen it already, may need to make a new branch
10129 if {![info exists arcout($p)]} {
10130 splitarc $p
10132 lappend arcids($a) $p
10133 set arcend($a) $p
10134 unset growing($a)
10136 lappend arcnos($p) $a
10138 set arcout($id) $ao
10140 if {$nid > 0} {
10141 global cached_dheads cached_dtags cached_atags
10142 unset -nocomplain cached_dheads
10143 unset -nocomplain cached_dtags
10144 unset -nocomplain cached_atags
10146 if {![eof $fd]} {
10147 return [expr {$nid >= 1000? 2: 1}]
10149 set cacheok 1
10150 if {[catch {
10151 fconfigure $fd -blocking 1
10152 close $fd
10153 } err]} {
10154 # got an error reading the list of commits
10155 # if we were updating, try rereading the whole thing again
10156 if {$allcupdate} {
10157 incr allcommits -1
10158 dropcache $err
10159 return
10161 error_popup "[mc "Error reading commit topology information;\
10162 branch and preceding/following tag information\
10163 will be incomplete."]\n($err)"
10164 set cacheok 0
10166 if {[incr allcommits -1] == 0} {
10167 notbusy allcommits
10168 if {$cacheok} {
10169 run savecache
10172 dispneartags 0
10173 return 0
10176 proc recalcarc {a} {
10177 global arctags archeads arcids idtags idheads
10179 set at {}
10180 set ah {}
10181 foreach id [lrange $arcids($a) 0 end-1] {
10182 if {[info exists idtags($id)]} {
10183 lappend at $id
10185 if {[info exists idheads($id)]} {
10186 lappend ah $id
10189 set arctags($a) $at
10190 set archeads($a) $ah
10193 proc splitarc {p} {
10194 global arcnos arcids nextarc arctags archeads idtags idheads
10195 global arcstart arcend arcout allparents growing
10197 set a $arcnos($p)
10198 if {[llength $a] != 1} {
10199 puts "oops splitarc called but [llength $a] arcs already"
10200 return
10202 set a [lindex $a 0]
10203 set i [lsearch -exact $arcids($a) $p]
10204 if {$i < 0} {
10205 puts "oops splitarc $p not in arc $a"
10206 return
10208 set na [incr nextarc]
10209 if {[info exists arcend($a)]} {
10210 set arcend($na) $arcend($a)
10211 } else {
10212 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10213 set j [lsearch -exact $arcnos($l) $a]
10214 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10216 set tail [lrange $arcids($a) [expr {$i+1}] end]
10217 set arcids($a) [lrange $arcids($a) 0 $i]
10218 set arcend($a) $p
10219 set arcstart($na) $p
10220 set arcout($p) $na
10221 set arcids($na) $tail
10222 if {[info exists growing($a)]} {
10223 set growing($na) 1
10224 unset growing($a)
10227 foreach id $tail {
10228 if {[llength $arcnos($id)] == 1} {
10229 set arcnos($id) $na
10230 } else {
10231 set j [lsearch -exact $arcnos($id) $a]
10232 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10236 # reconstruct tags and heads lists
10237 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10238 recalcarc $a
10239 recalcarc $na
10240 } else {
10241 set arctags($na) {}
10242 set archeads($na) {}
10246 # Update things for a new commit added that is a child of one
10247 # existing commit. Used when cherry-picking.
10248 proc addnewchild {id p} {
10249 global allparents allchildren idtags nextarc
10250 global arcnos arcids arctags arcout arcend arcstart archeads growing
10251 global seeds allcommits
10253 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10254 set allparents($id) [list $p]
10255 set allchildren($id) {}
10256 set arcnos($id) {}
10257 lappend seeds $id
10258 lappend allchildren($p) $id
10259 set a [incr nextarc]
10260 set arcstart($a) $id
10261 set archeads($a) {}
10262 set arctags($a) {}
10263 set arcids($a) [list $p]
10264 set arcend($a) $p
10265 if {![info exists arcout($p)]} {
10266 splitarc $p
10268 lappend arcnos($p) $a
10269 set arcout($id) [list $a]
10272 # This implements a cache for the topology information.
10273 # The cache saves, for each arc, the start and end of the arc,
10274 # the ids on the arc, and the outgoing arcs from the end.
10275 proc readcache {f} {
10276 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10277 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10278 global allcwait
10280 set a $nextarc
10281 set lim $cachedarcs
10282 if {$lim - $a > 500} {
10283 set lim [expr {$a + 500}]
10285 if {[catch {
10286 if {$a == $lim} {
10287 # finish reading the cache and setting up arctags, etc.
10288 set line [gets $f]
10289 if {$line ne "1"} {error "bad final version"}
10290 close $f
10291 foreach id [array names idtags] {
10292 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10293 [llength $allparents($id)] == 1} {
10294 set a [lindex $arcnos($id) 0]
10295 if {$arctags($a) eq {}} {
10296 recalcarc $a
10300 foreach id [array names idheads] {
10301 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10302 [llength $allparents($id)] == 1} {
10303 set a [lindex $arcnos($id) 0]
10304 if {$archeads($a) eq {}} {
10305 recalcarc $a
10309 foreach id [lsort -unique $possible_seeds] {
10310 if {$arcnos($id) eq {}} {
10311 lappend seeds $id
10314 set allcwait 0
10315 } else {
10316 while {[incr a] <= $lim} {
10317 set line [gets $f]
10318 if {[llength $line] != 3} {error "bad line"}
10319 set s [lindex $line 0]
10320 set arcstart($a) $s
10321 lappend arcout($s) $a
10322 if {![info exists arcnos($s)]} {
10323 lappend possible_seeds $s
10324 set arcnos($s) {}
10326 set e [lindex $line 1]
10327 if {$e eq {}} {
10328 set growing($a) 1
10329 } else {
10330 set arcend($a) $e
10331 if {![info exists arcout($e)]} {
10332 set arcout($e) {}
10335 set arcids($a) [lindex $line 2]
10336 foreach id $arcids($a) {
10337 lappend allparents($s) $id
10338 set s $id
10339 lappend arcnos($id) $a
10341 if {![info exists allparents($s)]} {
10342 set allparents($s) {}
10344 set arctags($a) {}
10345 set archeads($a) {}
10347 set nextarc [expr {$a - 1}]
10349 } err]} {
10350 dropcache $err
10351 return 0
10353 if {!$allcwait} {
10354 getallcommits
10356 return $allcwait
10359 proc getcache {f} {
10360 global nextarc cachedarcs possible_seeds
10362 if {[catch {
10363 set line [gets $f]
10364 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10365 # make sure it's an integer
10366 set cachedarcs [expr {int([lindex $line 1])}]
10367 if {$cachedarcs < 0} {error "bad number of arcs"}
10368 set nextarc 0
10369 set possible_seeds {}
10370 run readcache $f
10371 } err]} {
10372 dropcache $err
10374 return 0
10377 proc dropcache {err} {
10378 global allcwait nextarc cachedarcs seeds
10380 #puts "dropping cache ($err)"
10381 foreach v {arcnos arcout arcids arcstart arcend growing \
10382 arctags archeads allparents allchildren} {
10383 global $v
10384 unset -nocomplain $v
10386 set allcwait 0
10387 set nextarc 0
10388 set cachedarcs 0
10389 set seeds {}
10390 getallcommits
10393 proc writecache {f} {
10394 global cachearc cachedarcs allccache
10395 global arcstart arcend arcnos arcids arcout
10397 set a $cachearc
10398 set lim $cachedarcs
10399 if {$lim - $a > 1000} {
10400 set lim [expr {$a + 1000}]
10402 if {[catch {
10403 while {[incr a] <= $lim} {
10404 if {[info exists arcend($a)]} {
10405 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10406 } else {
10407 puts $f [list $arcstart($a) {} $arcids($a)]
10410 } err]} {
10411 catch {close $f}
10412 catch {file delete $allccache}
10413 #puts "writing cache failed ($err)"
10414 return 0
10416 set cachearc [expr {$a - 1}]
10417 if {$a > $cachedarcs} {
10418 puts $f "1"
10419 close $f
10420 return 0
10422 return 1
10425 proc savecache {} {
10426 global nextarc cachedarcs cachearc allccache
10428 if {$nextarc == $cachedarcs} return
10429 set cachearc 0
10430 set cachedarcs $nextarc
10431 catch {
10432 set f [open $allccache w]
10433 puts $f [list 1 $cachedarcs]
10434 run writecache $f
10438 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10439 # or 0 if neither is true.
10440 proc anc_or_desc {a b} {
10441 global arcout arcstart arcend arcnos cached_isanc
10443 if {$arcnos($a) eq $arcnos($b)} {
10444 # Both are on the same arc(s); either both are the same BMP,
10445 # or if one is not a BMP, the other is also not a BMP or is
10446 # the BMP at end of the arc (and it only has 1 incoming arc).
10447 # Or both can be BMPs with no incoming arcs.
10448 if {$a eq $b || $arcnos($a) eq {}} {
10449 return 0
10451 # assert {[llength $arcnos($a)] == 1}
10452 set arc [lindex $arcnos($a) 0]
10453 set i [lsearch -exact $arcids($arc) $a]
10454 set j [lsearch -exact $arcids($arc) $b]
10455 if {$i < 0 || $i > $j} {
10456 return 1
10457 } else {
10458 return -1
10462 if {![info exists arcout($a)]} {
10463 set arc [lindex $arcnos($a) 0]
10464 if {[info exists arcend($arc)]} {
10465 set aend $arcend($arc)
10466 } else {
10467 set aend {}
10469 set a $arcstart($arc)
10470 } else {
10471 set aend $a
10473 if {![info exists arcout($b)]} {
10474 set arc [lindex $arcnos($b) 0]
10475 if {[info exists arcend($arc)]} {
10476 set bend $arcend($arc)
10477 } else {
10478 set bend {}
10480 set b $arcstart($arc)
10481 } else {
10482 set bend $b
10484 if {$a eq $bend} {
10485 return 1
10487 if {$b eq $aend} {
10488 return -1
10490 if {[info exists cached_isanc($a,$bend)]} {
10491 if {$cached_isanc($a,$bend)} {
10492 return 1
10495 if {[info exists cached_isanc($b,$aend)]} {
10496 if {$cached_isanc($b,$aend)} {
10497 return -1
10499 if {[info exists cached_isanc($a,$bend)]} {
10500 return 0
10504 set todo [list $a $b]
10505 set anc($a) a
10506 set anc($b) b
10507 for {set i 0} {$i < [llength $todo]} {incr i} {
10508 set x [lindex $todo $i]
10509 if {$anc($x) eq {}} {
10510 continue
10512 foreach arc $arcnos($x) {
10513 set xd $arcstart($arc)
10514 if {$xd eq $bend} {
10515 set cached_isanc($a,$bend) 1
10516 set cached_isanc($b,$aend) 0
10517 return 1
10518 } elseif {$xd eq $aend} {
10519 set cached_isanc($b,$aend) 1
10520 set cached_isanc($a,$bend) 0
10521 return -1
10523 if {![info exists anc($xd)]} {
10524 set anc($xd) $anc($x)
10525 lappend todo $xd
10526 } elseif {$anc($xd) ne $anc($x)} {
10527 set anc($xd) {}
10531 set cached_isanc($a,$bend) 0
10532 set cached_isanc($b,$aend) 0
10533 return 0
10536 # This identifies whether $desc has an ancestor that is
10537 # a growing tip of the graph and which is not an ancestor of $anc
10538 # and returns 0 if so and 1 if not.
10539 # If we subsequently discover a tag on such a growing tip, and that
10540 # turns out to be a descendent of $anc (which it could, since we
10541 # don't necessarily see children before parents), then $desc
10542 # isn't a good choice to display as a descendent tag of
10543 # $anc (since it is the descendent of another tag which is
10544 # a descendent of $anc). Similarly, $anc isn't a good choice to
10545 # display as a ancestor tag of $desc.
10547 proc is_certain {desc anc} {
10548 global arcnos arcout arcstart arcend growing problems
10550 set certain {}
10551 if {[llength $arcnos($anc)] == 1} {
10552 # tags on the same arc are certain
10553 if {$arcnos($desc) eq $arcnos($anc)} {
10554 return 1
10556 if {![info exists arcout($anc)]} {
10557 # if $anc is partway along an arc, use the start of the arc instead
10558 set a [lindex $arcnos($anc) 0]
10559 set anc $arcstart($a)
10562 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10563 set x $desc
10564 } else {
10565 set a [lindex $arcnos($desc) 0]
10566 set x $arcend($a)
10568 if {$x == $anc} {
10569 return 1
10571 set anclist [list $x]
10572 set dl($x) 1
10573 set nnh 1
10574 set ngrowanc 0
10575 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10576 set x [lindex $anclist $i]
10577 if {$dl($x)} {
10578 incr nnh -1
10580 set done($x) 1
10581 foreach a $arcout($x) {
10582 if {[info exists growing($a)]} {
10583 if {![info exists growanc($x)] && $dl($x)} {
10584 set growanc($x) 1
10585 incr ngrowanc
10587 } else {
10588 set y $arcend($a)
10589 if {[info exists dl($y)]} {
10590 if {$dl($y)} {
10591 if {!$dl($x)} {
10592 set dl($y) 0
10593 if {![info exists done($y)]} {
10594 incr nnh -1
10596 if {[info exists growanc($x)]} {
10597 incr ngrowanc -1
10599 set xl [list $y]
10600 for {set k 0} {$k < [llength $xl]} {incr k} {
10601 set z [lindex $xl $k]
10602 foreach c $arcout($z) {
10603 if {[info exists arcend($c)]} {
10604 set v $arcend($c)
10605 if {[info exists dl($v)] && $dl($v)} {
10606 set dl($v) 0
10607 if {![info exists done($v)]} {
10608 incr nnh -1
10610 if {[info exists growanc($v)]} {
10611 incr ngrowanc -1
10613 lappend xl $v
10620 } elseif {$y eq $anc || !$dl($x)} {
10621 set dl($y) 0
10622 lappend anclist $y
10623 } else {
10624 set dl($y) 1
10625 lappend anclist $y
10626 incr nnh
10631 foreach x [array names growanc] {
10632 if {$dl($x)} {
10633 return 0
10635 return 0
10637 return 1
10640 proc validate_arctags {a} {
10641 global arctags idtags
10643 set i -1
10644 set na $arctags($a)
10645 foreach id $arctags($a) {
10646 incr i
10647 if {![info exists idtags($id)]} {
10648 set na [lreplace $na $i $i]
10649 incr i -1
10652 set arctags($a) $na
10655 proc validate_archeads {a} {
10656 global archeads idheads
10658 set i -1
10659 set na $archeads($a)
10660 foreach id $archeads($a) {
10661 incr i
10662 if {![info exists idheads($id)]} {
10663 set na [lreplace $na $i $i]
10664 incr i -1
10667 set archeads($a) $na
10670 # Return the list of IDs that have tags that are descendents of id,
10671 # ignoring IDs that are descendents of IDs already reported.
10672 proc desctags {id} {
10673 global arcnos arcstart arcids arctags idtags allparents
10674 global growing cached_dtags
10676 if {![info exists allparents($id)]} {
10677 return {}
10679 set t1 [clock clicks -milliseconds]
10680 set argid $id
10681 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10682 # part-way along an arc; check that arc first
10683 set a [lindex $arcnos($id) 0]
10684 if {$arctags($a) ne {}} {
10685 validate_arctags $a
10686 set i [lsearch -exact $arcids($a) $id]
10687 set tid {}
10688 foreach t $arctags($a) {
10689 set j [lsearch -exact $arcids($a) $t]
10690 if {$j >= $i} break
10691 set tid $t
10693 if {$tid ne {}} {
10694 return $tid
10697 set id $arcstart($a)
10698 if {[info exists idtags($id)]} {
10699 return $id
10702 if {[info exists cached_dtags($id)]} {
10703 return $cached_dtags($id)
10706 set origid $id
10707 set todo [list $id]
10708 set queued($id) 1
10709 set nc 1
10710 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10711 set id [lindex $todo $i]
10712 set done($id) 1
10713 set ta [info exists hastaggedancestor($id)]
10714 if {!$ta} {
10715 incr nc -1
10717 # ignore tags on starting node
10718 if {!$ta && $i > 0} {
10719 if {[info exists idtags($id)]} {
10720 set tagloc($id) $id
10721 set ta 1
10722 } elseif {[info exists cached_dtags($id)]} {
10723 set tagloc($id) $cached_dtags($id)
10724 set ta 1
10727 foreach a $arcnos($id) {
10728 set d $arcstart($a)
10729 if {!$ta && $arctags($a) ne {}} {
10730 validate_arctags $a
10731 if {$arctags($a) ne {}} {
10732 lappend tagloc($id) [lindex $arctags($a) end]
10735 if {$ta || $arctags($a) ne {}} {
10736 set tomark [list $d]
10737 for {set j 0} {$j < [llength $tomark]} {incr j} {
10738 set dd [lindex $tomark $j]
10739 if {![info exists hastaggedancestor($dd)]} {
10740 if {[info exists done($dd)]} {
10741 foreach b $arcnos($dd) {
10742 lappend tomark $arcstart($b)
10744 if {[info exists tagloc($dd)]} {
10745 unset tagloc($dd)
10747 } elseif {[info exists queued($dd)]} {
10748 incr nc -1
10750 set hastaggedancestor($dd) 1
10754 if {![info exists queued($d)]} {
10755 lappend todo $d
10756 set queued($d) 1
10757 if {![info exists hastaggedancestor($d)]} {
10758 incr nc
10763 set tags {}
10764 foreach id [array names tagloc] {
10765 if {![info exists hastaggedancestor($id)]} {
10766 foreach t $tagloc($id) {
10767 if {[lsearch -exact $tags $t] < 0} {
10768 lappend tags $t
10773 set t2 [clock clicks -milliseconds]
10774 set loopix $i
10776 # remove tags that are descendents of other tags
10777 for {set i 0} {$i < [llength $tags]} {incr i} {
10778 set a [lindex $tags $i]
10779 for {set j 0} {$j < $i} {incr j} {
10780 set b [lindex $tags $j]
10781 set r [anc_or_desc $a $b]
10782 if {$r == 1} {
10783 set tags [lreplace $tags $j $j]
10784 incr j -1
10785 incr i -1
10786 } elseif {$r == -1} {
10787 set tags [lreplace $tags $i $i]
10788 incr i -1
10789 break
10794 if {[array names growing] ne {}} {
10795 # graph isn't finished, need to check if any tag could get
10796 # eclipsed by another tag coming later. Simply ignore any
10797 # tags that could later get eclipsed.
10798 set ctags {}
10799 foreach t $tags {
10800 if {[is_certain $t $origid]} {
10801 lappend ctags $t
10804 if {$tags eq $ctags} {
10805 set cached_dtags($origid) $tags
10806 } else {
10807 set tags $ctags
10809 } else {
10810 set cached_dtags($origid) $tags
10812 set t3 [clock clicks -milliseconds]
10813 if {0 && $t3 - $t1 >= 100} {
10814 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10815 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10817 return $tags
10820 proc anctags {id} {
10821 global arcnos arcids arcout arcend arctags idtags allparents
10822 global growing cached_atags
10824 if {![info exists allparents($id)]} {
10825 return {}
10827 set t1 [clock clicks -milliseconds]
10828 set argid $id
10829 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10830 # part-way along an arc; check that arc first
10831 set a [lindex $arcnos($id) 0]
10832 if {$arctags($a) ne {}} {
10833 validate_arctags $a
10834 set i [lsearch -exact $arcids($a) $id]
10835 foreach t $arctags($a) {
10836 set j [lsearch -exact $arcids($a) $t]
10837 if {$j > $i} {
10838 return $t
10842 if {![info exists arcend($a)]} {
10843 return {}
10845 set id $arcend($a)
10846 if {[info exists idtags($id)]} {
10847 return $id
10850 if {[info exists cached_atags($id)]} {
10851 return $cached_atags($id)
10854 set origid $id
10855 set todo [list $id]
10856 set queued($id) 1
10857 set taglist {}
10858 set nc 1
10859 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10860 set id [lindex $todo $i]
10861 set done($id) 1
10862 set td [info exists hastaggeddescendent($id)]
10863 if {!$td} {
10864 incr nc -1
10866 # ignore tags on starting node
10867 if {!$td && $i > 0} {
10868 if {[info exists idtags($id)]} {
10869 set tagloc($id) $id
10870 set td 1
10871 } elseif {[info exists cached_atags($id)]} {
10872 set tagloc($id) $cached_atags($id)
10873 set td 1
10876 foreach a $arcout($id) {
10877 if {!$td && $arctags($a) ne {}} {
10878 validate_arctags $a
10879 if {$arctags($a) ne {}} {
10880 lappend tagloc($id) [lindex $arctags($a) 0]
10883 if {![info exists arcend($a)]} continue
10884 set d $arcend($a)
10885 if {$td || $arctags($a) ne {}} {
10886 set tomark [list $d]
10887 for {set j 0} {$j < [llength $tomark]} {incr j} {
10888 set dd [lindex $tomark $j]
10889 if {![info exists hastaggeddescendent($dd)]} {
10890 if {[info exists done($dd)]} {
10891 foreach b $arcout($dd) {
10892 if {[info exists arcend($b)]} {
10893 lappend tomark $arcend($b)
10896 if {[info exists tagloc($dd)]} {
10897 unset tagloc($dd)
10899 } elseif {[info exists queued($dd)]} {
10900 incr nc -1
10902 set hastaggeddescendent($dd) 1
10906 if {![info exists queued($d)]} {
10907 lappend todo $d
10908 set queued($d) 1
10909 if {![info exists hastaggeddescendent($d)]} {
10910 incr nc
10915 set t2 [clock clicks -milliseconds]
10916 set loopix $i
10917 set tags {}
10918 foreach id [array names tagloc] {
10919 if {![info exists hastaggeddescendent($id)]} {
10920 foreach t $tagloc($id) {
10921 if {[lsearch -exact $tags $t] < 0} {
10922 lappend tags $t
10928 # remove tags that are ancestors of other tags
10929 for {set i 0} {$i < [llength $tags]} {incr i} {
10930 set a [lindex $tags $i]
10931 for {set j 0} {$j < $i} {incr j} {
10932 set b [lindex $tags $j]
10933 set r [anc_or_desc $a $b]
10934 if {$r == -1} {
10935 set tags [lreplace $tags $j $j]
10936 incr j -1
10937 incr i -1
10938 } elseif {$r == 1} {
10939 set tags [lreplace $tags $i $i]
10940 incr i -1
10941 break
10946 if {[array names growing] ne {}} {
10947 # graph isn't finished, need to check if any tag could get
10948 # eclipsed by another tag coming later. Simply ignore any
10949 # tags that could later get eclipsed.
10950 set ctags {}
10951 foreach t $tags {
10952 if {[is_certain $origid $t]} {
10953 lappend ctags $t
10956 if {$tags eq $ctags} {
10957 set cached_atags($origid) $tags
10958 } else {
10959 set tags $ctags
10961 } else {
10962 set cached_atags($origid) $tags
10964 set t3 [clock clicks -milliseconds]
10965 if {0 && $t3 - $t1 >= 100} {
10966 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10967 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10969 return $tags
10972 # Return the list of IDs that have heads that are descendents of id,
10973 # including id itself if it has a head.
10974 proc descheads {id} {
10975 global arcnos arcstart arcids archeads idheads cached_dheads
10976 global allparents arcout
10978 if {![info exists allparents($id)]} {
10979 return {}
10981 set aret {}
10982 if {![info exists arcout($id)]} {
10983 # part-way along an arc; check it first
10984 set a [lindex $arcnos($id) 0]
10985 if {$archeads($a) ne {}} {
10986 validate_archeads $a
10987 set i [lsearch -exact $arcids($a) $id]
10988 foreach t $archeads($a) {
10989 set j [lsearch -exact $arcids($a) $t]
10990 if {$j > $i} break
10991 lappend aret $t
10994 set id $arcstart($a)
10996 set origid $id
10997 set todo [list $id]
10998 set seen($id) 1
10999 set ret {}
11000 for {set i 0} {$i < [llength $todo]} {incr i} {
11001 set id [lindex $todo $i]
11002 if {[info exists cached_dheads($id)]} {
11003 set ret [concat $ret $cached_dheads($id)]
11004 } else {
11005 if {[info exists idheads($id)]} {
11006 lappend ret $id
11008 foreach a $arcnos($id) {
11009 if {$archeads($a) ne {}} {
11010 validate_archeads $a
11011 if {$archeads($a) ne {}} {
11012 set ret [concat $ret $archeads($a)]
11015 set d $arcstart($a)
11016 if {![info exists seen($d)]} {
11017 lappend todo $d
11018 set seen($d) 1
11023 set ret [lsort -unique $ret]
11024 set cached_dheads($origid) $ret
11025 return [concat $ret $aret]
11028 proc addedtag {id} {
11029 global arcnos arcout cached_dtags cached_atags
11031 if {![info exists arcnos($id)]} return
11032 if {![info exists arcout($id)]} {
11033 recalcarc [lindex $arcnos($id) 0]
11035 unset -nocomplain cached_dtags
11036 unset -nocomplain cached_atags
11039 proc addedhead {hid head} {
11040 global arcnos arcout cached_dheads
11042 if {![info exists arcnos($hid)]} return
11043 if {![info exists arcout($hid)]} {
11044 recalcarc [lindex $arcnos($hid) 0]
11046 unset -nocomplain cached_dheads
11049 proc removedhead {hid head} {
11050 global cached_dheads
11052 unset -nocomplain cached_dheads
11055 proc movedhead {hid head} {
11056 global arcnos arcout cached_dheads
11058 if {![info exists arcnos($hid)]} return
11059 if {![info exists arcout($hid)]} {
11060 recalcarc [lindex $arcnos($hid) 0]
11062 unset -nocomplain cached_dheads
11065 proc changedrefs {} {
11066 global cached_dheads cached_dtags cached_atags cached_tagcontent
11067 global arctags archeads arcnos arcout idheads idtags
11069 foreach id [concat [array names idheads] [array names idtags]] {
11070 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11071 set a [lindex $arcnos($id) 0]
11072 if {![info exists donearc($a)]} {
11073 recalcarc $a
11074 set donearc($a) 1
11078 unset -nocomplain cached_tagcontent
11079 unset -nocomplain cached_dtags
11080 unset -nocomplain cached_atags
11081 unset -nocomplain cached_dheads
11084 proc rereadrefs {} {
11085 global idtags idheads idotherrefs mainheadid
11087 set refids [concat [array names idtags] \
11088 [array names idheads] [array names idotherrefs]]
11089 foreach id $refids {
11090 if {![info exists ref($id)]} {
11091 set ref($id) [listrefs $id]
11094 set oldmainhead $mainheadid
11095 readrefs
11096 changedrefs
11097 set refids [lsort -unique [concat $refids [array names idtags] \
11098 [array names idheads] [array names idotherrefs]]]
11099 foreach id $refids {
11100 set v [listrefs $id]
11101 if {![info exists ref($id)] || $ref($id) != $v} {
11102 redrawtags $id
11105 if {$oldmainhead ne $mainheadid} {
11106 redrawtags $oldmainhead
11107 redrawtags $mainheadid
11109 run refill_reflist
11112 proc listrefs {id} {
11113 global idtags idheads idotherrefs
11115 set x {}
11116 if {[info exists idtags($id)]} {
11117 set x $idtags($id)
11119 set y {}
11120 if {[info exists idheads($id)]} {
11121 set y $idheads($id)
11123 set z {}
11124 if {[info exists idotherrefs($id)]} {
11125 set z $idotherrefs($id)
11127 return [list $x $y $z]
11130 proc add_tag_ctext {tag} {
11131 global ctext cached_tagcontent tagids
11133 if {![info exists cached_tagcontent($tag)]} {
11134 catch {
11135 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11138 $ctext insert end "[mc "Tag"]: $tag\n" bold
11139 if {[info exists cached_tagcontent($tag)]} {
11140 set text $cached_tagcontent($tag)
11141 } else {
11142 set text "[mc "Id"]: $tagids($tag)"
11144 appendwithlinks $text {}
11147 proc showtag {tag isnew} {
11148 global ctext cached_tagcontent tagids linknum tagobjid
11150 if {$isnew} {
11151 addtohistory [list showtag $tag 0] savectextpos
11153 $ctext conf -state normal
11154 clear_ctext
11155 settabs 0
11156 set linknum 0
11157 add_tag_ctext $tag
11158 maybe_scroll_ctext 1
11159 $ctext conf -state disabled
11160 init_flist {}
11163 proc showtags {id isnew} {
11164 global idtags ctext linknum
11166 if {$isnew} {
11167 addtohistory [list showtags $id 0] savectextpos
11169 $ctext conf -state normal
11170 clear_ctext
11171 settabs 0
11172 set linknum 0
11173 set sep {}
11174 foreach tag $idtags($id) {
11175 $ctext insert end $sep
11176 add_tag_ctext $tag
11177 set sep "\n\n"
11179 maybe_scroll_ctext 1
11180 $ctext conf -state disabled
11181 init_flist {}
11184 proc doquit {} {
11185 global stopped
11186 global gitktmpdir
11188 set stopped 100
11189 savestuff .
11190 destroy .
11192 if {[info exists gitktmpdir]} {
11193 catch {file delete -force $gitktmpdir}
11197 proc mkfontdisp {font top which} {
11198 global fontattr fontpref $font NS use_ttk
11200 set fontpref($font) [set $font]
11201 ${NS}::button $top.${font}but -text $which \
11202 -command [list choosefont $font $which]
11203 ${NS}::label $top.$font -relief flat -font $font \
11204 -text $fontattr($font,family) -justify left
11205 grid x $top.${font}but $top.$font -sticky w
11208 proc choosefont {font which} {
11209 global fontparam fontlist fonttop fontattr
11210 global prefstop NS
11212 set fontparam(which) $which
11213 set fontparam(font) $font
11214 set fontparam(family) [font actual $font -family]
11215 set fontparam(size) $fontattr($font,size)
11216 set fontparam(weight) $fontattr($font,weight)
11217 set fontparam(slant) $fontattr($font,slant)
11218 set top .gitkfont
11219 set fonttop $top
11220 if {![winfo exists $top]} {
11221 font create sample
11222 eval font config sample [font actual $font]
11223 ttk_toplevel $top
11224 make_transient $top $prefstop
11225 wm title $top [mc "Gitk font chooser"]
11226 ${NS}::label $top.l -textvariable fontparam(which)
11227 pack $top.l -side top
11228 set fontlist [lsort [font families]]
11229 ${NS}::frame $top.f
11230 listbox $top.f.fam -listvariable fontlist \
11231 -yscrollcommand [list $top.f.sb set]
11232 bind $top.f.fam <<ListboxSelect>> selfontfam
11233 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11234 pack $top.f.sb -side right -fill y
11235 pack $top.f.fam -side left -fill both -expand 1
11236 pack $top.f -side top -fill both -expand 1
11237 ${NS}::frame $top.g
11238 spinbox $top.g.size -from 4 -to 40 -width 4 \
11239 -textvariable fontparam(size) \
11240 -validatecommand {string is integer -strict %s}
11241 checkbutton $top.g.bold -padx 5 \
11242 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11243 -variable fontparam(weight) -onvalue bold -offvalue normal
11244 checkbutton $top.g.ital -padx 5 \
11245 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11246 -variable fontparam(slant) -onvalue italic -offvalue roman
11247 pack $top.g.size $top.g.bold $top.g.ital -side left
11248 pack $top.g -side top
11249 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11250 -background white
11251 $top.c create text 100 25 -anchor center -text $which -font sample \
11252 -fill black -tags text
11253 bind $top.c <Configure> [list centertext $top.c]
11254 pack $top.c -side top -fill x
11255 ${NS}::frame $top.buts
11256 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11257 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11258 bind $top <Key-Return> fontok
11259 bind $top <Key-Escape> fontcan
11260 grid $top.buts.ok $top.buts.can
11261 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11262 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11263 pack $top.buts -side bottom -fill x
11264 trace add variable fontparam write chg_fontparam
11265 } else {
11266 raise $top
11267 $top.c itemconf text -text $which
11269 set i [lsearch -exact $fontlist $fontparam(family)]
11270 if {$i >= 0} {
11271 $top.f.fam selection set $i
11272 $top.f.fam see $i
11276 proc centertext {w} {
11277 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11280 proc fontok {} {
11281 global fontparam fontpref prefstop
11283 set f $fontparam(font)
11284 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11285 if {$fontparam(weight) eq "bold"} {
11286 lappend fontpref($f) "bold"
11288 if {$fontparam(slant) eq "italic"} {
11289 lappend fontpref($f) "italic"
11291 set w $prefstop.notebook.fonts.$f
11292 $w conf -text $fontparam(family) -font $fontpref($f)
11294 fontcan
11297 proc fontcan {} {
11298 global fonttop fontparam
11300 if {[info exists fonttop]} {
11301 catch {destroy $fonttop}
11302 catch {font delete sample}
11303 unset fonttop
11304 unset fontparam
11308 if {[package vsatisfies [package provide Tk] 8.6]} {
11309 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11310 # function to make use of it.
11311 proc choosefont {font which} {
11312 tk fontchooser configure -title $which -font $font \
11313 -command [list on_choosefont $font $which]
11314 tk fontchooser show
11316 proc on_choosefont {font which newfont} {
11317 global fontparam
11318 puts stderr "$font $newfont"
11319 array set f [font actual $newfont]
11320 set fontparam(which) $which
11321 set fontparam(font) $font
11322 set fontparam(family) $f(-family)
11323 set fontparam(size) $f(-size)
11324 set fontparam(weight) $f(-weight)
11325 set fontparam(slant) $f(-slant)
11326 fontok
11330 proc selfontfam {} {
11331 global fonttop fontparam
11333 set i [$fonttop.f.fam curselection]
11334 if {$i ne {}} {
11335 set fontparam(family) [$fonttop.f.fam get $i]
11339 proc chg_fontparam {v sub op} {
11340 global fontparam
11342 font config sample -$sub $fontparam($sub)
11345 # Create a property sheet tab page
11346 proc create_prefs_page {w} {
11347 global NS
11348 set parent [join [lrange [split $w .] 0 end-1] .]
11349 if {[winfo class $parent] eq "TNotebook"} {
11350 ${NS}::frame $w
11351 } else {
11352 ${NS}::labelframe $w
11356 proc prefspage_general {notebook} {
11357 global NS maxwidth maxgraphpct showneartags showlocalchanges
11358 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11359 global hideremotes want_ttk have_ttk maxrefs
11361 set page [create_prefs_page $notebook.general]
11363 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11364 grid $page.ldisp - -sticky w -pady 10
11365 ${NS}::label $page.spacer -text " "
11366 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11367 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11368 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11369 #xgettext:no-tcl-format
11370 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11371 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11372 grid x $page.maxpctl $page.maxpct -sticky w
11373 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11374 -variable showlocalchanges
11375 grid x $page.showlocal -sticky w
11376 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11377 -variable autoselect
11378 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11379 grid x $page.autoselect $page.autosellen -sticky w
11380 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11381 -variable hideremotes
11382 grid x $page.hideremotes -sticky w
11384 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11385 grid $page.ddisp - -sticky w -pady 10
11386 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11387 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11388 grid x $page.tabstopl $page.tabstop -sticky w
11389 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11390 -variable showneartags
11391 grid x $page.ntag -sticky w
11392 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11393 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11394 grid x $page.maxrefsl $page.maxrefs -sticky w
11395 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11396 -variable limitdiffs
11397 grid x $page.ldiff -sticky w
11398 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11399 -variable perfile_attrs
11400 grid x $page.lattr -sticky w
11402 ${NS}::entry $page.extdifft -textvariable extdifftool
11403 ${NS}::frame $page.extdifff
11404 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11405 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11406 pack $page.extdifff.l $page.extdifff.b -side left
11407 pack configure $page.extdifff.l -padx 10
11408 grid x $page.extdifff $page.extdifft -sticky ew
11410 ${NS}::label $page.lgen -text [mc "General options"]
11411 grid $page.lgen - -sticky w -pady 10
11412 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11413 -text [mc "Use themed widgets"]
11414 if {$have_ttk} {
11415 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11416 } else {
11417 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11419 grid x $page.want_ttk $page.ttk_note -sticky w
11420 return $page
11423 proc prefspage_colors {notebook} {
11424 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11426 set page [create_prefs_page $notebook.colors]
11428 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11429 grid $page.cdisp - -sticky w -pady 10
11430 label $page.ui -padx 40 -relief sunk -background $uicolor
11431 ${NS}::button $page.uibut -text [mc "Interface"] \
11432 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11433 grid x $page.uibut $page.ui -sticky w
11434 label $page.bg -padx 40 -relief sunk -background $bgcolor
11435 ${NS}::button $page.bgbut -text [mc "Background"] \
11436 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11437 grid x $page.bgbut $page.bg -sticky w
11438 label $page.fg -padx 40 -relief sunk -background $fgcolor
11439 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11440 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11441 grid x $page.fgbut $page.fg -sticky w
11442 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11443 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11444 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11445 [list $ctext tag conf d0 -foreground]]
11446 grid x $page.diffoldbut $page.diffold -sticky w
11447 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11448 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11449 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11450 [list $ctext tag conf dresult -foreground]]
11451 grid x $page.diffnewbut $page.diffnew -sticky w
11452 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11453 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11454 -command [list choosecolor diffcolors 2 $page.hunksep \
11455 [mc "diff hunk header"] \
11456 [list $ctext tag conf hunksep -foreground]]
11457 grid x $page.hunksepbut $page.hunksep -sticky w
11458 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11459 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11460 -command [list choosecolor markbgcolor {} $page.markbgsep \
11461 [mc "marked line background"] \
11462 [list $ctext tag conf omark -background]]
11463 grid x $page.markbgbut $page.markbgsep -sticky w
11464 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11465 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11466 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11467 grid x $page.selbgbut $page.selbgsep -sticky w
11468 return $page
11471 proc prefspage_fonts {notebook} {
11472 global NS
11473 set page [create_prefs_page $notebook.fonts]
11474 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11475 grid $page.cfont - -sticky w -pady 10
11476 mkfontdisp mainfont $page [mc "Main font"]
11477 mkfontdisp textfont $page [mc "Diff display font"]
11478 mkfontdisp uifont $page [mc "User interface font"]
11479 return $page
11482 proc doprefs {} {
11483 global maxwidth maxgraphpct use_ttk NS
11484 global oldprefs prefstop showneartags showlocalchanges
11485 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11486 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11487 global hideremotes want_ttk have_ttk
11489 set top .gitkprefs
11490 set prefstop $top
11491 if {[winfo exists $top]} {
11492 raise $top
11493 return
11495 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11496 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11497 set oldprefs($v) [set $v]
11499 ttk_toplevel $top
11500 wm title $top [mc "Gitk preferences"]
11501 make_transient $top .
11503 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11504 set notebook [ttk::notebook $top.notebook]
11505 } else {
11506 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11509 lappend pages [prefspage_general $notebook] [mc "General"]
11510 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11511 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11512 set col 0
11513 foreach {page title} $pages {
11514 if {$use_notebook} {
11515 $notebook add $page -text $title
11516 } else {
11517 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11518 -text $title -command [list raise $page]]
11519 $page configure -text $title
11520 grid $btn -row 0 -column [incr col] -sticky w
11521 grid $page -row 1 -column 0 -sticky news -columnspan 100
11525 if {!$use_notebook} {
11526 grid columnconfigure $notebook 0 -weight 1
11527 grid rowconfigure $notebook 1 -weight 1
11528 raise [lindex $pages 0]
11531 grid $notebook -sticky news -padx 2 -pady 2
11532 grid rowconfigure $top 0 -weight 1
11533 grid columnconfigure $top 0 -weight 1
11535 ${NS}::frame $top.buts
11536 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11537 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11538 bind $top <Key-Return> prefsok
11539 bind $top <Key-Escape> prefscan
11540 grid $top.buts.ok $top.buts.can
11541 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11542 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11543 grid $top.buts - - -pady 10 -sticky ew
11544 grid columnconfigure $top 2 -weight 1
11545 bind $top <Visibility> [list focus $top.buts.ok]
11548 proc choose_extdiff {} {
11549 global extdifftool
11551 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11552 if {$prog ne {}} {
11553 set extdifftool $prog
11557 proc choosecolor {v vi w x cmd} {
11558 global $v
11560 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11561 -title [mc "Gitk: choose color for %s" $x]]
11562 if {$c eq {}} return
11563 $w conf -background $c
11564 lset $v $vi $c
11565 eval $cmd $c
11568 proc setselbg {c} {
11569 global bglist cflist
11570 foreach w $bglist {
11571 if {[winfo exists $w]} {
11572 $w configure -selectbackground $c
11575 $cflist tag configure highlight \
11576 -background [$cflist cget -selectbackground]
11577 allcanvs itemconf secsel -fill $c
11580 # This sets the background color and the color scheme for the whole UI.
11581 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11582 # if we don't specify one ourselves, which makes the checkbuttons and
11583 # radiobuttons look bad. This chooses white for selectColor if the
11584 # background color is light, or black if it is dark.
11585 proc setui {c} {
11586 if {[tk windowingsystem] eq "win32"} { return }
11587 set bg [winfo rgb . $c]
11588 set selc black
11589 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11590 set selc white
11592 tk_setPalette background $c selectColor $selc
11595 proc setbg {c} {
11596 global bglist
11598 foreach w $bglist {
11599 if {[winfo exists $w]} {
11600 $w conf -background $c
11605 proc setfg {c} {
11606 global fglist canv
11608 foreach w $fglist {
11609 if {[winfo exists $w]} {
11610 $w conf -foreground $c
11613 allcanvs itemconf text -fill $c
11614 $canv itemconf circle -outline $c
11615 $canv itemconf markid -outline $c
11618 proc prefscan {} {
11619 global oldprefs prefstop
11621 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11622 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11623 global $v
11624 set $v $oldprefs($v)
11626 catch {destroy $prefstop}
11627 unset prefstop
11628 fontcan
11631 proc prefsok {} {
11632 global maxwidth maxgraphpct
11633 global oldprefs prefstop showneartags showlocalchanges
11634 global fontpref mainfont textfont uifont
11635 global limitdiffs treediffs perfile_attrs
11636 global hideremotes
11638 catch {destroy $prefstop}
11639 unset prefstop
11640 fontcan
11641 set fontchanged 0
11642 if {$mainfont ne $fontpref(mainfont)} {
11643 set mainfont $fontpref(mainfont)
11644 parsefont mainfont $mainfont
11645 eval font configure mainfont [fontflags mainfont]
11646 eval font configure mainfontbold [fontflags mainfont 1]
11647 setcoords
11648 set fontchanged 1
11650 if {$textfont ne $fontpref(textfont)} {
11651 set textfont $fontpref(textfont)
11652 parsefont textfont $textfont
11653 eval font configure textfont [fontflags textfont]
11654 eval font configure textfontbold [fontflags textfont 1]
11656 if {$uifont ne $fontpref(uifont)} {
11657 set uifont $fontpref(uifont)
11658 parsefont uifont $uifont
11659 eval font configure uifont [fontflags uifont]
11661 settabs
11662 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11663 if {$showlocalchanges} {
11664 doshowlocalchanges
11665 } else {
11666 dohidelocalchanges
11669 if {$limitdiffs != $oldprefs(limitdiffs) ||
11670 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11671 # treediffs elements are limited by path;
11672 # won't have encodings cached if perfile_attrs was just turned on
11673 unset -nocomplain treediffs
11675 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11676 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11677 redisplay
11678 } elseif {$showneartags != $oldprefs(showneartags) ||
11679 $limitdiffs != $oldprefs(limitdiffs)} {
11680 reselectline
11682 if {$hideremotes != $oldprefs(hideremotes)} {
11683 rereadrefs
11687 proc formatdate {d} {
11688 global datetimeformat
11689 if {$d ne {}} {
11690 # If $datetimeformat includes a timezone, display in the
11691 # timezone of the argument. Otherwise, display in local time.
11692 if {[string match {*%[zZ]*} $datetimeformat]} {
11693 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11694 # Tcl < 8.5 does not support -timezone. Emulate it by
11695 # setting TZ (e.g. TZ=<-0430>+04:30).
11696 global env
11697 if {[info exists env(TZ)]} {
11698 set savedTZ $env(TZ)
11700 set zone [lindex $d 1]
11701 set sign [string map {+ - - +} [string index $zone 0]]
11702 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11703 set d [clock format [lindex $d 0] -format $datetimeformat]
11704 if {[info exists savedTZ]} {
11705 set env(TZ) $savedTZ
11706 } else {
11707 unset env(TZ)
11710 } else {
11711 set d [clock format [lindex $d 0] -format $datetimeformat]
11714 return $d
11717 # This list of encoding names and aliases is distilled from
11718 # http://www.iana.org/assignments/character-sets.
11719 # Not all of them are supported by Tcl.
11720 set encoding_aliases {
11721 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11722 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11723 { ISO-10646-UTF-1 csISO10646UTF1 }
11724 { ISO_646.basic:1983 ref csISO646basic1983 }
11725 { INVARIANT csINVARIANT }
11726 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11727 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11728 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11729 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11730 { NATS-DANO iso-ir-9-1 csNATSDANO }
11731 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11732 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11733 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11734 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11735 { ISO-2022-KR csISO2022KR }
11736 { EUC-KR csEUCKR }
11737 { ISO-2022-JP csISO2022JP }
11738 { ISO-2022-JP-2 csISO2022JP2 }
11739 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11740 csISO13JISC6220jp }
11741 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11742 { IT iso-ir-15 ISO646-IT csISO15Italian }
11743 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11744 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11745 { greek7-old iso-ir-18 csISO18Greek7Old }
11746 { latin-greek iso-ir-19 csISO19LatinGreek }
11747 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11748 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11749 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11750 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11751 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11752 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11753 { INIS iso-ir-49 csISO49INIS }
11754 { INIS-8 iso-ir-50 csISO50INIS8 }
11755 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11756 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11757 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11758 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11759 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11760 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11761 csISO60Norwegian1 }
11762 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11763 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11764 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11765 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11766 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11767 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11768 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11769 { greek7 iso-ir-88 csISO88Greek7 }
11770 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11771 { iso-ir-90 csISO90 }
11772 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11773 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11774 csISO92JISC62991984b }
11775 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11776 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11777 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11778 csISO95JIS62291984handadd }
11779 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11780 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11781 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11782 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11783 CP819 csISOLatin1 }
11784 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11785 { T.61-7bit iso-ir-102 csISO102T617bit }
11786 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11787 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11788 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11789 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11790 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11791 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11792 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11793 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11794 arabic csISOLatinArabic }
11795 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11796 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11797 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11798 greek greek8 csISOLatinGreek }
11799 { T.101-G2 iso-ir-128 csISO128T101G2 }
11800 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11801 csISOLatinHebrew }
11802 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11803 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11804 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11805 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11806 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11807 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11808 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11809 csISOLatinCyrillic }
11810 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11811 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11812 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11813 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11814 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11815 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11816 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11817 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11818 { ISO_10367-box iso-ir-155 csISO10367Box }
11819 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11820 { latin-lap lap iso-ir-158 csISO158Lap }
11821 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11822 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11823 { us-dk csUSDK }
11824 { dk-us csDKUS }
11825 { JIS_X0201 X0201 csHalfWidthKatakana }
11826 { KSC5636 ISO646-KR csKSC5636 }
11827 { ISO-10646-UCS-2 csUnicode }
11828 { ISO-10646-UCS-4 csUCS4 }
11829 { DEC-MCS dec csDECMCS }
11830 { hp-roman8 roman8 r8 csHPRoman8 }
11831 { macintosh mac csMacintosh }
11832 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11833 csIBM037 }
11834 { IBM038 EBCDIC-INT cp038 csIBM038 }
11835 { IBM273 CP273 csIBM273 }
11836 { IBM274 EBCDIC-BE CP274 csIBM274 }
11837 { IBM275 EBCDIC-BR cp275 csIBM275 }
11838 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11839 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11840 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11841 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11842 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11843 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11844 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11845 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11846 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11847 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11848 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11849 { IBM437 cp437 437 csPC8CodePage437 }
11850 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11851 { IBM775 cp775 csPC775Baltic }
11852 { IBM850 cp850 850 csPC850Multilingual }
11853 { IBM851 cp851 851 csIBM851 }
11854 { IBM852 cp852 852 csPCp852 }
11855 { IBM855 cp855 855 csIBM855 }
11856 { IBM857 cp857 857 csIBM857 }
11857 { IBM860 cp860 860 csIBM860 }
11858 { IBM861 cp861 861 cp-is csIBM861 }
11859 { IBM862 cp862 862 csPC862LatinHebrew }
11860 { IBM863 cp863 863 csIBM863 }
11861 { IBM864 cp864 csIBM864 }
11862 { IBM865 cp865 865 csIBM865 }
11863 { IBM866 cp866 866 csIBM866 }
11864 { IBM868 CP868 cp-ar csIBM868 }
11865 { IBM869 cp869 869 cp-gr csIBM869 }
11866 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11867 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11868 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11869 { IBM891 cp891 csIBM891 }
11870 { IBM903 cp903 csIBM903 }
11871 { IBM904 cp904 904 csIBBM904 }
11872 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11873 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11874 { IBM1026 CP1026 csIBM1026 }
11875 { EBCDIC-AT-DE csIBMEBCDICATDE }
11876 { EBCDIC-AT-DE-A csEBCDICATDEA }
11877 { EBCDIC-CA-FR csEBCDICCAFR }
11878 { EBCDIC-DK-NO csEBCDICDKNO }
11879 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11880 { EBCDIC-FI-SE csEBCDICFISE }
11881 { EBCDIC-FI-SE-A csEBCDICFISEA }
11882 { EBCDIC-FR csEBCDICFR }
11883 { EBCDIC-IT csEBCDICIT }
11884 { EBCDIC-PT csEBCDICPT }
11885 { EBCDIC-ES csEBCDICES }
11886 { EBCDIC-ES-A csEBCDICESA }
11887 { EBCDIC-ES-S csEBCDICESS }
11888 { EBCDIC-UK csEBCDICUK }
11889 { EBCDIC-US csEBCDICUS }
11890 { UNKNOWN-8BIT csUnknown8BiT }
11891 { MNEMONIC csMnemonic }
11892 { MNEM csMnem }
11893 { VISCII csVISCII }
11894 { VIQR csVIQR }
11895 { KOI8-R csKOI8R }
11896 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11897 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11898 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11899 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11900 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11901 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11902 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11903 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11904 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11905 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11906 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11907 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11908 { IBM1047 IBM-1047 }
11909 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11910 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11911 { UNICODE-1-1 csUnicode11 }
11912 { CESU-8 csCESU-8 }
11913 { BOCU-1 csBOCU-1 }
11914 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11915 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11916 l8 }
11917 { ISO-8859-15 ISO_8859-15 Latin-9 }
11918 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11919 { GBK CP936 MS936 windows-936 }
11920 { JIS_Encoding csJISEncoding }
11921 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11922 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11923 EUC-JP }
11924 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11925 { ISO-10646-UCS-Basic csUnicodeASCII }
11926 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11927 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11928 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11929 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11930 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11931 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11932 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11933 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11934 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11935 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11936 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11937 { Ventura-US csVenturaUS }
11938 { Ventura-International csVenturaInternational }
11939 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11940 { PC8-Turkish csPC8Turkish }
11941 { IBM-Symbols csIBMSymbols }
11942 { IBM-Thai csIBMThai }
11943 { HP-Legal csHPLegal }
11944 { HP-Pi-font csHPPiFont }
11945 { HP-Math8 csHPMath8 }
11946 { Adobe-Symbol-Encoding csHPPSMath }
11947 { HP-DeskTop csHPDesktop }
11948 { Ventura-Math csVenturaMath }
11949 { Microsoft-Publishing csMicrosoftPublishing }
11950 { Windows-31J csWindows31J }
11951 { GB2312 csGB2312 }
11952 { Big5 csBig5 }
11955 proc tcl_encoding {enc} {
11956 global encoding_aliases tcl_encoding_cache
11957 if {[info exists tcl_encoding_cache($enc)]} {
11958 return $tcl_encoding_cache($enc)
11960 set names [encoding names]
11961 set lcnames [string tolower $names]
11962 set enc [string tolower $enc]
11963 set i [lsearch -exact $lcnames $enc]
11964 if {$i < 0} {
11965 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11966 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11967 set i [lsearch -exact $lcnames $encx]
11970 if {$i < 0} {
11971 foreach l $encoding_aliases {
11972 set ll [string tolower $l]
11973 if {[lsearch -exact $ll $enc] < 0} continue
11974 # look through the aliases for one that tcl knows about
11975 foreach e $ll {
11976 set i [lsearch -exact $lcnames $e]
11977 if {$i < 0} {
11978 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11979 set i [lsearch -exact $lcnames $ex]
11982 if {$i >= 0} break
11984 break
11987 set tclenc {}
11988 if {$i >= 0} {
11989 set tclenc [lindex $names $i]
11991 set tcl_encoding_cache($enc) $tclenc
11992 return $tclenc
11995 proc gitattr {path attr default} {
11996 global path_attr_cache
11997 if {[info exists path_attr_cache($attr,$path)]} {
11998 set r $path_attr_cache($attr,$path)
11999 } else {
12000 set r "unspecified"
12001 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
12002 regexp "(.*): $attr: (.*)" $line m f r
12004 set path_attr_cache($attr,$path) $r
12006 if {$r eq "unspecified"} {
12007 return $default
12009 return $r
12012 proc cache_gitattr {attr pathlist} {
12013 global path_attr_cache
12014 set newlist {}
12015 foreach path $pathlist {
12016 if {![info exists path_attr_cache($attr,$path)]} {
12017 lappend newlist $path
12020 set lim 1000
12021 if {[tk windowingsystem] == "win32"} {
12022 # windows has a 32k limit on the arguments to a command...
12023 set lim 30
12025 while {$newlist ne {}} {
12026 set head [lrange $newlist 0 [expr {$lim - 1}]]
12027 set newlist [lrange $newlist $lim end]
12028 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
12029 foreach row [split $rlist "\n"] {
12030 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12031 if {[string index $path 0] eq "\""} {
12032 set path [encoding convertfrom [lindex $path 0]]
12034 set path_attr_cache($attr,$path) $value
12041 proc get_path_encoding {path} {
12042 global gui_encoding perfile_attrs
12043 set tcl_enc $gui_encoding
12044 if {$path ne {} && $perfile_attrs} {
12045 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12046 if {$enc2 ne {}} {
12047 set tcl_enc $enc2
12050 return $tcl_enc
12053 ## For msgcat loading, first locate the installation location.
12054 if { [info exists ::env(GITK_MSGSDIR)] } {
12055 ## Msgsdir was manually set in the environment.
12056 set gitk_msgsdir $::env(GITK_MSGSDIR)
12057 } else {
12058 ## Let's guess the prefix from argv0.
12059 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12060 set gitk_libdir [file join $gitk_prefix share gitk lib]
12061 set gitk_msgsdir [file join $gitk_libdir msgs]
12062 unset gitk_prefix
12065 ## Internationalization (i18n) through msgcat and gettext. See
12066 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12067 package require msgcat
12068 namespace import ::msgcat::mc
12069 ## And eventually load the actual message catalog
12070 ::msgcat::mcload $gitk_msgsdir
12072 # First check that Tcl/Tk is recent enough
12073 if {[catch {package require Tk 8.4} err]} {
12074 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12075 Gitk requires at least Tcl/Tk 8.4."]
12076 exit 1
12079 # on OSX bring the current Wish process window to front
12080 if {[tk windowingsystem] eq "aqua"} {
12081 exec osascript -e [format {
12082 tell application "System Events"
12083 set frontmost of processes whose unix id is %d to true
12084 end tell
12085 } [pid] ]
12088 # Unset GIT_TRACE var if set
12089 if { [info exists ::env(GIT_TRACE)] } {
12090 unset ::env(GIT_TRACE)
12093 # defaults...
12094 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12096 set gitencoding {}
12097 catch {
12098 set gitencoding [exec git config --get i18n.commitencoding]
12100 catch {
12101 set gitencoding [exec git config --get i18n.logoutputencoding]
12103 if {$gitencoding == ""} {
12104 set gitencoding "utf-8"
12106 set tclencoding [tcl_encoding $gitencoding]
12107 if {$tclencoding == {}} {
12108 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12111 set gui_encoding [encoding system]
12112 catch {
12113 set enc [exec git config --get gui.encoding]
12114 if {$enc ne {}} {
12115 set tclenc [tcl_encoding $enc]
12116 if {$tclenc ne {}} {
12117 set gui_encoding $tclenc
12118 } else {
12119 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12124 set log_showroot true
12125 catch {
12126 set log_showroot [exec git config --bool --get log.showroot]
12129 if {[tk windowingsystem] eq "aqua"} {
12130 set mainfont {{Lucida Grande} 9}
12131 set textfont {Monaco 9}
12132 set uifont {{Lucida Grande} 9 bold}
12133 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12134 # fontconfig!
12135 set mainfont {sans 9}
12136 set textfont {monospace 9}
12137 set uifont {sans 9 bold}
12138 } else {
12139 set mainfont {Helvetica 9}
12140 set textfont {Courier 9}
12141 set uifont {Helvetica 9 bold}
12143 set tabstop 8
12144 set findmergefiles 0
12145 set maxgraphpct 50
12146 set maxwidth 16
12147 set revlistorder 0
12148 set fastdate 0
12149 set uparrowlen 5
12150 set downarrowlen 5
12151 set mingaplen 100
12152 set cmitmode "patch"
12153 set wrapcomment "none"
12154 set showneartags 1
12155 set hideremotes 0
12156 set maxrefs 20
12157 set visiblerefs {"master"}
12158 set maxlinelen 200
12159 set showlocalchanges 1
12160 set limitdiffs 1
12161 set datetimeformat "%Y-%m-%d %H:%M:%S"
12162 set autoselect 1
12163 set autosellen 40
12164 set perfile_attrs 0
12165 set want_ttk 1
12167 if {[tk windowingsystem] eq "aqua"} {
12168 set extdifftool "opendiff"
12169 } else {
12170 set extdifftool "meld"
12173 set colors {green red blue magenta darkgrey brown orange}
12174 if {[tk windowingsystem] eq "win32"} {
12175 set uicolor SystemButtonFace
12176 set uifgcolor SystemButtonText
12177 set uifgdisabledcolor SystemDisabledText
12178 set bgcolor SystemWindow
12179 set fgcolor SystemWindowText
12180 set selectbgcolor SystemHighlight
12181 } else {
12182 set uicolor grey85
12183 set uifgcolor black
12184 set uifgdisabledcolor "#999"
12185 set bgcolor white
12186 set fgcolor black
12187 set selectbgcolor gray85
12189 set diffcolors {red "#00a000" blue}
12190 set diffcontext 3
12191 set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12192 set ignorespace 0
12193 set worddiff ""
12194 set markbgcolor "#e0e0ff"
12196 set headbgcolor green
12197 set headfgcolor black
12198 set headoutlinecolor black
12199 set remotebgcolor #ffddaa
12200 set tagbgcolor yellow
12201 set tagfgcolor black
12202 set tagoutlinecolor black
12203 set reflinecolor black
12204 set filesepbgcolor #aaaaaa
12205 set filesepfgcolor black
12206 set linehoverbgcolor #ffff80
12207 set linehoverfgcolor black
12208 set linehoveroutlinecolor black
12209 set mainheadcirclecolor yellow
12210 set workingfilescirclecolor red
12211 set indexcirclecolor green
12212 set circlecolors {white blue gray blue blue}
12213 set linkfgcolor blue
12214 set circleoutlinecolor $fgcolor
12215 set foundbgcolor yellow
12216 set currentsearchhitbgcolor orange
12218 # button for popping up context menus
12219 if {[tk windowingsystem] eq "aqua"} {
12220 set ctxbut <Button-2>
12221 } else {
12222 set ctxbut <Button-3>
12225 catch {
12226 # follow the XDG base directory specification by default. See
12227 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12228 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12229 # XDG_CONFIG_HOME environment variable is set
12230 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12231 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12232 } else {
12233 # default XDG_CONFIG_HOME
12234 set config_file "~/.config/git/gitk"
12235 set config_file_tmp "~/.config/git/gitk-tmp"
12237 if {![file exists $config_file]} {
12238 # for backward compatibility use the old config file if it exists
12239 if {[file exists "~/.gitk"]} {
12240 set config_file "~/.gitk"
12241 set config_file_tmp "~/.gitk-tmp"
12242 } elseif {![file exists [file dirname $config_file]]} {
12243 file mkdir [file dirname $config_file]
12246 source $config_file
12248 config_check_tmp_exists 50
12250 set config_variables {
12251 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12252 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12253 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12254 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12255 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12256 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12257 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12258 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12259 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12260 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12262 foreach var $config_variables {
12263 config_init_trace $var
12264 trace add variable $var write config_variable_change_cb
12267 parsefont mainfont $mainfont
12268 eval font create mainfont [fontflags mainfont]
12269 eval font create mainfontbold [fontflags mainfont 1]
12271 parsefont textfont $textfont
12272 eval font create textfont [fontflags textfont]
12273 eval font create textfontbold [fontflags textfont 1]
12275 parsefont uifont $uifont
12276 eval font create uifont [fontflags uifont]
12278 setui $uicolor
12280 setoptions
12282 # check that we can find a .git directory somewhere...
12283 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12284 show_error {} . [mc "Cannot find a git repository here."]
12285 exit 1
12288 set selecthead {}
12289 set selectheadid {}
12291 set revtreeargs {}
12292 set cmdline_files {}
12293 set i 0
12294 set revtreeargscmd {}
12295 foreach arg $argv {
12296 switch -glob -- $arg {
12297 "" { }
12298 "--" {
12299 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12300 break
12302 "--select-commit=*" {
12303 set selecthead [string range $arg 16 end]
12305 "--argscmd=*" {
12306 set revtreeargscmd [string range $arg 10 end]
12308 default {
12309 lappend revtreeargs $arg
12312 incr i
12315 if {$selecthead eq "HEAD"} {
12316 set selecthead {}
12319 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12320 # no -- on command line, but some arguments (other than --argscmd)
12321 if {[catch {
12322 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12323 set cmdline_files [split $f "\n"]
12324 set n [llength $cmdline_files]
12325 set revtreeargs [lrange $revtreeargs 0 end-$n]
12326 # Unfortunately git rev-parse doesn't produce an error when
12327 # something is both a revision and a filename. To be consistent
12328 # with git log and git rev-list, check revtreeargs for filenames.
12329 foreach arg $revtreeargs {
12330 if {[file exists $arg]} {
12331 show_error {} . [mc "Ambiguous argument '%s': both revision\
12332 and filename" $arg]
12333 exit 1
12336 } err]} {
12337 # unfortunately we get both stdout and stderr in $err,
12338 # so look for "fatal:".
12339 set i [string first "fatal:" $err]
12340 if {$i > 0} {
12341 set err [string range $err [expr {$i + 6}] end]
12343 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12344 exit 1
12348 set nullid "0000000000000000000000000000000000000000"
12349 set nullid2 "0000000000000000000000000000000000000001"
12350 set nullfile "/dev/null"
12352 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12353 if {![info exists have_ttk]} {
12354 set have_ttk [llength [info commands ::ttk::style]]
12356 set use_ttk [expr {$have_ttk && $want_ttk}]
12357 set NS [expr {$use_ttk ? "ttk" : ""}]
12359 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12361 set show_notes {}
12362 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12363 set show_notes "--show-notes"
12366 set appname "gitk"
12368 set runq {}
12369 set history {}
12370 set historyindex 0
12371 set fh_serial 0
12372 set nhl_names {}
12373 set highlight_paths {}
12374 set findpattern {}
12375 set searchdirn -forwards
12376 set boldids {}
12377 set boldnameids {}
12378 set diffelide {0 0}
12379 set markingmatches 0
12380 set linkentercount 0
12381 set need_redisplay 0
12382 set nrows_drawn 0
12383 set firsttabstop 0
12385 set nextviewnum 1
12386 set curview 0
12387 set selectedview 0
12388 set selectedhlview [mc "None"]
12389 set highlight_related [mc "None"]
12390 set highlight_files {}
12391 set viewfiles(0) {}
12392 set viewperm(0) 0
12393 set viewchanged(0) 0
12394 set viewargs(0) {}
12395 set viewargscmd(0) {}
12397 set selectedline {}
12398 set numcommits 0
12399 set loginstance 0
12400 set cmdlineok 0
12401 set stopped 0
12402 set stuffsaved 0
12403 set patchnum 0
12404 set lserial 0
12405 set hasworktree [hasworktree]
12406 set cdup {}
12407 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12408 set cdup [exec git rev-parse --show-cdup]
12410 set worktree [exec git rev-parse --show-toplevel]
12411 setcoords
12412 makewindow
12413 catch {
12414 image create photo gitlogo -width 16 -height 16
12416 image create photo gitlogominus -width 4 -height 2
12417 gitlogominus put #C00000 -to 0 0 4 2
12418 gitlogo copy gitlogominus -to 1 5
12419 gitlogo copy gitlogominus -to 6 5
12420 gitlogo copy gitlogominus -to 11 5
12421 image delete gitlogominus
12423 image create photo gitlogoplus -width 4 -height 4
12424 gitlogoplus put #008000 -to 1 0 3 4
12425 gitlogoplus put #008000 -to 0 1 4 3
12426 gitlogo copy gitlogoplus -to 1 9
12427 gitlogo copy gitlogoplus -to 6 9
12428 gitlogo copy gitlogoplus -to 11 9
12429 image delete gitlogoplus
12431 image create photo gitlogo32 -width 32 -height 32
12432 gitlogo32 copy gitlogo -zoom 2 2
12434 wm iconphoto . -default gitlogo gitlogo32
12436 # wait for the window to become visible
12437 tkwait visibility .
12438 set_window_title
12439 update
12440 readrefs
12442 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12443 # create a view for the files/dirs specified on the command line
12444 set curview 1
12445 set selectedview 1
12446 set nextviewnum 2
12447 set viewname(1) [mc "Command line"]
12448 set viewfiles(1) $cmdline_files
12449 set viewargs(1) $revtreeargs
12450 set viewargscmd(1) $revtreeargscmd
12451 set viewperm(1) 0
12452 set viewchanged(1) 0
12453 set vdatemode(1) 0
12454 addviewmenu 1
12455 .bar.view entryconf [mca "Edit view..."] -state normal
12456 .bar.view entryconf [mca "Delete view"] -state normal
12459 if {[info exists permviews]} {
12460 foreach v $permviews {
12461 set n $nextviewnum
12462 incr nextviewnum
12463 set viewname($n) [lindex $v 0]
12464 set viewfiles($n) [lindex $v 1]
12465 set viewargs($n) [lindex $v 2]
12466 set viewargscmd($n) [lindex $v 3]
12467 set viewperm($n) 1
12468 set viewchanged($n) 0
12469 addviewmenu $n
12473 if {[tk windowingsystem] eq "win32"} {
12474 focus -force .
12477 getcommits {}
12479 # Local variables:
12480 # mode: tcl
12481 # indent-tabs-mode: t
12482 # tab-width: 8
12483 # End: