mingw: squash another warning about a cast
[git/raj.git] / gitk-git / gitk
blob5f1255c860486571ef1159695318c74c73f8c340
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 global use_ttk
1948 if {[tk windowingsystem] ne "win32"} {
1949 option add *Panedwindow.showHandle 1 startupFile
1950 option add *Panedwindow.sashRelief raised startupFile
1951 if {[tk windowingsystem] ne "aqua"} {
1952 option add *Menu.font uifont startupFile
1954 } else {
1955 option add *Menu.TearOff 0 startupFile
1957 option add *Button.font uifont startupFile
1958 option add *Checkbutton.font uifont startupFile
1959 option add *Radiobutton.font uifont startupFile
1960 option add *Menubutton.font uifont startupFile
1961 option add *Label.font uifont startupFile
1962 option add *Message.font uifont startupFile
1963 option add *Entry.font textfont startupFile
1964 option add *Text.font textfont startupFile
1965 option add *Labelframe.font uifont startupFile
1966 option add *Spinbox.font textfont startupFile
1967 option add *Listbox.font mainfont startupFile
1970 proc setttkstyle {} {
1971 eval font configure TkDefaultFont [fontflags mainfont]
1972 eval font configure TkTextFont [fontflags textfont]
1973 eval font configure TkHeadingFont [fontflags mainfont]
1974 eval font configure TkCaptionFont [fontflags mainfont] -weight bold
1975 eval font configure TkTooltipFont [fontflags uifont]
1976 eval font configure TkFixedFont [fontflags textfont]
1977 eval font configure TkIconFont [fontflags uifont]
1978 eval font configure TkMenuFont [fontflags uifont]
1979 eval font configure TkSmallCaptionFont [fontflags uifont]
1982 # Make a menu and submenus.
1983 # m is the window name for the menu, items is the list of menu items to add.
1984 # Each item is a list {mc label type description options...}
1985 # mc is ignored; it's so we can put mc there to alert xgettext
1986 # label is the string that appears in the menu
1987 # type is cascade, command or radiobutton (should add checkbutton)
1988 # description depends on type; it's the sublist for cascade, the
1989 # command to invoke for command, or {variable value} for radiobutton
1990 proc makemenu {m items} {
1991 menu $m
1992 if {[tk windowingsystem] eq {aqua}} {
1993 set Meta1 Cmd
1994 } else {
1995 set Meta1 Ctrl
1997 foreach i $items {
1998 set name [mc [lindex $i 1]]
1999 set type [lindex $i 2]
2000 set thing [lindex $i 3]
2001 set params [list $type]
2002 if {$name ne {}} {
2003 set u [string first "&" [string map {&& x} $name]]
2004 lappend params -label [string map {&& & & {}} $name]
2005 if {$u >= 0} {
2006 lappend params -underline $u
2009 switch -- $type {
2010 "cascade" {
2011 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
2012 lappend params -menu $m.$submenu
2014 "command" {
2015 lappend params -command $thing
2017 "radiobutton" {
2018 lappend params -variable [lindex $thing 0] \
2019 -value [lindex $thing 1]
2022 set tail [lrange $i 4 end]
2023 regsub -all {\yMeta1\y} $tail $Meta1 tail
2024 eval $m add $params $tail
2025 if {$type eq "cascade"} {
2026 makemenu $m.$submenu $thing
2031 # translate string and remove ampersands
2032 proc mca {str} {
2033 return [string map {&& & & {}} [mc $str]]
2036 proc cleardropsel {w} {
2037 $w selection clear
2039 proc makedroplist {w varname args} {
2040 global use_ttk
2041 if {$use_ttk} {
2042 set width 0
2043 foreach label $args {
2044 set cx [string length $label]
2045 if {$cx > $width} {set width $cx}
2047 set gm [ttk::combobox $w -width $width -state readonly\
2048 -textvariable $varname -values $args \
2049 -exportselection false]
2050 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2051 } else {
2052 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2054 return $gm
2057 proc makewindow {} {
2058 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2059 global tabstop
2060 global findtype findtypemenu findloc findstring fstring geometry
2061 global entries sha1entry sha1string sha1but
2062 global diffcontextstring diffcontext
2063 global ignorespace
2064 global maincursor textcursor curtextcursor
2065 global rowctxmenu fakerowmenu mergemax wrapcomment
2066 global highlight_files gdttype
2067 global searchstring sstring
2068 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2069 global uifgcolor uifgdisabledcolor
2070 global filesepbgcolor filesepfgcolor
2071 global mergecolors foundbgcolor currentsearchhitbgcolor
2072 global headctxmenu progresscanv progressitem progresscoords statusw
2073 global fprogitem fprogcoord lastprogupdate progupdatepending
2074 global rprogitem rprogcoord rownumsel numcommits
2075 global have_tk85 use_ttk NS
2076 global git_version
2077 global worddiff
2079 # The "mc" arguments here are purely so that xgettext
2080 # sees the following string as needing to be translated
2081 set file {
2082 mc "&File" cascade {
2083 {mc "&Update" command updatecommits -accelerator F5}
2084 {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2085 {mc "Reread re&ferences" command rereadrefs}
2086 {mc "&List references" command showrefs -accelerator F2}
2087 {xx "" separator}
2088 {mc "Start git &gui" command {exec git gui &}}
2089 {xx "" separator}
2090 {mc "&Quit" command doquit -accelerator Meta1-Q}
2092 set edit {
2093 mc "&Edit" cascade {
2094 {mc "&Preferences" command doprefs}
2096 set view {
2097 mc "&View" cascade {
2098 {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2099 {mc "&Edit view..." command editview -state disabled -accelerator F4}
2100 {mc "&Delete view" command delview -state disabled}
2101 {xx "" separator}
2102 {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2104 if {[tk windowingsystem] ne "aqua"} {
2105 set help {
2106 mc "&Help" cascade {
2107 {mc "&About gitk" command about}
2108 {mc "&Key bindings" command keys}
2110 set bar [list $file $edit $view $help]
2111 } else {
2112 proc ::tk::mac::ShowPreferences {} {doprefs}
2113 proc ::tk::mac::Quit {} {doquit}
2114 lset file end [lreplace [lindex $file end] end-1 end]
2115 set apple {
2116 xx "&Apple" cascade {
2117 {mc "&About gitk" command about}
2118 {xx "" separator}
2120 set help {
2121 mc "&Help" cascade {
2122 {mc "&Key bindings" command keys}
2124 set bar [list $apple $file $view $help]
2126 makemenu .bar $bar
2127 . configure -menu .bar
2129 if {$use_ttk} {
2130 # cover the non-themed toplevel with a themed frame.
2131 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2134 # the gui has upper and lower half, parts of a paned window.
2135 ${NS}::panedwindow .ctop -orient vertical
2137 # possibly use assumed geometry
2138 if {![info exists geometry(pwsash0)]} {
2139 set geometry(topheight) [expr {15 * $linespc}]
2140 set geometry(topwidth) [expr {80 * $charspc}]
2141 set geometry(botheight) [expr {15 * $linespc}]
2142 set geometry(botwidth) [expr {50 * $charspc}]
2143 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2144 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2147 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2148 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2149 ${NS}::frame .tf.histframe
2150 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2151 if {!$use_ttk} {
2152 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2155 # create three canvases
2156 set cscroll .tf.histframe.csb
2157 set canv .tf.histframe.pwclist.canv
2158 canvas $canv \
2159 -selectbackground $selectbgcolor \
2160 -background $bgcolor -bd 0 \
2161 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2162 .tf.histframe.pwclist add $canv
2163 set canv2 .tf.histframe.pwclist.canv2
2164 canvas $canv2 \
2165 -selectbackground $selectbgcolor \
2166 -background $bgcolor -bd 0 -yscrollincr $linespc
2167 .tf.histframe.pwclist add $canv2
2168 set canv3 .tf.histframe.pwclist.canv3
2169 canvas $canv3 \
2170 -selectbackground $selectbgcolor \
2171 -background $bgcolor -bd 0 -yscrollincr $linespc
2172 .tf.histframe.pwclist add $canv3
2173 if {$use_ttk} {
2174 bind .tf.histframe.pwclist <Map> {
2175 bind %W <Map> {}
2176 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2177 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2179 } else {
2180 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2181 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2184 # a scroll bar to rule them
2185 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2186 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2187 pack $cscroll -side right -fill y
2188 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2189 lappend bglist $canv $canv2 $canv3
2190 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2192 # we have two button bars at bottom of top frame. Bar 1
2193 ${NS}::frame .tf.bar
2194 ${NS}::frame .tf.lbar -height 15
2196 set sha1entry .tf.bar.sha1
2197 set entries $sha1entry
2198 set sha1but .tf.bar.sha1label
2199 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2200 -command gotocommit -width 8
2201 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2202 pack .tf.bar.sha1label -side left
2203 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2204 trace add variable sha1string write sha1change
2205 pack $sha1entry -side left -pady 2
2207 set bm_left_data {
2208 #define left_width 16
2209 #define left_height 16
2210 static unsigned char left_bits[] = {
2211 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2212 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2213 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2215 set bm_right_data {
2216 #define right_width 16
2217 #define right_height 16
2218 static unsigned char right_bits[] = {
2219 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2220 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2221 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2223 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2224 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2225 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2226 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2228 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2229 if {$use_ttk} {
2230 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2231 } else {
2232 .tf.bar.leftbut configure -image bm-left
2234 pack .tf.bar.leftbut -side left -fill y
2235 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2236 if {$use_ttk} {
2237 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2238 } else {
2239 .tf.bar.rightbut configure -image bm-right
2241 pack .tf.bar.rightbut -side left -fill y
2243 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2244 set rownumsel {}
2245 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2246 -relief sunken -anchor e
2247 ${NS}::label .tf.bar.rowlabel2 -text "/"
2248 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2249 -relief sunken -anchor e
2250 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2251 -side left
2252 if {!$use_ttk} {
2253 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2255 global selectedline
2256 trace add variable selectedline write selectedline_change
2258 # Status label and progress bar
2259 set statusw .tf.bar.status
2260 ${NS}::label $statusw -width 15 -relief sunken
2261 pack $statusw -side left -padx 5
2262 if {$use_ttk} {
2263 set progresscanv [ttk::progressbar .tf.bar.progress]
2264 } else {
2265 set h [expr {[font metrics uifont -linespace] + 2}]
2266 set progresscanv .tf.bar.progress
2267 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2268 set progressitem [$progresscanv create rect -1 0 0 $h -fill lime]
2269 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2270 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2272 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2273 set progresscoords {0 0}
2274 set fprogcoord 0
2275 set rprogcoord 0
2276 bind $progresscanv <Configure> adjustprogress
2277 set lastprogupdate [clock clicks -milliseconds]
2278 set progupdatepending 0
2280 # build up the bottom bar of upper window
2281 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2283 set bm_down_data {
2284 #define down_width 16
2285 #define down_height 16
2286 static unsigned char down_bits[] = {
2287 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2288 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2289 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2290 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2292 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2293 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2294 .tf.lbar.fnext configure -image bm-down
2296 set bm_up_data {
2297 #define up_width 16
2298 #define up_height 16
2299 static unsigned char up_bits[] = {
2300 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2301 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2302 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2303 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2305 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2306 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2307 .tf.lbar.fprev configure -image bm-up
2309 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2311 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2312 -side left -fill y
2313 set gdttype [mc "containing:"]
2314 set gm [makedroplist .tf.lbar.gdttype gdttype \
2315 [mc "containing:"] \
2316 [mc "touching paths:"] \
2317 [mc "adding/removing string:"] \
2318 [mc "changing lines matching:"]]
2319 trace add variable gdttype write gdttype_change
2320 pack .tf.lbar.gdttype -side left -fill y
2322 set findstring {}
2323 set fstring .tf.lbar.findstring
2324 lappend entries $fstring
2325 ${NS}::entry $fstring -width 30 -textvariable findstring
2326 trace add variable findstring write find_change
2327 set findtype [mc "Exact"]
2328 set findtypemenu [makedroplist .tf.lbar.findtype \
2329 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2330 trace add variable findtype write findcom_change
2331 set findloc [mc "All fields"]
2332 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2333 [mc "Comments"] [mc "Author"] [mc "Committer"]
2334 trace add variable findloc write find_change
2335 pack .tf.lbar.findloc -side right
2336 pack .tf.lbar.findtype -side right
2337 pack $fstring -side left -expand 1 -fill x
2339 # Finish putting the upper half of the viewer together
2340 pack .tf.lbar -in .tf -side bottom -fill x
2341 pack .tf.bar -in .tf -side bottom -fill x
2342 pack .tf.histframe -fill both -side top -expand 1
2343 .ctop add .tf
2344 if {!$use_ttk} {
2345 .ctop paneconfigure .tf -height $geometry(topheight)
2346 .ctop paneconfigure .tf -width $geometry(topwidth)
2349 # now build up the bottom
2350 ${NS}::panedwindow .pwbottom -orient horizontal
2352 # lower left, a text box over search bar, scroll bar to the right
2353 # if we know window height, then that will set the lower text height, otherwise
2354 # we set lower text height which will drive window height
2355 if {[info exists geometry(main)]} {
2356 ${NS}::frame .bleft -width $geometry(botwidth)
2357 } else {
2358 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2360 ${NS}::frame .bleft.top
2361 ${NS}::frame .bleft.mid
2362 ${NS}::frame .bleft.bottom
2364 # gap between sub-widgets
2365 set wgap [font measure uifont "i"]
2367 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2368 pack .bleft.top.search -side left -padx 5
2369 set sstring .bleft.top.sstring
2370 set searchstring ""
2371 ${NS}::entry $sstring -width 20 -textvariable searchstring
2372 lappend entries $sstring
2373 trace add variable searchstring write incrsearch
2374 pack $sstring -side left -expand 1 -fill x
2375 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2376 -command changediffdisp -variable diffelide -value {0 0}
2377 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2378 -command changediffdisp -variable diffelide -value {0 1}
2379 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2380 -command changediffdisp -variable diffelide -value {1 0}
2382 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2383 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left -ipadx $wgap
2384 spinbox .bleft.mid.diffcontext -width 5 \
2385 -from 0 -increment 1 -to 10000000 \
2386 -validate all -validatecommand "diffcontextvalidate %P" \
2387 -textvariable diffcontextstring
2388 .bleft.mid.diffcontext set $diffcontext
2389 trace add variable diffcontextstring write diffcontextchange
2390 lappend entries .bleft.mid.diffcontext
2391 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left -ipadx $wgap
2392 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2393 -command changeignorespace -variable ignorespace
2394 pack .bleft.mid.ignspace -side left -padx 5
2396 set worddiff [mc "Line diff"]
2397 if {[package vcompare $git_version "1.7.2"] >= 0} {
2398 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2399 [mc "Markup words"] [mc "Color words"]
2400 trace add variable worddiff write changeworddiff
2401 pack .bleft.mid.worddiff -side left -padx 5
2404 set ctext .bleft.bottom.ctext
2405 text $ctext -background $bgcolor -foreground $fgcolor \
2406 -state disabled -font textfont \
2407 -yscrollcommand scrolltext -wrap none \
2408 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2409 if {$have_tk85} {
2410 $ctext conf -tabstyle wordprocessor
2412 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2413 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2414 pack .bleft.top -side top -fill x
2415 pack .bleft.mid -side top -fill x
2416 grid $ctext .bleft.bottom.sb -sticky nsew
2417 grid .bleft.bottom.sbhorizontal -sticky ew
2418 grid columnconfigure .bleft.bottom 0 -weight 1
2419 grid rowconfigure .bleft.bottom 0 -weight 1
2420 grid rowconfigure .bleft.bottom 1 -weight 0
2421 pack .bleft.bottom -side top -fill both -expand 1
2422 lappend bglist $ctext
2423 lappend fglist $ctext
2425 $ctext tag conf comment -wrap $wrapcomment
2426 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2427 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2428 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2429 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2430 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2431 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2432 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2433 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2434 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2435 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2436 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2437 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2438 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2439 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2440 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2441 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2442 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2443 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2444 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2445 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2446 $ctext tag conf mmax -fore darkgrey
2447 set mergemax 16
2448 $ctext tag conf mresult -font textfontbold
2449 $ctext tag conf msep -font textfontbold
2450 $ctext tag conf found -back $foundbgcolor
2451 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2452 $ctext tag conf wwrap -wrap word -lmargin2 1c
2453 $ctext tag conf bold -font textfontbold
2455 .pwbottom add .bleft
2456 if {!$use_ttk} {
2457 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2460 # lower right
2461 ${NS}::frame .bright
2462 ${NS}::frame .bright.mode
2463 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2464 -command reselectline -variable cmitmode -value "patch"
2465 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2466 -command reselectline -variable cmitmode -value "tree"
2467 grid .bright.mode.patch .bright.mode.tree -sticky ew
2468 pack .bright.mode -side top -fill x
2469 set cflist .bright.cfiles
2470 set indent [font measure mainfont "nn"]
2471 text $cflist \
2472 -selectbackground $selectbgcolor \
2473 -background $bgcolor -foreground $fgcolor \
2474 -font mainfont \
2475 -tabs [list $indent [expr {2 * $indent}]] \
2476 -yscrollcommand ".bright.sb set" \
2477 -cursor [. cget -cursor] \
2478 -spacing1 1 -spacing3 1
2479 lappend bglist $cflist
2480 lappend fglist $cflist
2481 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2482 pack .bright.sb -side right -fill y
2483 pack $cflist -side left -fill both -expand 1
2484 $cflist tag configure highlight \
2485 -background [$cflist cget -selectbackground]
2486 $cflist tag configure bold -font mainfontbold
2488 .pwbottom add .bright
2489 .ctop add .pwbottom
2491 # restore window width & height if known
2492 if {[info exists geometry(main)]} {
2493 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2494 if {$w > [winfo screenwidth .]} {
2495 set w [winfo screenwidth .]
2497 if {$h > [winfo screenheight .]} {
2498 set h [winfo screenheight .]
2500 wm geometry . "${w}x$h"
2504 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2505 wm state . $geometry(state)
2508 if {[tk windowingsystem] eq {aqua}} {
2509 set M1B M1
2510 set ::BM "3"
2511 } else {
2512 set M1B Control
2513 set ::BM "2"
2516 if {$use_ttk} {
2517 bind .ctop <Map> {
2518 bind %W <Map> {}
2519 %W sashpos 0 $::geometry(topheight)
2521 bind .pwbottom <Map> {
2522 bind %W <Map> {}
2523 %W sashpos 0 $::geometry(botwidth)
2527 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2528 pack .ctop -fill both -expand 1
2529 bindall <1> {selcanvline %W %x %y}
2530 #bindall <B1-Motion> {selcanvline %W %x %y}
2531 if {[tk windowingsystem] == "win32"} {
2532 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2533 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2534 } else {
2535 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2536 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2537 bind $ctext <Button> {
2538 if {"%b" eq 6} {
2539 $ctext xview scroll -5 units
2540 } elseif {"%b" eq 7} {
2541 $ctext xview scroll 5 units
2544 if {[tk windowingsystem] eq "aqua"} {
2545 bindall <MouseWheel> {
2546 set delta [expr {- (%D)}]
2547 allcanvs yview scroll $delta units
2549 bindall <Shift-MouseWheel> {
2550 set delta [expr {- (%D)}]
2551 $canv xview scroll $delta units
2555 bindall <$::BM> "canvscan mark %W %x %y"
2556 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2557 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2558 bind . <$M1B-Key-w> doquit
2559 bindkey <Home> selfirstline
2560 bindkey <End> sellastline
2561 bind . <Key-Up> "selnextline -1"
2562 bind . <Key-Down> "selnextline 1"
2563 bind . <Shift-Key-Up> "dofind -1 0"
2564 bind . <Shift-Key-Down> "dofind 1 0"
2565 bindkey <Key-Right> "goforw"
2566 bindkey <Key-Left> "goback"
2567 bind . <Key-Prior> "selnextpage -1"
2568 bind . <Key-Next> "selnextpage 1"
2569 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2570 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2571 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2572 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2573 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2574 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2575 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2576 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2577 bindkey <Key-space> "$ctext yview scroll 1 pages"
2578 bindkey p "selnextline -1"
2579 bindkey n "selnextline 1"
2580 bindkey z "goback"
2581 bindkey x "goforw"
2582 bindkey k "selnextline -1"
2583 bindkey j "selnextline 1"
2584 bindkey h "goback"
2585 bindkey l "goforw"
2586 bindkey b prevfile
2587 bindkey d "$ctext yview scroll 18 units"
2588 bindkey u "$ctext yview scroll -18 units"
2589 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2590 bindkey / {focus $fstring}
2591 bindkey <Key-KP_Divide> {focus $fstring}
2592 bindkey <Key-Return> {dofind 1 1}
2593 bindkey ? {dofind -1 1}
2594 bindkey f nextfile
2595 bind . <F5> updatecommits
2596 bindmodfunctionkey Shift 5 reloadcommits
2597 bind . <F2> showrefs
2598 bindmodfunctionkey Shift 4 {newview 0}
2599 bind . <F4> edit_or_newview
2600 bind . <$M1B-q> doquit
2601 bind . <$M1B-f> {dofind 1 1}
2602 bind . <$M1B-g> {dofind 1 0}
2603 bind . <$M1B-r> dosearchback
2604 bind . <$M1B-s> dosearch
2605 bind . <$M1B-equal> {incrfont 1}
2606 bind . <$M1B-plus> {incrfont 1}
2607 bind . <$M1B-KP_Add> {incrfont 1}
2608 bind . <$M1B-minus> {incrfont -1}
2609 bind . <$M1B-KP_Subtract> {incrfont -1}
2610 wm protocol . WM_DELETE_WINDOW doquit
2611 bind . <Destroy> {stop_backends}
2612 bind . <Button-1> "click %W"
2613 bind $fstring <Key-Return> {dofind 1 1}
2614 bind $sha1entry <Key-Return> {gotocommit; break}
2615 bind $sha1entry <<PasteSelection>> clearsha1
2616 bind $sha1entry <<Paste>> clearsha1
2617 bind $cflist <1> {sel_flist %W %x %y; break}
2618 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2619 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2620 global ctxbut
2621 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2622 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2623 bind $ctext <Button-1> {focus %W}
2624 bind $ctext <<Selection>> rehighlight_search_results
2625 for {set i 1} {$i < 10} {incr i} {
2626 bind . <$M1B-Key-$i> [list go_to_parent $i]
2629 set maincursor [. cget -cursor]
2630 set textcursor [$ctext cget -cursor]
2631 set curtextcursor $textcursor
2633 set rowctxmenu .rowctxmenu
2634 makemenu $rowctxmenu {
2635 {mc "Diff this -> selected" command {diffvssel 0}}
2636 {mc "Diff selected -> this" command {diffvssel 1}}
2637 {mc "Make patch" command mkpatch}
2638 {mc "Create tag" command mktag}
2639 {mc "Copy commit summary" command copysummary}
2640 {mc "Write commit to file" command writecommit}
2641 {mc "Create new branch" command mkbranch}
2642 {mc "Cherry-pick this commit" command cherrypick}
2643 {mc "Reset HEAD branch to here" command resethead}
2644 {mc "Mark this commit" command markhere}
2645 {mc "Return to mark" command gotomark}
2646 {mc "Find descendant of this and mark" command find_common_desc}
2647 {mc "Compare with marked commit" command compare_commits}
2648 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2649 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2650 {mc "Revert this commit" command revert}
2652 $rowctxmenu configure -tearoff 0
2654 set fakerowmenu .fakerowmenu
2655 makemenu $fakerowmenu {
2656 {mc "Diff this -> selected" command {diffvssel 0}}
2657 {mc "Diff selected -> this" command {diffvssel 1}}
2658 {mc "Make patch" command mkpatch}
2659 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2660 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2662 $fakerowmenu configure -tearoff 0
2664 set headctxmenu .headctxmenu
2665 makemenu $headctxmenu {
2666 {mc "Check out this branch" command cobranch}
2667 {mc "Remove this branch" command rmbranch}
2668 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2670 $headctxmenu configure -tearoff 0
2672 global flist_menu
2673 set flist_menu .flistctxmenu
2674 makemenu $flist_menu {
2675 {mc "Highlight this too" command {flist_hl 0}}
2676 {mc "Highlight this only" command {flist_hl 1}}
2677 {mc "External diff" command {external_diff}}
2678 {mc "Blame parent commit" command {external_blame 1}}
2679 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2681 $flist_menu configure -tearoff 0
2683 global diff_menu
2684 set diff_menu .diffctxmenu
2685 makemenu $diff_menu {
2686 {mc "Show origin of this line" command show_line_source}
2687 {mc "Run git gui blame on this line" command {external_blame_diff}}
2689 $diff_menu configure -tearoff 0
2692 # Windows sends all mouse wheel events to the current focused window, not
2693 # the one where the mouse hovers, so bind those events here and redirect
2694 # to the correct window
2695 proc windows_mousewheel_redirector {W X Y D} {
2696 global canv canv2 canv3
2697 set w [winfo containing -displayof $W $X $Y]
2698 if {$w ne ""} {
2699 set u [expr {$D < 0 ? 5 : -5}]
2700 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2701 allcanvs yview scroll $u units
2702 } else {
2703 catch {
2704 $w yview scroll $u units
2710 # Update row number label when selectedline changes
2711 proc selectedline_change {n1 n2 op} {
2712 global selectedline rownumsel
2714 if {$selectedline eq {}} {
2715 set rownumsel {}
2716 } else {
2717 set rownumsel [expr {$selectedline + 1}]
2721 # mouse-2 makes all windows scan vertically, but only the one
2722 # the cursor is in scans horizontally
2723 proc canvscan {op w x y} {
2724 global canv canv2 canv3
2725 foreach c [list $canv $canv2 $canv3] {
2726 if {$c == $w} {
2727 $c scan $op $x $y
2728 } else {
2729 $c scan $op 0 $y
2734 proc scrollcanv {cscroll f0 f1} {
2735 $cscroll set $f0 $f1
2736 drawvisible
2737 flushhighlights
2740 # when we make a key binding for the toplevel, make sure
2741 # it doesn't get triggered when that key is pressed in the
2742 # find string entry widget.
2743 proc bindkey {ev script} {
2744 global entries
2745 bind . $ev $script
2746 set escript [bind Entry $ev]
2747 if {$escript == {}} {
2748 set escript [bind Entry <Key>]
2750 foreach e $entries {
2751 bind $e $ev "$escript; break"
2755 proc bindmodfunctionkey {mod n script} {
2756 bind . <$mod-F$n> $script
2757 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2760 # set the focus back to the toplevel for any click outside
2761 # the entry widgets
2762 proc click {w} {
2763 global ctext entries
2764 foreach e [concat $entries $ctext] {
2765 if {$w == $e} return
2767 focus .
2770 # Adjust the progress bar for a change in requested extent or canvas size
2771 proc adjustprogress {} {
2772 global progresscanv progressitem progresscoords
2773 global fprogitem fprogcoord lastprogupdate progupdatepending
2774 global rprogitem rprogcoord use_ttk
2776 if {$use_ttk} {
2777 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2778 return
2781 set w [expr {[winfo width $progresscanv] - 4}]
2782 set x0 [expr {$w * [lindex $progresscoords 0]}]
2783 set x1 [expr {$w * [lindex $progresscoords 1]}]
2784 set h [winfo height $progresscanv]
2785 $progresscanv coords $progressitem $x0 0 $x1 $h
2786 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2787 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2788 set now [clock clicks -milliseconds]
2789 if {$now >= $lastprogupdate + 100} {
2790 set progupdatepending 0
2791 update
2792 } elseif {!$progupdatepending} {
2793 set progupdatepending 1
2794 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2798 proc doprogupdate {} {
2799 global lastprogupdate progupdatepending
2801 if {$progupdatepending} {
2802 set progupdatepending 0
2803 set lastprogupdate [clock clicks -milliseconds]
2804 update
2808 proc config_check_tmp_exists {tries_left} {
2809 global config_file_tmp
2811 if {[file exists $config_file_tmp]} {
2812 incr tries_left -1
2813 if {$tries_left > 0} {
2814 after 100 [list config_check_tmp_exists $tries_left]
2815 } else {
2816 error_popup "There appears to be a stale $config_file_tmp\
2817 file, which will prevent gitk from saving its configuration on exit.\
2818 Please remove it if it is not being used by any existing gitk process."
2823 proc config_init_trace {name} {
2824 global config_variable_changed config_variable_original
2826 upvar #0 $name var
2827 set config_variable_changed($name) 0
2828 set config_variable_original($name) $var
2831 proc config_variable_change_cb {name name2 op} {
2832 global config_variable_changed config_variable_original
2834 upvar #0 $name var
2835 if {$op eq "write" &&
2836 (![info exists config_variable_original($name)] ||
2837 $config_variable_original($name) ne $var)} {
2838 set config_variable_changed($name) 1
2842 proc savestuff {w} {
2843 global stuffsaved
2844 global config_file config_file_tmp
2845 global config_variables config_variable_changed
2846 global viewchanged
2848 upvar #0 viewname current_viewname
2849 upvar #0 viewfiles current_viewfiles
2850 upvar #0 viewargs current_viewargs
2851 upvar #0 viewargscmd current_viewargscmd
2852 upvar #0 viewperm current_viewperm
2853 upvar #0 nextviewnum current_nextviewnum
2854 upvar #0 use_ttk current_use_ttk
2856 if {$stuffsaved} return
2857 if {![winfo viewable .]} return
2858 set remove_tmp 0
2859 if {[catch {
2860 set try_count 0
2861 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2862 if {[incr try_count] > 50} {
2863 error "Unable to write config file: $config_file_tmp exists"
2865 after 100
2867 set remove_tmp 1
2868 if {$::tcl_platform(platform) eq {windows}} {
2869 file attributes $config_file_tmp -hidden true
2871 if {[file exists $config_file]} {
2872 source $config_file
2874 foreach var_name $config_variables {
2875 upvar #0 $var_name var
2876 upvar 0 $var_name old_var
2877 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2878 puts $f [list set $var_name $old_var]
2879 } else {
2880 puts $f [list set $var_name $var]
2884 puts $f "set geometry(main) [wm geometry .]"
2885 puts $f "set geometry(state) [wm state .]"
2886 puts $f "set geometry(topwidth) [winfo width .tf]"
2887 puts $f "set geometry(topheight) [winfo height .tf]"
2888 if {$current_use_ttk} {
2889 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2890 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2891 } else {
2892 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2893 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2895 puts $f "set geometry(botwidth) [winfo width .bleft]"
2896 puts $f "set geometry(botheight) [winfo height .bleft]"
2898 array set view_save {}
2899 array set views {}
2900 if {![info exists permviews]} { set permviews {} }
2901 foreach view $permviews {
2902 set view_save([lindex $view 0]) 1
2903 set views([lindex $view 0]) $view
2905 puts -nonewline $f "set permviews {"
2906 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2907 if {$viewchanged($v)} {
2908 if {$current_viewperm($v)} {
2909 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2910 } else {
2911 set view_save($current_viewname($v)) 0
2915 # write old and updated view to their places and append remaining to the end
2916 foreach view $permviews {
2917 set view_name [lindex $view 0]
2918 if {$view_save($view_name)} {
2919 puts $f "{$views($view_name)}"
2921 unset views($view_name)
2923 foreach view_name [array names views] {
2924 puts $f "{$views($view_name)}"
2926 puts $f "}"
2927 close $f
2928 file rename -force $config_file_tmp $config_file
2929 set remove_tmp 0
2930 } err]} {
2931 puts "Error saving config: $err"
2933 if {$remove_tmp} {
2934 file delete -force $config_file_tmp
2936 set stuffsaved 1
2939 proc resizeclistpanes {win w} {
2940 global oldwidth use_ttk
2941 if {[info exists oldwidth($win)]} {
2942 if {$use_ttk} {
2943 set s0 [$win sashpos 0]
2944 set s1 [$win sashpos 1]
2945 } else {
2946 set s0 [$win sash coord 0]
2947 set s1 [$win sash coord 1]
2949 if {$w < 60} {
2950 set sash0 [expr {int($w/2 - 2)}]
2951 set sash1 [expr {int($w*5/6 - 2)}]
2952 } else {
2953 set factor [expr {1.0 * $w / $oldwidth($win)}]
2954 set sash0 [expr {int($factor * [lindex $s0 0])}]
2955 set sash1 [expr {int($factor * [lindex $s1 0])}]
2956 if {$sash0 < 30} {
2957 set sash0 30
2959 if {$sash1 < $sash0 + 20} {
2960 set sash1 [expr {$sash0 + 20}]
2962 if {$sash1 > $w - 10} {
2963 set sash1 [expr {$w - 10}]
2964 if {$sash0 > $sash1 - 20} {
2965 set sash0 [expr {$sash1 - 20}]
2969 if {$use_ttk} {
2970 $win sashpos 0 $sash0
2971 $win sashpos 1 $sash1
2972 } else {
2973 $win sash place 0 $sash0 [lindex $s0 1]
2974 $win sash place 1 $sash1 [lindex $s1 1]
2977 set oldwidth($win) $w
2980 proc resizecdetpanes {win w} {
2981 global oldwidth use_ttk
2982 if {[info exists oldwidth($win)]} {
2983 if {$use_ttk} {
2984 set s0 [$win sashpos 0]
2985 } else {
2986 set s0 [$win sash coord 0]
2988 if {$w < 60} {
2989 set sash0 [expr {int($w*3/4 - 2)}]
2990 } else {
2991 set factor [expr {1.0 * $w / $oldwidth($win)}]
2992 set sash0 [expr {int($factor * [lindex $s0 0])}]
2993 if {$sash0 < 45} {
2994 set sash0 45
2996 if {$sash0 > $w - 15} {
2997 set sash0 [expr {$w - 15}]
3000 if {$use_ttk} {
3001 $win sashpos 0 $sash0
3002 } else {
3003 $win sash place 0 $sash0 [lindex $s0 1]
3006 set oldwidth($win) $w
3009 proc allcanvs args {
3010 global canv canv2 canv3
3011 eval $canv $args
3012 eval $canv2 $args
3013 eval $canv3 $args
3016 proc bindall {event action} {
3017 global canv canv2 canv3
3018 bind $canv $event $action
3019 bind $canv2 $event $action
3020 bind $canv3 $event $action
3023 proc about {} {
3024 global uifont NS
3025 set w .about
3026 if {[winfo exists $w]} {
3027 raise $w
3028 return
3030 ttk_toplevel $w
3031 wm title $w [mc "About gitk"]
3032 make_transient $w .
3033 message $w.m -text [mc "
3034 Gitk - a commit viewer for git
3036 Copyright \u00a9 2005-2014 Paul Mackerras
3038 Use and redistribute under the terms of the GNU General Public License"] \
3039 -justify center -aspect 400 -border 2 -bg white -relief groove
3040 pack $w.m -side top -fill x -padx 2 -pady 2
3041 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3042 pack $w.ok -side bottom
3043 bind $w <Visibility> "focus $w.ok"
3044 bind $w <Key-Escape> "destroy $w"
3045 bind $w <Key-Return> "destroy $w"
3046 tk::PlaceWindow $w widget .
3049 proc keys {} {
3050 global NS
3051 set w .keys
3052 if {[winfo exists $w]} {
3053 raise $w
3054 return
3056 if {[tk windowingsystem] eq {aqua}} {
3057 set M1T Cmd
3058 } else {
3059 set M1T Ctrl
3061 ttk_toplevel $w
3062 wm title $w [mc "Gitk key bindings"]
3063 make_transient $w .
3064 message $w.m -text "
3065 [mc "Gitk key bindings:"]
3067 [mc "<%s-Q> Quit" $M1T]
3068 [mc "<%s-W> Close window" $M1T]
3069 [mc "<Home> Move to first commit"]
3070 [mc "<End> Move to last commit"]
3071 [mc "<Up>, p, k Move up one commit"]
3072 [mc "<Down>, n, j Move down one commit"]
3073 [mc "<Left>, z, h Go back in history list"]
3074 [mc "<Right>, x, l Go forward in history list"]
3075 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3076 [mc "<PageUp> Move up one page in commit list"]
3077 [mc "<PageDown> Move down one page in commit list"]
3078 [mc "<%s-Home> Scroll to top of commit list" $M1T]
3079 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
3080 [mc "<%s-Up> Scroll commit list up one line" $M1T]
3081 [mc "<%s-Down> Scroll commit list down one line" $M1T]
3082 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3083 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3084 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3085 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3086 [mc "<Delete>, b Scroll diff view up one page"]
3087 [mc "<Backspace> Scroll diff view up one page"]
3088 [mc "<Space> Scroll diff view down one page"]
3089 [mc "u Scroll diff view up 18 lines"]
3090 [mc "d Scroll diff view down 18 lines"]
3091 [mc "<%s-F> Find" $M1T]
3092 [mc "<%s-G> Move to next find hit" $M1T]
3093 [mc "<Return> Move to next find hit"]
3094 [mc "g Go to commit"]
3095 [mc "/ Focus the search box"]
3096 [mc "? Move to previous find hit"]
3097 [mc "f Scroll diff view to next file"]
3098 [mc "<%s-S> Search for next hit in diff view" $M1T]
3099 [mc "<%s-R> Search for previous hit in diff view" $M1T]
3100 [mc "<%s-KP+> Increase font size" $M1T]
3101 [mc "<%s-plus> Increase font size" $M1T]
3102 [mc "<%s-KP-> Decrease font size" $M1T]
3103 [mc "<%s-minus> Decrease font size" $M1T]
3104 [mc "<F5> Update"]
3106 -justify left -bg white -border 2 -relief groove
3107 pack $w.m -side top -fill both -padx 2 -pady 2
3108 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3109 bind $w <Key-Escape> [list destroy $w]
3110 pack $w.ok -side bottom
3111 bind $w <Visibility> "focus $w.ok"
3112 bind $w <Key-Escape> "destroy $w"
3113 bind $w <Key-Return> "destroy $w"
3116 # Procedures for manipulating the file list window at the
3117 # bottom right of the overall window.
3119 proc treeview {w l openlevs} {
3120 global treecontents treediropen treeheight treeparent treeindex
3122 set ix 0
3123 set treeindex() 0
3124 set lev 0
3125 set prefix {}
3126 set prefixend -1
3127 set prefendstack {}
3128 set htstack {}
3129 set ht 0
3130 set treecontents() {}
3131 $w conf -state normal
3132 foreach f $l {
3133 while {[string range $f 0 $prefixend] ne $prefix} {
3134 if {$lev <= $openlevs} {
3135 $w mark set e:$treeindex($prefix) "end -1c"
3136 $w mark gravity e:$treeindex($prefix) left
3138 set treeheight($prefix) $ht
3139 incr ht [lindex $htstack end]
3140 set htstack [lreplace $htstack end end]
3141 set prefixend [lindex $prefendstack end]
3142 set prefendstack [lreplace $prefendstack end end]
3143 set prefix [string range $prefix 0 $prefixend]
3144 incr lev -1
3146 set tail [string range $f [expr {$prefixend+1}] end]
3147 while {[set slash [string first "/" $tail]] >= 0} {
3148 lappend htstack $ht
3149 set ht 0
3150 lappend prefendstack $prefixend
3151 incr prefixend [expr {$slash + 1}]
3152 set d [string range $tail 0 $slash]
3153 lappend treecontents($prefix) $d
3154 set oldprefix $prefix
3155 append prefix $d
3156 set treecontents($prefix) {}
3157 set treeindex($prefix) [incr ix]
3158 set treeparent($prefix) $oldprefix
3159 set tail [string range $tail [expr {$slash+1}] end]
3160 if {$lev <= $openlevs} {
3161 set ht 1
3162 set treediropen($prefix) [expr {$lev < $openlevs}]
3163 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3164 $w mark set d:$ix "end -1c"
3165 $w mark gravity d:$ix left
3166 set str "\n"
3167 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3168 $w insert end $str
3169 $w image create end -align center -image $bm -padx 1 \
3170 -name a:$ix
3171 $w insert end $d [highlight_tag $prefix]
3172 $w mark set s:$ix "end -1c"
3173 $w mark gravity s:$ix left
3175 incr lev
3177 if {$tail ne {}} {
3178 if {$lev <= $openlevs} {
3179 incr ht
3180 set str "\n"
3181 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3182 $w insert end $str
3183 $w insert end $tail [highlight_tag $f]
3185 lappend treecontents($prefix) $tail
3188 while {$htstack ne {}} {
3189 set treeheight($prefix) $ht
3190 incr ht [lindex $htstack end]
3191 set htstack [lreplace $htstack end end]
3192 set prefixend [lindex $prefendstack end]
3193 set prefendstack [lreplace $prefendstack end end]
3194 set prefix [string range $prefix 0 $prefixend]
3196 $w conf -state disabled
3199 proc linetoelt {l} {
3200 global treeheight treecontents
3202 set y 2
3203 set prefix {}
3204 while {1} {
3205 foreach e $treecontents($prefix) {
3206 if {$y == $l} {
3207 return "$prefix$e"
3209 set n 1
3210 if {[string index $e end] eq "/"} {
3211 set n $treeheight($prefix$e)
3212 if {$y + $n > $l} {
3213 append prefix $e
3214 incr y
3215 break
3218 incr y $n
3223 proc highlight_tree {y prefix} {
3224 global treeheight treecontents cflist
3226 foreach e $treecontents($prefix) {
3227 set path $prefix$e
3228 if {[highlight_tag $path] ne {}} {
3229 $cflist tag add bold $y.0 "$y.0 lineend"
3231 incr y
3232 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3233 set y [highlight_tree $y $path]
3236 return $y
3239 proc treeclosedir {w dir} {
3240 global treediropen treeheight treeparent treeindex
3242 set ix $treeindex($dir)
3243 $w conf -state normal
3244 $w delete s:$ix e:$ix
3245 set treediropen($dir) 0
3246 $w image configure a:$ix -image tri-rt
3247 $w conf -state disabled
3248 set n [expr {1 - $treeheight($dir)}]
3249 while {$dir ne {}} {
3250 incr treeheight($dir) $n
3251 set dir $treeparent($dir)
3255 proc treeopendir {w dir} {
3256 global treediropen treeheight treeparent treecontents treeindex
3258 set ix $treeindex($dir)
3259 $w conf -state normal
3260 $w image configure a:$ix -image tri-dn
3261 $w mark set e:$ix s:$ix
3262 $w mark gravity e:$ix right
3263 set lev 0
3264 set str "\n"
3265 set n [llength $treecontents($dir)]
3266 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3267 incr lev
3268 append str "\t"
3269 incr treeheight($x) $n
3271 foreach e $treecontents($dir) {
3272 set de $dir$e
3273 if {[string index $e end] eq "/"} {
3274 set iy $treeindex($de)
3275 $w mark set d:$iy e:$ix
3276 $w mark gravity d:$iy left
3277 $w insert e:$ix $str
3278 set treediropen($de) 0
3279 $w image create e:$ix -align center -image tri-rt -padx 1 \
3280 -name a:$iy
3281 $w insert e:$ix $e [highlight_tag $de]
3282 $w mark set s:$iy e:$ix
3283 $w mark gravity s:$iy left
3284 set treeheight($de) 1
3285 } else {
3286 $w insert e:$ix $str
3287 $w insert e:$ix $e [highlight_tag $de]
3290 $w mark gravity e:$ix right
3291 $w conf -state disabled
3292 set treediropen($dir) 1
3293 set top [lindex [split [$w index @0,0] .] 0]
3294 set ht [$w cget -height]
3295 set l [lindex [split [$w index s:$ix] .] 0]
3296 if {$l < $top} {
3297 $w yview $l.0
3298 } elseif {$l + $n + 1 > $top + $ht} {
3299 set top [expr {$l + $n + 2 - $ht}]
3300 if {$l < $top} {
3301 set top $l
3303 $w yview $top.0
3307 proc treeclick {w x y} {
3308 global treediropen cmitmode ctext cflist cflist_top
3310 if {$cmitmode ne "tree"} return
3311 if {![info exists cflist_top]} return
3312 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3313 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3314 $cflist tag add highlight $l.0 "$l.0 lineend"
3315 set cflist_top $l
3316 if {$l == 1} {
3317 $ctext yview 1.0
3318 return
3320 set e [linetoelt $l]
3321 if {[string index $e end] ne "/"} {
3322 showfile $e
3323 } elseif {$treediropen($e)} {
3324 treeclosedir $w $e
3325 } else {
3326 treeopendir $w $e
3330 proc setfilelist {id} {
3331 global treefilelist cflist jump_to_here
3333 treeview $cflist $treefilelist($id) 0
3334 if {$jump_to_here ne {}} {
3335 set f [lindex $jump_to_here 0]
3336 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3337 showfile $f
3342 image create bitmap tri-rt -background black -foreground blue -data {
3343 #define tri-rt_width 13
3344 #define tri-rt_height 13
3345 static unsigned char tri-rt_bits[] = {
3346 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3347 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3348 0x00, 0x00};
3349 } -maskdata {
3350 #define tri-rt-mask_width 13
3351 #define tri-rt-mask_height 13
3352 static unsigned char tri-rt-mask_bits[] = {
3353 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3354 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3355 0x08, 0x00};
3357 image create bitmap tri-dn -background black -foreground blue -data {
3358 #define tri-dn_width 13
3359 #define tri-dn_height 13
3360 static unsigned char tri-dn_bits[] = {
3361 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3362 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3363 0x00, 0x00};
3364 } -maskdata {
3365 #define tri-dn-mask_width 13
3366 #define tri-dn-mask_height 13
3367 static unsigned char tri-dn-mask_bits[] = {
3368 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3369 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3370 0x00, 0x00};
3373 image create bitmap reficon-T -background black -foreground yellow -data {
3374 #define tagicon_width 13
3375 #define tagicon_height 9
3376 static unsigned char tagicon_bits[] = {
3377 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3378 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3379 } -maskdata {
3380 #define tagicon-mask_width 13
3381 #define tagicon-mask_height 9
3382 static unsigned char tagicon-mask_bits[] = {
3383 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3384 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3386 set rectdata {
3387 #define headicon_width 13
3388 #define headicon_height 9
3389 static unsigned char headicon_bits[] = {
3390 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3391 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3393 set rectmask {
3394 #define headicon-mask_width 13
3395 #define headicon-mask_height 9
3396 static unsigned char headicon-mask_bits[] = {
3397 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3398 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3400 image create bitmap reficon-H -background black -foreground lime \
3401 -data $rectdata -maskdata $rectmask
3402 image create bitmap reficon-o -background black -foreground "#ddddff" \
3403 -data $rectdata -maskdata $rectmask
3405 proc init_flist {first} {
3406 global cflist cflist_top difffilestart
3408 $cflist conf -state normal
3409 $cflist delete 0.0 end
3410 if {$first ne {}} {
3411 $cflist insert end $first
3412 set cflist_top 1
3413 $cflist tag add highlight 1.0 "1.0 lineend"
3414 } else {
3415 unset -nocomplain cflist_top
3417 $cflist conf -state disabled
3418 set difffilestart {}
3421 proc highlight_tag {f} {
3422 global highlight_paths
3424 foreach p $highlight_paths {
3425 if {[string match $p $f]} {
3426 return "bold"
3429 return {}
3432 proc highlight_filelist {} {
3433 global cmitmode cflist
3435 $cflist conf -state normal
3436 if {$cmitmode ne "tree"} {
3437 set end [lindex [split [$cflist index end] .] 0]
3438 for {set l 2} {$l < $end} {incr l} {
3439 set line [$cflist get $l.0 "$l.0 lineend"]
3440 if {[highlight_tag $line] ne {}} {
3441 $cflist tag add bold $l.0 "$l.0 lineend"
3444 } else {
3445 highlight_tree 2 {}
3447 $cflist conf -state disabled
3450 proc unhighlight_filelist {} {
3451 global cflist
3453 $cflist conf -state normal
3454 $cflist tag remove bold 1.0 end
3455 $cflist conf -state disabled
3458 proc add_flist {fl} {
3459 global cflist
3461 $cflist conf -state normal
3462 foreach f $fl {
3463 $cflist insert end "\n"
3464 $cflist insert end $f [highlight_tag $f]
3466 $cflist conf -state disabled
3469 proc sel_flist {w x y} {
3470 global ctext difffilestart cflist cflist_top cmitmode
3472 if {$cmitmode eq "tree"} return
3473 if {![info exists cflist_top]} return
3474 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3475 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3476 $cflist tag add highlight $l.0 "$l.0 lineend"
3477 set cflist_top $l
3478 if {$l == 1} {
3479 $ctext yview 1.0
3480 } else {
3481 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3483 suppress_highlighting_file_for_current_scrollpos
3486 proc pop_flist_menu {w X Y x y} {
3487 global ctext cflist cmitmode flist_menu flist_menu_file
3488 global treediffs diffids
3490 stopfinding
3491 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3492 if {$l <= 1} return
3493 if {$cmitmode eq "tree"} {
3494 set e [linetoelt $l]
3495 if {[string index $e end] eq "/"} return
3496 } else {
3497 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3499 set flist_menu_file $e
3500 set xdiffstate "normal"
3501 if {$cmitmode eq "tree"} {
3502 set xdiffstate "disabled"
3504 # Disable "External diff" item in tree mode
3505 $flist_menu entryconf 2 -state $xdiffstate
3506 tk_popup $flist_menu $X $Y
3509 proc find_ctext_fileinfo {line} {
3510 global ctext_file_names ctext_file_lines
3512 set ok [bsearch $ctext_file_lines $line]
3513 set tline [lindex $ctext_file_lines $ok]
3515 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3516 return {}
3517 } else {
3518 return [list [lindex $ctext_file_names $ok] $tline]
3522 proc pop_diff_menu {w X Y x y} {
3523 global ctext diff_menu flist_menu_file
3524 global diff_menu_txtpos diff_menu_line
3525 global diff_menu_filebase
3527 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3528 set diff_menu_line [lindex $diff_menu_txtpos 0]
3529 # don't pop up the menu on hunk-separator or file-separator lines
3530 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3531 return
3533 stopfinding
3534 set f [find_ctext_fileinfo $diff_menu_line]
3535 if {$f eq {}} return
3536 set flist_menu_file [lindex $f 0]
3537 set diff_menu_filebase [lindex $f 1]
3538 tk_popup $diff_menu $X $Y
3541 proc flist_hl {only} {
3542 global flist_menu_file findstring gdttype
3544 set x [shellquote $flist_menu_file]
3545 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3546 set findstring $x
3547 } else {
3548 append findstring " " $x
3550 set gdttype [mc "touching paths:"]
3553 proc gitknewtmpdir {} {
3554 global diffnum gitktmpdir gitdir env
3556 if {![info exists gitktmpdir]} {
3557 if {[info exists env(GITK_TMPDIR)]} {
3558 set tmpdir $env(GITK_TMPDIR)
3559 } elseif {[info exists env(TMPDIR)]} {
3560 set tmpdir $env(TMPDIR)
3561 } else {
3562 set tmpdir $gitdir
3564 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3565 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3566 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3568 if {[catch {file mkdir $gitktmpdir} err]} {
3569 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3570 unset gitktmpdir
3571 return {}
3573 set diffnum 0
3575 incr diffnum
3576 set diffdir [file join $gitktmpdir $diffnum]
3577 if {[catch {file mkdir $diffdir} err]} {
3578 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3579 return {}
3581 return $diffdir
3584 proc save_file_from_commit {filename output what} {
3585 global nullfile
3587 if {[catch {exec git show $filename -- > $output} err]} {
3588 if {[string match "fatal: bad revision *" $err]} {
3589 return $nullfile
3591 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3592 return {}
3594 return $output
3597 proc external_diff_get_one_file {diffid filename diffdir} {
3598 global nullid nullid2 nullfile
3599 global worktree
3601 if {$diffid == $nullid} {
3602 set difffile [file join $worktree $filename]
3603 if {[file exists $difffile]} {
3604 return $difffile
3606 return $nullfile
3608 if {$diffid == $nullid2} {
3609 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3610 return [save_file_from_commit :$filename $difffile index]
3612 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3613 return [save_file_from_commit $diffid:$filename $difffile \
3614 "revision $diffid"]
3617 proc external_diff {} {
3618 global nullid nullid2
3619 global flist_menu_file
3620 global diffids
3621 global extdifftool
3623 if {[llength $diffids] == 1} {
3624 # no reference commit given
3625 set diffidto [lindex $diffids 0]
3626 if {$diffidto eq $nullid} {
3627 # diffing working copy with index
3628 set diffidfrom $nullid2
3629 } elseif {$diffidto eq $nullid2} {
3630 # diffing index with HEAD
3631 set diffidfrom "HEAD"
3632 } else {
3633 # use first parent commit
3634 global parentlist selectedline
3635 set diffidfrom [lindex $parentlist $selectedline 0]
3637 } else {
3638 set diffidfrom [lindex $diffids 0]
3639 set diffidto [lindex $diffids 1]
3642 # make sure that several diffs wont collide
3643 set diffdir [gitknewtmpdir]
3644 if {$diffdir eq {}} return
3646 # gather files to diff
3647 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3648 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3650 if {$difffromfile ne {} && $difftofile ne {}} {
3651 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3652 if {[catch {set fl [open |$cmd r]} err]} {
3653 file delete -force $diffdir
3654 error_popup "$extdifftool: [mc "command failed:"] $err"
3655 } else {
3656 fconfigure $fl -blocking 0
3657 filerun $fl [list delete_at_eof $fl $diffdir]
3662 proc find_hunk_blamespec {base line} {
3663 global ctext
3665 # Find and parse the hunk header
3666 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3667 if {$s_lix eq {}} return
3669 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3670 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3671 s_line old_specs osz osz1 new_line nsz]} {
3672 return
3675 # base lines for the parents
3676 set base_lines [list $new_line]
3677 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3678 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3679 old_spec old_line osz]} {
3680 return
3682 lappend base_lines $old_line
3685 # Now scan the lines to determine offset within the hunk
3686 set max_parent [expr {[llength $base_lines]-2}]
3687 set dline 0
3688 set s_lno [lindex [split $s_lix "."] 0]
3690 # Determine if the line is removed
3691 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3692 if {[string match {[-+ ]*} $chunk]} {
3693 set removed_idx [string first "-" $chunk]
3694 # Choose a parent index
3695 if {$removed_idx >= 0} {
3696 set parent $removed_idx
3697 } else {
3698 set unchanged_idx [string first " " $chunk]
3699 if {$unchanged_idx >= 0} {
3700 set parent $unchanged_idx
3701 } else {
3702 # blame the current commit
3703 set parent -1
3706 # then count other lines that belong to it
3707 for {set i $line} {[incr i -1] > $s_lno} {} {
3708 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3709 # Determine if the line is removed
3710 set removed_idx [string first "-" $chunk]
3711 if {$parent >= 0} {
3712 set code [string index $chunk $parent]
3713 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3714 incr dline
3716 } else {
3717 if {$removed_idx < 0} {
3718 incr dline
3722 incr parent
3723 } else {
3724 set parent 0
3727 incr dline [lindex $base_lines $parent]
3728 return [list $parent $dline]
3731 proc external_blame_diff {} {
3732 global currentid cmitmode
3733 global diff_menu_txtpos diff_menu_line
3734 global diff_menu_filebase flist_menu_file
3736 if {$cmitmode eq "tree"} {
3737 set parent_idx 0
3738 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3739 } else {
3740 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3741 if {$hinfo ne {}} {
3742 set parent_idx [lindex $hinfo 0]
3743 set line [lindex $hinfo 1]
3744 } else {
3745 set parent_idx 0
3746 set line 0
3750 external_blame $parent_idx $line
3753 # Find the SHA1 ID of the blob for file $fname in the index
3754 # at stage 0 or 2
3755 proc index_sha1 {fname} {
3756 set f [open [list | git ls-files -s $fname] r]
3757 while {[gets $f line] >= 0} {
3758 set info [lindex [split $line "\t"] 0]
3759 set stage [lindex $info 2]
3760 if {$stage eq "0" || $stage eq "2"} {
3761 close $f
3762 return [lindex $info 1]
3765 close $f
3766 return {}
3769 # Turn an absolute path into one relative to the current directory
3770 proc make_relative {f} {
3771 if {[file pathtype $f] eq "relative"} {
3772 return $f
3774 set elts [file split $f]
3775 set here [file split [pwd]]
3776 set ei 0
3777 set hi 0
3778 set res {}
3779 foreach d $here {
3780 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3781 lappend res ".."
3782 } else {
3783 incr ei
3785 incr hi
3787 set elts [concat $res [lrange $elts $ei end]]
3788 return [eval file join $elts]
3791 proc external_blame {parent_idx {line {}}} {
3792 global flist_menu_file cdup
3793 global nullid nullid2
3794 global parentlist selectedline currentid
3796 if {$parent_idx > 0} {
3797 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3798 } else {
3799 set base_commit $currentid
3802 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3803 error_popup [mc "No such commit"]
3804 return
3807 set cmdline [list git gui blame]
3808 if {$line ne {} && $line > 1} {
3809 lappend cmdline "--line=$line"
3811 set f [file join $cdup $flist_menu_file]
3812 # Unfortunately it seems git gui blame doesn't like
3813 # being given an absolute path...
3814 set f [make_relative $f]
3815 lappend cmdline $base_commit $f
3816 if {[catch {eval exec $cmdline &} err]} {
3817 error_popup "[mc "git gui blame: command failed:"] $err"
3821 proc show_line_source {} {
3822 global cmitmode currentid parents curview blamestuff blameinst
3823 global diff_menu_line diff_menu_filebase flist_menu_file
3824 global nullid nullid2 gitdir cdup
3826 set from_index {}
3827 if {$cmitmode eq "tree"} {
3828 set id $currentid
3829 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3830 } else {
3831 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3832 if {$h eq {}} return
3833 set pi [lindex $h 0]
3834 if {$pi == 0} {
3835 mark_ctext_line $diff_menu_line
3836 return
3838 incr pi -1
3839 if {$currentid eq $nullid} {
3840 if {$pi > 0} {
3841 # must be a merge in progress...
3842 if {[catch {
3843 # get the last line from .git/MERGE_HEAD
3844 set f [open [file join $gitdir MERGE_HEAD] r]
3845 set id [lindex [split [read $f] "\n"] end-1]
3846 close $f
3847 } err]} {
3848 error_popup [mc "Couldn't read merge head: %s" $err]
3849 return
3851 } elseif {$parents($curview,$currentid) eq $nullid2} {
3852 # need to do the blame from the index
3853 if {[catch {
3854 set from_index [index_sha1 $flist_menu_file]
3855 } err]} {
3856 error_popup [mc "Error reading index: %s" $err]
3857 return
3859 } else {
3860 set id $parents($curview,$currentid)
3862 } else {
3863 set id [lindex $parents($curview,$currentid) $pi]
3865 set line [lindex $h 1]
3867 set blameargs {}
3868 if {$from_index ne {}} {
3869 lappend blameargs | git cat-file blob $from_index
3871 lappend blameargs | git blame -p -L$line,+1
3872 if {$from_index ne {}} {
3873 lappend blameargs --contents -
3874 } else {
3875 lappend blameargs $id
3877 lappend blameargs -- [file join $cdup $flist_menu_file]
3878 if {[catch {
3879 set f [open $blameargs r]
3880 } err]} {
3881 error_popup [mc "Couldn't start git blame: %s" $err]
3882 return
3884 nowbusy blaming [mc "Searching"]
3885 fconfigure $f -blocking 0
3886 set i [reg_instance $f]
3887 set blamestuff($i) {}
3888 set blameinst $i
3889 filerun $f [list read_line_source $f $i]
3892 proc stopblaming {} {
3893 global blameinst
3895 if {[info exists blameinst]} {
3896 stop_instance $blameinst
3897 unset blameinst
3898 notbusy blaming
3902 proc read_line_source {fd inst} {
3903 global blamestuff curview commfd blameinst nullid nullid2
3905 while {[gets $fd line] >= 0} {
3906 lappend blamestuff($inst) $line
3908 if {![eof $fd]} {
3909 return 1
3911 unset commfd($inst)
3912 unset blameinst
3913 notbusy blaming
3914 fconfigure $fd -blocking 1
3915 if {[catch {close $fd} err]} {
3916 error_popup [mc "Error running git blame: %s" $err]
3917 return 0
3920 set fname {}
3921 set line [split [lindex $blamestuff($inst) 0] " "]
3922 set id [lindex $line 0]
3923 set lnum [lindex $line 1]
3924 if {[string length $id] == 40 && [string is xdigit $id] &&
3925 [string is digit -strict $lnum]} {
3926 # look for "filename" line
3927 foreach l $blamestuff($inst) {
3928 if {[string match "filename *" $l]} {
3929 set fname [string range $l 9 end]
3930 break
3934 if {$fname ne {}} {
3935 # all looks good, select it
3936 if {$id eq $nullid} {
3937 # blame uses all-zeroes to mean not committed,
3938 # which would mean a change in the index
3939 set id $nullid2
3941 if {[commitinview $id $curview]} {
3942 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3943 } else {
3944 error_popup [mc "That line comes from commit %s, \
3945 which is not in this view" [shortids $id]]
3947 } else {
3948 puts "oops couldn't parse git blame output"
3950 return 0
3953 # delete $dir when we see eof on $f (presumably because the child has exited)
3954 proc delete_at_eof {f dir} {
3955 while {[gets $f line] >= 0} {}
3956 if {[eof $f]} {
3957 if {[catch {close $f} err]} {
3958 error_popup "[mc "External diff viewer failed:"] $err"
3960 file delete -force $dir
3961 return 0
3963 return 1
3966 # Functions for adding and removing shell-type quoting
3968 proc shellquote {str} {
3969 if {![string match "*\['\"\\ \t]*" $str]} {
3970 return $str
3972 if {![string match "*\['\"\\]*" $str]} {
3973 return "\"$str\""
3975 if {![string match "*'*" $str]} {
3976 return "'$str'"
3978 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3981 proc shellarglist {l} {
3982 set str {}
3983 foreach a $l {
3984 if {$str ne {}} {
3985 append str " "
3987 append str [shellquote $a]
3989 return $str
3992 proc shelldequote {str} {
3993 set ret {}
3994 set used -1
3995 while {1} {
3996 incr used
3997 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3998 append ret [string range $str $used end]
3999 set used [string length $str]
4000 break
4002 set first [lindex $first 0]
4003 set ch [string index $str $first]
4004 if {$first > $used} {
4005 append ret [string range $str $used [expr {$first - 1}]]
4006 set used $first
4008 if {$ch eq " " || $ch eq "\t"} break
4009 incr used
4010 if {$ch eq "'"} {
4011 set first [string first "'" $str $used]
4012 if {$first < 0} {
4013 error "unmatched single-quote"
4015 append ret [string range $str $used [expr {$first - 1}]]
4016 set used $first
4017 continue
4019 if {$ch eq "\\"} {
4020 if {$used >= [string length $str]} {
4021 error "trailing backslash"
4023 append ret [string index $str $used]
4024 continue
4026 # here ch == "\""
4027 while {1} {
4028 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4029 error "unmatched double-quote"
4031 set first [lindex $first 0]
4032 set ch [string index $str $first]
4033 if {$first > $used} {
4034 append ret [string range $str $used [expr {$first - 1}]]
4035 set used $first
4037 if {$ch eq "\""} break
4038 incr used
4039 append ret [string index $str $used]
4040 incr used
4043 return [list $used $ret]
4046 proc shellsplit {str} {
4047 set l {}
4048 while {1} {
4049 set str [string trimleft $str]
4050 if {$str eq {}} break
4051 set dq [shelldequote $str]
4052 set n [lindex $dq 0]
4053 set word [lindex $dq 1]
4054 set str [string range $str $n end]
4055 lappend l $word
4057 return $l
4060 proc set_window_title {} {
4061 global appname curview viewname vrevs
4062 set rev [mc "All files"]
4063 if {$curview ne 0} {
4064 if {$viewname($curview) eq [mc "Command line"]} {
4065 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4066 } else {
4067 set rev $viewname($curview)
4070 wm title . "[reponame]: $rev - $appname"
4073 # Code to implement multiple views
4075 proc newview {ishighlight} {
4076 global nextviewnum newviewname newishighlight
4077 global revtreeargs viewargscmd newviewopts curview
4079 set newishighlight $ishighlight
4080 set top .gitkview
4081 if {[winfo exists $top]} {
4082 raise $top
4083 return
4085 decode_view_opts $nextviewnum $revtreeargs
4086 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4087 set newviewopts($nextviewnum,perm) 0
4088 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4089 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4092 set known_view_options {
4093 {perm b . {} {mc "Remember this view"}}
4094 {reflabel l + {} {mc "References (space separated list):"}}
4095 {refs t15 .. {} {mc "Branches & tags:"}}
4096 {allrefs b *. "--all" {mc "All refs"}}
4097 {branches b . "--branches" {mc "All (local) branches"}}
4098 {tags b . "--tags" {mc "All tags"}}
4099 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4100 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4101 {author t15 .. "--author=*" {mc "Author:"}}
4102 {committer t15 . "--committer=*" {mc "Committer:"}}
4103 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4104 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4105 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4106 {changes_l l + {} {mc "Changes to Files:"}}
4107 {pickaxe_s r0 . {} {mc "Fixed String"}}
4108 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4109 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4110 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4111 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4112 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4113 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4114 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4115 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4116 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4117 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4118 {lright b . "--left-right" {mc "Mark branch sides"}}
4119 {first b . "--first-parent" {mc "Limit to first parent"}}
4120 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4121 {args t50 *. {} {mc "Additional arguments to git log:"}}
4122 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4123 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4126 # Convert $newviewopts($n, ...) into args for git log.
4127 proc encode_view_opts {n} {
4128 global known_view_options newviewopts
4130 set rargs [list]
4131 foreach opt $known_view_options {
4132 set patterns [lindex $opt 3]
4133 if {$patterns eq {}} continue
4134 set pattern [lindex $patterns 0]
4136 if {[lindex $opt 1] eq "b"} {
4137 set val $newviewopts($n,[lindex $opt 0])
4138 if {$val} {
4139 lappend rargs $pattern
4141 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4142 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4143 set val $newviewopts($n,$button_id)
4144 if {$val eq $value} {
4145 lappend rargs $pattern
4147 } else {
4148 set val $newviewopts($n,[lindex $opt 0])
4149 set val [string trim $val]
4150 if {$val ne {}} {
4151 set pfix [string range $pattern 0 end-1]
4152 lappend rargs $pfix$val
4156 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4157 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4160 # Fill $newviewopts($n, ...) based on args for git log.
4161 proc decode_view_opts {n view_args} {
4162 global known_view_options newviewopts
4164 foreach opt $known_view_options {
4165 set id [lindex $opt 0]
4166 if {[lindex $opt 1] eq "b"} {
4167 # Checkboxes
4168 set val 0
4169 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4170 # Radiobuttons
4171 regexp {^(.*_)} $id uselessvar id
4172 set val 0
4173 } else {
4174 # Text fields
4175 set val {}
4177 set newviewopts($n,$id) $val
4179 set oargs [list]
4180 set refargs [list]
4181 foreach arg $view_args {
4182 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4183 && ![info exists found(limit)]} {
4184 set newviewopts($n,limit) $cnt
4185 set found(limit) 1
4186 continue
4188 catch { unset val }
4189 foreach opt $known_view_options {
4190 set id [lindex $opt 0]
4191 if {[info exists found($id)]} continue
4192 foreach pattern [lindex $opt 3] {
4193 if {![string match $pattern $arg]} continue
4194 if {[lindex $opt 1] eq "b"} {
4195 # Check buttons
4196 set val 1
4197 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4198 # Radio buttons
4199 regexp {^(.*_)} $id uselessvar id
4200 set val $num
4201 } else {
4202 # Text input fields
4203 set size [string length $pattern]
4204 set val [string range $arg [expr {$size-1}] end]
4206 set newviewopts($n,$id) $val
4207 set found($id) 1
4208 break
4210 if {[info exists val]} break
4212 if {[info exists val]} continue
4213 if {[regexp {^-} $arg]} {
4214 lappend oargs $arg
4215 } else {
4216 lappend refargs $arg
4219 set newviewopts($n,refs) [shellarglist $refargs]
4220 set newviewopts($n,args) [shellarglist $oargs]
4223 proc edit_or_newview {} {
4224 global curview
4226 if {$curview > 0} {
4227 editview
4228 } else {
4229 newview 0
4233 proc editview {} {
4234 global curview
4235 global viewname viewperm newviewname newviewopts
4236 global viewargs viewargscmd
4238 set top .gitkvedit-$curview
4239 if {[winfo exists $top]} {
4240 raise $top
4241 return
4243 decode_view_opts $curview $viewargs($curview)
4244 set newviewname($curview) $viewname($curview)
4245 set newviewopts($curview,perm) $viewperm($curview)
4246 set newviewopts($curview,cmd) $viewargscmd($curview)
4247 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4250 proc vieweditor {top n title} {
4251 global newviewname newviewopts viewfiles bgcolor
4252 global known_view_options NS
4254 ttk_toplevel $top
4255 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4256 make_transient $top .
4258 # View name
4259 ${NS}::frame $top.nfr
4260 ${NS}::label $top.nl -text [mc "View Name"]
4261 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4262 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4263 pack $top.nl -in $top.nfr -side left -padx {0 5}
4264 pack $top.name -in $top.nfr -side left -padx {0 25}
4266 # View options
4267 set cframe $top.nfr
4268 set cexpand 0
4269 set cnt 0
4270 foreach opt $known_view_options {
4271 set id [lindex $opt 0]
4272 set type [lindex $opt 1]
4273 set flags [lindex $opt 2]
4274 set title [eval [lindex $opt 4]]
4275 set lxpad 0
4277 if {$flags eq "+" || $flags eq "*"} {
4278 set cframe $top.fr$cnt
4279 incr cnt
4280 ${NS}::frame $cframe
4281 pack $cframe -in $top -fill x -pady 3 -padx 3
4282 set cexpand [expr {$flags eq "*"}]
4283 } elseif {$flags eq ".." || $flags eq "*."} {
4284 set cframe $top.fr$cnt
4285 incr cnt
4286 ${NS}::frame $cframe
4287 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4288 set cexpand [expr {$flags eq "*."}]
4289 } else {
4290 set lxpad 5
4293 if {$type eq "l"} {
4294 ${NS}::label $cframe.l_$id -text $title
4295 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4296 } elseif {$type eq "b"} {
4297 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4298 pack $cframe.c_$id -in $cframe -side left \
4299 -padx [list $lxpad 0] -expand $cexpand -anchor w
4300 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4301 regexp {^(.*_)} $id uselessvar button_id
4302 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4303 pack $cframe.c_$id -in $cframe -side left \
4304 -padx [list $lxpad 0] -expand $cexpand -anchor w
4305 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4306 ${NS}::label $cframe.l_$id -text $title
4307 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4308 -textvariable newviewopts($n,$id)
4309 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4310 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4311 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4312 ${NS}::label $cframe.l_$id -text $title
4313 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4314 -textvariable newviewopts($n,$id)
4315 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4316 pack $cframe.e_$id -in $cframe -side top -fill x
4317 } elseif {$type eq "path"} {
4318 ${NS}::label $top.l -text $title
4319 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4320 text $top.t -width 40 -height 5 -background $bgcolor
4321 if {[info exists viewfiles($n)]} {
4322 foreach f $viewfiles($n) {
4323 $top.t insert end $f
4324 $top.t insert end "\n"
4326 $top.t delete {end - 1c} end
4327 $top.t mark set insert 0.0
4329 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4333 ${NS}::frame $top.buts
4334 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4335 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4336 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4337 bind $top <Control-Return> [list newviewok $top $n]
4338 bind $top <F5> [list newviewok $top $n 1]
4339 bind $top <Escape> [list destroy $top]
4340 grid $top.buts.ok $top.buts.apply $top.buts.can
4341 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4342 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4343 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4344 pack $top.buts -in $top -side top -fill x
4345 focus $top.t
4348 proc doviewmenu {m first cmd op argv} {
4349 set nmenu [$m index end]
4350 for {set i $first} {$i <= $nmenu} {incr i} {
4351 if {[$m entrycget $i -command] eq $cmd} {
4352 eval $m $op $i $argv
4353 break
4358 proc allviewmenus {n op args} {
4359 # global viewhlmenu
4361 doviewmenu .bar.view 5 [list showview $n] $op $args
4362 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4365 proc newviewok {top n {apply 0}} {
4366 global nextviewnum newviewperm newviewname newishighlight
4367 global viewname viewfiles viewperm viewchanged selectedview curview
4368 global viewargs viewargscmd newviewopts viewhlmenu
4370 if {[catch {
4371 set newargs [encode_view_opts $n]
4372 } err]} {
4373 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4374 return
4376 set files {}
4377 foreach f [split [$top.t get 0.0 end] "\n"] {
4378 set ft [string trim $f]
4379 if {$ft ne {}} {
4380 lappend files $ft
4383 if {![info exists viewfiles($n)]} {
4384 # creating a new view
4385 incr nextviewnum
4386 set viewname($n) $newviewname($n)
4387 set viewperm($n) $newviewopts($n,perm)
4388 set viewchanged($n) 1
4389 set viewfiles($n) $files
4390 set viewargs($n) $newargs
4391 set viewargscmd($n) $newviewopts($n,cmd)
4392 addviewmenu $n
4393 if {!$newishighlight} {
4394 run showview $n
4395 } else {
4396 run addvhighlight $n
4398 } else {
4399 # editing an existing view
4400 set viewperm($n) $newviewopts($n,perm)
4401 set viewchanged($n) 1
4402 if {$newviewname($n) ne $viewname($n)} {
4403 set viewname($n) $newviewname($n)
4404 doviewmenu .bar.view 5 [list showview $n] \
4405 entryconf [list -label $viewname($n)]
4406 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4407 # entryconf [list -label $viewname($n) -value $viewname($n)]
4409 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4410 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4411 set viewfiles($n) $files
4412 set viewargs($n) $newargs
4413 set viewargscmd($n) $newviewopts($n,cmd)
4414 if {$curview == $n} {
4415 run reloadcommits
4419 if {$apply} return
4420 catch {destroy $top}
4423 proc delview {} {
4424 global curview viewperm hlview selectedhlview viewchanged
4426 if {$curview == 0} return
4427 if {[info exists hlview] && $hlview == $curview} {
4428 set selectedhlview [mc "None"]
4429 unset hlview
4431 allviewmenus $curview delete
4432 set viewperm($curview) 0
4433 set viewchanged($curview) 1
4434 showview 0
4437 proc addviewmenu {n} {
4438 global viewname viewhlmenu
4440 .bar.view add radiobutton -label $viewname($n) \
4441 -command [list showview $n] -variable selectedview -value $n
4442 #$viewhlmenu add radiobutton -label $viewname($n) \
4443 # -command [list addvhighlight $n] -variable selectedhlview
4446 proc showview {n} {
4447 global curview cached_commitrow ordertok
4448 global displayorder parentlist rowidlist rowisopt rowfinal
4449 global colormap rowtextx nextcolor canvxmax
4450 global numcommits viewcomplete
4451 global selectedline currentid canv canvy0
4452 global treediffs
4453 global pending_select mainheadid
4454 global commitidx
4455 global selectedview
4456 global hlview selectedhlview commitinterest
4458 if {$n == $curview} return
4459 set selid {}
4460 set ymax [lindex [$canv cget -scrollregion] 3]
4461 set span [$canv yview]
4462 set ytop [expr {[lindex $span 0] * $ymax}]
4463 set ybot [expr {[lindex $span 1] * $ymax}]
4464 set yscreen [expr {($ybot - $ytop) / 2}]
4465 if {$selectedline ne {}} {
4466 set selid $currentid
4467 set y [yc $selectedline]
4468 if {$ytop < $y && $y < $ybot} {
4469 set yscreen [expr {$y - $ytop}]
4471 } elseif {[info exists pending_select]} {
4472 set selid $pending_select
4473 unset pending_select
4475 unselectline
4476 normalline
4477 unset -nocomplain treediffs
4478 clear_display
4479 if {[info exists hlview] && $hlview == $n} {
4480 unset hlview
4481 set selectedhlview [mc "None"]
4483 unset -nocomplain commitinterest
4484 unset -nocomplain cached_commitrow
4485 unset -nocomplain ordertok
4487 set curview $n
4488 set selectedview $n
4489 .bar.view entryconf [mca "&Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4490 .bar.view entryconf [mca "&Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4492 run refill_reflist
4493 if {![info exists viewcomplete($n)]} {
4494 getcommits $selid
4495 return
4498 set displayorder {}
4499 set parentlist {}
4500 set rowidlist {}
4501 set rowisopt {}
4502 set rowfinal {}
4503 set numcommits $commitidx($n)
4505 unset -nocomplain colormap
4506 unset -nocomplain rowtextx
4507 set nextcolor 0
4508 set canvxmax [$canv cget -width]
4509 set curview $n
4510 set row 0
4511 setcanvscroll
4512 set yf 0
4513 set row {}
4514 if {$selid ne {} && [commitinview $selid $n]} {
4515 set row [rowofcommit $selid]
4516 # try to get the selected row in the same position on the screen
4517 set ymax [lindex [$canv cget -scrollregion] 3]
4518 set ytop [expr {[yc $row] - $yscreen}]
4519 if {$ytop < 0} {
4520 set ytop 0
4522 set yf [expr {$ytop * 1.0 / $ymax}]
4524 allcanvs yview moveto $yf
4525 drawvisible
4526 if {$row ne {}} {
4527 selectline $row 0
4528 } elseif {!$viewcomplete($n)} {
4529 reset_pending_select $selid
4530 } else {
4531 reset_pending_select {}
4533 if {[commitinview $pending_select $curview]} {
4534 selectline [rowofcommit $pending_select] 1
4535 } else {
4536 set row [first_real_row]
4537 if {$row < $numcommits} {
4538 selectline $row 0
4542 if {!$viewcomplete($n)} {
4543 if {$numcommits == 0} {
4544 show_status [mc "Reading commits..."]
4546 } elseif {$numcommits == 0} {
4547 show_status [mc "No commits selected"]
4549 set_window_title
4552 # Stuff relating to the highlighting facility
4554 proc ishighlighted {id} {
4555 global vhighlights fhighlights nhighlights rhighlights
4557 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4558 return $nhighlights($id)
4560 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4561 return $vhighlights($id)
4563 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4564 return $fhighlights($id)
4566 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4567 return $rhighlights($id)
4569 return 0
4572 proc bolden {id font} {
4573 global canv linehtag currentid boldids need_redisplay markedid
4575 # need_redisplay = 1 means the display is stale and about to be redrawn
4576 if {$need_redisplay} return
4577 lappend boldids $id
4578 $canv itemconf $linehtag($id) -font $font
4579 if {[info exists currentid] && $id eq $currentid} {
4580 $canv delete secsel
4581 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4582 -outline {{}} -tags secsel \
4583 -fill [$canv cget -selectbackground]]
4584 $canv lower $t
4586 if {[info exists markedid] && $id eq $markedid} {
4587 make_idmark $id
4591 proc bolden_name {id font} {
4592 global canv2 linentag currentid boldnameids need_redisplay
4594 if {$need_redisplay} return
4595 lappend boldnameids $id
4596 $canv2 itemconf $linentag($id) -font $font
4597 if {[info exists currentid] && $id eq $currentid} {
4598 $canv2 delete secsel
4599 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4600 -outline {{}} -tags secsel \
4601 -fill [$canv2 cget -selectbackground]]
4602 $canv2 lower $t
4606 proc unbolden {} {
4607 global boldids
4609 set stillbold {}
4610 foreach id $boldids {
4611 if {![ishighlighted $id]} {
4612 bolden $id mainfont
4613 } else {
4614 lappend stillbold $id
4617 set boldids $stillbold
4620 proc addvhighlight {n} {
4621 global hlview viewcomplete curview vhl_done commitidx
4623 if {[info exists hlview]} {
4624 delvhighlight
4626 set hlview $n
4627 if {$n != $curview && ![info exists viewcomplete($n)]} {
4628 start_rev_list $n
4630 set vhl_done $commitidx($hlview)
4631 if {$vhl_done > 0} {
4632 drawvisible
4636 proc delvhighlight {} {
4637 global hlview vhighlights
4639 if {![info exists hlview]} return
4640 unset hlview
4641 unset -nocomplain vhighlights
4642 unbolden
4645 proc vhighlightmore {} {
4646 global hlview vhl_done commitidx vhighlights curview
4648 set max $commitidx($hlview)
4649 set vr [visiblerows]
4650 set r0 [lindex $vr 0]
4651 set r1 [lindex $vr 1]
4652 for {set i $vhl_done} {$i < $max} {incr i} {
4653 set id [commitonrow $i $hlview]
4654 if {[commitinview $id $curview]} {
4655 set row [rowofcommit $id]
4656 if {$r0 <= $row && $row <= $r1} {
4657 if {![highlighted $row]} {
4658 bolden $id mainfontbold
4660 set vhighlights($id) 1
4664 set vhl_done $max
4665 return 0
4668 proc askvhighlight {row id} {
4669 global hlview vhighlights iddrawn
4671 if {[commitinview $id $hlview]} {
4672 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4673 bolden $id mainfontbold
4675 set vhighlights($id) 1
4676 } else {
4677 set vhighlights($id) 0
4681 proc hfiles_change {} {
4682 global highlight_files filehighlight fhighlights fh_serial
4683 global highlight_paths
4685 if {[info exists filehighlight]} {
4686 # delete previous highlights
4687 catch {close $filehighlight}
4688 unset filehighlight
4689 unset -nocomplain fhighlights
4690 unbolden
4691 unhighlight_filelist
4693 set highlight_paths {}
4694 after cancel do_file_hl $fh_serial
4695 incr fh_serial
4696 if {$highlight_files ne {}} {
4697 after 300 do_file_hl $fh_serial
4701 proc gdttype_change {name ix op} {
4702 global gdttype highlight_files findstring findpattern
4704 stopfinding
4705 if {$findstring ne {}} {
4706 if {$gdttype eq [mc "containing:"]} {
4707 if {$highlight_files ne {}} {
4708 set highlight_files {}
4709 hfiles_change
4711 findcom_change
4712 } else {
4713 if {$findpattern ne {}} {
4714 set findpattern {}
4715 findcom_change
4717 set highlight_files $findstring
4718 hfiles_change
4720 drawvisible
4722 # enable/disable findtype/findloc menus too
4725 proc find_change {name ix op} {
4726 global gdttype findstring highlight_files
4728 stopfinding
4729 if {$gdttype eq [mc "containing:"]} {
4730 findcom_change
4731 } else {
4732 if {$highlight_files ne $findstring} {
4733 set highlight_files $findstring
4734 hfiles_change
4737 drawvisible
4740 proc findcom_change args {
4741 global nhighlights boldnameids
4742 global findpattern findtype findstring gdttype
4744 stopfinding
4745 # delete previous highlights, if any
4746 foreach id $boldnameids {
4747 bolden_name $id mainfont
4749 set boldnameids {}
4750 unset -nocomplain nhighlights
4751 unbolden
4752 unmarkmatches
4753 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4754 set findpattern {}
4755 } elseif {$findtype eq [mc "Regexp"]} {
4756 set findpattern $findstring
4757 } else {
4758 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4759 $findstring]
4760 set findpattern "*$e*"
4764 proc makepatterns {l} {
4765 set ret {}
4766 foreach e $l {
4767 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4768 if {[string index $ee end] eq "/"} {
4769 lappend ret "$ee*"
4770 } else {
4771 lappend ret $ee
4772 lappend ret "$ee/*"
4775 return $ret
4778 proc do_file_hl {serial} {
4779 global highlight_files filehighlight highlight_paths gdttype fhl_list
4780 global cdup findtype
4782 if {$gdttype eq [mc "touching paths:"]} {
4783 # If "exact" match then convert backslashes to forward slashes.
4784 # Most useful to support Windows-flavoured file paths.
4785 if {$findtype eq [mc "Exact"]} {
4786 set highlight_files [string map {"\\" "/"} $highlight_files]
4788 if {[catch {set paths [shellsplit $highlight_files]}]} return
4789 set highlight_paths [makepatterns $paths]
4790 highlight_filelist
4791 set relative_paths {}
4792 foreach path $paths {
4793 lappend relative_paths [file join $cdup $path]
4795 set gdtargs [concat -- $relative_paths]
4796 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4797 set gdtargs [list "-S$highlight_files"]
4798 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4799 set gdtargs [list "-G$highlight_files"]
4800 } else {
4801 # must be "containing:", i.e. we're searching commit info
4802 return
4804 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4805 set filehighlight [open $cmd r+]
4806 fconfigure $filehighlight -blocking 0
4807 filerun $filehighlight readfhighlight
4808 set fhl_list {}
4809 drawvisible
4810 flushhighlights
4813 proc flushhighlights {} {
4814 global filehighlight fhl_list
4816 if {[info exists filehighlight]} {
4817 lappend fhl_list {}
4818 puts $filehighlight ""
4819 flush $filehighlight
4823 proc askfilehighlight {row id} {
4824 global filehighlight fhighlights fhl_list
4826 lappend fhl_list $id
4827 set fhighlights($id) -1
4828 puts $filehighlight $id
4831 proc readfhighlight {} {
4832 global filehighlight fhighlights curview iddrawn
4833 global fhl_list find_dirn
4835 if {![info exists filehighlight]} {
4836 return 0
4838 set nr 0
4839 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4840 set line [string trim $line]
4841 set i [lsearch -exact $fhl_list $line]
4842 if {$i < 0} continue
4843 for {set j 0} {$j < $i} {incr j} {
4844 set id [lindex $fhl_list $j]
4845 set fhighlights($id) 0
4847 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4848 if {$line eq {}} continue
4849 if {![commitinview $line $curview]} continue
4850 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4851 bolden $line mainfontbold
4853 set fhighlights($line) 1
4855 if {[eof $filehighlight]} {
4856 # strange...
4857 puts "oops, git diff-tree died"
4858 catch {close $filehighlight}
4859 unset filehighlight
4860 return 0
4862 if {[info exists find_dirn]} {
4863 run findmore
4865 return 1
4868 proc doesmatch {f} {
4869 global findtype findpattern
4871 if {$findtype eq [mc "Regexp"]} {
4872 return [regexp $findpattern $f]
4873 } elseif {$findtype eq [mc "IgnCase"]} {
4874 return [string match -nocase $findpattern $f]
4875 } else {
4876 return [string match $findpattern $f]
4880 proc askfindhighlight {row id} {
4881 global nhighlights commitinfo iddrawn
4882 global findloc
4883 global markingmatches
4885 if {![info exists commitinfo($id)]} {
4886 getcommit $id
4888 set info $commitinfo($id)
4889 set isbold 0
4890 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4891 foreach f $info ty $fldtypes {
4892 if {$ty eq ""} continue
4893 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4894 [doesmatch $f]} {
4895 if {$ty eq [mc "Author"]} {
4896 set isbold 2
4897 break
4899 set isbold 1
4902 if {$isbold && [info exists iddrawn($id)]} {
4903 if {![ishighlighted $id]} {
4904 bolden $id mainfontbold
4905 if {$isbold > 1} {
4906 bolden_name $id mainfontbold
4909 if {$markingmatches} {
4910 markrowmatches $row $id
4913 set nhighlights($id) $isbold
4916 proc markrowmatches {row id} {
4917 global canv canv2 linehtag linentag commitinfo findloc
4919 set headline [lindex $commitinfo($id) 0]
4920 set author [lindex $commitinfo($id) 1]
4921 $canv delete match$row
4922 $canv2 delete match$row
4923 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4924 set m [findmatches $headline]
4925 if {$m ne {}} {
4926 markmatches $canv $row $headline $linehtag($id) $m \
4927 [$canv itemcget $linehtag($id) -font] $row
4930 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4931 set m [findmatches $author]
4932 if {$m ne {}} {
4933 markmatches $canv2 $row $author $linentag($id) $m \
4934 [$canv2 itemcget $linentag($id) -font] $row
4939 proc vrel_change {name ix op} {
4940 global highlight_related
4942 rhighlight_none
4943 if {$highlight_related ne [mc "None"]} {
4944 run drawvisible
4948 # prepare for testing whether commits are descendents or ancestors of a
4949 proc rhighlight_sel {a} {
4950 global descendent desc_todo ancestor anc_todo
4951 global highlight_related
4953 unset -nocomplain descendent
4954 set desc_todo [list $a]
4955 unset -nocomplain ancestor
4956 set anc_todo [list $a]
4957 if {$highlight_related ne [mc "None"]} {
4958 rhighlight_none
4959 run drawvisible
4963 proc rhighlight_none {} {
4964 global rhighlights
4966 unset -nocomplain rhighlights
4967 unbolden
4970 proc is_descendent {a} {
4971 global curview children descendent desc_todo
4973 set v $curview
4974 set la [rowofcommit $a]
4975 set todo $desc_todo
4976 set leftover {}
4977 set done 0
4978 for {set i 0} {$i < [llength $todo]} {incr i} {
4979 set do [lindex $todo $i]
4980 if {[rowofcommit $do] < $la} {
4981 lappend leftover $do
4982 continue
4984 foreach nk $children($v,$do) {
4985 if {![info exists descendent($nk)]} {
4986 set descendent($nk) 1
4987 lappend todo $nk
4988 if {$nk eq $a} {
4989 set done 1
4993 if {$done} {
4994 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4995 return
4998 set descendent($a) 0
4999 set desc_todo $leftover
5002 proc is_ancestor {a} {
5003 global curview parents ancestor anc_todo
5005 set v $curview
5006 set la [rowofcommit $a]
5007 set todo $anc_todo
5008 set leftover {}
5009 set done 0
5010 for {set i 0} {$i < [llength $todo]} {incr i} {
5011 set do [lindex $todo $i]
5012 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
5013 lappend leftover $do
5014 continue
5016 foreach np $parents($v,$do) {
5017 if {![info exists ancestor($np)]} {
5018 set ancestor($np) 1
5019 lappend todo $np
5020 if {$np eq $a} {
5021 set done 1
5025 if {$done} {
5026 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5027 return
5030 set ancestor($a) 0
5031 set anc_todo $leftover
5034 proc askrelhighlight {row id} {
5035 global descendent highlight_related iddrawn rhighlights
5036 global selectedline ancestor
5038 if {$selectedline eq {}} return
5039 set isbold 0
5040 if {$highlight_related eq [mc "Descendant"] ||
5041 $highlight_related eq [mc "Not descendant"]} {
5042 if {![info exists descendent($id)]} {
5043 is_descendent $id
5045 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5046 set isbold 1
5048 } elseif {$highlight_related eq [mc "Ancestor"] ||
5049 $highlight_related eq [mc "Not ancestor"]} {
5050 if {![info exists ancestor($id)]} {
5051 is_ancestor $id
5053 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5054 set isbold 1
5057 if {[info exists iddrawn($id)]} {
5058 if {$isbold && ![ishighlighted $id]} {
5059 bolden $id mainfontbold
5062 set rhighlights($id) $isbold
5065 # Graph layout functions
5067 proc shortids {ids} {
5068 set res {}
5069 foreach id $ids {
5070 if {[llength $id] > 1} {
5071 lappend res [shortids $id]
5072 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5073 lappend res [string range $id 0 7]
5074 } else {
5075 lappend res $id
5078 return $res
5081 proc ntimes {n o} {
5082 set ret {}
5083 set o [list $o]
5084 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5085 if {($n & $mask) != 0} {
5086 set ret [concat $ret $o]
5088 set o [concat $o $o]
5090 return $ret
5093 proc ordertoken {id} {
5094 global ordertok curview varcid varcstart varctok curview parents children
5095 global nullid nullid2
5097 if {[info exists ordertok($id)]} {
5098 return $ordertok($id)
5100 set origid $id
5101 set todo {}
5102 while {1} {
5103 if {[info exists varcid($curview,$id)]} {
5104 set a $varcid($curview,$id)
5105 set p [lindex $varcstart($curview) $a]
5106 } else {
5107 set p [lindex $children($curview,$id) 0]
5109 if {[info exists ordertok($p)]} {
5110 set tok $ordertok($p)
5111 break
5113 set id [first_real_child $curview,$p]
5114 if {$id eq {}} {
5115 # it's a root
5116 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5117 break
5119 if {[llength $parents($curview,$id)] == 1} {
5120 lappend todo [list $p {}]
5121 } else {
5122 set j [lsearch -exact $parents($curview,$id) $p]
5123 if {$j < 0} {
5124 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5126 lappend todo [list $p [strrep $j]]
5129 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5130 set p [lindex $todo $i 0]
5131 append tok [lindex $todo $i 1]
5132 set ordertok($p) $tok
5134 set ordertok($origid) $tok
5135 return $tok
5138 # Work out where id should go in idlist so that order-token
5139 # values increase from left to right
5140 proc idcol {idlist id {i 0}} {
5141 set t [ordertoken $id]
5142 if {$i < 0} {
5143 set i 0
5145 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5146 if {$i > [llength $idlist]} {
5147 set i [llength $idlist]
5149 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5150 incr i
5151 } else {
5152 if {$t > [ordertoken [lindex $idlist $i]]} {
5153 while {[incr i] < [llength $idlist] &&
5154 $t >= [ordertoken [lindex $idlist $i]]} {}
5157 return $i
5160 proc initlayout {} {
5161 global rowidlist rowisopt rowfinal displayorder parentlist
5162 global numcommits canvxmax canv
5163 global nextcolor
5164 global colormap rowtextx
5166 set numcommits 0
5167 set displayorder {}
5168 set parentlist {}
5169 set nextcolor 0
5170 set rowidlist {}
5171 set rowisopt {}
5172 set rowfinal {}
5173 set canvxmax [$canv cget -width]
5174 unset -nocomplain colormap
5175 unset -nocomplain rowtextx
5176 setcanvscroll
5179 proc setcanvscroll {} {
5180 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5181 global lastscrollset lastscrollrows
5183 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5184 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5185 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5186 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5187 set lastscrollset [clock clicks -milliseconds]
5188 set lastscrollrows $numcommits
5191 proc visiblerows {} {
5192 global canv numcommits linespc
5194 set ymax [lindex [$canv cget -scrollregion] 3]
5195 if {$ymax eq {} || $ymax == 0} return
5196 set f [$canv yview]
5197 set y0 [expr {int([lindex $f 0] * $ymax)}]
5198 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5199 if {$r0 < 0} {
5200 set r0 0
5202 set y1 [expr {int([lindex $f 1] * $ymax)}]
5203 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5204 if {$r1 >= $numcommits} {
5205 set r1 [expr {$numcommits - 1}]
5207 return [list $r0 $r1]
5210 proc layoutmore {} {
5211 global commitidx viewcomplete curview
5212 global numcommits pending_select curview
5213 global lastscrollset lastscrollrows
5215 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5216 [clock clicks -milliseconds] - $lastscrollset > 500} {
5217 setcanvscroll
5219 if {[info exists pending_select] &&
5220 [commitinview $pending_select $curview]} {
5221 update
5222 selectline [rowofcommit $pending_select] 1
5224 drawvisible
5227 # With path limiting, we mightn't get the actual HEAD commit,
5228 # so ask git rev-list what is the first ancestor of HEAD that
5229 # touches a file in the path limit.
5230 proc get_viewmainhead {view} {
5231 global viewmainheadid vfilelimit viewinstances mainheadid
5233 catch {
5234 set rfd [open [concat | git rev-list -1 $mainheadid \
5235 -- $vfilelimit($view)] r]
5236 set j [reg_instance $rfd]
5237 lappend viewinstances($view) $j
5238 fconfigure $rfd -blocking 0
5239 filerun $rfd [list getviewhead $rfd $j $view]
5240 set viewmainheadid($curview) {}
5244 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5245 proc getviewhead {fd inst view} {
5246 global viewmainheadid commfd curview viewinstances showlocalchanges
5248 set id {}
5249 if {[gets $fd line] < 0} {
5250 if {![eof $fd]} {
5251 return 1
5253 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5254 set id $line
5256 set viewmainheadid($view) $id
5257 close $fd
5258 unset commfd($inst)
5259 set i [lsearch -exact $viewinstances($view) $inst]
5260 if {$i >= 0} {
5261 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5263 if {$showlocalchanges && $id ne {} && $view == $curview} {
5264 doshowlocalchanges
5266 return 0
5269 proc doshowlocalchanges {} {
5270 global curview viewmainheadid
5272 if {$viewmainheadid($curview) eq {}} return
5273 if {[commitinview $viewmainheadid($curview) $curview]} {
5274 dodiffindex
5275 } else {
5276 interestedin $viewmainheadid($curview) dodiffindex
5280 proc dohidelocalchanges {} {
5281 global nullid nullid2 lserial curview
5283 if {[commitinview $nullid $curview]} {
5284 removefakerow $nullid
5286 if {[commitinview $nullid2 $curview]} {
5287 removefakerow $nullid2
5289 incr lserial
5292 # spawn off a process to do git diff-index --cached HEAD
5293 proc dodiffindex {} {
5294 global lserial showlocalchanges vfilelimit curview
5295 global hasworktree git_version
5297 if {!$showlocalchanges || !$hasworktree} return
5298 incr lserial
5299 if {[package vcompare $git_version "1.7.2"] >= 0} {
5300 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5301 } else {
5302 set cmd "|git diff-index --cached HEAD"
5304 if {$vfilelimit($curview) ne {}} {
5305 set cmd [concat $cmd -- $vfilelimit($curview)]
5307 set fd [open $cmd r]
5308 fconfigure $fd -blocking 0
5309 set i [reg_instance $fd]
5310 filerun $fd [list readdiffindex $fd $lserial $i]
5313 proc readdiffindex {fd serial inst} {
5314 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5315 global vfilelimit
5317 set isdiff 1
5318 if {[gets $fd line] < 0} {
5319 if {![eof $fd]} {
5320 return 1
5322 set isdiff 0
5324 # we only need to see one line and we don't really care what it says...
5325 stop_instance $inst
5327 if {$serial != $lserial} {
5328 return 0
5331 # now see if there are any local changes not checked in to the index
5332 set cmd "|git diff-files"
5333 if {$vfilelimit($curview) ne {}} {
5334 set cmd [concat $cmd -- $vfilelimit($curview)]
5336 set fd [open $cmd r]
5337 fconfigure $fd -blocking 0
5338 set i [reg_instance $fd]
5339 filerun $fd [list readdifffiles $fd $serial $i]
5341 if {$isdiff && ![commitinview $nullid2 $curview]} {
5342 # add the line for the changes in the index to the graph
5343 set hl [mc "Local changes checked in to index but not committed"]
5344 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5345 set commitdata($nullid2) "\n $hl\n"
5346 if {[commitinview $nullid $curview]} {
5347 removefakerow $nullid
5349 insertfakerow $nullid2 $viewmainheadid($curview)
5350 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5351 if {[commitinview $nullid $curview]} {
5352 removefakerow $nullid
5354 removefakerow $nullid2
5356 return 0
5359 proc readdifffiles {fd serial inst} {
5360 global viewmainheadid nullid nullid2 curview
5361 global commitinfo commitdata lserial
5363 set isdiff 1
5364 if {[gets $fd line] < 0} {
5365 if {![eof $fd]} {
5366 return 1
5368 set isdiff 0
5370 # we only need to see one line and we don't really care what it says...
5371 stop_instance $inst
5373 if {$serial != $lserial} {
5374 return 0
5377 if {$isdiff && ![commitinview $nullid $curview]} {
5378 # add the line for the local diff to the graph
5379 set hl [mc "Local uncommitted changes, not checked in to index"]
5380 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5381 set commitdata($nullid) "\n $hl\n"
5382 if {[commitinview $nullid2 $curview]} {
5383 set p $nullid2
5384 } else {
5385 set p $viewmainheadid($curview)
5387 insertfakerow $nullid $p
5388 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5389 removefakerow $nullid
5391 return 0
5394 proc nextuse {id row} {
5395 global curview children
5397 if {[info exists children($curview,$id)]} {
5398 foreach kid $children($curview,$id) {
5399 if {![commitinview $kid $curview]} {
5400 return -1
5402 if {[rowofcommit $kid] > $row} {
5403 return [rowofcommit $kid]
5407 if {[commitinview $id $curview]} {
5408 return [rowofcommit $id]
5410 return -1
5413 proc prevuse {id row} {
5414 global curview children
5416 set ret -1
5417 if {[info exists children($curview,$id)]} {
5418 foreach kid $children($curview,$id) {
5419 if {![commitinview $kid $curview]} break
5420 if {[rowofcommit $kid] < $row} {
5421 set ret [rowofcommit $kid]
5425 return $ret
5428 proc make_idlist {row} {
5429 global displayorder parentlist uparrowlen downarrowlen mingaplen
5430 global commitidx curview children
5432 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5433 if {$r < 0} {
5434 set r 0
5436 set ra [expr {$row - $downarrowlen}]
5437 if {$ra < 0} {
5438 set ra 0
5440 set rb [expr {$row + $uparrowlen}]
5441 if {$rb > $commitidx($curview)} {
5442 set rb $commitidx($curview)
5444 make_disporder $r [expr {$rb + 1}]
5445 set ids {}
5446 for {} {$r < $ra} {incr r} {
5447 set nextid [lindex $displayorder [expr {$r + 1}]]
5448 foreach p [lindex $parentlist $r] {
5449 if {$p eq $nextid} continue
5450 set rn [nextuse $p $r]
5451 if {$rn >= $row &&
5452 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5453 lappend ids [list [ordertoken $p] $p]
5457 for {} {$r < $row} {incr r} {
5458 set nextid [lindex $displayorder [expr {$r + 1}]]
5459 foreach p [lindex $parentlist $r] {
5460 if {$p eq $nextid} continue
5461 set rn [nextuse $p $r]
5462 if {$rn < 0 || $rn >= $row} {
5463 lappend ids [list [ordertoken $p] $p]
5467 set id [lindex $displayorder $row]
5468 lappend ids [list [ordertoken $id] $id]
5469 while {$r < $rb} {
5470 foreach p [lindex $parentlist $r] {
5471 set firstkid [lindex $children($curview,$p) 0]
5472 if {[rowofcommit $firstkid] < $row} {
5473 lappend ids [list [ordertoken $p] $p]
5476 incr r
5477 set id [lindex $displayorder $r]
5478 if {$id ne {}} {
5479 set firstkid [lindex $children($curview,$id) 0]
5480 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5481 lappend ids [list [ordertoken $id] $id]
5485 set idlist {}
5486 foreach idx [lsort -unique $ids] {
5487 lappend idlist [lindex $idx 1]
5489 return $idlist
5492 proc rowsequal {a b} {
5493 while {[set i [lsearch -exact $a {}]] >= 0} {
5494 set a [lreplace $a $i $i]
5496 while {[set i [lsearch -exact $b {}]] >= 0} {
5497 set b [lreplace $b $i $i]
5499 return [expr {$a eq $b}]
5502 proc makeupline {id row rend col} {
5503 global rowidlist uparrowlen downarrowlen mingaplen
5505 for {set r $rend} {1} {set r $rstart} {
5506 set rstart [prevuse $id $r]
5507 if {$rstart < 0} return
5508 if {$rstart < $row} break
5510 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5511 set rstart [expr {$rend - $uparrowlen - 1}]
5513 for {set r $rstart} {[incr r] <= $row} {} {
5514 set idlist [lindex $rowidlist $r]
5515 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5516 set col [idcol $idlist $id $col]
5517 lset rowidlist $r [linsert $idlist $col $id]
5518 changedrow $r
5523 proc layoutrows {row endrow} {
5524 global rowidlist rowisopt rowfinal displayorder
5525 global uparrowlen downarrowlen maxwidth mingaplen
5526 global children parentlist
5527 global commitidx viewcomplete curview
5529 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5530 set idlist {}
5531 if {$row > 0} {
5532 set rm1 [expr {$row - 1}]
5533 foreach id [lindex $rowidlist $rm1] {
5534 if {$id ne {}} {
5535 lappend idlist $id
5538 set final [lindex $rowfinal $rm1]
5540 for {} {$row < $endrow} {incr row} {
5541 set rm1 [expr {$row - 1}]
5542 if {$rm1 < 0 || $idlist eq {}} {
5543 set idlist [make_idlist $row]
5544 set final 1
5545 } else {
5546 set id [lindex $displayorder $rm1]
5547 set col [lsearch -exact $idlist $id]
5548 set idlist [lreplace $idlist $col $col]
5549 foreach p [lindex $parentlist $rm1] {
5550 if {[lsearch -exact $idlist $p] < 0} {
5551 set col [idcol $idlist $p $col]
5552 set idlist [linsert $idlist $col $p]
5553 # if not the first child, we have to insert a line going up
5554 if {$id ne [lindex $children($curview,$p) 0]} {
5555 makeupline $p $rm1 $row $col
5559 set id [lindex $displayorder $row]
5560 if {$row > $downarrowlen} {
5561 set termrow [expr {$row - $downarrowlen - 1}]
5562 foreach p [lindex $parentlist $termrow] {
5563 set i [lsearch -exact $idlist $p]
5564 if {$i < 0} continue
5565 set nr [nextuse $p $termrow]
5566 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5567 set idlist [lreplace $idlist $i $i]
5571 set col [lsearch -exact $idlist $id]
5572 if {$col < 0} {
5573 set col [idcol $idlist $id]
5574 set idlist [linsert $idlist $col $id]
5575 if {$children($curview,$id) ne {}} {
5576 makeupline $id $rm1 $row $col
5579 set r [expr {$row + $uparrowlen - 1}]
5580 if {$r < $commitidx($curview)} {
5581 set x $col
5582 foreach p [lindex $parentlist $r] {
5583 if {[lsearch -exact $idlist $p] >= 0} continue
5584 set fk [lindex $children($curview,$p) 0]
5585 if {[rowofcommit $fk] < $row} {
5586 set x [idcol $idlist $p $x]
5587 set idlist [linsert $idlist $x $p]
5590 if {[incr r] < $commitidx($curview)} {
5591 set p [lindex $displayorder $r]
5592 if {[lsearch -exact $idlist $p] < 0} {
5593 set fk [lindex $children($curview,$p) 0]
5594 if {$fk ne {} && [rowofcommit $fk] < $row} {
5595 set x [idcol $idlist $p $x]
5596 set idlist [linsert $idlist $x $p]
5602 if {$final && !$viewcomplete($curview) &&
5603 $row + $uparrowlen + $mingaplen + $downarrowlen
5604 >= $commitidx($curview)} {
5605 set final 0
5607 set l [llength $rowidlist]
5608 if {$row == $l} {
5609 lappend rowidlist $idlist
5610 lappend rowisopt 0
5611 lappend rowfinal $final
5612 } elseif {$row < $l} {
5613 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5614 lset rowidlist $row $idlist
5615 changedrow $row
5617 lset rowfinal $row $final
5618 } else {
5619 set pad [ntimes [expr {$row - $l}] {}]
5620 set rowidlist [concat $rowidlist $pad]
5621 lappend rowidlist $idlist
5622 set rowfinal [concat $rowfinal $pad]
5623 lappend rowfinal $final
5624 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5627 return $row
5630 proc changedrow {row} {
5631 global displayorder iddrawn rowisopt need_redisplay
5633 set l [llength $rowisopt]
5634 if {$row < $l} {
5635 lset rowisopt $row 0
5636 if {$row + 1 < $l} {
5637 lset rowisopt [expr {$row + 1}] 0
5638 if {$row + 2 < $l} {
5639 lset rowisopt [expr {$row + 2}] 0
5643 set id [lindex $displayorder $row]
5644 if {[info exists iddrawn($id)]} {
5645 set need_redisplay 1
5649 proc insert_pad {row col npad} {
5650 global rowidlist
5652 set pad [ntimes $npad {}]
5653 set idlist [lindex $rowidlist $row]
5654 set bef [lrange $idlist 0 [expr {$col - 1}]]
5655 set aft [lrange $idlist $col end]
5656 set i [lsearch -exact $aft {}]
5657 if {$i > 0} {
5658 set aft [lreplace $aft $i $i]
5660 lset rowidlist $row [concat $bef $pad $aft]
5661 changedrow $row
5664 proc optimize_rows {row col endrow} {
5665 global rowidlist rowisopt displayorder curview children
5667 if {$row < 1} {
5668 set row 1
5670 for {} {$row < $endrow} {incr row; set col 0} {
5671 if {[lindex $rowisopt $row]} continue
5672 set haspad 0
5673 set y0 [expr {$row - 1}]
5674 set ym [expr {$row - 2}]
5675 set idlist [lindex $rowidlist $row]
5676 set previdlist [lindex $rowidlist $y0]
5677 if {$idlist eq {} || $previdlist eq {}} continue
5678 if {$ym >= 0} {
5679 set pprevidlist [lindex $rowidlist $ym]
5680 if {$pprevidlist eq {}} continue
5681 } else {
5682 set pprevidlist {}
5684 set x0 -1
5685 set xm -1
5686 for {} {$col < [llength $idlist]} {incr col} {
5687 set id [lindex $idlist $col]
5688 if {[lindex $previdlist $col] eq $id} continue
5689 if {$id eq {}} {
5690 set haspad 1
5691 continue
5693 set x0 [lsearch -exact $previdlist $id]
5694 if {$x0 < 0} continue
5695 set z [expr {$x0 - $col}]
5696 set isarrow 0
5697 set z0 {}
5698 if {$ym >= 0} {
5699 set xm [lsearch -exact $pprevidlist $id]
5700 if {$xm >= 0} {
5701 set z0 [expr {$xm - $x0}]
5704 if {$z0 eq {}} {
5705 # if row y0 is the first child of $id then it's not an arrow
5706 if {[lindex $children($curview,$id) 0] ne
5707 [lindex $displayorder $y0]} {
5708 set isarrow 1
5711 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5712 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5713 set isarrow 1
5715 # Looking at lines from this row to the previous row,
5716 # make them go straight up if they end in an arrow on
5717 # the previous row; otherwise make them go straight up
5718 # or at 45 degrees.
5719 if {$z < -1 || ($z < 0 && $isarrow)} {
5720 # Line currently goes left too much;
5721 # insert pads in the previous row, then optimize it
5722 set npad [expr {-1 - $z + $isarrow}]
5723 insert_pad $y0 $x0 $npad
5724 if {$y0 > 0} {
5725 optimize_rows $y0 $x0 $row
5727 set previdlist [lindex $rowidlist $y0]
5728 set x0 [lsearch -exact $previdlist $id]
5729 set z [expr {$x0 - $col}]
5730 if {$z0 ne {}} {
5731 set pprevidlist [lindex $rowidlist $ym]
5732 set xm [lsearch -exact $pprevidlist $id]
5733 set z0 [expr {$xm - $x0}]
5735 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5736 # Line currently goes right too much;
5737 # insert pads in this line
5738 set npad [expr {$z - 1 + $isarrow}]
5739 insert_pad $row $col $npad
5740 set idlist [lindex $rowidlist $row]
5741 incr col $npad
5742 set z [expr {$x0 - $col}]
5743 set haspad 1
5745 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5746 # this line links to its first child on row $row-2
5747 set id [lindex $displayorder $ym]
5748 set xc [lsearch -exact $pprevidlist $id]
5749 if {$xc >= 0} {
5750 set z0 [expr {$xc - $x0}]
5753 # avoid lines jigging left then immediately right
5754 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5755 insert_pad $y0 $x0 1
5756 incr x0
5757 optimize_rows $y0 $x0 $row
5758 set previdlist [lindex $rowidlist $y0]
5761 if {!$haspad} {
5762 # Find the first column that doesn't have a line going right
5763 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5764 set id [lindex $idlist $col]
5765 if {$id eq {}} break
5766 set x0 [lsearch -exact $previdlist $id]
5767 if {$x0 < 0} {
5768 # check if this is the link to the first child
5769 set kid [lindex $displayorder $y0]
5770 if {[lindex $children($curview,$id) 0] eq $kid} {
5771 # it is, work out offset to child
5772 set x0 [lsearch -exact $previdlist $kid]
5775 if {$x0 <= $col} break
5777 # Insert a pad at that column as long as it has a line and
5778 # isn't the last column
5779 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5780 set idlist [linsert $idlist $col {}]
5781 lset rowidlist $row $idlist
5782 changedrow $row
5788 proc xc {row col} {
5789 global canvx0 linespc
5790 return [expr {$canvx0 + $col * $linespc}]
5793 proc yc {row} {
5794 global canvy0 linespc
5795 return [expr {$canvy0 + $row * $linespc}]
5798 proc linewidth {id} {
5799 global thickerline lthickness
5801 set wid $lthickness
5802 if {[info exists thickerline] && $id eq $thickerline} {
5803 set wid [expr {2 * $lthickness}]
5805 return $wid
5808 proc rowranges {id} {
5809 global curview children uparrowlen downarrowlen
5810 global rowidlist
5812 set kids $children($curview,$id)
5813 if {$kids eq {}} {
5814 return {}
5816 set ret {}
5817 lappend kids $id
5818 foreach child $kids {
5819 if {![commitinview $child $curview]} break
5820 set row [rowofcommit $child]
5821 if {![info exists prev]} {
5822 lappend ret [expr {$row + 1}]
5823 } else {
5824 if {$row <= $prevrow} {
5825 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5827 # see if the line extends the whole way from prevrow to row
5828 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5829 [lsearch -exact [lindex $rowidlist \
5830 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5831 # it doesn't, see where it ends
5832 set r [expr {$prevrow + $downarrowlen}]
5833 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5834 while {[incr r -1] > $prevrow &&
5835 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5836 } else {
5837 while {[incr r] <= $row &&
5838 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5839 incr r -1
5841 lappend ret $r
5842 # see where it starts up again
5843 set r [expr {$row - $uparrowlen}]
5844 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5845 while {[incr r] < $row &&
5846 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5847 } else {
5848 while {[incr r -1] >= $prevrow &&
5849 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5850 incr r
5852 lappend ret $r
5855 if {$child eq $id} {
5856 lappend ret $row
5858 set prev $child
5859 set prevrow $row
5861 return $ret
5864 proc drawlineseg {id row endrow arrowlow} {
5865 global rowidlist displayorder iddrawn linesegs
5866 global canv colormap linespc curview maxlinelen parentlist
5868 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5869 set le [expr {$row + 1}]
5870 set arrowhigh 1
5871 while {1} {
5872 set c [lsearch -exact [lindex $rowidlist $le] $id]
5873 if {$c < 0} {
5874 incr le -1
5875 break
5877 lappend cols $c
5878 set x [lindex $displayorder $le]
5879 if {$x eq $id} {
5880 set arrowhigh 0
5881 break
5883 if {[info exists iddrawn($x)] || $le == $endrow} {
5884 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5885 if {$c >= 0} {
5886 lappend cols $c
5887 set arrowhigh 0
5889 break
5891 incr le
5893 if {$le <= $row} {
5894 return $row
5897 set lines {}
5898 set i 0
5899 set joinhigh 0
5900 if {[info exists linesegs($id)]} {
5901 set lines $linesegs($id)
5902 foreach li $lines {
5903 set r0 [lindex $li 0]
5904 if {$r0 > $row} {
5905 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5906 set joinhigh 1
5908 break
5910 incr i
5913 set joinlow 0
5914 if {$i > 0} {
5915 set li [lindex $lines [expr {$i-1}]]
5916 set r1 [lindex $li 1]
5917 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5918 set joinlow 1
5922 set x [lindex $cols [expr {$le - $row}]]
5923 set xp [lindex $cols [expr {$le - 1 - $row}]]
5924 set dir [expr {$xp - $x}]
5925 if {$joinhigh} {
5926 set ith [lindex $lines $i 2]
5927 set coords [$canv coords $ith]
5928 set ah [$canv itemcget $ith -arrow]
5929 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5930 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5931 if {$x2 ne {} && $x - $x2 == $dir} {
5932 set coords [lrange $coords 0 end-2]
5934 } else {
5935 set coords [list [xc $le $x] [yc $le]]
5937 if {$joinlow} {
5938 set itl [lindex $lines [expr {$i-1}] 2]
5939 set al [$canv itemcget $itl -arrow]
5940 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5941 } elseif {$arrowlow} {
5942 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5943 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5944 set arrowlow 0
5947 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5948 for {set y $le} {[incr y -1] > $row} {} {
5949 set x $xp
5950 set xp [lindex $cols [expr {$y - 1 - $row}]]
5951 set ndir [expr {$xp - $x}]
5952 if {$dir != $ndir || $xp < 0} {
5953 lappend coords [xc $y $x] [yc $y]
5955 set dir $ndir
5957 if {!$joinlow} {
5958 if {$xp < 0} {
5959 # join parent line to first child
5960 set ch [lindex $displayorder $row]
5961 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5962 if {$xc < 0} {
5963 puts "oops: drawlineseg: child $ch not on row $row"
5964 } elseif {$xc != $x} {
5965 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5966 set d [expr {int(0.5 * $linespc)}]
5967 set x1 [xc $row $x]
5968 if {$xc < $x} {
5969 set x2 [expr {$x1 - $d}]
5970 } else {
5971 set x2 [expr {$x1 + $d}]
5973 set y2 [yc $row]
5974 set y1 [expr {$y2 + $d}]
5975 lappend coords $x1 $y1 $x2 $y2
5976 } elseif {$xc < $x - 1} {
5977 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5978 } elseif {$xc > $x + 1} {
5979 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5981 set x $xc
5983 lappend coords [xc $row $x] [yc $row]
5984 } else {
5985 set xn [xc $row $xp]
5986 set yn [yc $row]
5987 lappend coords $xn $yn
5989 if {!$joinhigh} {
5990 assigncolor $id
5991 set t [$canv create line $coords -width [linewidth $id] \
5992 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5993 $canv lower $t
5994 bindline $t $id
5995 set lines [linsert $lines $i [list $row $le $t]]
5996 } else {
5997 $canv coords $ith $coords
5998 if {$arrow ne $ah} {
5999 $canv itemconf $ith -arrow $arrow
6001 lset lines $i 0 $row
6003 } else {
6004 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
6005 set ndir [expr {$xo - $xp}]
6006 set clow [$canv coords $itl]
6007 if {$dir == $ndir} {
6008 set clow [lrange $clow 2 end]
6010 set coords [concat $coords $clow]
6011 if {!$joinhigh} {
6012 lset lines [expr {$i-1}] 1 $le
6013 } else {
6014 # coalesce two pieces
6015 $canv delete $ith
6016 set b [lindex $lines [expr {$i-1}] 0]
6017 set e [lindex $lines $i 1]
6018 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6020 $canv coords $itl $coords
6021 if {$arrow ne $al} {
6022 $canv itemconf $itl -arrow $arrow
6026 set linesegs($id) $lines
6027 return $le
6030 proc drawparentlinks {id row} {
6031 global rowidlist canv colormap curview parentlist
6032 global idpos linespc
6034 set rowids [lindex $rowidlist $row]
6035 set col [lsearch -exact $rowids $id]
6036 if {$col < 0} return
6037 set olds [lindex $parentlist $row]
6038 set row2 [expr {$row + 1}]
6039 set x [xc $row $col]
6040 set y [yc $row]
6041 set y2 [yc $row2]
6042 set d [expr {int(0.5 * $linespc)}]
6043 set ymid [expr {$y + $d}]
6044 set ids [lindex $rowidlist $row2]
6045 # rmx = right-most X coord used
6046 set rmx 0
6047 foreach p $olds {
6048 set i [lsearch -exact $ids $p]
6049 if {$i < 0} {
6050 puts "oops, parent $p of $id not in list"
6051 continue
6053 set x2 [xc $row2 $i]
6054 if {$x2 > $rmx} {
6055 set rmx $x2
6057 set j [lsearch -exact $rowids $p]
6058 if {$j < 0} {
6059 # drawlineseg will do this one for us
6060 continue
6062 assigncolor $p
6063 # should handle duplicated parents here...
6064 set coords [list $x $y]
6065 if {$i != $col} {
6066 # if attaching to a vertical segment, draw a smaller
6067 # slant for visual distinctness
6068 if {$i == $j} {
6069 if {$i < $col} {
6070 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6071 } else {
6072 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6074 } elseif {$i < $col && $i < $j} {
6075 # segment slants towards us already
6076 lappend coords [xc $row $j] $y
6077 } else {
6078 if {$i < $col - 1} {
6079 lappend coords [expr {$x2 + $linespc}] $y
6080 } elseif {$i > $col + 1} {
6081 lappend coords [expr {$x2 - $linespc}] $y
6083 lappend coords $x2 $y2
6085 } else {
6086 lappend coords $x2 $y2
6088 set t [$canv create line $coords -width [linewidth $p] \
6089 -fill $colormap($p) -tags lines.$p]
6090 $canv lower $t
6091 bindline $t $p
6093 if {$rmx > [lindex $idpos($id) 1]} {
6094 lset idpos($id) 1 $rmx
6095 redrawtags $id
6099 proc drawlines {id} {
6100 global canv
6102 $canv itemconf lines.$id -width [linewidth $id]
6105 proc drawcmittext {id row col} {
6106 global linespc canv canv2 canv3 fgcolor curview
6107 global cmitlisted commitinfo rowidlist parentlist
6108 global rowtextx idpos idtags idheads idotherrefs
6109 global linehtag linentag linedtag selectedline
6110 global canvxmax boldids boldnameids fgcolor markedid
6111 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6112 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6113 global circleoutlinecolor
6115 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6116 set listed $cmitlisted($curview,$id)
6117 if {$id eq $nullid} {
6118 set ofill $workingfilescirclecolor
6119 } elseif {$id eq $nullid2} {
6120 set ofill $indexcirclecolor
6121 } elseif {$id eq $mainheadid} {
6122 set ofill $mainheadcirclecolor
6123 } else {
6124 set ofill [lindex $circlecolors $listed]
6126 set x [xc $row $col]
6127 set y [yc $row]
6128 set orad [expr {$linespc / 3}]
6129 if {$listed <= 2} {
6130 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6131 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6132 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6133 } elseif {$listed == 3} {
6134 # triangle pointing left for left-side commits
6135 set t [$canv create polygon \
6136 [expr {$x - $orad}] $y \
6137 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6138 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6139 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6140 } else {
6141 # triangle pointing right for right-side commits
6142 set t [$canv create polygon \
6143 [expr {$x + $orad - 1}] $y \
6144 [expr {$x - $orad}] [expr {$y - $orad}] \
6145 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6146 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6148 set circleitem($row) $t
6149 $canv raise $t
6150 $canv bind $t <1> {selcanvline {} %x %y}
6151 set rmx [llength [lindex $rowidlist $row]]
6152 set olds [lindex $parentlist $row]
6153 if {$olds ne {}} {
6154 set nextids [lindex $rowidlist [expr {$row + 1}]]
6155 foreach p $olds {
6156 set i [lsearch -exact $nextids $p]
6157 if {$i > $rmx} {
6158 set rmx $i
6162 set xt [xc $row $rmx]
6163 set rowtextx($row) $xt
6164 set idpos($id) [list $x $xt $y]
6165 if {[info exists idtags($id)] || [info exists idheads($id)]
6166 || [info exists idotherrefs($id)]} {
6167 set xt [drawtags $id $x $xt $y]
6169 if {[lindex $commitinfo($id) 6] > 0} {
6170 set xt [drawnotesign $xt $y]
6172 set headline [lindex $commitinfo($id) 0]
6173 set name [lindex $commitinfo($id) 1]
6174 set date [lindex $commitinfo($id) 2]
6175 set date [formatdate $date]
6176 set font mainfont
6177 set nfont mainfont
6178 set isbold [ishighlighted $id]
6179 if {$isbold > 0} {
6180 lappend boldids $id
6181 set font mainfontbold
6182 if {$isbold > 1} {
6183 lappend boldnameids $id
6184 set nfont mainfontbold
6187 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6188 -text $headline -font $font -tags text]
6189 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6190 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6191 -text $name -font $nfont -tags text]
6192 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6193 -text $date -font mainfont -tags text]
6194 if {$selectedline == $row} {
6195 make_secsel $id
6197 if {[info exists markedid] && $markedid eq $id} {
6198 make_idmark $id
6200 set xr [expr {$xt + [font measure $font $headline]}]
6201 if {$xr > $canvxmax} {
6202 set canvxmax $xr
6203 setcanvscroll
6207 proc drawcmitrow {row} {
6208 global displayorder rowidlist nrows_drawn
6209 global iddrawn markingmatches
6210 global commitinfo numcommits
6211 global filehighlight fhighlights findpattern nhighlights
6212 global hlview vhighlights
6213 global highlight_related rhighlights
6215 if {$row >= $numcommits} return
6217 set id [lindex $displayorder $row]
6218 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6219 askvhighlight $row $id
6221 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6222 askfilehighlight $row $id
6224 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6225 askfindhighlight $row $id
6227 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6228 askrelhighlight $row $id
6230 if {![info exists iddrawn($id)]} {
6231 set col [lsearch -exact [lindex $rowidlist $row] $id]
6232 if {$col < 0} {
6233 puts "oops, row $row id $id not in list"
6234 return
6236 if {![info exists commitinfo($id)]} {
6237 getcommit $id
6239 assigncolor $id
6240 drawcmittext $id $row $col
6241 set iddrawn($id) 1
6242 incr nrows_drawn
6244 if {$markingmatches} {
6245 markrowmatches $row $id
6249 proc drawcommits {row {endrow {}}} {
6250 global numcommits iddrawn displayorder curview need_redisplay
6251 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6253 if {$row < 0} {
6254 set row 0
6256 if {$endrow eq {}} {
6257 set endrow $row
6259 if {$endrow >= $numcommits} {
6260 set endrow [expr {$numcommits - 1}]
6263 set rl1 [expr {$row - $downarrowlen - 3}]
6264 if {$rl1 < 0} {
6265 set rl1 0
6267 set ro1 [expr {$row - 3}]
6268 if {$ro1 < 0} {
6269 set ro1 0
6271 set r2 [expr {$endrow + $uparrowlen + 3}]
6272 if {$r2 > $numcommits} {
6273 set r2 $numcommits
6275 for {set r $rl1} {$r < $r2} {incr r} {
6276 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6277 if {$rl1 < $r} {
6278 layoutrows $rl1 $r
6280 set rl1 [expr {$r + 1}]
6283 if {$rl1 < $r} {
6284 layoutrows $rl1 $r
6286 optimize_rows $ro1 0 $r2
6287 if {$need_redisplay || $nrows_drawn > 2000} {
6288 clear_display
6291 # make the lines join to already-drawn rows either side
6292 set r [expr {$row - 1}]
6293 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6294 set r $row
6296 set er [expr {$endrow + 1}]
6297 if {$er >= $numcommits ||
6298 ![info exists iddrawn([lindex $displayorder $er])]} {
6299 set er $endrow
6301 for {} {$r <= $er} {incr r} {
6302 set id [lindex $displayorder $r]
6303 set wasdrawn [info exists iddrawn($id)]
6304 drawcmitrow $r
6305 if {$r == $er} break
6306 set nextid [lindex $displayorder [expr {$r + 1}]]
6307 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6308 drawparentlinks $id $r
6310 set rowids [lindex $rowidlist $r]
6311 foreach lid $rowids {
6312 if {$lid eq {}} continue
6313 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6314 if {$lid eq $id} {
6315 # see if this is the first child of any of its parents
6316 foreach p [lindex $parentlist $r] {
6317 if {[lsearch -exact $rowids $p] < 0} {
6318 # make this line extend up to the child
6319 set lineend($p) [drawlineseg $p $r $er 0]
6322 } else {
6323 set lineend($lid) [drawlineseg $lid $r $er 1]
6329 proc undolayout {row} {
6330 global uparrowlen mingaplen downarrowlen
6331 global rowidlist rowisopt rowfinal need_redisplay
6333 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6334 if {$r < 0} {
6335 set r 0
6337 if {[llength $rowidlist] > $r} {
6338 incr r -1
6339 set rowidlist [lrange $rowidlist 0 $r]
6340 set rowfinal [lrange $rowfinal 0 $r]
6341 set rowisopt [lrange $rowisopt 0 $r]
6342 set need_redisplay 1
6343 run drawvisible
6347 proc drawvisible {} {
6348 global canv linespc curview vrowmod selectedline targetrow targetid
6349 global need_redisplay cscroll numcommits
6351 set fs [$canv yview]
6352 set ymax [lindex [$canv cget -scrollregion] 3]
6353 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6354 set f0 [lindex $fs 0]
6355 set f1 [lindex $fs 1]
6356 set y0 [expr {int($f0 * $ymax)}]
6357 set y1 [expr {int($f1 * $ymax)}]
6359 if {[info exists targetid]} {
6360 if {[commitinview $targetid $curview]} {
6361 set r [rowofcommit $targetid]
6362 if {$r != $targetrow} {
6363 # Fix up the scrollregion and change the scrolling position
6364 # now that our target row has moved.
6365 set diff [expr {($r - $targetrow) * $linespc}]
6366 set targetrow $r
6367 setcanvscroll
6368 set ymax [lindex [$canv cget -scrollregion] 3]
6369 incr y0 $diff
6370 incr y1 $diff
6371 set f0 [expr {$y0 / $ymax}]
6372 set f1 [expr {$y1 / $ymax}]
6373 allcanvs yview moveto $f0
6374 $cscroll set $f0 $f1
6375 set need_redisplay 1
6377 } else {
6378 unset targetid
6382 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6383 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6384 if {$endrow >= $vrowmod($curview)} {
6385 update_arcrows $curview
6387 if {$selectedline ne {} &&
6388 $row <= $selectedline && $selectedline <= $endrow} {
6389 set targetrow $selectedline
6390 } elseif {[info exists targetid]} {
6391 set targetrow [expr {int(($row + $endrow) / 2)}]
6393 if {[info exists targetrow]} {
6394 if {$targetrow >= $numcommits} {
6395 set targetrow [expr {$numcommits - 1}]
6397 set targetid [commitonrow $targetrow]
6399 drawcommits $row $endrow
6402 proc clear_display {} {
6403 global iddrawn linesegs need_redisplay nrows_drawn
6404 global vhighlights fhighlights nhighlights rhighlights
6405 global linehtag linentag linedtag boldids boldnameids
6407 allcanvs delete all
6408 unset -nocomplain iddrawn
6409 unset -nocomplain linesegs
6410 unset -nocomplain linehtag
6411 unset -nocomplain linentag
6412 unset -nocomplain linedtag
6413 set boldids {}
6414 set boldnameids {}
6415 unset -nocomplain vhighlights
6416 unset -nocomplain fhighlights
6417 unset -nocomplain nhighlights
6418 unset -nocomplain rhighlights
6419 set need_redisplay 0
6420 set nrows_drawn 0
6423 proc findcrossings {id} {
6424 global rowidlist parentlist numcommits displayorder
6426 set cross {}
6427 set ccross {}
6428 foreach {s e} [rowranges $id] {
6429 if {$e >= $numcommits} {
6430 set e [expr {$numcommits - 1}]
6432 if {$e <= $s} continue
6433 for {set row $e} {[incr row -1] >= $s} {} {
6434 set x [lsearch -exact [lindex $rowidlist $row] $id]
6435 if {$x < 0} break
6436 set olds [lindex $parentlist $row]
6437 set kid [lindex $displayorder $row]
6438 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6439 if {$kidx < 0} continue
6440 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6441 foreach p $olds {
6442 set px [lsearch -exact $nextrow $p]
6443 if {$px < 0} continue
6444 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6445 if {[lsearch -exact $ccross $p] >= 0} continue
6446 if {$x == $px + ($kidx < $px? -1: 1)} {
6447 lappend ccross $p
6448 } elseif {[lsearch -exact $cross $p] < 0} {
6449 lappend cross $p
6455 return [concat $ccross {{}} $cross]
6458 proc assigncolor {id} {
6459 global colormap colors nextcolor
6460 global parents children children curview
6462 if {[info exists colormap($id)]} return
6463 set ncolors [llength $colors]
6464 if {[info exists children($curview,$id)]} {
6465 set kids $children($curview,$id)
6466 } else {
6467 set kids {}
6469 if {[llength $kids] == 1} {
6470 set child [lindex $kids 0]
6471 if {[info exists colormap($child)]
6472 && [llength $parents($curview,$child)] == 1} {
6473 set colormap($id) $colormap($child)
6474 return
6477 set badcolors {}
6478 set origbad {}
6479 foreach x [findcrossings $id] {
6480 if {$x eq {}} {
6481 # delimiter between corner crossings and other crossings
6482 if {[llength $badcolors] >= $ncolors - 1} break
6483 set origbad $badcolors
6485 if {[info exists colormap($x)]
6486 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6487 lappend badcolors $colormap($x)
6490 if {[llength $badcolors] >= $ncolors} {
6491 set badcolors $origbad
6493 set origbad $badcolors
6494 if {[llength $badcolors] < $ncolors - 1} {
6495 foreach child $kids {
6496 if {[info exists colormap($child)]
6497 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6498 lappend badcolors $colormap($child)
6500 foreach p $parents($curview,$child) {
6501 if {[info exists colormap($p)]
6502 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6503 lappend badcolors $colormap($p)
6507 if {[llength $badcolors] >= $ncolors} {
6508 set badcolors $origbad
6511 for {set i 0} {$i <= $ncolors} {incr i} {
6512 set c [lindex $colors $nextcolor]
6513 if {[incr nextcolor] >= $ncolors} {
6514 set nextcolor 0
6516 if {[lsearch -exact $badcolors $c]} break
6518 set colormap($id) $c
6521 proc bindline {t id} {
6522 global canv
6524 $canv bind $t <Enter> "lineenter %x %y $id"
6525 $canv bind $t <Motion> "linemotion %x %y $id"
6526 $canv bind $t <Leave> "lineleave $id"
6527 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6530 proc graph_pane_width {} {
6531 global use_ttk
6533 if {$use_ttk} {
6534 set g [.tf.histframe.pwclist sashpos 0]
6535 } else {
6536 set g [.tf.histframe.pwclist sash coord 0]
6538 return [lindex $g 0]
6541 proc totalwidth {l font extra} {
6542 set tot 0
6543 foreach str $l {
6544 set tot [expr {$tot + [font measure $font $str] + $extra}]
6546 return $tot
6549 proc drawtags {id x xt y1} {
6550 global idtags idheads idotherrefs mainhead
6551 global linespc lthickness
6552 global canv rowtextx curview fgcolor bgcolor ctxbut
6553 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6554 global tagbgcolor tagfgcolor tagoutlinecolor
6555 global reflinecolor
6557 set marks {}
6558 set ntags 0
6559 set nheads 0
6560 set singletag 0
6561 set maxtags 3
6562 set maxtagpct 25
6563 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6564 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6565 set extra [expr {$delta + $lthickness + $linespc}]
6567 if {[info exists idtags($id)]} {
6568 set marks $idtags($id)
6569 set ntags [llength $marks]
6570 if {$ntags > $maxtags ||
6571 [totalwidth $marks mainfont $extra] > $maxwidth} {
6572 # show just a single "n tags..." tag
6573 set singletag 1
6574 if {$ntags == 1} {
6575 set marks [list "tag..."]
6576 } else {
6577 set marks [list [format "%d tags..." $ntags]]
6579 set ntags 1
6582 if {[info exists idheads($id)]} {
6583 set marks [concat $marks $idheads($id)]
6584 set nheads [llength $idheads($id)]
6586 if {[info exists idotherrefs($id)]} {
6587 set marks [concat $marks $idotherrefs($id)]
6589 if {$marks eq {}} {
6590 return $xt
6593 set yt [expr {$y1 - 0.5 * $linespc}]
6594 set yb [expr {$yt + $linespc - 1}]
6595 set xvals {}
6596 set wvals {}
6597 set i -1
6598 foreach tag $marks {
6599 incr i
6600 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6601 set wid [font measure mainfontbold $tag]
6602 } else {
6603 set wid [font measure mainfont $tag]
6605 lappend xvals $xt
6606 lappend wvals $wid
6607 set xt [expr {$xt + $wid + $extra}]
6609 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6610 -width $lthickness -fill $reflinecolor -tags tag.$id]
6611 $canv lower $t
6612 foreach tag $marks x $xvals wid $wvals {
6613 set tag_quoted [string map {% %%} $tag]
6614 set xl [expr {$x + $delta}]
6615 set xr [expr {$x + $delta + $wid + $lthickness}]
6616 set font mainfont
6617 if {[incr ntags -1] >= 0} {
6618 # draw a tag
6619 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6620 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6621 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6622 -tags tag.$id]
6623 if {$singletag} {
6624 set tagclick [list showtags $id 1]
6625 } else {
6626 set tagclick [list showtag $tag_quoted 1]
6628 $canv bind $t <1> $tagclick
6629 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6630 } else {
6631 # draw a head or other ref
6632 if {[incr nheads -1] >= 0} {
6633 set col $headbgcolor
6634 if {$tag eq $mainhead} {
6635 set font mainfontbold
6637 } else {
6638 set col "#ddddff"
6640 set xl [expr {$xl - $delta/2}]
6641 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6642 -width 1 -outline black -fill $col -tags tag.$id
6643 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6644 set rwid [font measure mainfont $remoteprefix]
6645 set xi [expr {$x + 1}]
6646 set yti [expr {$yt + 1}]
6647 set xri [expr {$x + $rwid}]
6648 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6649 -width 0 -fill $remotebgcolor -tags tag.$id
6652 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6653 -font $font -tags [list tag.$id text]]
6654 if {$ntags >= 0} {
6655 $canv bind $t <1> $tagclick
6656 } elseif {$nheads >= 0} {
6657 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6660 return $xt
6663 proc drawnotesign {xt y} {
6664 global linespc canv fgcolor
6666 set orad [expr {$linespc / 3}]
6667 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6668 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6669 -fill yellow -outline $fgcolor -width 1 -tags circle]
6670 set xt [expr {$xt + $orad * 3}]
6671 return $xt
6674 proc xcoord {i level ln} {
6675 global canvx0 xspc1 xspc2
6677 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6678 if {$i > 0 && $i == $level} {
6679 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6680 } elseif {$i > $level} {
6681 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6683 return $x
6686 proc show_status {msg} {
6687 global canv fgcolor
6689 clear_display
6690 set_window_title
6691 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6692 -tags text -fill $fgcolor
6695 # Don't change the text pane cursor if it is currently the hand cursor,
6696 # showing that we are over a sha1 ID link.
6697 proc settextcursor {c} {
6698 global ctext curtextcursor
6700 if {[$ctext cget -cursor] == $curtextcursor} {
6701 $ctext config -cursor $c
6703 set curtextcursor $c
6706 proc nowbusy {what {name {}}} {
6707 global isbusy busyname statusw
6709 if {[array names isbusy] eq {}} {
6710 . config -cursor watch
6711 settextcursor watch
6713 set isbusy($what) 1
6714 set busyname($what) $name
6715 if {$name ne {}} {
6716 $statusw conf -text $name
6720 proc notbusy {what} {
6721 global isbusy maincursor textcursor busyname statusw
6723 catch {
6724 unset isbusy($what)
6725 if {$busyname($what) ne {} &&
6726 [$statusw cget -text] eq $busyname($what)} {
6727 $statusw conf -text {}
6730 if {[array names isbusy] eq {}} {
6731 . config -cursor $maincursor
6732 settextcursor $textcursor
6736 proc findmatches {f} {
6737 global findtype findstring
6738 if {$findtype == [mc "Regexp"]} {
6739 set matches [regexp -indices -all -inline $findstring $f]
6740 } else {
6741 set fs $findstring
6742 if {$findtype == [mc "IgnCase"]} {
6743 set f [string tolower $f]
6744 set fs [string tolower $fs]
6746 set matches {}
6747 set i 0
6748 set l [string length $fs]
6749 while {[set j [string first $fs $f $i]] >= 0} {
6750 lappend matches [list $j [expr {$j+$l-1}]]
6751 set i [expr {$j + $l}]
6754 return $matches
6757 proc dofind {{dirn 1} {wrap 1}} {
6758 global findstring findstartline findcurline selectedline numcommits
6759 global gdttype filehighlight fh_serial find_dirn findallowwrap
6761 if {[info exists find_dirn]} {
6762 if {$find_dirn == $dirn} return
6763 stopfinding
6765 focus .
6766 if {$findstring eq {} || $numcommits == 0} return
6767 if {$selectedline eq {}} {
6768 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6769 } else {
6770 set findstartline $selectedline
6772 set findcurline $findstartline
6773 nowbusy finding [mc "Searching"]
6774 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6775 after cancel do_file_hl $fh_serial
6776 do_file_hl $fh_serial
6778 set find_dirn $dirn
6779 set findallowwrap $wrap
6780 run findmore
6783 proc stopfinding {} {
6784 global find_dirn findcurline fprogcoord
6786 if {[info exists find_dirn]} {
6787 unset find_dirn
6788 unset findcurline
6789 notbusy finding
6790 set fprogcoord 0
6791 adjustprogress
6793 stopblaming
6796 proc findmore {} {
6797 global commitdata commitinfo numcommits findpattern findloc
6798 global findstartline findcurline findallowwrap
6799 global find_dirn gdttype fhighlights fprogcoord
6800 global curview varcorder vrownum varccommits vrowmod
6802 if {![info exists find_dirn]} {
6803 return 0
6805 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6806 set l $findcurline
6807 set moretodo 0
6808 if {$find_dirn > 0} {
6809 incr l
6810 if {$l >= $numcommits} {
6811 set l 0
6813 if {$l <= $findstartline} {
6814 set lim [expr {$findstartline + 1}]
6815 } else {
6816 set lim $numcommits
6817 set moretodo $findallowwrap
6819 } else {
6820 if {$l == 0} {
6821 set l $numcommits
6823 incr l -1
6824 if {$l >= $findstartline} {
6825 set lim [expr {$findstartline - 1}]
6826 } else {
6827 set lim -1
6828 set moretodo $findallowwrap
6831 set n [expr {($lim - $l) * $find_dirn}]
6832 if {$n > 500} {
6833 set n 500
6834 set moretodo 1
6836 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6837 update_arcrows $curview
6839 set found 0
6840 set domore 1
6841 set ai [bsearch $vrownum($curview) $l]
6842 set a [lindex $varcorder($curview) $ai]
6843 set arow [lindex $vrownum($curview) $ai]
6844 set ids [lindex $varccommits($curview,$a)]
6845 set arowend [expr {$arow + [llength $ids]}]
6846 if {$gdttype eq [mc "containing:"]} {
6847 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6848 if {$l < $arow || $l >= $arowend} {
6849 incr ai $find_dirn
6850 set a [lindex $varcorder($curview) $ai]
6851 set arow [lindex $vrownum($curview) $ai]
6852 set ids [lindex $varccommits($curview,$a)]
6853 set arowend [expr {$arow + [llength $ids]}]
6855 set id [lindex $ids [expr {$l - $arow}]]
6856 # shouldn't happen unless git log doesn't give all the commits...
6857 if {![info exists commitdata($id)] ||
6858 ![doesmatch $commitdata($id)]} {
6859 continue
6861 if {![info exists commitinfo($id)]} {
6862 getcommit $id
6864 set info $commitinfo($id)
6865 foreach f $info ty $fldtypes {
6866 if {$ty eq ""} continue
6867 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6868 [doesmatch $f]} {
6869 set found 1
6870 break
6873 if {$found} break
6875 } else {
6876 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6877 if {$l < $arow || $l >= $arowend} {
6878 incr ai $find_dirn
6879 set a [lindex $varcorder($curview) $ai]
6880 set arow [lindex $vrownum($curview) $ai]
6881 set ids [lindex $varccommits($curview,$a)]
6882 set arowend [expr {$arow + [llength $ids]}]
6884 set id [lindex $ids [expr {$l - $arow}]]
6885 if {![info exists fhighlights($id)]} {
6886 # this sets fhighlights($id) to -1
6887 askfilehighlight $l $id
6889 if {$fhighlights($id) > 0} {
6890 set found $domore
6891 break
6893 if {$fhighlights($id) < 0} {
6894 if {$domore} {
6895 set domore 0
6896 set findcurline [expr {$l - $find_dirn}]
6901 if {$found || ($domore && !$moretodo)} {
6902 unset findcurline
6903 unset find_dirn
6904 notbusy finding
6905 set fprogcoord 0
6906 adjustprogress
6907 if {$found} {
6908 findselectline $l
6909 } else {
6910 bell
6912 return 0
6914 if {!$domore} {
6915 flushhighlights
6916 } else {
6917 set findcurline [expr {$l - $find_dirn}]
6919 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6920 if {$n < 0} {
6921 incr n $numcommits
6923 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6924 adjustprogress
6925 return $domore
6928 proc findselectline {l} {
6929 global findloc commentend ctext findcurline markingmatches gdttype
6931 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6932 set findcurline $l
6933 selectline $l 1
6934 if {$markingmatches &&
6935 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6936 # highlight the matches in the comments
6937 set f [$ctext get 1.0 $commentend]
6938 set matches [findmatches $f]
6939 foreach match $matches {
6940 set start [lindex $match 0]
6941 set end [expr {[lindex $match 1] + 1}]
6942 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6945 drawvisible
6948 # mark the bits of a headline or author that match a find string
6949 proc markmatches {canv l str tag matches font row} {
6950 global selectedline
6952 set bbox [$canv bbox $tag]
6953 set x0 [lindex $bbox 0]
6954 set y0 [lindex $bbox 1]
6955 set y1 [lindex $bbox 3]
6956 foreach match $matches {
6957 set start [lindex $match 0]
6958 set end [lindex $match 1]
6959 if {$start > $end} continue
6960 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6961 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6962 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6963 [expr {$x0+$xlen+2}] $y1 \
6964 -outline {} -tags [list match$l matches] -fill yellow]
6965 $canv lower $t
6966 if {$row == $selectedline} {
6967 $canv raise $t secsel
6972 proc unmarkmatches {} {
6973 global markingmatches
6975 allcanvs delete matches
6976 set markingmatches 0
6977 stopfinding
6980 proc selcanvline {w x y} {
6981 global canv canvy0 ctext linespc
6982 global rowtextx
6983 set ymax [lindex [$canv cget -scrollregion] 3]
6984 if {$ymax == {}} return
6985 set yfrac [lindex [$canv yview] 0]
6986 set y [expr {$y + $yfrac * $ymax}]
6987 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6988 if {$l < 0} {
6989 set l 0
6991 if {$w eq $canv} {
6992 set xmax [lindex [$canv cget -scrollregion] 2]
6993 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6994 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6996 unmarkmatches
6997 selectline $l 1
7000 proc commit_descriptor {p} {
7001 global commitinfo
7002 if {![info exists commitinfo($p)]} {
7003 getcommit $p
7005 set l "..."
7006 if {[llength $commitinfo($p)] > 1} {
7007 set l [lindex $commitinfo($p) 0]
7009 return "$p ($l)\n"
7012 # append some text to the ctext widget, and make any SHA1 ID
7013 # that we know about be a clickable link.
7014 proc appendwithlinks {text tags} {
7015 global ctext linknum curview
7017 set start [$ctext index "end - 1c"]
7018 $ctext insert end $text $tags
7019 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
7020 foreach l $links {
7021 set s [lindex $l 0]
7022 set e [lindex $l 1]
7023 set linkid [string range $text $s $e]
7024 incr e
7025 $ctext tag delete link$linknum
7026 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7027 setlink $linkid link$linknum
7028 incr linknum
7032 proc setlink {id lk} {
7033 global curview ctext pendinglinks
7034 global linkfgcolor
7036 if {[string range $id 0 1] eq "-g"} {
7037 set id [string range $id 2 end]
7040 set known 0
7041 if {[string length $id] < 40} {
7042 set matches [longid $id]
7043 if {[llength $matches] > 0} {
7044 if {[llength $matches] > 1} return
7045 set known 1
7046 set id [lindex $matches 0]
7048 } else {
7049 set known [commitinview $id $curview]
7051 if {$known} {
7052 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7053 $ctext tag bind $lk <1> [list selbyid $id]
7054 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7055 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7056 } else {
7057 lappend pendinglinks($id) $lk
7058 interestedin $id {makelink %P}
7062 proc appendshortlink {id {pre {}} {post {}}} {
7063 global ctext linknum
7065 $ctext insert end $pre
7066 $ctext tag delete link$linknum
7067 $ctext insert end [string range $id 0 7] link$linknum
7068 $ctext insert end $post
7069 setlink $id link$linknum
7070 incr linknum
7073 proc makelink {id} {
7074 global pendinglinks
7076 if {![info exists pendinglinks($id)]} return
7077 foreach lk $pendinglinks($id) {
7078 setlink $id $lk
7080 unset pendinglinks($id)
7083 proc linkcursor {w inc} {
7084 global linkentercount curtextcursor
7086 if {[incr linkentercount $inc] > 0} {
7087 $w configure -cursor hand2
7088 } else {
7089 $w configure -cursor $curtextcursor
7090 if {$linkentercount < 0} {
7091 set linkentercount 0
7096 proc viewnextline {dir} {
7097 global canv linespc
7099 $canv delete hover
7100 set ymax [lindex [$canv cget -scrollregion] 3]
7101 set wnow [$canv yview]
7102 set wtop [expr {[lindex $wnow 0] * $ymax}]
7103 set newtop [expr {$wtop + $dir * $linespc}]
7104 if {$newtop < 0} {
7105 set newtop 0
7106 } elseif {$newtop > $ymax} {
7107 set newtop $ymax
7109 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7112 # add a list of tag or branch names at position pos
7113 # returns the number of names inserted
7114 proc appendrefs {pos ids var} {
7115 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7117 if {[catch {$ctext index $pos}]} {
7118 return 0
7120 $ctext conf -state normal
7121 $ctext delete $pos "$pos lineend"
7122 set tags {}
7123 foreach id $ids {
7124 foreach tag [set $var\($id\)] {
7125 lappend tags [list $tag $id]
7129 set sep {}
7130 set tags [lsort -index 0 -decreasing $tags]
7131 set nutags 0
7133 if {[llength $tags] > $maxrefs} {
7134 # If we are displaying heads, and there are too many,
7135 # see if there are some important heads to display.
7136 # Currently that are the current head and heads listed in $visiblerefs option
7137 set itags {}
7138 if {$var eq "idheads"} {
7139 set utags {}
7140 foreach ti $tags {
7141 set hname [lindex $ti 0]
7142 set id [lindex $ti 1]
7143 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7144 [llength $itags] < $maxrefs} {
7145 lappend itags $ti
7146 } else {
7147 lappend utags $ti
7150 set tags $utags
7152 if {$itags ne {}} {
7153 set str [mc "and many more"]
7154 set sep " "
7155 } else {
7156 set str [mc "many"]
7158 $ctext insert $pos "$str ([llength $tags])"
7159 set nutags [llength $tags]
7160 set tags $itags
7163 foreach ti $tags {
7164 set id [lindex $ti 1]
7165 set lk link$linknum
7166 incr linknum
7167 $ctext tag delete $lk
7168 $ctext insert $pos $sep
7169 $ctext insert $pos [lindex $ti 0] $lk
7170 setlink $id $lk
7171 set sep ", "
7173 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7174 $ctext conf -state disabled
7175 return [expr {[llength $tags] + $nutags}]
7178 # called when we have finished computing the nearby tags
7179 proc dispneartags {delay} {
7180 global selectedline currentid showneartags tagphase
7182 if {$selectedline eq {} || !$showneartags} return
7183 after cancel dispnexttag
7184 if {$delay} {
7185 after 200 dispnexttag
7186 set tagphase -1
7187 } else {
7188 after idle dispnexttag
7189 set tagphase 0
7193 proc dispnexttag {} {
7194 global selectedline currentid showneartags tagphase ctext
7196 if {$selectedline eq {} || !$showneartags} return
7197 switch -- $tagphase {
7199 set dtags [desctags $currentid]
7200 if {$dtags ne {}} {
7201 appendrefs precedes $dtags idtags
7205 set atags [anctags $currentid]
7206 if {$atags ne {}} {
7207 appendrefs follows $atags idtags
7211 set dheads [descheads $currentid]
7212 if {$dheads ne {}} {
7213 if {[appendrefs branch $dheads idheads] > 1
7214 && [$ctext get "branch -3c"] eq "h"} {
7215 # turn "Branch" into "Branches"
7216 $ctext conf -state normal
7217 $ctext insert "branch -2c" "es"
7218 $ctext conf -state disabled
7223 if {[incr tagphase] <= 2} {
7224 after idle dispnexttag
7228 proc make_secsel {id} {
7229 global linehtag linentag linedtag canv canv2 canv3
7231 if {![info exists linehtag($id)]} return
7232 $canv delete secsel
7233 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7234 -tags secsel -fill [$canv cget -selectbackground]]
7235 $canv lower $t
7236 $canv2 delete secsel
7237 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7238 -tags secsel -fill [$canv2 cget -selectbackground]]
7239 $canv2 lower $t
7240 $canv3 delete secsel
7241 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7242 -tags secsel -fill [$canv3 cget -selectbackground]]
7243 $canv3 lower $t
7246 proc make_idmark {id} {
7247 global linehtag canv fgcolor
7249 if {![info exists linehtag($id)]} return
7250 $canv delete markid
7251 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7252 -tags markid -outline $fgcolor]
7253 $canv raise $t
7256 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7257 global canv ctext commitinfo selectedline
7258 global canvy0 linespc parents children curview
7259 global currentid sha1entry
7260 global commentend idtags linknum
7261 global mergemax numcommits pending_select
7262 global cmitmode showneartags allcommits
7263 global targetrow targetid lastscrollrows
7264 global autoselect autosellen jump_to_here
7265 global vinlinediff
7267 unset -nocomplain pending_select
7268 $canv delete hover
7269 normalline
7270 unsel_reflist
7271 stopfinding
7272 if {$l < 0 || $l >= $numcommits} return
7273 set id [commitonrow $l]
7274 set targetid $id
7275 set targetrow $l
7276 set selectedline $l
7277 set currentid $id
7278 if {$lastscrollrows < $numcommits} {
7279 setcanvscroll
7282 if {$cmitmode ne "patch" && $switch_to_patch} {
7283 set cmitmode "patch"
7286 set y [expr {$canvy0 + $l * $linespc}]
7287 set ymax [lindex [$canv cget -scrollregion] 3]
7288 set ytop [expr {$y - $linespc - 1}]
7289 set ybot [expr {$y + $linespc + 1}]
7290 set wnow [$canv yview]
7291 set wtop [expr {[lindex $wnow 0] * $ymax}]
7292 set wbot [expr {[lindex $wnow 1] * $ymax}]
7293 set wh [expr {$wbot - $wtop}]
7294 set newtop $wtop
7295 if {$ytop < $wtop} {
7296 if {$ybot < $wtop} {
7297 set newtop [expr {$y - $wh / 2.0}]
7298 } else {
7299 set newtop $ytop
7300 if {$newtop > $wtop - $linespc} {
7301 set newtop [expr {$wtop - $linespc}]
7304 } elseif {$ybot > $wbot} {
7305 if {$ytop > $wbot} {
7306 set newtop [expr {$y - $wh / 2.0}]
7307 } else {
7308 set newtop [expr {$ybot - $wh}]
7309 if {$newtop < $wtop + $linespc} {
7310 set newtop [expr {$wtop + $linespc}]
7314 if {$newtop != $wtop} {
7315 if {$newtop < 0} {
7316 set newtop 0
7318 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7319 drawvisible
7322 make_secsel $id
7324 if {$isnew} {
7325 addtohistory [list selbyid $id 0] savecmitpos
7328 $sha1entry delete 0 end
7329 $sha1entry insert 0 $id
7330 if {$autoselect} {
7331 $sha1entry selection range 0 $autosellen
7333 rhighlight_sel $id
7335 $ctext conf -state normal
7336 clear_ctext
7337 set linknum 0
7338 if {![info exists commitinfo($id)]} {
7339 getcommit $id
7341 set info $commitinfo($id)
7342 set date [formatdate [lindex $info 2]]
7343 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7344 set date [formatdate [lindex $info 4]]
7345 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7346 if {[info exists idtags($id)]} {
7347 $ctext insert end [mc "Tags:"]
7348 foreach tag $idtags($id) {
7349 $ctext insert end " $tag"
7351 $ctext insert end "\n"
7354 set headers {}
7355 set olds $parents($curview,$id)
7356 if {[llength $olds] > 1} {
7357 set np 0
7358 foreach p $olds {
7359 if {$np >= $mergemax} {
7360 set tag mmax
7361 } else {
7362 set tag m$np
7364 $ctext insert end "[mc "Parent"]: " $tag
7365 appendwithlinks [commit_descriptor $p] {}
7366 incr np
7368 } else {
7369 foreach p $olds {
7370 append headers "[mc "Parent"]: [commit_descriptor $p]"
7374 foreach c $children($curview,$id) {
7375 append headers "[mc "Child"]: [commit_descriptor $c]"
7378 # make anything that looks like a SHA1 ID be a clickable link
7379 appendwithlinks $headers {}
7380 if {$showneartags} {
7381 if {![info exists allcommits]} {
7382 getallcommits
7384 $ctext insert end "[mc "Branch"]: "
7385 $ctext mark set branch "end -1c"
7386 $ctext mark gravity branch left
7387 $ctext insert end "\n[mc "Follows"]: "
7388 $ctext mark set follows "end -1c"
7389 $ctext mark gravity follows left
7390 $ctext insert end "\n[mc "Precedes"]: "
7391 $ctext mark set precedes "end -1c"
7392 $ctext mark gravity precedes left
7393 $ctext insert end "\n"
7394 dispneartags 1
7396 $ctext insert end "\n"
7397 set comment [lindex $info 5]
7398 if {[string first "\r" $comment] >= 0} {
7399 set comment [string map {"\r" "\n "} $comment]
7401 appendwithlinks $comment {comment}
7403 $ctext tag remove found 1.0 end
7404 $ctext conf -state disabled
7405 set commentend [$ctext index "end - 1c"]
7407 set jump_to_here $desired_loc
7408 init_flist [mc "Comments"]
7409 if {$cmitmode eq "tree"} {
7410 gettree $id
7411 } elseif {$vinlinediff($curview) == 1} {
7412 showinlinediff $id
7413 } elseif {[llength $olds] <= 1} {
7414 startdiff $id
7415 } else {
7416 mergediff $id
7420 proc selfirstline {} {
7421 unmarkmatches
7422 selectline 0 1
7425 proc sellastline {} {
7426 global numcommits
7427 unmarkmatches
7428 set l [expr {$numcommits - 1}]
7429 selectline $l 1
7432 proc selnextline {dir} {
7433 global selectedline
7434 focus .
7435 if {$selectedline eq {}} return
7436 set l [expr {$selectedline + $dir}]
7437 unmarkmatches
7438 selectline $l 1
7441 proc selnextpage {dir} {
7442 global canv linespc selectedline numcommits
7444 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7445 if {$lpp < 1} {
7446 set lpp 1
7448 allcanvs yview scroll [expr {$dir * $lpp}] units
7449 drawvisible
7450 if {$selectedline eq {}} return
7451 set l [expr {$selectedline + $dir * $lpp}]
7452 if {$l < 0} {
7453 set l 0
7454 } elseif {$l >= $numcommits} {
7455 set l [expr $numcommits - 1]
7457 unmarkmatches
7458 selectline $l 1
7461 proc unselectline {} {
7462 global selectedline currentid
7464 set selectedline {}
7465 unset -nocomplain currentid
7466 allcanvs delete secsel
7467 rhighlight_none
7470 proc reselectline {} {
7471 global selectedline
7473 if {$selectedline ne {}} {
7474 selectline $selectedline 0
7478 proc addtohistory {cmd {saveproc {}}} {
7479 global history historyindex curview
7481 unset_posvars
7482 save_position
7483 set elt [list $curview $cmd $saveproc {}]
7484 if {$historyindex > 0
7485 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7486 return
7489 if {$historyindex < [llength $history]} {
7490 set history [lreplace $history $historyindex end $elt]
7491 } else {
7492 lappend history $elt
7494 incr historyindex
7495 if {$historyindex > 1} {
7496 .tf.bar.leftbut conf -state normal
7497 } else {
7498 .tf.bar.leftbut conf -state disabled
7500 .tf.bar.rightbut conf -state disabled
7503 # save the scrolling position of the diff display pane
7504 proc save_position {} {
7505 global historyindex history
7507 if {$historyindex < 1} return
7508 set hi [expr {$historyindex - 1}]
7509 set fn [lindex $history $hi 2]
7510 if {$fn ne {}} {
7511 lset history $hi 3 [eval $fn]
7515 proc unset_posvars {} {
7516 global last_posvars
7518 if {[info exists last_posvars]} {
7519 foreach {var val} $last_posvars {
7520 global $var
7521 unset -nocomplain $var
7523 unset last_posvars
7527 proc godo {elt} {
7528 global curview last_posvars
7530 set view [lindex $elt 0]
7531 set cmd [lindex $elt 1]
7532 set pv [lindex $elt 3]
7533 if {$curview != $view} {
7534 showview $view
7536 unset_posvars
7537 foreach {var val} $pv {
7538 global $var
7539 set $var $val
7541 set last_posvars $pv
7542 eval $cmd
7545 proc goback {} {
7546 global history historyindex
7547 focus .
7549 if {$historyindex > 1} {
7550 save_position
7551 incr historyindex -1
7552 godo [lindex $history [expr {$historyindex - 1}]]
7553 .tf.bar.rightbut conf -state normal
7555 if {$historyindex <= 1} {
7556 .tf.bar.leftbut conf -state disabled
7560 proc goforw {} {
7561 global history historyindex
7562 focus .
7564 if {$historyindex < [llength $history]} {
7565 save_position
7566 set cmd [lindex $history $historyindex]
7567 incr historyindex
7568 godo $cmd
7569 .tf.bar.leftbut conf -state normal
7571 if {$historyindex >= [llength $history]} {
7572 .tf.bar.rightbut conf -state disabled
7576 proc go_to_parent {i} {
7577 global parents curview targetid
7578 set ps $parents($curview,$targetid)
7579 if {[llength $ps] >= $i} {
7580 selbyid [lindex $ps [expr $i - 1]]
7584 proc gettree {id} {
7585 global treefilelist treeidlist diffids diffmergeid treepending
7586 global nullid nullid2
7588 set diffids $id
7589 unset -nocomplain diffmergeid
7590 if {![info exists treefilelist($id)]} {
7591 if {![info exists treepending]} {
7592 if {$id eq $nullid} {
7593 set cmd [list | git ls-files]
7594 } elseif {$id eq $nullid2} {
7595 set cmd [list | git ls-files --stage -t]
7596 } else {
7597 set cmd [list | git ls-tree -r $id]
7599 if {[catch {set gtf [open $cmd r]}]} {
7600 return
7602 set treepending $id
7603 set treefilelist($id) {}
7604 set treeidlist($id) {}
7605 fconfigure $gtf -blocking 0 -encoding binary
7606 filerun $gtf [list gettreeline $gtf $id]
7608 } else {
7609 setfilelist $id
7613 proc gettreeline {gtf id} {
7614 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7616 set nl 0
7617 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7618 if {$diffids eq $nullid} {
7619 set fname $line
7620 } else {
7621 set i [string first "\t" $line]
7622 if {$i < 0} continue
7623 set fname [string range $line [expr {$i+1}] end]
7624 set line [string range $line 0 [expr {$i-1}]]
7625 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7626 set sha1 [lindex $line 2]
7627 lappend treeidlist($id) $sha1
7629 if {[string index $fname 0] eq "\""} {
7630 set fname [lindex $fname 0]
7632 set fname [encoding convertfrom $fname]
7633 lappend treefilelist($id) $fname
7635 if {![eof $gtf]} {
7636 return [expr {$nl >= 1000? 2: 1}]
7638 close $gtf
7639 unset treepending
7640 if {$cmitmode ne "tree"} {
7641 if {![info exists diffmergeid]} {
7642 gettreediffs $diffids
7644 } elseif {$id ne $diffids} {
7645 gettree $diffids
7646 } else {
7647 setfilelist $id
7649 return 0
7652 proc showfile {f} {
7653 global treefilelist treeidlist diffids nullid nullid2
7654 global ctext_file_names ctext_file_lines
7655 global ctext commentend
7657 set i [lsearch -exact $treefilelist($diffids) $f]
7658 if {$i < 0} {
7659 puts "oops, $f not in list for id $diffids"
7660 return
7662 if {$diffids eq $nullid} {
7663 if {[catch {set bf [open $f r]} err]} {
7664 puts "oops, can't read $f: $err"
7665 return
7667 } else {
7668 set blob [lindex $treeidlist($diffids) $i]
7669 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7670 puts "oops, error reading blob $blob: $err"
7671 return
7674 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7675 filerun $bf [list getblobline $bf $diffids]
7676 $ctext config -state normal
7677 clear_ctext $commentend
7678 lappend ctext_file_names $f
7679 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7680 $ctext insert end "\n"
7681 $ctext insert end "$f\n" filesep
7682 $ctext config -state disabled
7683 $ctext yview $commentend
7684 settabs 0
7687 proc getblobline {bf id} {
7688 global diffids cmitmode ctext
7690 if {$id ne $diffids || $cmitmode ne "tree"} {
7691 catch {close $bf}
7692 return 0
7694 $ctext config -state normal
7695 set nl 0
7696 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7697 $ctext insert end "$line\n"
7699 if {[eof $bf]} {
7700 global jump_to_here ctext_file_names commentend
7702 # delete last newline
7703 $ctext delete "end - 2c" "end - 1c"
7704 close $bf
7705 if {$jump_to_here ne {} &&
7706 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7707 set lnum [expr {[lindex $jump_to_here 1] +
7708 [lindex [split $commentend .] 0]}]
7709 mark_ctext_line $lnum
7711 $ctext config -state disabled
7712 return 0
7714 $ctext config -state disabled
7715 return [expr {$nl >= 1000? 2: 1}]
7718 proc mark_ctext_line {lnum} {
7719 global ctext markbgcolor
7721 $ctext tag delete omark
7722 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7723 $ctext tag conf omark -background $markbgcolor
7724 $ctext see $lnum.0
7727 proc mergediff {id} {
7728 global diffmergeid
7729 global diffids treediffs
7730 global parents curview
7732 set diffmergeid $id
7733 set diffids $id
7734 set treediffs($id) {}
7735 set np [llength $parents($curview,$id)]
7736 settabs $np
7737 getblobdiffs $id
7740 proc startdiff {ids} {
7741 global treediffs diffids treepending diffmergeid nullid nullid2
7743 settabs 1
7744 set diffids $ids
7745 unset -nocomplain diffmergeid
7746 if {![info exists treediffs($ids)] ||
7747 [lsearch -exact $ids $nullid] >= 0 ||
7748 [lsearch -exact $ids $nullid2] >= 0} {
7749 if {![info exists treepending]} {
7750 gettreediffs $ids
7752 } else {
7753 addtocflist $ids
7757 proc showinlinediff {ids} {
7758 global commitinfo commitdata ctext
7759 global treediffs
7761 set info $commitinfo($ids)
7762 set diff [lindex $info 7]
7763 set difflines [split $diff "\n"]
7765 initblobdiffvars
7766 set treediff {}
7768 set inhdr 0
7769 foreach line $difflines {
7770 if {![string compare -length 5 "diff " $line]} {
7771 set inhdr 1
7772 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7773 # offset also accounts for the b/ prefix
7774 lappend treediff [string range $line 6 end]
7775 set inhdr 0
7779 set treediffs($ids) $treediff
7780 add_flist $treediff
7782 $ctext conf -state normal
7783 foreach line $difflines {
7784 parseblobdiffline $ids $line
7786 maybe_scroll_ctext 1
7787 $ctext conf -state disabled
7790 # If the filename (name) is under any of the passed filter paths
7791 # then return true to include the file in the listing.
7792 proc path_filter {filter name} {
7793 set worktree [gitworktree]
7794 foreach p $filter {
7795 set fq_p [file normalize $p]
7796 set fq_n [file normalize [file join $worktree $name]]
7797 if {[string match [file normalize $fq_p]* $fq_n]} {
7798 return 1
7801 return 0
7804 proc addtocflist {ids} {
7805 global treediffs
7807 add_flist $treediffs($ids)
7808 getblobdiffs $ids
7811 proc diffcmd {ids flags} {
7812 global log_showroot nullid nullid2 git_version
7814 set i [lsearch -exact $ids $nullid]
7815 set j [lsearch -exact $ids $nullid2]
7816 if {$i >= 0} {
7817 if {[llength $ids] > 1 && $j < 0} {
7818 # comparing working directory with some specific revision
7819 set cmd [concat | git diff-index $flags]
7820 if {$i == 0} {
7821 lappend cmd -R [lindex $ids 1]
7822 } else {
7823 lappend cmd [lindex $ids 0]
7825 } else {
7826 # comparing working directory with index
7827 set cmd [concat | git diff-files $flags]
7828 if {$j == 1} {
7829 lappend cmd -R
7832 } elseif {$j >= 0} {
7833 if {[package vcompare $git_version "1.7.2"] >= 0} {
7834 set flags "$flags --ignore-submodules=dirty"
7836 set cmd [concat | git diff-index --cached $flags]
7837 if {[llength $ids] > 1} {
7838 # comparing index with specific revision
7839 if {$j == 0} {
7840 lappend cmd -R [lindex $ids 1]
7841 } else {
7842 lappend cmd [lindex $ids 0]
7844 } else {
7845 # comparing index with HEAD
7846 lappend cmd HEAD
7848 } else {
7849 if {$log_showroot} {
7850 lappend flags --root
7852 set cmd [concat | git diff-tree -r $flags $ids]
7854 return $cmd
7857 proc gettreediffs {ids} {
7858 global treediff treepending limitdiffs vfilelimit curview
7860 set cmd [diffcmd $ids {--no-commit-id}]
7861 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7862 set cmd [concat $cmd -- $vfilelimit($curview)]
7864 if {[catch {set gdtf [open $cmd r]}]} return
7866 set treepending $ids
7867 set treediff {}
7868 fconfigure $gdtf -blocking 0 -encoding binary
7869 filerun $gdtf [list gettreediffline $gdtf $ids]
7872 proc gettreediffline {gdtf ids} {
7873 global treediff treediffs treepending diffids diffmergeid
7874 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7876 set nr 0
7877 set sublist {}
7878 set max 1000
7879 if {$perfile_attrs} {
7880 # cache_gitattr is slow, and even slower on win32 where we
7881 # have to invoke it for only about 30 paths at a time
7882 set max 500
7883 if {[tk windowingsystem] == "win32"} {
7884 set max 120
7887 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7888 set i [string first "\t" $line]
7889 if {$i >= 0} {
7890 set file [string range $line [expr {$i+1}] end]
7891 if {[string index $file 0] eq "\""} {
7892 set file [lindex $file 0]
7894 set file [encoding convertfrom $file]
7895 if {$file ne [lindex $treediff end]} {
7896 lappend treediff $file
7897 lappend sublist $file
7901 if {$perfile_attrs} {
7902 cache_gitattr encoding $sublist
7904 if {![eof $gdtf]} {
7905 return [expr {$nr >= $max? 2: 1}]
7907 close $gdtf
7908 set treediffs($ids) $treediff
7909 unset treepending
7910 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7911 gettree $diffids
7912 } elseif {$ids != $diffids} {
7913 if {![info exists diffmergeid]} {
7914 gettreediffs $diffids
7916 } else {
7917 addtocflist $ids
7919 return 0
7922 # empty string or positive integer
7923 proc diffcontextvalidate {v} {
7924 return [regexp {^(|[1-9][0-9]*)$} $v]
7927 proc diffcontextchange {n1 n2 op} {
7928 global diffcontextstring diffcontext
7930 if {[string is integer -strict $diffcontextstring]} {
7931 if {$diffcontextstring >= 0} {
7932 set diffcontext $diffcontextstring
7933 reselectline
7938 proc changeignorespace {} {
7939 reselectline
7942 proc changeworddiff {name ix op} {
7943 reselectline
7946 proc initblobdiffvars {} {
7947 global diffencoding targetline diffnparents
7948 global diffinhdr currdiffsubmod diffseehere
7949 set targetline {}
7950 set diffnparents 0
7951 set diffinhdr 0
7952 set diffencoding [get_path_encoding {}]
7953 set currdiffsubmod ""
7954 set diffseehere -1
7957 proc getblobdiffs {ids} {
7958 global blobdifffd diffids env
7959 global treediffs
7960 global diffcontext
7961 global ignorespace
7962 global worddiff
7963 global limitdiffs vfilelimit curview
7964 global git_version
7966 set textconv {}
7967 if {[package vcompare $git_version "1.6.1"] >= 0} {
7968 set textconv "--textconv"
7970 set submodule {}
7971 if {[package vcompare $git_version "1.6.6"] >= 0} {
7972 set submodule "--submodule"
7974 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7975 if {$ignorespace} {
7976 append cmd " -w"
7978 if {$worddiff ne [mc "Line diff"]} {
7979 append cmd " --word-diff=porcelain"
7981 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7982 set cmd [concat $cmd -- $vfilelimit($curview)]
7984 if {[catch {set bdf [open $cmd r]} err]} {
7985 error_popup [mc "Error getting diffs: %s" $err]
7986 return
7988 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7989 set blobdifffd($ids) $bdf
7990 initblobdiffvars
7991 filerun $bdf [list getblobdiffline $bdf $diffids]
7994 proc savecmitpos {} {
7995 global ctext cmitmode
7997 if {$cmitmode eq "tree"} {
7998 return {}
8000 return [list target_scrollpos [$ctext index @0,0]]
8003 proc savectextpos {} {
8004 global ctext
8006 return [list target_scrollpos [$ctext index @0,0]]
8009 proc maybe_scroll_ctext {ateof} {
8010 global ctext target_scrollpos
8012 if {![info exists target_scrollpos]} return
8013 if {!$ateof} {
8014 set nlines [expr {[winfo height $ctext]
8015 / [font metrics textfont -linespace]}]
8016 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
8018 $ctext yview $target_scrollpos
8019 unset target_scrollpos
8022 proc setinlist {var i val} {
8023 global $var
8025 while {[llength [set $var]] < $i} {
8026 lappend $var {}
8028 if {[llength [set $var]] == $i} {
8029 lappend $var $val
8030 } else {
8031 lset $var $i $val
8035 proc makediffhdr {fname ids} {
8036 global ctext curdiffstart treediffs diffencoding
8037 global ctext_file_names jump_to_here targetline diffline
8039 set fname [encoding convertfrom $fname]
8040 set diffencoding [get_path_encoding $fname]
8041 set i [lsearch -exact $treediffs($ids) $fname]
8042 if {$i >= 0} {
8043 setinlist difffilestart $i $curdiffstart
8045 lset ctext_file_names end $fname
8046 set l [expr {(78 - [string length $fname]) / 2}]
8047 set pad [string range "----------------------------------------" 1 $l]
8048 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8049 set targetline {}
8050 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8051 set targetline [lindex $jump_to_here 1]
8053 set diffline 0
8056 proc blobdiffmaybeseehere {ateof} {
8057 global diffseehere
8058 if {$diffseehere >= 0} {
8059 mark_ctext_line [lindex [split $diffseehere .] 0]
8061 maybe_scroll_ctext $ateof
8064 proc getblobdiffline {bdf ids} {
8065 global diffids blobdifffd
8066 global ctext
8068 set nr 0
8069 $ctext conf -state normal
8070 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8071 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8072 catch {close $bdf}
8073 return 0
8075 parseblobdiffline $ids $line
8077 $ctext conf -state disabled
8078 blobdiffmaybeseehere [eof $bdf]
8079 if {[eof $bdf]} {
8080 catch {close $bdf}
8081 return 0
8083 return [expr {$nr >= 1000? 2: 1}]
8086 proc parseblobdiffline {ids line} {
8087 global ctext curdiffstart
8088 global diffnexthead diffnextnote difffilestart
8089 global ctext_file_names ctext_file_lines
8090 global diffinhdr treediffs mergemax diffnparents
8091 global diffencoding jump_to_here targetline diffline currdiffsubmod
8092 global worddiff diffseehere
8094 if {![string compare -length 5 "diff " $line]} {
8095 if {![regexp {^diff (--cc|--git) } $line m type]} {
8096 set line [encoding convertfrom $line]
8097 $ctext insert end "$line\n" hunksep
8098 continue
8100 # start of a new file
8101 set diffinhdr 1
8102 $ctext insert end "\n"
8103 set curdiffstart [$ctext index "end - 1c"]
8104 lappend ctext_file_names ""
8105 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8106 $ctext insert end "\n" filesep
8108 if {$type eq "--cc"} {
8109 # start of a new file in a merge diff
8110 set fname [string range $line 10 end]
8111 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8112 lappend treediffs($ids) $fname
8113 add_flist [list $fname]
8116 } else {
8117 set line [string range $line 11 end]
8118 # If the name hasn't changed the length will be odd,
8119 # the middle char will be a space, and the two bits either
8120 # side will be a/name and b/name, or "a/name" and "b/name".
8121 # If the name has changed we'll get "rename from" and
8122 # "rename to" or "copy from" and "copy to" lines following
8123 # this, and we'll use them to get the filenames.
8124 # This complexity is necessary because spaces in the
8125 # filename(s) don't get escaped.
8126 set l [string length $line]
8127 set i [expr {$l / 2}]
8128 if {!(($l & 1) && [string index $line $i] eq " " &&
8129 [string range $line 2 [expr {$i - 1}]] eq \
8130 [string range $line [expr {$i + 3}] end])} {
8131 return
8133 # unescape if quoted and chop off the a/ from the front
8134 if {[string index $line 0] eq "\""} {
8135 set fname [string range [lindex $line 0] 2 end]
8136 } else {
8137 set fname [string range $line 2 [expr {$i - 1}]]
8140 makediffhdr $fname $ids
8142 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8143 set fname [encoding convertfrom [string range $line 16 end]]
8144 $ctext insert end "\n"
8145 set curdiffstart [$ctext index "end - 1c"]
8146 lappend ctext_file_names $fname
8147 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8148 $ctext insert end "$line\n" filesep
8149 set i [lsearch -exact $treediffs($ids) $fname]
8150 if {$i >= 0} {
8151 setinlist difffilestart $i $curdiffstart
8154 } elseif {![string compare -length 2 "@@" $line]} {
8155 regexp {^@@+} $line ats
8156 set line [encoding convertfrom $diffencoding $line]
8157 $ctext insert end "$line\n" hunksep
8158 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8159 set diffline $nl
8161 set diffnparents [expr {[string length $ats] - 1}]
8162 set diffinhdr 0
8164 } elseif {![string compare -length 10 "Submodule " $line]} {
8165 # start of a new submodule
8166 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8167 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8168 } else {
8169 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8171 if {$currdiffsubmod != $fname} {
8172 $ctext insert end "\n"; # Add newline after commit message
8174 set curdiffstart [$ctext index "end - 1c"]
8175 lappend ctext_file_names ""
8176 if {$currdiffsubmod != $fname} {
8177 lappend ctext_file_lines $fname
8178 makediffhdr $fname $ids
8179 set currdiffsubmod $fname
8180 $ctext insert end "\n$line\n" filesep
8181 } else {
8182 $ctext insert end "$line\n" filesep
8184 } elseif {![string compare -length 3 " >" $line]} {
8185 set $currdiffsubmod ""
8186 set line [encoding convertfrom $diffencoding $line]
8187 $ctext insert end "$line\n" dresult
8188 } elseif {![string compare -length 3 " <" $line]} {
8189 set $currdiffsubmod ""
8190 set line [encoding convertfrom $diffencoding $line]
8191 $ctext insert end "$line\n" d0
8192 } elseif {$diffinhdr} {
8193 if {![string compare -length 12 "rename from " $line]} {
8194 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8195 if {[string index $fname 0] eq "\""} {
8196 set fname [lindex $fname 0]
8198 set fname [encoding convertfrom $fname]
8199 set i [lsearch -exact $treediffs($ids) $fname]
8200 if {$i >= 0} {
8201 setinlist difffilestart $i $curdiffstart
8203 } elseif {![string compare -length 10 $line "rename to "] ||
8204 ![string compare -length 8 $line "copy to "]} {
8205 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8206 if {[string index $fname 0] eq "\""} {
8207 set fname [lindex $fname 0]
8209 makediffhdr $fname $ids
8210 } elseif {[string compare -length 3 $line "---"] == 0} {
8211 # do nothing
8212 return
8213 } elseif {[string compare -length 3 $line "+++"] == 0} {
8214 set diffinhdr 0
8215 return
8217 $ctext insert end "$line\n" filesep
8219 } else {
8220 set line [string map {\x1A ^Z} \
8221 [encoding convertfrom $diffencoding $line]]
8222 # parse the prefix - one ' ', '-' or '+' for each parent
8223 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8224 set tag [expr {$diffnparents > 1? "m": "d"}]
8225 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8226 set words_pre_markup ""
8227 set words_post_markup ""
8228 if {[string trim $prefix " -+"] eq {}} {
8229 # prefix only has " ", "-" and "+" in it: normal diff line
8230 set num [string first "-" $prefix]
8231 if {$dowords} {
8232 set line [string range $line 1 end]
8234 if {$num >= 0} {
8235 # removed line, first parent with line is $num
8236 if {$num >= $mergemax} {
8237 set num "max"
8239 if {$dowords && $worddiff eq [mc "Markup words"]} {
8240 $ctext insert end "\[-$line-\]" $tag$num
8241 } else {
8242 $ctext insert end "$line" $tag$num
8244 if {!$dowords} {
8245 $ctext insert end "\n" $tag$num
8247 } else {
8248 set tags {}
8249 if {[string first "+" $prefix] >= 0} {
8250 # added line
8251 lappend tags ${tag}result
8252 if {$diffnparents > 1} {
8253 set num [string first " " $prefix]
8254 if {$num >= 0} {
8255 if {$num >= $mergemax} {
8256 set num "max"
8258 lappend tags m$num
8261 set words_pre_markup "{+"
8262 set words_post_markup "+}"
8264 if {$targetline ne {}} {
8265 if {$diffline == $targetline} {
8266 set diffseehere [$ctext index "end - 1 chars"]
8267 set targetline {}
8268 } else {
8269 incr diffline
8272 if {$dowords && $worddiff eq [mc "Markup words"]} {
8273 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8274 } else {
8275 $ctext insert end "$line" $tags
8277 if {!$dowords} {
8278 $ctext insert end "\n" $tags
8281 } elseif {$dowords && $prefix eq "~"} {
8282 $ctext insert end "\n" {}
8283 } else {
8284 # "\ No newline at end of file",
8285 # or something else we don't recognize
8286 $ctext insert end "$line\n" hunksep
8291 proc changediffdisp {} {
8292 global ctext diffelide
8294 $ctext tag conf d0 -elide [lindex $diffelide 0]
8295 $ctext tag conf dresult -elide [lindex $diffelide 1]
8298 proc highlightfile {cline} {
8299 global cflist cflist_top
8301 if {![info exists cflist_top]} return
8303 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8304 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8305 $cflist see $cline.0
8306 set cflist_top $cline
8309 proc highlightfile_for_scrollpos {topidx} {
8310 global cmitmode difffilestart
8312 if {$cmitmode eq "tree"} return
8313 if {![info exists difffilestart]} return
8315 set top [lindex [split $topidx .] 0]
8316 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8317 highlightfile 0
8318 } else {
8319 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8323 proc prevfile {} {
8324 global difffilestart ctext cmitmode
8326 if {$cmitmode eq "tree"} return
8327 set prev 0.0
8328 set here [$ctext index @0,0]
8329 foreach loc $difffilestart {
8330 if {[$ctext compare $loc >= $here]} {
8331 $ctext yview $prev
8332 return
8334 set prev $loc
8336 $ctext yview $prev
8339 proc nextfile {} {
8340 global difffilestart ctext cmitmode
8342 if {$cmitmode eq "tree"} return
8343 set here [$ctext index @0,0]
8344 foreach loc $difffilestart {
8345 if {[$ctext compare $loc > $here]} {
8346 $ctext yview $loc
8347 return
8352 proc clear_ctext {{first 1.0}} {
8353 global ctext smarktop smarkbot
8354 global ctext_file_names ctext_file_lines
8355 global pendinglinks
8357 set l [lindex [split $first .] 0]
8358 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8359 set smarktop $l
8361 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8362 set smarkbot $l
8364 $ctext delete $first end
8365 if {$first eq "1.0"} {
8366 unset -nocomplain pendinglinks
8368 set ctext_file_names {}
8369 set ctext_file_lines {}
8372 proc settabs {{firstab {}}} {
8373 global firsttabstop tabstop ctext have_tk85
8375 if {$firstab ne {} && $have_tk85} {
8376 set firsttabstop $firstab
8378 set w [font measure textfont "0"]
8379 if {$firsttabstop != 0} {
8380 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8381 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8382 } elseif {$have_tk85 || $tabstop != 8} {
8383 $ctext conf -tabs [expr {$tabstop * $w}]
8384 } else {
8385 $ctext conf -tabs {}
8389 proc incrsearch {name ix op} {
8390 global ctext searchstring searchdirn
8392 if {[catch {$ctext index anchor}]} {
8393 # no anchor set, use start of selection, or of visible area
8394 set sel [$ctext tag ranges sel]
8395 if {$sel ne {}} {
8396 $ctext mark set anchor [lindex $sel 0]
8397 } elseif {$searchdirn eq "-forwards"} {
8398 $ctext mark set anchor @0,0
8399 } else {
8400 $ctext mark set anchor @0,[winfo height $ctext]
8403 if {$searchstring ne {}} {
8404 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8405 if {$here ne {}} {
8406 $ctext see $here
8407 set mend "$here + $mlen c"
8408 $ctext tag remove sel 1.0 end
8409 $ctext tag add sel $here $mend
8410 suppress_highlighting_file_for_current_scrollpos
8411 highlightfile_for_scrollpos $here
8414 rehighlight_search_results
8417 proc dosearch {} {
8418 global sstring ctext searchstring searchdirn
8420 focus $sstring
8421 $sstring icursor end
8422 set searchdirn -forwards
8423 if {$searchstring ne {}} {
8424 set sel [$ctext tag ranges sel]
8425 if {$sel ne {}} {
8426 set start "[lindex $sel 0] + 1c"
8427 } elseif {[catch {set start [$ctext index anchor]}]} {
8428 set start "@0,0"
8430 set match [$ctext search -count mlen -- $searchstring $start]
8431 $ctext tag remove sel 1.0 end
8432 if {$match eq {}} {
8433 bell
8434 return
8436 $ctext see $match
8437 suppress_highlighting_file_for_current_scrollpos
8438 highlightfile_for_scrollpos $match
8439 set mend "$match + $mlen c"
8440 $ctext tag add sel $match $mend
8441 $ctext mark unset anchor
8442 rehighlight_search_results
8446 proc dosearchback {} {
8447 global sstring ctext searchstring searchdirn
8449 focus $sstring
8450 $sstring icursor end
8451 set searchdirn -backwards
8452 if {$searchstring ne {}} {
8453 set sel [$ctext tag ranges sel]
8454 if {$sel ne {}} {
8455 set start [lindex $sel 0]
8456 } elseif {[catch {set start [$ctext index anchor]}]} {
8457 set start @0,[winfo height $ctext]
8459 set match [$ctext search -backwards -count ml -- $searchstring $start]
8460 $ctext tag remove sel 1.0 end
8461 if {$match eq {}} {
8462 bell
8463 return
8465 $ctext see $match
8466 suppress_highlighting_file_for_current_scrollpos
8467 highlightfile_for_scrollpos $match
8468 set mend "$match + $ml c"
8469 $ctext tag add sel $match $mend
8470 $ctext mark unset anchor
8471 rehighlight_search_results
8475 proc rehighlight_search_results {} {
8476 global ctext searchstring
8478 $ctext tag remove found 1.0 end
8479 $ctext tag remove currentsearchhit 1.0 end
8481 if {$searchstring ne {}} {
8482 searchmarkvisible 1
8486 proc searchmark {first last} {
8487 global ctext searchstring
8489 set sel [$ctext tag ranges sel]
8491 set mend $first.0
8492 while {1} {
8493 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8494 if {$match eq {}} break
8495 set mend "$match + $mlen c"
8496 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8497 $ctext tag add currentsearchhit $match $mend
8498 } else {
8499 $ctext tag add found $match $mend
8504 proc searchmarkvisible {doall} {
8505 global ctext smarktop smarkbot
8507 set topline [lindex [split [$ctext index @0,0] .] 0]
8508 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8509 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8510 # no overlap with previous
8511 searchmark $topline $botline
8512 set smarktop $topline
8513 set smarkbot $botline
8514 } else {
8515 if {$topline < $smarktop} {
8516 searchmark $topline [expr {$smarktop-1}]
8517 set smarktop $topline
8519 if {$botline > $smarkbot} {
8520 searchmark [expr {$smarkbot+1}] $botline
8521 set smarkbot $botline
8526 proc suppress_highlighting_file_for_current_scrollpos {} {
8527 global ctext suppress_highlighting_file_for_this_scrollpos
8529 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8532 proc scrolltext {f0 f1} {
8533 global searchstring cmitmode ctext
8534 global suppress_highlighting_file_for_this_scrollpos
8536 set topidx [$ctext index @0,0]
8537 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8538 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8539 highlightfile_for_scrollpos $topidx
8542 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8544 .bleft.bottom.sb set $f0 $f1
8545 if {$searchstring ne {}} {
8546 searchmarkvisible 0
8550 proc setcoords {} {
8551 global linespc charspc canvx0 canvy0
8552 global xspc1 xspc2 lthickness
8554 set linespc [font metrics mainfont -linespace]
8555 set charspc [font measure mainfont "m"]
8556 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8557 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8558 set lthickness [expr {int($linespc / 9) + 1}]
8559 set xspc1(0) $linespc
8560 set xspc2 $linespc
8563 proc redisplay {} {
8564 global canv
8565 global selectedline
8567 set ymax [lindex [$canv cget -scrollregion] 3]
8568 if {$ymax eq {} || $ymax == 0} return
8569 set span [$canv yview]
8570 clear_display
8571 setcanvscroll
8572 allcanvs yview moveto [lindex $span 0]
8573 drawvisible
8574 if {$selectedline ne {}} {
8575 selectline $selectedline 0
8576 allcanvs yview moveto [lindex $span 0]
8580 proc parsefont {f n} {
8581 global fontattr
8583 set fontattr($f,family) [lindex $n 0]
8584 set s [lindex $n 1]
8585 if {$s eq {} || $s == 0} {
8586 set s 10
8587 } elseif {$s < 0} {
8588 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8590 set fontattr($f,size) $s
8591 set fontattr($f,weight) normal
8592 set fontattr($f,slant) roman
8593 foreach style [lrange $n 2 end] {
8594 switch -- $style {
8595 "normal" -
8596 "bold" {set fontattr($f,weight) $style}
8597 "roman" -
8598 "italic" {set fontattr($f,slant) $style}
8603 proc fontflags {f {isbold 0}} {
8604 global fontattr
8606 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8607 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8608 -slant $fontattr($f,slant)]
8611 proc fontname {f} {
8612 global fontattr
8614 set n [list $fontattr($f,family) $fontattr($f,size)]
8615 if {$fontattr($f,weight) eq "bold"} {
8616 lappend n "bold"
8618 if {$fontattr($f,slant) eq "italic"} {
8619 lappend n "italic"
8621 return $n
8624 proc incrfont {inc} {
8625 global mainfont textfont ctext canv cflist showrefstop
8626 global stopped entries fontattr
8628 unmarkmatches
8629 set s $fontattr(mainfont,size)
8630 incr s $inc
8631 if {$s < 1} {
8632 set s 1
8634 set fontattr(mainfont,size) $s
8635 font config mainfont -size $s
8636 font config mainfontbold -size $s
8637 set mainfont [fontname mainfont]
8638 set s $fontattr(textfont,size)
8639 incr s $inc
8640 if {$s < 1} {
8641 set s 1
8643 set fontattr(textfont,size) $s
8644 font config textfont -size $s
8645 font config textfontbold -size $s
8646 set textfont [fontname textfont]
8647 setcoords
8648 settabs
8649 redisplay
8652 proc clearsha1 {} {
8653 global sha1entry sha1string
8654 if {[string length $sha1string] == 40} {
8655 $sha1entry delete 0 end
8659 proc sha1change {n1 n2 op} {
8660 global sha1string currentid sha1but
8661 if {$sha1string == {}
8662 || ([info exists currentid] && $sha1string == $currentid)} {
8663 set state disabled
8664 } else {
8665 set state normal
8667 if {[$sha1but cget -state] == $state} return
8668 if {$state == "normal"} {
8669 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8670 } else {
8671 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8675 proc gotocommit {} {
8676 global sha1string tagids headids curview varcid
8678 if {$sha1string == {}
8679 || ([info exists currentid] && $sha1string == $currentid)} return
8680 if {[info exists tagids($sha1string)]} {
8681 set id $tagids($sha1string)
8682 } elseif {[info exists headids($sha1string)]} {
8683 set id $headids($sha1string)
8684 } else {
8685 set id [string tolower $sha1string]
8686 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8687 set matches [longid $id]
8688 if {$matches ne {}} {
8689 if {[llength $matches] > 1} {
8690 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8691 return
8693 set id [lindex $matches 0]
8695 } else {
8696 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8697 error_popup [mc "Revision %s is not known" $sha1string]
8698 return
8702 if {[commitinview $id $curview]} {
8703 selectline [rowofcommit $id] 1
8704 return
8706 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8707 set msg [mc "SHA1 id %s is not known" $sha1string]
8708 } else {
8709 set msg [mc "Revision %s is not in the current view" $sha1string]
8711 error_popup $msg
8714 proc lineenter {x y id} {
8715 global hoverx hovery hoverid hovertimer
8716 global commitinfo canv
8718 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8719 set hoverx $x
8720 set hovery $y
8721 set hoverid $id
8722 if {[info exists hovertimer]} {
8723 after cancel $hovertimer
8725 set hovertimer [after 500 linehover]
8726 $canv delete hover
8729 proc linemotion {x y id} {
8730 global hoverx hovery hoverid hovertimer
8732 if {[info exists hoverid] && $id == $hoverid} {
8733 set hoverx $x
8734 set hovery $y
8735 if {[info exists hovertimer]} {
8736 after cancel $hovertimer
8738 set hovertimer [after 500 linehover]
8742 proc lineleave {id} {
8743 global hoverid hovertimer canv
8745 if {[info exists hoverid] && $id == $hoverid} {
8746 $canv delete hover
8747 if {[info exists hovertimer]} {
8748 after cancel $hovertimer
8749 unset hovertimer
8751 unset hoverid
8755 proc linehover {} {
8756 global hoverx hovery hoverid hovertimer
8757 global canv linespc lthickness
8758 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8760 global commitinfo
8762 set text [lindex $commitinfo($hoverid) 0]
8763 set ymax [lindex [$canv cget -scrollregion] 3]
8764 if {$ymax == {}} return
8765 set yfrac [lindex [$canv yview] 0]
8766 set x [expr {$hoverx + 2 * $linespc}]
8767 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8768 set x0 [expr {$x - 2 * $lthickness}]
8769 set y0 [expr {$y - 2 * $lthickness}]
8770 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8771 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8772 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8773 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8774 -width 1 -tags hover]
8775 $canv raise $t
8776 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8777 -font mainfont -fill $linehoverfgcolor]
8778 $canv raise $t
8781 proc clickisonarrow {id y} {
8782 global lthickness
8784 set ranges [rowranges $id]
8785 set thresh [expr {2 * $lthickness + 6}]
8786 set n [expr {[llength $ranges] - 1}]
8787 for {set i 1} {$i < $n} {incr i} {
8788 set row [lindex $ranges $i]
8789 if {abs([yc $row] - $y) < $thresh} {
8790 return $i
8793 return {}
8796 proc arrowjump {id n y} {
8797 global canv
8799 # 1 <-> 2, 3 <-> 4, etc...
8800 set n [expr {(($n - 1) ^ 1) + 1}]
8801 set row [lindex [rowranges $id] $n]
8802 set yt [yc $row]
8803 set ymax [lindex [$canv cget -scrollregion] 3]
8804 if {$ymax eq {} || $ymax <= 0} return
8805 set view [$canv yview]
8806 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8807 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8808 if {$yfrac < 0} {
8809 set yfrac 0
8811 allcanvs yview moveto $yfrac
8814 proc lineclick {x y id isnew} {
8815 global ctext commitinfo children canv thickerline curview
8817 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8818 unmarkmatches
8819 unselectline
8820 normalline
8821 $canv delete hover
8822 # draw this line thicker than normal
8823 set thickerline $id
8824 drawlines $id
8825 if {$isnew} {
8826 set ymax [lindex [$canv cget -scrollregion] 3]
8827 if {$ymax eq {}} return
8828 set yfrac [lindex [$canv yview] 0]
8829 set y [expr {$y + $yfrac * $ymax}]
8831 set dirn [clickisonarrow $id $y]
8832 if {$dirn ne {}} {
8833 arrowjump $id $dirn $y
8834 return
8837 if {$isnew} {
8838 addtohistory [list lineclick $x $y $id 0] savectextpos
8840 # fill the details pane with info about this line
8841 $ctext conf -state normal
8842 clear_ctext
8843 settabs 0
8844 $ctext insert end "[mc "Parent"]:\t"
8845 $ctext insert end $id link0
8846 setlink $id link0
8847 set info $commitinfo($id)
8848 $ctext insert end "\n\t[lindex $info 0]\n"
8849 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8850 set date [formatdate [lindex $info 2]]
8851 $ctext insert end "\t[mc "Date"]:\t$date\n"
8852 set kids $children($curview,$id)
8853 if {$kids ne {}} {
8854 $ctext insert end "\n[mc "Children"]:"
8855 set i 0
8856 foreach child $kids {
8857 incr i
8858 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8859 set info $commitinfo($child)
8860 $ctext insert end "\n\t"
8861 $ctext insert end $child link$i
8862 setlink $child link$i
8863 $ctext insert end "\n\t[lindex $info 0]"
8864 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8865 set date [formatdate [lindex $info 2]]
8866 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8869 maybe_scroll_ctext 1
8870 $ctext conf -state disabled
8871 init_flist {}
8874 proc normalline {} {
8875 global thickerline
8876 if {[info exists thickerline]} {
8877 set id $thickerline
8878 unset thickerline
8879 drawlines $id
8883 proc selbyid {id {isnew 1}} {
8884 global curview
8885 if {[commitinview $id $curview]} {
8886 selectline [rowofcommit $id] $isnew
8890 proc mstime {} {
8891 global startmstime
8892 if {![info exists startmstime]} {
8893 set startmstime [clock clicks -milliseconds]
8895 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8898 proc rowmenu {x y id} {
8899 global rowctxmenu selectedline rowmenuid curview
8900 global nullid nullid2 fakerowmenu mainhead markedid
8902 stopfinding
8903 set rowmenuid $id
8904 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8905 set state disabled
8906 } else {
8907 set state normal
8909 if {[info exists markedid] && $markedid ne $id} {
8910 set mstate normal
8911 } else {
8912 set mstate disabled
8914 if {$id ne $nullid && $id ne $nullid2} {
8915 set menu $rowctxmenu
8916 if {$mainhead ne {}} {
8917 $menu entryconfigure 8 -label [mc "Reset %s branch to here" $mainhead] -state normal
8918 } else {
8919 $menu entryconfigure 8 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8921 $menu entryconfigure 10 -state $mstate
8922 $menu entryconfigure 11 -state $mstate
8923 $menu entryconfigure 12 -state $mstate
8924 } else {
8925 set menu $fakerowmenu
8927 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8928 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8929 $menu entryconfigure [mca "Make patch"] -state $state
8930 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8931 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8932 tk_popup $menu $x $y
8935 proc markhere {} {
8936 global rowmenuid markedid canv
8938 set markedid $rowmenuid
8939 make_idmark $markedid
8942 proc gotomark {} {
8943 global markedid
8945 if {[info exists markedid]} {
8946 selbyid $markedid
8950 proc replace_by_kids {l r} {
8951 global curview children
8953 set id [commitonrow $r]
8954 set l [lreplace $l 0 0]
8955 foreach kid $children($curview,$id) {
8956 lappend l [rowofcommit $kid]
8958 return [lsort -integer -decreasing -unique $l]
8961 proc find_common_desc {} {
8962 global markedid rowmenuid curview children
8964 if {![info exists markedid]} return
8965 if {![commitinview $markedid $curview] ||
8966 ![commitinview $rowmenuid $curview]} return
8967 #set t1 [clock clicks -milliseconds]
8968 set l1 [list [rowofcommit $markedid]]
8969 set l2 [list [rowofcommit $rowmenuid]]
8970 while 1 {
8971 set r1 [lindex $l1 0]
8972 set r2 [lindex $l2 0]
8973 if {$r1 eq {} || $r2 eq {}} break
8974 if {$r1 == $r2} {
8975 selectline $r1 1
8976 break
8978 if {$r1 > $r2} {
8979 set l1 [replace_by_kids $l1 $r1]
8980 } else {
8981 set l2 [replace_by_kids $l2 $r2]
8984 #set t2 [clock clicks -milliseconds]
8985 #puts "took [expr {$t2-$t1}]ms"
8988 proc compare_commits {} {
8989 global markedid rowmenuid curview children
8991 if {![info exists markedid]} return
8992 if {![commitinview $markedid $curview]} return
8993 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8994 do_cmp_commits $markedid $rowmenuid
8997 proc getpatchid {id} {
8998 global patchids
9000 if {![info exists patchids($id)]} {
9001 set cmd [diffcmd [list $id] {-p --root}]
9002 # trim off the initial "|"
9003 set cmd [lrange $cmd 1 end]
9004 if {[catch {
9005 set x [eval exec $cmd | git patch-id]
9006 set patchids($id) [lindex $x 0]
9007 }]} {
9008 set patchids($id) "error"
9011 return $patchids($id)
9014 proc do_cmp_commits {a b} {
9015 global ctext curview parents children patchids commitinfo
9017 $ctext conf -state normal
9018 clear_ctext
9019 init_flist {}
9020 for {set i 0} {$i < 100} {incr i} {
9021 set skipa 0
9022 set skipb 0
9023 if {[llength $parents($curview,$a)] > 1} {
9024 appendshortlink $a [mc "Skipping merge commit "] "\n"
9025 set skipa 1
9026 } else {
9027 set patcha [getpatchid $a]
9029 if {[llength $parents($curview,$b)] > 1} {
9030 appendshortlink $b [mc "Skipping merge commit "] "\n"
9031 set skipb 1
9032 } else {
9033 set patchb [getpatchid $b]
9035 if {!$skipa && !$skipb} {
9036 set heada [lindex $commitinfo($a) 0]
9037 set headb [lindex $commitinfo($b) 0]
9038 if {$patcha eq "error"} {
9039 appendshortlink $a [mc "Error getting patch ID for "] \
9040 [mc " - stopping\n"]
9041 break
9043 if {$patchb eq "error"} {
9044 appendshortlink $b [mc "Error getting patch ID for "] \
9045 [mc " - stopping\n"]
9046 break
9048 if {$patcha eq $patchb} {
9049 if {$heada eq $headb} {
9050 appendshortlink $a [mc "Commit "]
9051 appendshortlink $b " == " " $heada\n"
9052 } else {
9053 appendshortlink $a [mc "Commit "] " $heada\n"
9054 appendshortlink $b [mc " is the same patch as\n "] \
9055 " $headb\n"
9057 set skipa 1
9058 set skipb 1
9059 } else {
9060 $ctext insert end "\n"
9061 appendshortlink $a [mc "Commit "] " $heada\n"
9062 appendshortlink $b [mc " differs from\n "] \
9063 " $headb\n"
9064 $ctext insert end [mc "Diff of commits:\n\n"]
9065 $ctext conf -state disabled
9066 update
9067 diffcommits $a $b
9068 return
9071 if {$skipa} {
9072 set kids [real_children $curview,$a]
9073 if {[llength $kids] != 1} {
9074 $ctext insert end "\n"
9075 appendshortlink $a [mc "Commit "] \
9076 [mc " has %s children - stopping\n" [llength $kids]]
9077 break
9079 set a [lindex $kids 0]
9081 if {$skipb} {
9082 set kids [real_children $curview,$b]
9083 if {[llength $kids] != 1} {
9084 appendshortlink $b [mc "Commit "] \
9085 [mc " has %s children - stopping\n" [llength $kids]]
9086 break
9088 set b [lindex $kids 0]
9091 $ctext conf -state disabled
9094 proc diffcommits {a b} {
9095 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9097 set tmpdir [gitknewtmpdir]
9098 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9099 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9100 if {[catch {
9101 exec git diff-tree -p --pretty $a >$fna
9102 exec git diff-tree -p --pretty $b >$fnb
9103 } err]} {
9104 error_popup [mc "Error writing commit to file: %s" $err]
9105 return
9107 if {[catch {
9108 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9109 } err]} {
9110 error_popup [mc "Error diffing commits: %s" $err]
9111 return
9113 set diffids [list commits $a $b]
9114 set blobdifffd($diffids) $fd
9115 set diffinhdr 0
9116 set currdiffsubmod ""
9117 filerun $fd [list getblobdiffline $fd $diffids]
9120 proc diffvssel {dirn} {
9121 global rowmenuid selectedline
9123 if {$selectedline eq {}} return
9124 if {$dirn} {
9125 set oldid [commitonrow $selectedline]
9126 set newid $rowmenuid
9127 } else {
9128 set oldid $rowmenuid
9129 set newid [commitonrow $selectedline]
9131 addtohistory [list doseldiff $oldid $newid] savectextpos
9132 doseldiff $oldid $newid
9135 proc diffvsmark {dirn} {
9136 global rowmenuid markedid
9138 if {![info exists markedid]} return
9139 if {$dirn} {
9140 set oldid $markedid
9141 set newid $rowmenuid
9142 } else {
9143 set oldid $rowmenuid
9144 set newid $markedid
9146 addtohistory [list doseldiff $oldid $newid] savectextpos
9147 doseldiff $oldid $newid
9150 proc doseldiff {oldid newid} {
9151 global ctext
9152 global commitinfo
9154 $ctext conf -state normal
9155 clear_ctext
9156 init_flist [mc "Top"]
9157 $ctext insert end "[mc "From"] "
9158 $ctext insert end $oldid link0
9159 setlink $oldid link0
9160 $ctext insert end "\n "
9161 $ctext insert end [lindex $commitinfo($oldid) 0]
9162 $ctext insert end "\n\n[mc "To"] "
9163 $ctext insert end $newid link1
9164 setlink $newid link1
9165 $ctext insert end "\n "
9166 $ctext insert end [lindex $commitinfo($newid) 0]
9167 $ctext insert end "\n"
9168 $ctext conf -state disabled
9169 $ctext tag remove found 1.0 end
9170 startdiff [list $oldid $newid]
9173 proc mkpatch {} {
9174 global rowmenuid currentid commitinfo patchtop patchnum NS
9176 if {![info exists currentid]} return
9177 set oldid $currentid
9178 set oldhead [lindex $commitinfo($oldid) 0]
9179 set newid $rowmenuid
9180 set newhead [lindex $commitinfo($newid) 0]
9181 set top .patch
9182 set patchtop $top
9183 catch {destroy $top}
9184 ttk_toplevel $top
9185 make_transient $top .
9186 ${NS}::label $top.title -text [mc "Generate patch"]
9187 grid $top.title - -pady 10
9188 ${NS}::label $top.from -text [mc "From:"]
9189 ${NS}::entry $top.fromsha1 -width 40
9190 $top.fromsha1 insert 0 $oldid
9191 $top.fromsha1 conf -state readonly
9192 grid $top.from $top.fromsha1 -sticky w
9193 ${NS}::entry $top.fromhead -width 60
9194 $top.fromhead insert 0 $oldhead
9195 $top.fromhead conf -state readonly
9196 grid x $top.fromhead -sticky w
9197 ${NS}::label $top.to -text [mc "To:"]
9198 ${NS}::entry $top.tosha1 -width 40
9199 $top.tosha1 insert 0 $newid
9200 $top.tosha1 conf -state readonly
9201 grid $top.to $top.tosha1 -sticky w
9202 ${NS}::entry $top.tohead -width 60
9203 $top.tohead insert 0 $newhead
9204 $top.tohead conf -state readonly
9205 grid x $top.tohead -sticky w
9206 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9207 grid $top.rev x -pady 10 -padx 5
9208 ${NS}::label $top.flab -text [mc "Output file:"]
9209 ${NS}::entry $top.fname -width 60
9210 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9211 incr patchnum
9212 grid $top.flab $top.fname -sticky w
9213 ${NS}::frame $top.buts
9214 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9215 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9216 bind $top <Key-Return> mkpatchgo
9217 bind $top <Key-Escape> mkpatchcan
9218 grid $top.buts.gen $top.buts.can
9219 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9220 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9221 grid $top.buts - -pady 10 -sticky ew
9222 focus $top.fname
9225 proc mkpatchrev {} {
9226 global patchtop
9228 set oldid [$patchtop.fromsha1 get]
9229 set oldhead [$patchtop.fromhead get]
9230 set newid [$patchtop.tosha1 get]
9231 set newhead [$patchtop.tohead get]
9232 foreach e [list fromsha1 fromhead tosha1 tohead] \
9233 v [list $newid $newhead $oldid $oldhead] {
9234 $patchtop.$e conf -state normal
9235 $patchtop.$e delete 0 end
9236 $patchtop.$e insert 0 $v
9237 $patchtop.$e conf -state readonly
9241 proc mkpatchgo {} {
9242 global patchtop nullid nullid2
9244 set oldid [$patchtop.fromsha1 get]
9245 set newid [$patchtop.tosha1 get]
9246 set fname [$patchtop.fname get]
9247 set cmd [diffcmd [list $oldid $newid] -p]
9248 # trim off the initial "|"
9249 set cmd [lrange $cmd 1 end]
9250 lappend cmd >$fname &
9251 if {[catch {eval exec $cmd} err]} {
9252 error_popup "[mc "Error creating patch:"] $err" $patchtop
9254 catch {destroy $patchtop}
9255 unset patchtop
9258 proc mkpatchcan {} {
9259 global patchtop
9261 catch {destroy $patchtop}
9262 unset patchtop
9265 proc mktag {} {
9266 global rowmenuid mktagtop commitinfo NS
9268 set top .maketag
9269 set mktagtop $top
9270 catch {destroy $top}
9271 ttk_toplevel $top
9272 make_transient $top .
9273 ${NS}::label $top.title -text [mc "Create tag"]
9274 grid $top.title - -pady 10
9275 ${NS}::label $top.id -text [mc "ID:"]
9276 ${NS}::entry $top.sha1 -width 40
9277 $top.sha1 insert 0 $rowmenuid
9278 $top.sha1 conf -state readonly
9279 grid $top.id $top.sha1 -sticky w
9280 ${NS}::entry $top.head -width 60
9281 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9282 $top.head conf -state readonly
9283 grid x $top.head -sticky w
9284 ${NS}::label $top.tlab -text [mc "Tag name:"]
9285 ${NS}::entry $top.tag -width 60
9286 grid $top.tlab $top.tag -sticky w
9287 ${NS}::label $top.op -text [mc "Tag message is optional"]
9288 grid $top.op -columnspan 2 -sticky we
9289 ${NS}::label $top.mlab -text [mc "Tag message:"]
9290 ${NS}::entry $top.msg -width 60
9291 grid $top.mlab $top.msg -sticky w
9292 ${NS}::frame $top.buts
9293 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9294 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9295 bind $top <Key-Return> mktaggo
9296 bind $top <Key-Escape> mktagcan
9297 grid $top.buts.gen $top.buts.can
9298 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9299 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9300 grid $top.buts - -pady 10 -sticky ew
9301 focus $top.tag
9304 proc domktag {} {
9305 global mktagtop env tagids idtags
9307 set id [$mktagtop.sha1 get]
9308 set tag [$mktagtop.tag get]
9309 set msg [$mktagtop.msg get]
9310 if {$tag == {}} {
9311 error_popup [mc "No tag name specified"] $mktagtop
9312 return 0
9314 if {[info exists tagids($tag)]} {
9315 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9316 return 0
9318 if {[catch {
9319 if {$msg != {}} {
9320 exec git tag -a -m $msg $tag $id
9321 } else {
9322 exec git tag $tag $id
9324 } err]} {
9325 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9326 return 0
9329 set tagids($tag) $id
9330 lappend idtags($id) $tag
9331 redrawtags $id
9332 addedtag $id
9333 dispneartags 0
9334 run refill_reflist
9335 return 1
9338 proc redrawtags {id} {
9339 global canv linehtag idpos currentid curview cmitlisted markedid
9340 global canvxmax iddrawn circleitem mainheadid circlecolors
9341 global mainheadcirclecolor
9343 if {![commitinview $id $curview]} return
9344 if {![info exists iddrawn($id)]} return
9345 set row [rowofcommit $id]
9346 if {$id eq $mainheadid} {
9347 set ofill $mainheadcirclecolor
9348 } else {
9349 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9351 $canv itemconf $circleitem($row) -fill $ofill
9352 $canv delete tag.$id
9353 set xt [eval drawtags $id $idpos($id)]
9354 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9355 set text [$canv itemcget $linehtag($id) -text]
9356 set font [$canv itemcget $linehtag($id) -font]
9357 set xr [expr {$xt + [font measure $font $text]}]
9358 if {$xr > $canvxmax} {
9359 set canvxmax $xr
9360 setcanvscroll
9362 if {[info exists currentid] && $currentid == $id} {
9363 make_secsel $id
9365 if {[info exists markedid] && $markedid eq $id} {
9366 make_idmark $id
9370 proc mktagcan {} {
9371 global mktagtop
9373 catch {destroy $mktagtop}
9374 unset mktagtop
9377 proc mktaggo {} {
9378 if {![domktag]} return
9379 mktagcan
9382 proc copysummary {} {
9383 global rowmenuid autosellen
9385 set format "%h (\"%s\", %ad)"
9386 set cmd [list git show -s --pretty=format:$format --date=short]
9387 if {$autosellen < 40} {
9388 lappend cmd --abbrev=$autosellen
9390 set summary [eval exec $cmd $rowmenuid]
9392 clipboard clear
9393 clipboard append $summary
9396 proc writecommit {} {
9397 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9399 set top .writecommit
9400 set wrcomtop $top
9401 catch {destroy $top}
9402 ttk_toplevel $top
9403 make_transient $top .
9404 ${NS}::label $top.title -text [mc "Write commit to file"]
9405 grid $top.title - -pady 10
9406 ${NS}::label $top.id -text [mc "ID:"]
9407 ${NS}::entry $top.sha1 -width 40
9408 $top.sha1 insert 0 $rowmenuid
9409 $top.sha1 conf -state readonly
9410 grid $top.id $top.sha1 -sticky w
9411 ${NS}::entry $top.head -width 60
9412 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9413 $top.head conf -state readonly
9414 grid x $top.head -sticky w
9415 ${NS}::label $top.clab -text [mc "Command:"]
9416 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9417 grid $top.clab $top.cmd -sticky w -pady 10
9418 ${NS}::label $top.flab -text [mc "Output file:"]
9419 ${NS}::entry $top.fname -width 60
9420 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9421 grid $top.flab $top.fname -sticky w
9422 ${NS}::frame $top.buts
9423 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9424 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9425 bind $top <Key-Return> wrcomgo
9426 bind $top <Key-Escape> wrcomcan
9427 grid $top.buts.gen $top.buts.can
9428 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9429 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9430 grid $top.buts - -pady 10 -sticky ew
9431 focus $top.fname
9434 proc wrcomgo {} {
9435 global wrcomtop
9437 set id [$wrcomtop.sha1 get]
9438 set cmd "echo $id | [$wrcomtop.cmd get]"
9439 set fname [$wrcomtop.fname get]
9440 if {[catch {exec sh -c $cmd >$fname &} err]} {
9441 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9443 catch {destroy $wrcomtop}
9444 unset wrcomtop
9447 proc wrcomcan {} {
9448 global wrcomtop
9450 catch {destroy $wrcomtop}
9451 unset wrcomtop
9454 proc mkbranch {} {
9455 global rowmenuid mkbrtop NS
9457 set top .makebranch
9458 catch {destroy $top}
9459 ttk_toplevel $top
9460 make_transient $top .
9461 ${NS}::label $top.title -text [mc "Create new branch"]
9462 grid $top.title - -pady 10
9463 ${NS}::label $top.id -text [mc "ID:"]
9464 ${NS}::entry $top.sha1 -width 40
9465 $top.sha1 insert 0 $rowmenuid
9466 $top.sha1 conf -state readonly
9467 grid $top.id $top.sha1 -sticky w
9468 ${NS}::label $top.nlab -text [mc "Name:"]
9469 ${NS}::entry $top.name -width 40
9470 grid $top.nlab $top.name -sticky w
9471 ${NS}::frame $top.buts
9472 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9473 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9474 bind $top <Key-Return> [list mkbrgo $top]
9475 bind $top <Key-Escape> "catch {destroy $top}"
9476 grid $top.buts.go $top.buts.can
9477 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9478 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9479 grid $top.buts - -pady 10 -sticky ew
9480 focus $top.name
9483 proc mkbrgo {top} {
9484 global headids idheads
9486 set name [$top.name get]
9487 set id [$top.sha1 get]
9488 set cmdargs {}
9489 set old_id {}
9490 if {$name eq {}} {
9491 error_popup [mc "Please specify a name for the new branch"] $top
9492 return
9494 if {[info exists headids($name)]} {
9495 if {![confirm_popup [mc \
9496 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9497 return
9499 set old_id $headids($name)
9500 lappend cmdargs -f
9502 catch {destroy $top}
9503 lappend cmdargs $name $id
9504 nowbusy newbranch
9505 update
9506 if {[catch {
9507 eval exec git branch $cmdargs
9508 } err]} {
9509 notbusy newbranch
9510 error_popup $err
9511 } else {
9512 notbusy newbranch
9513 if {$old_id ne {}} {
9514 movehead $id $name
9515 movedhead $id $name
9516 redrawtags $old_id
9517 redrawtags $id
9518 } else {
9519 set headids($name) $id
9520 lappend idheads($id) $name
9521 addedhead $id $name
9522 redrawtags $id
9524 dispneartags 0
9525 run refill_reflist
9529 proc exec_citool {tool_args {baseid {}}} {
9530 global commitinfo env
9532 set save_env [array get env GIT_AUTHOR_*]
9534 if {$baseid ne {}} {
9535 if {![info exists commitinfo($baseid)]} {
9536 getcommit $baseid
9538 set author [lindex $commitinfo($baseid) 1]
9539 set date [lindex $commitinfo($baseid) 2]
9540 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9541 $author author name email]
9542 && $date ne {}} {
9543 set env(GIT_AUTHOR_NAME) $name
9544 set env(GIT_AUTHOR_EMAIL) $email
9545 set env(GIT_AUTHOR_DATE) $date
9549 eval exec git citool $tool_args &
9551 array unset env GIT_AUTHOR_*
9552 array set env $save_env
9555 proc cherrypick {} {
9556 global rowmenuid curview
9557 global mainhead mainheadid
9558 global gitdir
9560 set oldhead [exec git rev-parse HEAD]
9561 set dheads [descheads $rowmenuid]
9562 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9563 set ok [confirm_popup [mc "Commit %s is already\
9564 included in branch %s -- really re-apply it?" \
9565 [string range $rowmenuid 0 7] $mainhead]]
9566 if {!$ok} return
9568 nowbusy cherrypick [mc "Cherry-picking"]
9569 update
9570 # Unfortunately git-cherry-pick writes stuff to stderr even when
9571 # no error occurs, and exec takes that as an indication of error...
9572 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9573 notbusy cherrypick
9574 if {[regexp -line \
9575 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9576 $err msg fname]} {
9577 error_popup [mc "Cherry-pick failed because of local changes\
9578 to file '%s'.\nPlease commit, reset or stash\
9579 your changes and try again." $fname]
9580 } elseif {[regexp -line \
9581 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9582 $err]} {
9583 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9584 conflict.\nDo you wish to run git citool to\
9585 resolve it?"]]} {
9586 # Force citool to read MERGE_MSG
9587 file delete [file join $gitdir "GITGUI_MSG"]
9588 exec_citool {} $rowmenuid
9590 } else {
9591 error_popup $err
9593 run updatecommits
9594 return
9596 set newhead [exec git rev-parse HEAD]
9597 if {$newhead eq $oldhead} {
9598 notbusy cherrypick
9599 error_popup [mc "No changes committed"]
9600 return
9602 addnewchild $newhead $oldhead
9603 if {[commitinview $oldhead $curview]} {
9604 # XXX this isn't right if we have a path limit...
9605 insertrow $newhead $oldhead $curview
9606 if {$mainhead ne {}} {
9607 movehead $newhead $mainhead
9608 movedhead $newhead $mainhead
9610 set mainheadid $newhead
9611 redrawtags $oldhead
9612 redrawtags $newhead
9613 selbyid $newhead
9615 notbusy cherrypick
9618 proc revert {} {
9619 global rowmenuid curview
9620 global mainhead mainheadid
9621 global gitdir
9623 set oldhead [exec git rev-parse HEAD]
9624 set dheads [descheads $rowmenuid]
9625 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9626 set ok [confirm_popup [mc "Commit %s is not\
9627 included in branch %s -- really revert it?" \
9628 [string range $rowmenuid 0 7] $mainhead]]
9629 if {!$ok} return
9631 nowbusy revert [mc "Reverting"]
9632 update
9634 if [catch {exec git revert --no-edit $rowmenuid} err] {
9635 notbusy revert
9636 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9637 $err match files] {
9638 regsub {\n( |\t)+} $files "\n" files
9639 error_popup [mc "Revert failed because of local changes to\
9640 the following files:%s Please commit, reset or stash \
9641 your changes and try again." $files]
9642 } elseif [regexp {error: could not revert} $err] {
9643 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9644 Do you wish to run git citool to resolve it?"]] {
9645 # Force citool to read MERGE_MSG
9646 file delete [file join $gitdir "GITGUI_MSG"]
9647 exec_citool {} $rowmenuid
9649 } else { error_popup $err }
9650 run updatecommits
9651 return
9654 set newhead [exec git rev-parse HEAD]
9655 if { $newhead eq $oldhead } {
9656 notbusy revert
9657 error_popup [mc "No changes committed"]
9658 return
9661 addnewchild $newhead $oldhead
9663 if [commitinview $oldhead $curview] {
9664 # XXX this isn't right if we have a path limit...
9665 insertrow $newhead $oldhead $curview
9666 if {$mainhead ne {}} {
9667 movehead $newhead $mainhead
9668 movedhead $newhead $mainhead
9670 set mainheadid $newhead
9671 redrawtags $oldhead
9672 redrawtags $newhead
9673 selbyid $newhead
9676 notbusy revert
9679 proc resethead {} {
9680 global mainhead rowmenuid confirm_ok resettype NS
9682 set confirm_ok 0
9683 set w ".confirmreset"
9684 ttk_toplevel $w
9685 make_transient $w .
9686 wm title $w [mc "Confirm reset"]
9687 ${NS}::label $w.m -text \
9688 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9689 pack $w.m -side top -fill x -padx 20 -pady 20
9690 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9691 set resettype mixed
9692 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9693 -text [mc "Soft: Leave working tree and index untouched"]
9694 grid $w.f.soft -sticky w
9695 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9696 -text [mc "Mixed: Leave working tree untouched, reset index"]
9697 grid $w.f.mixed -sticky w
9698 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9699 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9700 grid $w.f.hard -sticky w
9701 pack $w.f -side top -fill x -padx 4
9702 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9703 pack $w.ok -side left -fill x -padx 20 -pady 20
9704 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9705 bind $w <Key-Escape> [list destroy $w]
9706 pack $w.cancel -side right -fill x -padx 20 -pady 20
9707 bind $w <Visibility> "grab $w; focus $w"
9708 tkwait window $w
9709 if {!$confirm_ok} return
9710 if {[catch {set fd [open \
9711 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9712 error_popup $err
9713 } else {
9714 dohidelocalchanges
9715 filerun $fd [list readresetstat $fd]
9716 nowbusy reset [mc "Resetting"]
9717 selbyid $rowmenuid
9721 proc readresetstat {fd} {
9722 global mainhead mainheadid showlocalchanges rprogcoord
9724 if {[gets $fd line] >= 0} {
9725 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9726 set rprogcoord [expr {1.0 * $m / $n}]
9727 adjustprogress
9729 return 1
9731 set rprogcoord 0
9732 adjustprogress
9733 notbusy reset
9734 if {[catch {close $fd} err]} {
9735 error_popup $err
9737 set oldhead $mainheadid
9738 set newhead [exec git rev-parse HEAD]
9739 if {$newhead ne $oldhead} {
9740 movehead $newhead $mainhead
9741 movedhead $newhead $mainhead
9742 set mainheadid $newhead
9743 redrawtags $oldhead
9744 redrawtags $newhead
9746 if {$showlocalchanges} {
9747 doshowlocalchanges
9749 return 0
9752 # context menu for a head
9753 proc headmenu {x y id head} {
9754 global headmenuid headmenuhead headctxmenu mainhead
9756 stopfinding
9757 set headmenuid $id
9758 set headmenuhead $head
9759 set state normal
9760 if {[string match "remotes/*" $head]} {
9761 set state disabled
9763 if {$head eq $mainhead} {
9764 set state disabled
9766 $headctxmenu entryconfigure 0 -state $state
9767 $headctxmenu entryconfigure 1 -state $state
9768 tk_popup $headctxmenu $x $y
9771 proc cobranch {} {
9772 global headmenuid headmenuhead headids
9773 global showlocalchanges
9775 # check the tree is clean first??
9776 nowbusy checkout [mc "Checking out"]
9777 update
9778 dohidelocalchanges
9779 if {[catch {
9780 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9781 } err]} {
9782 notbusy checkout
9783 error_popup $err
9784 if {$showlocalchanges} {
9785 dodiffindex
9787 } else {
9788 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9792 proc readcheckoutstat {fd newhead newheadid} {
9793 global mainhead mainheadid headids showlocalchanges progresscoords
9794 global viewmainheadid curview
9796 if {[gets $fd line] >= 0} {
9797 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9798 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9799 adjustprogress
9801 return 1
9803 set progresscoords {0 0}
9804 adjustprogress
9805 notbusy checkout
9806 if {[catch {close $fd} err]} {
9807 error_popup $err
9809 set oldmainid $mainheadid
9810 set mainhead $newhead
9811 set mainheadid $newheadid
9812 set viewmainheadid($curview) $newheadid
9813 redrawtags $oldmainid
9814 redrawtags $newheadid
9815 selbyid $newheadid
9816 if {$showlocalchanges} {
9817 dodiffindex
9821 proc rmbranch {} {
9822 global headmenuid headmenuhead mainhead
9823 global idheads
9825 set head $headmenuhead
9826 set id $headmenuid
9827 # this check shouldn't be needed any more...
9828 if {$head eq $mainhead} {
9829 error_popup [mc "Cannot delete the currently checked-out branch"]
9830 return
9832 set dheads [descheads $id]
9833 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9834 # the stuff on this branch isn't on any other branch
9835 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9836 branch.\nReally delete branch %s?" $head $head]]} return
9838 nowbusy rmbranch
9839 update
9840 if {[catch {exec git branch -D $head} err]} {
9841 notbusy rmbranch
9842 error_popup $err
9843 return
9845 removehead $id $head
9846 removedhead $id $head
9847 redrawtags $id
9848 notbusy rmbranch
9849 dispneartags 0
9850 run refill_reflist
9853 # Display a list of tags and heads
9854 proc showrefs {} {
9855 global showrefstop bgcolor fgcolor selectbgcolor NS
9856 global bglist fglist reflistfilter reflist maincursor
9858 set top .showrefs
9859 set showrefstop $top
9860 if {[winfo exists $top]} {
9861 raise $top
9862 refill_reflist
9863 return
9865 ttk_toplevel $top
9866 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9867 make_transient $top .
9868 text $top.list -background $bgcolor -foreground $fgcolor \
9869 -selectbackground $selectbgcolor -font mainfont \
9870 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9871 -width 30 -height 20 -cursor $maincursor \
9872 -spacing1 1 -spacing3 1 -state disabled
9873 $top.list tag configure highlight -background $selectbgcolor
9874 if {![lsearch -exact $bglist $top.list]} {
9875 lappend bglist $top.list
9876 lappend fglist $top.list
9878 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9879 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9880 grid $top.list $top.ysb -sticky nsew
9881 grid $top.xsb x -sticky ew
9882 ${NS}::frame $top.f
9883 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9884 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9885 set reflistfilter "*"
9886 trace add variable reflistfilter write reflistfilter_change
9887 pack $top.f.e -side right -fill x -expand 1
9888 pack $top.f.l -side left
9889 grid $top.f - -sticky ew -pady 2
9890 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9891 bind $top <Key-Escape> [list destroy $top]
9892 grid $top.close -
9893 grid columnconfigure $top 0 -weight 1
9894 grid rowconfigure $top 0 -weight 1
9895 bind $top.list <1> {break}
9896 bind $top.list <B1-Motion> {break}
9897 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9898 set reflist {}
9899 refill_reflist
9902 proc sel_reflist {w x y} {
9903 global showrefstop reflist headids tagids otherrefids
9905 if {![winfo exists $showrefstop]} return
9906 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9907 set ref [lindex $reflist [expr {$l-1}]]
9908 set n [lindex $ref 0]
9909 switch -- [lindex $ref 1] {
9910 "H" {selbyid $headids($n)}
9911 "T" {selbyid $tagids($n)}
9912 "o" {selbyid $otherrefids($n)}
9914 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9917 proc unsel_reflist {} {
9918 global showrefstop
9920 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9921 $showrefstop.list tag remove highlight 0.0 end
9924 proc reflistfilter_change {n1 n2 op} {
9925 global reflistfilter
9927 after cancel refill_reflist
9928 after 200 refill_reflist
9931 proc refill_reflist {} {
9932 global reflist reflistfilter showrefstop headids tagids otherrefids
9933 global curview
9935 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9936 set refs {}
9937 foreach n [array names headids] {
9938 if {[string match $reflistfilter $n]} {
9939 if {[commitinview $headids($n) $curview]} {
9940 lappend refs [list $n H]
9941 } else {
9942 interestedin $headids($n) {run refill_reflist}
9946 foreach n [array names tagids] {
9947 if {[string match $reflistfilter $n]} {
9948 if {[commitinview $tagids($n) $curview]} {
9949 lappend refs [list $n T]
9950 } else {
9951 interestedin $tagids($n) {run refill_reflist}
9955 foreach n [array names otherrefids] {
9956 if {[string match $reflistfilter $n]} {
9957 if {[commitinview $otherrefids($n) $curview]} {
9958 lappend refs [list $n o]
9959 } else {
9960 interestedin $otherrefids($n) {run refill_reflist}
9964 set refs [lsort -index 0 $refs]
9965 if {$refs eq $reflist} return
9967 # Update the contents of $showrefstop.list according to the
9968 # differences between $reflist (old) and $refs (new)
9969 $showrefstop.list conf -state normal
9970 $showrefstop.list insert end "\n"
9971 set i 0
9972 set j 0
9973 while {$i < [llength $reflist] || $j < [llength $refs]} {
9974 if {$i < [llength $reflist]} {
9975 if {$j < [llength $refs]} {
9976 set cmp [string compare [lindex $reflist $i 0] \
9977 [lindex $refs $j 0]]
9978 if {$cmp == 0} {
9979 set cmp [string compare [lindex $reflist $i 1] \
9980 [lindex $refs $j 1]]
9982 } else {
9983 set cmp -1
9985 } else {
9986 set cmp 1
9988 switch -- $cmp {
9989 -1 {
9990 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9991 incr i
9994 incr i
9995 incr j
9998 set l [expr {$j + 1}]
9999 $showrefstop.list image create $l.0 -align baseline \
10000 -image reficon-[lindex $refs $j 1] -padx 2
10001 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
10002 incr j
10006 set reflist $refs
10007 # delete last newline
10008 $showrefstop.list delete end-2c end-1c
10009 $showrefstop.list conf -state disabled
10012 # Stuff for finding nearby tags
10013 proc getallcommits {} {
10014 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
10015 global idheads idtags idotherrefs allparents tagobjid
10016 global gitdir
10018 if {![info exists allcommits]} {
10019 set nextarc 0
10020 set allcommits 0
10021 set seeds {}
10022 set allcwait 0
10023 set cachedarcs 0
10024 set allccache [file join $gitdir "gitk.cache"]
10025 if {![catch {
10026 set f [open $allccache r]
10027 set allcwait 1
10028 getcache $f
10029 }]} return
10032 if {$allcwait} {
10033 return
10035 set cmd [list | git rev-list --parents]
10036 set allcupdate [expr {$seeds ne {}}]
10037 if {!$allcupdate} {
10038 set ids "--all"
10039 } else {
10040 set refs [concat [array names idheads] [array names idtags] \
10041 [array names idotherrefs]]
10042 set ids {}
10043 set tagobjs {}
10044 foreach name [array names tagobjid] {
10045 lappend tagobjs $tagobjid($name)
10047 foreach id [lsort -unique $refs] {
10048 if {![info exists allparents($id)] &&
10049 [lsearch -exact $tagobjs $id] < 0} {
10050 lappend ids $id
10053 if {$ids ne {}} {
10054 foreach id $seeds {
10055 lappend ids "^$id"
10059 if {$ids ne {}} {
10060 set fd [open [concat $cmd $ids] r]
10061 fconfigure $fd -blocking 0
10062 incr allcommits
10063 nowbusy allcommits
10064 filerun $fd [list getallclines $fd]
10065 } else {
10066 dispneartags 0
10070 # Since most commits have 1 parent and 1 child, we group strings of
10071 # such commits into "arcs" joining branch/merge points (BMPs), which
10072 # are commits that either don't have 1 parent or don't have 1 child.
10074 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10075 # arcout(id) - outgoing arcs for BMP
10076 # arcids(a) - list of IDs on arc including end but not start
10077 # arcstart(a) - BMP ID at start of arc
10078 # arcend(a) - BMP ID at end of arc
10079 # growing(a) - arc a is still growing
10080 # arctags(a) - IDs out of arcids (excluding end) that have tags
10081 # archeads(a) - IDs out of arcids (excluding end) that have heads
10082 # The start of an arc is at the descendent end, so "incoming" means
10083 # coming from descendents, and "outgoing" means going towards ancestors.
10085 proc getallclines {fd} {
10086 global allparents allchildren idtags idheads nextarc
10087 global arcnos arcids arctags arcout arcend arcstart archeads growing
10088 global seeds allcommits cachedarcs allcupdate
10090 set nid 0
10091 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10092 set id [lindex $line 0]
10093 if {[info exists allparents($id)]} {
10094 # seen it already
10095 continue
10097 set cachedarcs 0
10098 set olds [lrange $line 1 end]
10099 set allparents($id) $olds
10100 if {![info exists allchildren($id)]} {
10101 set allchildren($id) {}
10102 set arcnos($id) {}
10103 lappend seeds $id
10104 } else {
10105 set a $arcnos($id)
10106 if {[llength $olds] == 1 && [llength $a] == 1} {
10107 lappend arcids($a) $id
10108 if {[info exists idtags($id)]} {
10109 lappend arctags($a) $id
10111 if {[info exists idheads($id)]} {
10112 lappend archeads($a) $id
10114 if {[info exists allparents($olds)]} {
10115 # seen parent already
10116 if {![info exists arcout($olds)]} {
10117 splitarc $olds
10119 lappend arcids($a) $olds
10120 set arcend($a) $olds
10121 unset growing($a)
10123 lappend allchildren($olds) $id
10124 lappend arcnos($olds) $a
10125 continue
10128 foreach a $arcnos($id) {
10129 lappend arcids($a) $id
10130 set arcend($a) $id
10131 unset growing($a)
10134 set ao {}
10135 foreach p $olds {
10136 lappend allchildren($p) $id
10137 set a [incr nextarc]
10138 set arcstart($a) $id
10139 set archeads($a) {}
10140 set arctags($a) {}
10141 set archeads($a) {}
10142 set arcids($a) {}
10143 lappend ao $a
10144 set growing($a) 1
10145 if {[info exists allparents($p)]} {
10146 # seen it already, may need to make a new branch
10147 if {![info exists arcout($p)]} {
10148 splitarc $p
10150 lappend arcids($a) $p
10151 set arcend($a) $p
10152 unset growing($a)
10154 lappend arcnos($p) $a
10156 set arcout($id) $ao
10158 if {$nid > 0} {
10159 global cached_dheads cached_dtags cached_atags
10160 unset -nocomplain cached_dheads
10161 unset -nocomplain cached_dtags
10162 unset -nocomplain cached_atags
10164 if {![eof $fd]} {
10165 return [expr {$nid >= 1000? 2: 1}]
10167 set cacheok 1
10168 if {[catch {
10169 fconfigure $fd -blocking 1
10170 close $fd
10171 } err]} {
10172 # got an error reading the list of commits
10173 # if we were updating, try rereading the whole thing again
10174 if {$allcupdate} {
10175 incr allcommits -1
10176 dropcache $err
10177 return
10179 error_popup "[mc "Error reading commit topology information;\
10180 branch and preceding/following tag information\
10181 will be incomplete."]\n($err)"
10182 set cacheok 0
10184 if {[incr allcommits -1] == 0} {
10185 notbusy allcommits
10186 if {$cacheok} {
10187 run savecache
10190 dispneartags 0
10191 return 0
10194 proc recalcarc {a} {
10195 global arctags archeads arcids idtags idheads
10197 set at {}
10198 set ah {}
10199 foreach id [lrange $arcids($a) 0 end-1] {
10200 if {[info exists idtags($id)]} {
10201 lappend at $id
10203 if {[info exists idheads($id)]} {
10204 lappend ah $id
10207 set arctags($a) $at
10208 set archeads($a) $ah
10211 proc splitarc {p} {
10212 global arcnos arcids nextarc arctags archeads idtags idheads
10213 global arcstart arcend arcout allparents growing
10215 set a $arcnos($p)
10216 if {[llength $a] != 1} {
10217 puts "oops splitarc called but [llength $a] arcs already"
10218 return
10220 set a [lindex $a 0]
10221 set i [lsearch -exact $arcids($a) $p]
10222 if {$i < 0} {
10223 puts "oops splitarc $p not in arc $a"
10224 return
10226 set na [incr nextarc]
10227 if {[info exists arcend($a)]} {
10228 set arcend($na) $arcend($a)
10229 } else {
10230 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10231 set j [lsearch -exact $arcnos($l) $a]
10232 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10234 set tail [lrange $arcids($a) [expr {$i+1}] end]
10235 set arcids($a) [lrange $arcids($a) 0 $i]
10236 set arcend($a) $p
10237 set arcstart($na) $p
10238 set arcout($p) $na
10239 set arcids($na) $tail
10240 if {[info exists growing($a)]} {
10241 set growing($na) 1
10242 unset growing($a)
10245 foreach id $tail {
10246 if {[llength $arcnos($id)] == 1} {
10247 set arcnos($id) $na
10248 } else {
10249 set j [lsearch -exact $arcnos($id) $a]
10250 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10254 # reconstruct tags and heads lists
10255 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10256 recalcarc $a
10257 recalcarc $na
10258 } else {
10259 set arctags($na) {}
10260 set archeads($na) {}
10264 # Update things for a new commit added that is a child of one
10265 # existing commit. Used when cherry-picking.
10266 proc addnewchild {id p} {
10267 global allparents allchildren idtags nextarc
10268 global arcnos arcids arctags arcout arcend arcstart archeads growing
10269 global seeds allcommits
10271 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10272 set allparents($id) [list $p]
10273 set allchildren($id) {}
10274 set arcnos($id) {}
10275 lappend seeds $id
10276 lappend allchildren($p) $id
10277 set a [incr nextarc]
10278 set arcstart($a) $id
10279 set archeads($a) {}
10280 set arctags($a) {}
10281 set arcids($a) [list $p]
10282 set arcend($a) $p
10283 if {![info exists arcout($p)]} {
10284 splitarc $p
10286 lappend arcnos($p) $a
10287 set arcout($id) [list $a]
10290 # This implements a cache for the topology information.
10291 # The cache saves, for each arc, the start and end of the arc,
10292 # the ids on the arc, and the outgoing arcs from the end.
10293 proc readcache {f} {
10294 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10295 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10296 global allcwait
10298 set a $nextarc
10299 set lim $cachedarcs
10300 if {$lim - $a > 500} {
10301 set lim [expr {$a + 500}]
10303 if {[catch {
10304 if {$a == $lim} {
10305 # finish reading the cache and setting up arctags, etc.
10306 set line [gets $f]
10307 if {$line ne "1"} {error "bad final version"}
10308 close $f
10309 foreach id [array names idtags] {
10310 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10311 [llength $allparents($id)] == 1} {
10312 set a [lindex $arcnos($id) 0]
10313 if {$arctags($a) eq {}} {
10314 recalcarc $a
10318 foreach id [array names idheads] {
10319 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10320 [llength $allparents($id)] == 1} {
10321 set a [lindex $arcnos($id) 0]
10322 if {$archeads($a) eq {}} {
10323 recalcarc $a
10327 foreach id [lsort -unique $possible_seeds] {
10328 if {$arcnos($id) eq {}} {
10329 lappend seeds $id
10332 set allcwait 0
10333 } else {
10334 while {[incr a] <= $lim} {
10335 set line [gets $f]
10336 if {[llength $line] != 3} {error "bad line"}
10337 set s [lindex $line 0]
10338 set arcstart($a) $s
10339 lappend arcout($s) $a
10340 if {![info exists arcnos($s)]} {
10341 lappend possible_seeds $s
10342 set arcnos($s) {}
10344 set e [lindex $line 1]
10345 if {$e eq {}} {
10346 set growing($a) 1
10347 } else {
10348 set arcend($a) $e
10349 if {![info exists arcout($e)]} {
10350 set arcout($e) {}
10353 set arcids($a) [lindex $line 2]
10354 foreach id $arcids($a) {
10355 lappend allparents($s) $id
10356 set s $id
10357 lappend arcnos($id) $a
10359 if {![info exists allparents($s)]} {
10360 set allparents($s) {}
10362 set arctags($a) {}
10363 set archeads($a) {}
10365 set nextarc [expr {$a - 1}]
10367 } err]} {
10368 dropcache $err
10369 return 0
10371 if {!$allcwait} {
10372 getallcommits
10374 return $allcwait
10377 proc getcache {f} {
10378 global nextarc cachedarcs possible_seeds
10380 if {[catch {
10381 set line [gets $f]
10382 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10383 # make sure it's an integer
10384 set cachedarcs [expr {int([lindex $line 1])}]
10385 if {$cachedarcs < 0} {error "bad number of arcs"}
10386 set nextarc 0
10387 set possible_seeds {}
10388 run readcache $f
10389 } err]} {
10390 dropcache $err
10392 return 0
10395 proc dropcache {err} {
10396 global allcwait nextarc cachedarcs seeds
10398 #puts "dropping cache ($err)"
10399 foreach v {arcnos arcout arcids arcstart arcend growing \
10400 arctags archeads allparents allchildren} {
10401 global $v
10402 unset -nocomplain $v
10404 set allcwait 0
10405 set nextarc 0
10406 set cachedarcs 0
10407 set seeds {}
10408 getallcommits
10411 proc writecache {f} {
10412 global cachearc cachedarcs allccache
10413 global arcstart arcend arcnos arcids arcout
10415 set a $cachearc
10416 set lim $cachedarcs
10417 if {$lim - $a > 1000} {
10418 set lim [expr {$a + 1000}]
10420 if {[catch {
10421 while {[incr a] <= $lim} {
10422 if {[info exists arcend($a)]} {
10423 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10424 } else {
10425 puts $f [list $arcstart($a) {} $arcids($a)]
10428 } err]} {
10429 catch {close $f}
10430 catch {file delete $allccache}
10431 #puts "writing cache failed ($err)"
10432 return 0
10434 set cachearc [expr {$a - 1}]
10435 if {$a > $cachedarcs} {
10436 puts $f "1"
10437 close $f
10438 return 0
10440 return 1
10443 proc savecache {} {
10444 global nextarc cachedarcs cachearc allccache
10446 if {$nextarc == $cachedarcs} return
10447 set cachearc 0
10448 set cachedarcs $nextarc
10449 catch {
10450 set f [open $allccache w]
10451 puts $f [list 1 $cachedarcs]
10452 run writecache $f
10456 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10457 # or 0 if neither is true.
10458 proc anc_or_desc {a b} {
10459 global arcout arcstart arcend arcnos cached_isanc
10461 if {$arcnos($a) eq $arcnos($b)} {
10462 # Both are on the same arc(s); either both are the same BMP,
10463 # or if one is not a BMP, the other is also not a BMP or is
10464 # the BMP at end of the arc (and it only has 1 incoming arc).
10465 # Or both can be BMPs with no incoming arcs.
10466 if {$a eq $b || $arcnos($a) eq {}} {
10467 return 0
10469 # assert {[llength $arcnos($a)] == 1}
10470 set arc [lindex $arcnos($a) 0]
10471 set i [lsearch -exact $arcids($arc) $a]
10472 set j [lsearch -exact $arcids($arc) $b]
10473 if {$i < 0 || $i > $j} {
10474 return 1
10475 } else {
10476 return -1
10480 if {![info exists arcout($a)]} {
10481 set arc [lindex $arcnos($a) 0]
10482 if {[info exists arcend($arc)]} {
10483 set aend $arcend($arc)
10484 } else {
10485 set aend {}
10487 set a $arcstart($arc)
10488 } else {
10489 set aend $a
10491 if {![info exists arcout($b)]} {
10492 set arc [lindex $arcnos($b) 0]
10493 if {[info exists arcend($arc)]} {
10494 set bend $arcend($arc)
10495 } else {
10496 set bend {}
10498 set b $arcstart($arc)
10499 } else {
10500 set bend $b
10502 if {$a eq $bend} {
10503 return 1
10505 if {$b eq $aend} {
10506 return -1
10508 if {[info exists cached_isanc($a,$bend)]} {
10509 if {$cached_isanc($a,$bend)} {
10510 return 1
10513 if {[info exists cached_isanc($b,$aend)]} {
10514 if {$cached_isanc($b,$aend)} {
10515 return -1
10517 if {[info exists cached_isanc($a,$bend)]} {
10518 return 0
10522 set todo [list $a $b]
10523 set anc($a) a
10524 set anc($b) b
10525 for {set i 0} {$i < [llength $todo]} {incr i} {
10526 set x [lindex $todo $i]
10527 if {$anc($x) eq {}} {
10528 continue
10530 foreach arc $arcnos($x) {
10531 set xd $arcstart($arc)
10532 if {$xd eq $bend} {
10533 set cached_isanc($a,$bend) 1
10534 set cached_isanc($b,$aend) 0
10535 return 1
10536 } elseif {$xd eq $aend} {
10537 set cached_isanc($b,$aend) 1
10538 set cached_isanc($a,$bend) 0
10539 return -1
10541 if {![info exists anc($xd)]} {
10542 set anc($xd) $anc($x)
10543 lappend todo $xd
10544 } elseif {$anc($xd) ne $anc($x)} {
10545 set anc($xd) {}
10549 set cached_isanc($a,$bend) 0
10550 set cached_isanc($b,$aend) 0
10551 return 0
10554 # This identifies whether $desc has an ancestor that is
10555 # a growing tip of the graph and which is not an ancestor of $anc
10556 # and returns 0 if so and 1 if not.
10557 # If we subsequently discover a tag on such a growing tip, and that
10558 # turns out to be a descendent of $anc (which it could, since we
10559 # don't necessarily see children before parents), then $desc
10560 # isn't a good choice to display as a descendent tag of
10561 # $anc (since it is the descendent of another tag which is
10562 # a descendent of $anc). Similarly, $anc isn't a good choice to
10563 # display as a ancestor tag of $desc.
10565 proc is_certain {desc anc} {
10566 global arcnos arcout arcstart arcend growing problems
10568 set certain {}
10569 if {[llength $arcnos($anc)] == 1} {
10570 # tags on the same arc are certain
10571 if {$arcnos($desc) eq $arcnos($anc)} {
10572 return 1
10574 if {![info exists arcout($anc)]} {
10575 # if $anc is partway along an arc, use the start of the arc instead
10576 set a [lindex $arcnos($anc) 0]
10577 set anc $arcstart($a)
10580 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10581 set x $desc
10582 } else {
10583 set a [lindex $arcnos($desc) 0]
10584 set x $arcend($a)
10586 if {$x == $anc} {
10587 return 1
10589 set anclist [list $x]
10590 set dl($x) 1
10591 set nnh 1
10592 set ngrowanc 0
10593 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10594 set x [lindex $anclist $i]
10595 if {$dl($x)} {
10596 incr nnh -1
10598 set done($x) 1
10599 foreach a $arcout($x) {
10600 if {[info exists growing($a)]} {
10601 if {![info exists growanc($x)] && $dl($x)} {
10602 set growanc($x) 1
10603 incr ngrowanc
10605 } else {
10606 set y $arcend($a)
10607 if {[info exists dl($y)]} {
10608 if {$dl($y)} {
10609 if {!$dl($x)} {
10610 set dl($y) 0
10611 if {![info exists done($y)]} {
10612 incr nnh -1
10614 if {[info exists growanc($x)]} {
10615 incr ngrowanc -1
10617 set xl [list $y]
10618 for {set k 0} {$k < [llength $xl]} {incr k} {
10619 set z [lindex $xl $k]
10620 foreach c $arcout($z) {
10621 if {[info exists arcend($c)]} {
10622 set v $arcend($c)
10623 if {[info exists dl($v)] && $dl($v)} {
10624 set dl($v) 0
10625 if {![info exists done($v)]} {
10626 incr nnh -1
10628 if {[info exists growanc($v)]} {
10629 incr ngrowanc -1
10631 lappend xl $v
10638 } elseif {$y eq $anc || !$dl($x)} {
10639 set dl($y) 0
10640 lappend anclist $y
10641 } else {
10642 set dl($y) 1
10643 lappend anclist $y
10644 incr nnh
10649 foreach x [array names growanc] {
10650 if {$dl($x)} {
10651 return 0
10653 return 0
10655 return 1
10658 proc validate_arctags {a} {
10659 global arctags idtags
10661 set i -1
10662 set na $arctags($a)
10663 foreach id $arctags($a) {
10664 incr i
10665 if {![info exists idtags($id)]} {
10666 set na [lreplace $na $i $i]
10667 incr i -1
10670 set arctags($a) $na
10673 proc validate_archeads {a} {
10674 global archeads idheads
10676 set i -1
10677 set na $archeads($a)
10678 foreach id $archeads($a) {
10679 incr i
10680 if {![info exists idheads($id)]} {
10681 set na [lreplace $na $i $i]
10682 incr i -1
10685 set archeads($a) $na
10688 # Return the list of IDs that have tags that are descendents of id,
10689 # ignoring IDs that are descendents of IDs already reported.
10690 proc desctags {id} {
10691 global arcnos arcstart arcids arctags idtags allparents
10692 global growing cached_dtags
10694 if {![info exists allparents($id)]} {
10695 return {}
10697 set t1 [clock clicks -milliseconds]
10698 set argid $id
10699 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10700 # part-way along an arc; check that arc first
10701 set a [lindex $arcnos($id) 0]
10702 if {$arctags($a) ne {}} {
10703 validate_arctags $a
10704 set i [lsearch -exact $arcids($a) $id]
10705 set tid {}
10706 foreach t $arctags($a) {
10707 set j [lsearch -exact $arcids($a) $t]
10708 if {$j >= $i} break
10709 set tid $t
10711 if {$tid ne {}} {
10712 return $tid
10715 set id $arcstart($a)
10716 if {[info exists idtags($id)]} {
10717 return $id
10720 if {[info exists cached_dtags($id)]} {
10721 return $cached_dtags($id)
10724 set origid $id
10725 set todo [list $id]
10726 set queued($id) 1
10727 set nc 1
10728 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10729 set id [lindex $todo $i]
10730 set done($id) 1
10731 set ta [info exists hastaggedancestor($id)]
10732 if {!$ta} {
10733 incr nc -1
10735 # ignore tags on starting node
10736 if {!$ta && $i > 0} {
10737 if {[info exists idtags($id)]} {
10738 set tagloc($id) $id
10739 set ta 1
10740 } elseif {[info exists cached_dtags($id)]} {
10741 set tagloc($id) $cached_dtags($id)
10742 set ta 1
10745 foreach a $arcnos($id) {
10746 set d $arcstart($a)
10747 if {!$ta && $arctags($a) ne {}} {
10748 validate_arctags $a
10749 if {$arctags($a) ne {}} {
10750 lappend tagloc($id) [lindex $arctags($a) end]
10753 if {$ta || $arctags($a) ne {}} {
10754 set tomark [list $d]
10755 for {set j 0} {$j < [llength $tomark]} {incr j} {
10756 set dd [lindex $tomark $j]
10757 if {![info exists hastaggedancestor($dd)]} {
10758 if {[info exists done($dd)]} {
10759 foreach b $arcnos($dd) {
10760 lappend tomark $arcstart($b)
10762 if {[info exists tagloc($dd)]} {
10763 unset tagloc($dd)
10765 } elseif {[info exists queued($dd)]} {
10766 incr nc -1
10768 set hastaggedancestor($dd) 1
10772 if {![info exists queued($d)]} {
10773 lappend todo $d
10774 set queued($d) 1
10775 if {![info exists hastaggedancestor($d)]} {
10776 incr nc
10781 set tags {}
10782 foreach id [array names tagloc] {
10783 if {![info exists hastaggedancestor($id)]} {
10784 foreach t $tagloc($id) {
10785 if {[lsearch -exact $tags $t] < 0} {
10786 lappend tags $t
10791 set t2 [clock clicks -milliseconds]
10792 set loopix $i
10794 # remove tags that are descendents of other tags
10795 for {set i 0} {$i < [llength $tags]} {incr i} {
10796 set a [lindex $tags $i]
10797 for {set j 0} {$j < $i} {incr j} {
10798 set b [lindex $tags $j]
10799 set r [anc_or_desc $a $b]
10800 if {$r == 1} {
10801 set tags [lreplace $tags $j $j]
10802 incr j -1
10803 incr i -1
10804 } elseif {$r == -1} {
10805 set tags [lreplace $tags $i $i]
10806 incr i -1
10807 break
10812 if {[array names growing] ne {}} {
10813 # graph isn't finished, need to check if any tag could get
10814 # eclipsed by another tag coming later. Simply ignore any
10815 # tags that could later get eclipsed.
10816 set ctags {}
10817 foreach t $tags {
10818 if {[is_certain $t $origid]} {
10819 lappend ctags $t
10822 if {$tags eq $ctags} {
10823 set cached_dtags($origid) $tags
10824 } else {
10825 set tags $ctags
10827 } else {
10828 set cached_dtags($origid) $tags
10830 set t3 [clock clicks -milliseconds]
10831 if {0 && $t3 - $t1 >= 100} {
10832 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10833 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10835 return $tags
10838 proc anctags {id} {
10839 global arcnos arcids arcout arcend arctags idtags allparents
10840 global growing cached_atags
10842 if {![info exists allparents($id)]} {
10843 return {}
10845 set t1 [clock clicks -milliseconds]
10846 set argid $id
10847 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10848 # part-way along an arc; check that arc first
10849 set a [lindex $arcnos($id) 0]
10850 if {$arctags($a) ne {}} {
10851 validate_arctags $a
10852 set i [lsearch -exact $arcids($a) $id]
10853 foreach t $arctags($a) {
10854 set j [lsearch -exact $arcids($a) $t]
10855 if {$j > $i} {
10856 return $t
10860 if {![info exists arcend($a)]} {
10861 return {}
10863 set id $arcend($a)
10864 if {[info exists idtags($id)]} {
10865 return $id
10868 if {[info exists cached_atags($id)]} {
10869 return $cached_atags($id)
10872 set origid $id
10873 set todo [list $id]
10874 set queued($id) 1
10875 set taglist {}
10876 set nc 1
10877 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10878 set id [lindex $todo $i]
10879 set done($id) 1
10880 set td [info exists hastaggeddescendent($id)]
10881 if {!$td} {
10882 incr nc -1
10884 # ignore tags on starting node
10885 if {!$td && $i > 0} {
10886 if {[info exists idtags($id)]} {
10887 set tagloc($id) $id
10888 set td 1
10889 } elseif {[info exists cached_atags($id)]} {
10890 set tagloc($id) $cached_atags($id)
10891 set td 1
10894 foreach a $arcout($id) {
10895 if {!$td && $arctags($a) ne {}} {
10896 validate_arctags $a
10897 if {$arctags($a) ne {}} {
10898 lappend tagloc($id) [lindex $arctags($a) 0]
10901 if {![info exists arcend($a)]} continue
10902 set d $arcend($a)
10903 if {$td || $arctags($a) ne {}} {
10904 set tomark [list $d]
10905 for {set j 0} {$j < [llength $tomark]} {incr j} {
10906 set dd [lindex $tomark $j]
10907 if {![info exists hastaggeddescendent($dd)]} {
10908 if {[info exists done($dd)]} {
10909 foreach b $arcout($dd) {
10910 if {[info exists arcend($b)]} {
10911 lappend tomark $arcend($b)
10914 if {[info exists tagloc($dd)]} {
10915 unset tagloc($dd)
10917 } elseif {[info exists queued($dd)]} {
10918 incr nc -1
10920 set hastaggeddescendent($dd) 1
10924 if {![info exists queued($d)]} {
10925 lappend todo $d
10926 set queued($d) 1
10927 if {![info exists hastaggeddescendent($d)]} {
10928 incr nc
10933 set t2 [clock clicks -milliseconds]
10934 set loopix $i
10935 set tags {}
10936 foreach id [array names tagloc] {
10937 if {![info exists hastaggeddescendent($id)]} {
10938 foreach t $tagloc($id) {
10939 if {[lsearch -exact $tags $t] < 0} {
10940 lappend tags $t
10946 # remove tags that are ancestors of other tags
10947 for {set i 0} {$i < [llength $tags]} {incr i} {
10948 set a [lindex $tags $i]
10949 for {set j 0} {$j < $i} {incr j} {
10950 set b [lindex $tags $j]
10951 set r [anc_or_desc $a $b]
10952 if {$r == -1} {
10953 set tags [lreplace $tags $j $j]
10954 incr j -1
10955 incr i -1
10956 } elseif {$r == 1} {
10957 set tags [lreplace $tags $i $i]
10958 incr i -1
10959 break
10964 if {[array names growing] ne {}} {
10965 # graph isn't finished, need to check if any tag could get
10966 # eclipsed by another tag coming later. Simply ignore any
10967 # tags that could later get eclipsed.
10968 set ctags {}
10969 foreach t $tags {
10970 if {[is_certain $origid $t]} {
10971 lappend ctags $t
10974 if {$tags eq $ctags} {
10975 set cached_atags($origid) $tags
10976 } else {
10977 set tags $ctags
10979 } else {
10980 set cached_atags($origid) $tags
10982 set t3 [clock clicks -milliseconds]
10983 if {0 && $t3 - $t1 >= 100} {
10984 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10985 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10987 return $tags
10990 # Return the list of IDs that have heads that are descendents of id,
10991 # including id itself if it has a head.
10992 proc descheads {id} {
10993 global arcnos arcstart arcids archeads idheads cached_dheads
10994 global allparents arcout
10996 if {![info exists allparents($id)]} {
10997 return {}
10999 set aret {}
11000 if {![info exists arcout($id)]} {
11001 # part-way along an arc; check it first
11002 set a [lindex $arcnos($id) 0]
11003 if {$archeads($a) ne {}} {
11004 validate_archeads $a
11005 set i [lsearch -exact $arcids($a) $id]
11006 foreach t $archeads($a) {
11007 set j [lsearch -exact $arcids($a) $t]
11008 if {$j > $i} break
11009 lappend aret $t
11012 set id $arcstart($a)
11014 set origid $id
11015 set todo [list $id]
11016 set seen($id) 1
11017 set ret {}
11018 for {set i 0} {$i < [llength $todo]} {incr i} {
11019 set id [lindex $todo $i]
11020 if {[info exists cached_dheads($id)]} {
11021 set ret [concat $ret $cached_dheads($id)]
11022 } else {
11023 if {[info exists idheads($id)]} {
11024 lappend ret $id
11026 foreach a $arcnos($id) {
11027 if {$archeads($a) ne {}} {
11028 validate_archeads $a
11029 if {$archeads($a) ne {}} {
11030 set ret [concat $ret $archeads($a)]
11033 set d $arcstart($a)
11034 if {![info exists seen($d)]} {
11035 lappend todo $d
11036 set seen($d) 1
11041 set ret [lsort -unique $ret]
11042 set cached_dheads($origid) $ret
11043 return [concat $ret $aret]
11046 proc addedtag {id} {
11047 global arcnos arcout cached_dtags cached_atags
11049 if {![info exists arcnos($id)]} return
11050 if {![info exists arcout($id)]} {
11051 recalcarc [lindex $arcnos($id) 0]
11053 unset -nocomplain cached_dtags
11054 unset -nocomplain cached_atags
11057 proc addedhead {hid head} {
11058 global arcnos arcout cached_dheads
11060 if {![info exists arcnos($hid)]} return
11061 if {![info exists arcout($hid)]} {
11062 recalcarc [lindex $arcnos($hid) 0]
11064 unset -nocomplain cached_dheads
11067 proc removedhead {hid head} {
11068 global cached_dheads
11070 unset -nocomplain cached_dheads
11073 proc movedhead {hid head} {
11074 global arcnos arcout cached_dheads
11076 if {![info exists arcnos($hid)]} return
11077 if {![info exists arcout($hid)]} {
11078 recalcarc [lindex $arcnos($hid) 0]
11080 unset -nocomplain cached_dheads
11083 proc changedrefs {} {
11084 global cached_dheads cached_dtags cached_atags cached_tagcontent
11085 global arctags archeads arcnos arcout idheads idtags
11087 foreach id [concat [array names idheads] [array names idtags]] {
11088 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11089 set a [lindex $arcnos($id) 0]
11090 if {![info exists donearc($a)]} {
11091 recalcarc $a
11092 set donearc($a) 1
11096 unset -nocomplain cached_tagcontent
11097 unset -nocomplain cached_dtags
11098 unset -nocomplain cached_atags
11099 unset -nocomplain cached_dheads
11102 proc rereadrefs {} {
11103 global idtags idheads idotherrefs mainheadid
11105 set refids [concat [array names idtags] \
11106 [array names idheads] [array names idotherrefs]]
11107 foreach id $refids {
11108 if {![info exists ref($id)]} {
11109 set ref($id) [listrefs $id]
11112 set oldmainhead $mainheadid
11113 readrefs
11114 changedrefs
11115 set refids [lsort -unique [concat $refids [array names idtags] \
11116 [array names idheads] [array names idotherrefs]]]
11117 foreach id $refids {
11118 set v [listrefs $id]
11119 if {![info exists ref($id)] || $ref($id) != $v} {
11120 redrawtags $id
11123 if {$oldmainhead ne $mainheadid} {
11124 redrawtags $oldmainhead
11125 redrawtags $mainheadid
11127 run refill_reflist
11130 proc listrefs {id} {
11131 global idtags idheads idotherrefs
11133 set x {}
11134 if {[info exists idtags($id)]} {
11135 set x $idtags($id)
11137 set y {}
11138 if {[info exists idheads($id)]} {
11139 set y $idheads($id)
11141 set z {}
11142 if {[info exists idotherrefs($id)]} {
11143 set z $idotherrefs($id)
11145 return [list $x $y $z]
11148 proc add_tag_ctext {tag} {
11149 global ctext cached_tagcontent tagids
11151 if {![info exists cached_tagcontent($tag)]} {
11152 catch {
11153 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11156 $ctext insert end "[mc "Tag"]: $tag\n" bold
11157 if {[info exists cached_tagcontent($tag)]} {
11158 set text $cached_tagcontent($tag)
11159 } else {
11160 set text "[mc "Id"]: $tagids($tag)"
11162 appendwithlinks $text {}
11165 proc showtag {tag isnew} {
11166 global ctext cached_tagcontent tagids linknum tagobjid
11168 if {$isnew} {
11169 addtohistory [list showtag $tag 0] savectextpos
11171 $ctext conf -state normal
11172 clear_ctext
11173 settabs 0
11174 set linknum 0
11175 add_tag_ctext $tag
11176 maybe_scroll_ctext 1
11177 $ctext conf -state disabled
11178 init_flist {}
11181 proc showtags {id isnew} {
11182 global idtags ctext linknum
11184 if {$isnew} {
11185 addtohistory [list showtags $id 0] savectextpos
11187 $ctext conf -state normal
11188 clear_ctext
11189 settabs 0
11190 set linknum 0
11191 set sep {}
11192 foreach tag $idtags($id) {
11193 $ctext insert end $sep
11194 add_tag_ctext $tag
11195 set sep "\n\n"
11197 maybe_scroll_ctext 1
11198 $ctext conf -state disabled
11199 init_flist {}
11202 proc doquit {} {
11203 global stopped
11204 global gitktmpdir
11206 set stopped 100
11207 savestuff .
11208 destroy .
11210 if {[info exists gitktmpdir]} {
11211 catch {file delete -force $gitktmpdir}
11215 proc mkfontdisp {font top which} {
11216 global fontattr fontpref $font NS use_ttk
11218 set fontpref($font) [set $font]
11219 ${NS}::button $top.${font}but -text $which \
11220 -command [list choosefont $font $which]
11221 ${NS}::label $top.$font -relief flat -font $font \
11222 -text $fontattr($font,family) -justify left
11223 grid x $top.${font}but $top.$font -sticky w
11226 proc choosefont {font which} {
11227 global fontparam fontlist fonttop fontattr
11228 global prefstop NS
11230 set fontparam(which) $which
11231 set fontparam(font) $font
11232 set fontparam(family) [font actual $font -family]
11233 set fontparam(size) $fontattr($font,size)
11234 set fontparam(weight) $fontattr($font,weight)
11235 set fontparam(slant) $fontattr($font,slant)
11236 set top .gitkfont
11237 set fonttop $top
11238 if {![winfo exists $top]} {
11239 font create sample
11240 eval font config sample [font actual $font]
11241 ttk_toplevel $top
11242 make_transient $top $prefstop
11243 wm title $top [mc "Gitk font chooser"]
11244 ${NS}::label $top.l -textvariable fontparam(which)
11245 pack $top.l -side top
11246 set fontlist [lsort [font families]]
11247 ${NS}::frame $top.f
11248 listbox $top.f.fam -listvariable fontlist \
11249 -yscrollcommand [list $top.f.sb set]
11250 bind $top.f.fam <<ListboxSelect>> selfontfam
11251 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11252 pack $top.f.sb -side right -fill y
11253 pack $top.f.fam -side left -fill both -expand 1
11254 pack $top.f -side top -fill both -expand 1
11255 ${NS}::frame $top.g
11256 spinbox $top.g.size -from 4 -to 40 -width 4 \
11257 -textvariable fontparam(size) \
11258 -validatecommand {string is integer -strict %s}
11259 checkbutton $top.g.bold -padx 5 \
11260 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11261 -variable fontparam(weight) -onvalue bold -offvalue normal
11262 checkbutton $top.g.ital -padx 5 \
11263 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11264 -variable fontparam(slant) -onvalue italic -offvalue roman
11265 pack $top.g.size $top.g.bold $top.g.ital -side left
11266 pack $top.g -side top
11267 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11268 -background white
11269 $top.c create text 100 25 -anchor center -text $which -font sample \
11270 -fill black -tags text
11271 bind $top.c <Configure> [list centertext $top.c]
11272 pack $top.c -side top -fill x
11273 ${NS}::frame $top.buts
11274 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11275 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11276 bind $top <Key-Return> fontok
11277 bind $top <Key-Escape> fontcan
11278 grid $top.buts.ok $top.buts.can
11279 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11280 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11281 pack $top.buts -side bottom -fill x
11282 trace add variable fontparam write chg_fontparam
11283 } else {
11284 raise $top
11285 $top.c itemconf text -text $which
11287 set i [lsearch -exact $fontlist $fontparam(family)]
11288 if {$i >= 0} {
11289 $top.f.fam selection set $i
11290 $top.f.fam see $i
11294 proc centertext {w} {
11295 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11298 proc fontok {} {
11299 global fontparam fontpref prefstop
11301 set f $fontparam(font)
11302 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11303 if {$fontparam(weight) eq "bold"} {
11304 lappend fontpref($f) "bold"
11306 if {$fontparam(slant) eq "italic"} {
11307 lappend fontpref($f) "italic"
11309 set w $prefstop.notebook.fonts.$f
11310 $w conf -text $fontparam(family) -font $fontpref($f)
11312 fontcan
11315 proc fontcan {} {
11316 global fonttop fontparam
11318 if {[info exists fonttop]} {
11319 catch {destroy $fonttop}
11320 catch {font delete sample}
11321 unset fonttop
11322 unset fontparam
11326 if {[package vsatisfies [package provide Tk] 8.6]} {
11327 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11328 # function to make use of it.
11329 proc choosefont {font which} {
11330 tk fontchooser configure -title $which -font $font \
11331 -command [list on_choosefont $font $which]
11332 tk fontchooser show
11334 proc on_choosefont {font which newfont} {
11335 global fontparam
11336 puts stderr "$font $newfont"
11337 array set f [font actual $newfont]
11338 set fontparam(which) $which
11339 set fontparam(font) $font
11340 set fontparam(family) $f(-family)
11341 set fontparam(size) $f(-size)
11342 set fontparam(weight) $f(-weight)
11343 set fontparam(slant) $f(-slant)
11344 fontok
11348 proc selfontfam {} {
11349 global fonttop fontparam
11351 set i [$fonttop.f.fam curselection]
11352 if {$i ne {}} {
11353 set fontparam(family) [$fonttop.f.fam get $i]
11357 proc chg_fontparam {v sub op} {
11358 global fontparam
11360 font config sample -$sub $fontparam($sub)
11363 # Create a property sheet tab page
11364 proc create_prefs_page {w} {
11365 global NS
11366 set parent [join [lrange [split $w .] 0 end-1] .]
11367 if {[winfo class $parent] eq "TNotebook"} {
11368 ${NS}::frame $w
11369 } else {
11370 ${NS}::labelframe $w
11374 proc prefspage_general {notebook} {
11375 global NS maxwidth maxgraphpct showneartags showlocalchanges
11376 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11377 global hideremotes want_ttk have_ttk maxrefs
11379 set page [create_prefs_page $notebook.general]
11381 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11382 grid $page.ldisp - -sticky w -pady 10
11383 ${NS}::label $page.spacer -text " "
11384 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11385 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11386 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11387 #xgettext:no-tcl-format
11388 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11389 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11390 grid x $page.maxpctl $page.maxpct -sticky w
11391 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11392 -variable showlocalchanges
11393 grid x $page.showlocal -sticky w
11394 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11395 -variable autoselect
11396 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11397 grid x $page.autoselect $page.autosellen -sticky w
11398 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11399 -variable hideremotes
11400 grid x $page.hideremotes -sticky w
11402 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11403 grid $page.ddisp - -sticky w -pady 10
11404 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11405 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11406 grid x $page.tabstopl $page.tabstop -sticky w
11407 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11408 -variable showneartags
11409 grid x $page.ntag -sticky w
11410 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11411 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11412 grid x $page.maxrefsl $page.maxrefs -sticky w
11413 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11414 -variable limitdiffs
11415 grid x $page.ldiff -sticky w
11416 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11417 -variable perfile_attrs
11418 grid x $page.lattr -sticky w
11420 ${NS}::entry $page.extdifft -textvariable extdifftool
11421 ${NS}::frame $page.extdifff
11422 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11423 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11424 pack $page.extdifff.l $page.extdifff.b -side left
11425 pack configure $page.extdifff.l -padx 10
11426 grid x $page.extdifff $page.extdifft -sticky ew
11428 ${NS}::label $page.lgen -text [mc "General options"]
11429 grid $page.lgen - -sticky w -pady 10
11430 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11431 -text [mc "Use themed widgets"]
11432 if {$have_ttk} {
11433 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11434 } else {
11435 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11437 grid x $page.want_ttk $page.ttk_note -sticky w
11438 return $page
11441 proc prefspage_colors {notebook} {
11442 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11444 set page [create_prefs_page $notebook.colors]
11446 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11447 grid $page.cdisp - -sticky w -pady 10
11448 label $page.ui -padx 40 -relief sunk -background $uicolor
11449 ${NS}::button $page.uibut -text [mc "Interface"] \
11450 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11451 grid x $page.uibut $page.ui -sticky w
11452 label $page.bg -padx 40 -relief sunk -background $bgcolor
11453 ${NS}::button $page.bgbut -text [mc "Background"] \
11454 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11455 grid x $page.bgbut $page.bg -sticky w
11456 label $page.fg -padx 40 -relief sunk -background $fgcolor
11457 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11458 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11459 grid x $page.fgbut $page.fg -sticky w
11460 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11461 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11462 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11463 [list $ctext tag conf d0 -foreground]]
11464 grid x $page.diffoldbut $page.diffold -sticky w
11465 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11466 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11467 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11468 [list $ctext tag conf dresult -foreground]]
11469 grid x $page.diffnewbut $page.diffnew -sticky w
11470 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11471 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11472 -command [list choosecolor diffcolors 2 $page.hunksep \
11473 [mc "diff hunk header"] \
11474 [list $ctext tag conf hunksep -foreground]]
11475 grid x $page.hunksepbut $page.hunksep -sticky w
11476 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11477 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11478 -command [list choosecolor markbgcolor {} $page.markbgsep \
11479 [mc "marked line background"] \
11480 [list $ctext tag conf omark -background]]
11481 grid x $page.markbgbut $page.markbgsep -sticky w
11482 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11483 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11484 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11485 grid x $page.selbgbut $page.selbgsep -sticky w
11486 return $page
11489 proc prefspage_fonts {notebook} {
11490 global NS
11491 set page [create_prefs_page $notebook.fonts]
11492 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11493 grid $page.cfont - -sticky w -pady 10
11494 mkfontdisp mainfont $page [mc "Main font"]
11495 mkfontdisp textfont $page [mc "Diff display font"]
11496 mkfontdisp uifont $page [mc "User interface font"]
11497 return $page
11500 proc doprefs {} {
11501 global maxwidth maxgraphpct use_ttk NS
11502 global oldprefs prefstop showneartags showlocalchanges
11503 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11504 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11505 global hideremotes want_ttk have_ttk
11507 set top .gitkprefs
11508 set prefstop $top
11509 if {[winfo exists $top]} {
11510 raise $top
11511 return
11513 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11514 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11515 set oldprefs($v) [set $v]
11517 ttk_toplevel $top
11518 wm title $top [mc "Gitk preferences"]
11519 make_transient $top .
11521 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11522 set notebook [ttk::notebook $top.notebook]
11523 } else {
11524 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11527 lappend pages [prefspage_general $notebook] [mc "General"]
11528 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11529 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11530 set col 0
11531 foreach {page title} $pages {
11532 if {$use_notebook} {
11533 $notebook add $page -text $title
11534 } else {
11535 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11536 -text $title -command [list raise $page]]
11537 $page configure -text $title
11538 grid $btn -row 0 -column [incr col] -sticky w
11539 grid $page -row 1 -column 0 -sticky news -columnspan 100
11543 if {!$use_notebook} {
11544 grid columnconfigure $notebook 0 -weight 1
11545 grid rowconfigure $notebook 1 -weight 1
11546 raise [lindex $pages 0]
11549 grid $notebook -sticky news -padx 2 -pady 2
11550 grid rowconfigure $top 0 -weight 1
11551 grid columnconfigure $top 0 -weight 1
11553 ${NS}::frame $top.buts
11554 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11555 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11556 bind $top <Key-Return> prefsok
11557 bind $top <Key-Escape> prefscan
11558 grid $top.buts.ok $top.buts.can
11559 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11560 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11561 grid $top.buts - - -pady 10 -sticky ew
11562 grid columnconfigure $top 2 -weight 1
11563 bind $top <Visibility> [list focus $top.buts.ok]
11566 proc choose_extdiff {} {
11567 global extdifftool
11569 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11570 if {$prog ne {}} {
11571 set extdifftool $prog
11575 proc choosecolor {v vi w x cmd} {
11576 global $v
11578 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11579 -title [mc "Gitk: choose color for %s" $x]]
11580 if {$c eq {}} return
11581 $w conf -background $c
11582 lset $v $vi $c
11583 eval $cmd $c
11586 proc setselbg {c} {
11587 global bglist cflist
11588 foreach w $bglist {
11589 if {[winfo exists $w]} {
11590 $w configure -selectbackground $c
11593 $cflist tag configure highlight \
11594 -background [$cflist cget -selectbackground]
11595 allcanvs itemconf secsel -fill $c
11598 # This sets the background color and the color scheme for the whole UI.
11599 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11600 # if we don't specify one ourselves, which makes the checkbuttons and
11601 # radiobuttons look bad. This chooses white for selectColor if the
11602 # background color is light, or black if it is dark.
11603 proc setui {c} {
11604 if {[tk windowingsystem] eq "win32"} { return }
11605 set bg [winfo rgb . $c]
11606 set selc black
11607 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11608 set selc white
11610 tk_setPalette background $c selectColor $selc
11613 proc setbg {c} {
11614 global bglist
11616 foreach w $bglist {
11617 if {[winfo exists $w]} {
11618 $w conf -background $c
11623 proc setfg {c} {
11624 global fglist canv
11626 foreach w $fglist {
11627 if {[winfo exists $w]} {
11628 $w conf -foreground $c
11631 allcanvs itemconf text -fill $c
11632 $canv itemconf circle -outline $c
11633 $canv itemconf markid -outline $c
11636 proc prefscan {} {
11637 global oldprefs prefstop
11639 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11640 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11641 global $v
11642 set $v $oldprefs($v)
11644 catch {destroy $prefstop}
11645 unset prefstop
11646 fontcan
11649 proc prefsok {} {
11650 global maxwidth maxgraphpct
11651 global oldprefs prefstop showneartags showlocalchanges
11652 global fontpref mainfont textfont uifont
11653 global limitdiffs treediffs perfile_attrs
11654 global hideremotes
11656 catch {destroy $prefstop}
11657 unset prefstop
11658 fontcan
11659 set fontchanged 0
11660 if {$mainfont ne $fontpref(mainfont)} {
11661 set mainfont $fontpref(mainfont)
11662 parsefont mainfont $mainfont
11663 eval font configure mainfont [fontflags mainfont]
11664 eval font configure mainfontbold [fontflags mainfont 1]
11665 setcoords
11666 set fontchanged 1
11668 if {$textfont ne $fontpref(textfont)} {
11669 set textfont $fontpref(textfont)
11670 parsefont textfont $textfont
11671 eval font configure textfont [fontflags textfont]
11672 eval font configure textfontbold [fontflags textfont 1]
11674 if {$uifont ne $fontpref(uifont)} {
11675 set uifont $fontpref(uifont)
11676 parsefont uifont $uifont
11677 eval font configure uifont [fontflags uifont]
11679 settabs
11680 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11681 if {$showlocalchanges} {
11682 doshowlocalchanges
11683 } else {
11684 dohidelocalchanges
11687 if {$limitdiffs != $oldprefs(limitdiffs) ||
11688 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11689 # treediffs elements are limited by path;
11690 # won't have encodings cached if perfile_attrs was just turned on
11691 unset -nocomplain treediffs
11693 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11694 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11695 redisplay
11696 } elseif {$showneartags != $oldprefs(showneartags) ||
11697 $limitdiffs != $oldprefs(limitdiffs)} {
11698 reselectline
11700 if {$hideremotes != $oldprefs(hideremotes)} {
11701 rereadrefs
11705 proc formatdate {d} {
11706 global datetimeformat
11707 if {$d ne {}} {
11708 # If $datetimeformat includes a timezone, display in the
11709 # timezone of the argument. Otherwise, display in local time.
11710 if {[string match {*%[zZ]*} $datetimeformat]} {
11711 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11712 # Tcl < 8.5 does not support -timezone. Emulate it by
11713 # setting TZ (e.g. TZ=<-0430>+04:30).
11714 global env
11715 if {[info exists env(TZ)]} {
11716 set savedTZ $env(TZ)
11718 set zone [lindex $d 1]
11719 set sign [string map {+ - - +} [string index $zone 0]]
11720 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11721 set d [clock format [lindex $d 0] -format $datetimeformat]
11722 if {[info exists savedTZ]} {
11723 set env(TZ) $savedTZ
11724 } else {
11725 unset env(TZ)
11728 } else {
11729 set d [clock format [lindex $d 0] -format $datetimeformat]
11732 return $d
11735 # This list of encoding names and aliases is distilled from
11736 # http://www.iana.org/assignments/character-sets.
11737 # Not all of them are supported by Tcl.
11738 set encoding_aliases {
11739 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11740 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11741 { ISO-10646-UTF-1 csISO10646UTF1 }
11742 { ISO_646.basic:1983 ref csISO646basic1983 }
11743 { INVARIANT csINVARIANT }
11744 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11745 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11746 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11747 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11748 { NATS-DANO iso-ir-9-1 csNATSDANO }
11749 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11750 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11751 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11752 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11753 { ISO-2022-KR csISO2022KR }
11754 { EUC-KR csEUCKR }
11755 { ISO-2022-JP csISO2022JP }
11756 { ISO-2022-JP-2 csISO2022JP2 }
11757 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11758 csISO13JISC6220jp }
11759 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11760 { IT iso-ir-15 ISO646-IT csISO15Italian }
11761 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11762 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11763 { greek7-old iso-ir-18 csISO18Greek7Old }
11764 { latin-greek iso-ir-19 csISO19LatinGreek }
11765 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11766 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11767 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11768 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11769 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11770 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11771 { INIS iso-ir-49 csISO49INIS }
11772 { INIS-8 iso-ir-50 csISO50INIS8 }
11773 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11774 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11775 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11776 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11777 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11778 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11779 csISO60Norwegian1 }
11780 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11781 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11782 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11783 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11784 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11785 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11786 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11787 { greek7 iso-ir-88 csISO88Greek7 }
11788 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11789 { iso-ir-90 csISO90 }
11790 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11791 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11792 csISO92JISC62991984b }
11793 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11794 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11795 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11796 csISO95JIS62291984handadd }
11797 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11798 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11799 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11800 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11801 CP819 csISOLatin1 }
11802 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11803 { T.61-7bit iso-ir-102 csISO102T617bit }
11804 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11805 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11806 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11807 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11808 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11809 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11810 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11811 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11812 arabic csISOLatinArabic }
11813 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11814 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11815 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11816 greek greek8 csISOLatinGreek }
11817 { T.101-G2 iso-ir-128 csISO128T101G2 }
11818 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11819 csISOLatinHebrew }
11820 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11821 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11822 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11823 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11824 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11825 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11826 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11827 csISOLatinCyrillic }
11828 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11829 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11830 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11831 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11832 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11833 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11834 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11835 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11836 { ISO_10367-box iso-ir-155 csISO10367Box }
11837 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11838 { latin-lap lap iso-ir-158 csISO158Lap }
11839 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11840 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11841 { us-dk csUSDK }
11842 { dk-us csDKUS }
11843 { JIS_X0201 X0201 csHalfWidthKatakana }
11844 { KSC5636 ISO646-KR csKSC5636 }
11845 { ISO-10646-UCS-2 csUnicode }
11846 { ISO-10646-UCS-4 csUCS4 }
11847 { DEC-MCS dec csDECMCS }
11848 { hp-roman8 roman8 r8 csHPRoman8 }
11849 { macintosh mac csMacintosh }
11850 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11851 csIBM037 }
11852 { IBM038 EBCDIC-INT cp038 csIBM038 }
11853 { IBM273 CP273 csIBM273 }
11854 { IBM274 EBCDIC-BE CP274 csIBM274 }
11855 { IBM275 EBCDIC-BR cp275 csIBM275 }
11856 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11857 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11858 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11859 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11860 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11861 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11862 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11863 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11864 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11865 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11866 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11867 { IBM437 cp437 437 csPC8CodePage437 }
11868 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11869 { IBM775 cp775 csPC775Baltic }
11870 { IBM850 cp850 850 csPC850Multilingual }
11871 { IBM851 cp851 851 csIBM851 }
11872 { IBM852 cp852 852 csPCp852 }
11873 { IBM855 cp855 855 csIBM855 }
11874 { IBM857 cp857 857 csIBM857 }
11875 { IBM860 cp860 860 csIBM860 }
11876 { IBM861 cp861 861 cp-is csIBM861 }
11877 { IBM862 cp862 862 csPC862LatinHebrew }
11878 { IBM863 cp863 863 csIBM863 }
11879 { IBM864 cp864 csIBM864 }
11880 { IBM865 cp865 865 csIBM865 }
11881 { IBM866 cp866 866 csIBM866 }
11882 { IBM868 CP868 cp-ar csIBM868 }
11883 { IBM869 cp869 869 cp-gr csIBM869 }
11884 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11885 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11886 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11887 { IBM891 cp891 csIBM891 }
11888 { IBM903 cp903 csIBM903 }
11889 { IBM904 cp904 904 csIBBM904 }
11890 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11891 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11892 { IBM1026 CP1026 csIBM1026 }
11893 { EBCDIC-AT-DE csIBMEBCDICATDE }
11894 { EBCDIC-AT-DE-A csEBCDICATDEA }
11895 { EBCDIC-CA-FR csEBCDICCAFR }
11896 { EBCDIC-DK-NO csEBCDICDKNO }
11897 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11898 { EBCDIC-FI-SE csEBCDICFISE }
11899 { EBCDIC-FI-SE-A csEBCDICFISEA }
11900 { EBCDIC-FR csEBCDICFR }
11901 { EBCDIC-IT csEBCDICIT }
11902 { EBCDIC-PT csEBCDICPT }
11903 { EBCDIC-ES csEBCDICES }
11904 { EBCDIC-ES-A csEBCDICESA }
11905 { EBCDIC-ES-S csEBCDICESS }
11906 { EBCDIC-UK csEBCDICUK }
11907 { EBCDIC-US csEBCDICUS }
11908 { UNKNOWN-8BIT csUnknown8BiT }
11909 { MNEMONIC csMnemonic }
11910 { MNEM csMnem }
11911 { VISCII csVISCII }
11912 { VIQR csVIQR }
11913 { KOI8-R csKOI8R }
11914 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11915 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11916 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11917 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11918 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11919 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11920 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11921 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11922 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11923 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11924 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11925 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11926 { IBM1047 IBM-1047 }
11927 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11928 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11929 { UNICODE-1-1 csUnicode11 }
11930 { CESU-8 csCESU-8 }
11931 { BOCU-1 csBOCU-1 }
11932 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11933 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11934 l8 }
11935 { ISO-8859-15 ISO_8859-15 Latin-9 }
11936 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11937 { GBK CP936 MS936 windows-936 }
11938 { JIS_Encoding csJISEncoding }
11939 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11940 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11941 EUC-JP }
11942 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11943 { ISO-10646-UCS-Basic csUnicodeASCII }
11944 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11945 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11946 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11947 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11948 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11949 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11950 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11951 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11952 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11953 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11954 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11955 { Ventura-US csVenturaUS }
11956 { Ventura-International csVenturaInternational }
11957 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11958 { PC8-Turkish csPC8Turkish }
11959 { IBM-Symbols csIBMSymbols }
11960 { IBM-Thai csIBMThai }
11961 { HP-Legal csHPLegal }
11962 { HP-Pi-font csHPPiFont }
11963 { HP-Math8 csHPMath8 }
11964 { Adobe-Symbol-Encoding csHPPSMath }
11965 { HP-DeskTop csHPDesktop }
11966 { Ventura-Math csVenturaMath }
11967 { Microsoft-Publishing csMicrosoftPublishing }
11968 { Windows-31J csWindows31J }
11969 { GB2312 csGB2312 }
11970 { Big5 csBig5 }
11973 proc tcl_encoding {enc} {
11974 global encoding_aliases tcl_encoding_cache
11975 if {[info exists tcl_encoding_cache($enc)]} {
11976 return $tcl_encoding_cache($enc)
11978 set names [encoding names]
11979 set lcnames [string tolower $names]
11980 set enc [string tolower $enc]
11981 set i [lsearch -exact $lcnames $enc]
11982 if {$i < 0} {
11983 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11984 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11985 set i [lsearch -exact $lcnames $encx]
11988 if {$i < 0} {
11989 foreach l $encoding_aliases {
11990 set ll [string tolower $l]
11991 if {[lsearch -exact $ll $enc] < 0} continue
11992 # look through the aliases for one that tcl knows about
11993 foreach e $ll {
11994 set i [lsearch -exact $lcnames $e]
11995 if {$i < 0} {
11996 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11997 set i [lsearch -exact $lcnames $ex]
12000 if {$i >= 0} break
12002 break
12005 set tclenc {}
12006 if {$i >= 0} {
12007 set tclenc [lindex $names $i]
12009 set tcl_encoding_cache($enc) $tclenc
12010 return $tclenc
12013 proc gitattr {path attr default} {
12014 global path_attr_cache
12015 if {[info exists path_attr_cache($attr,$path)]} {
12016 set r $path_attr_cache($attr,$path)
12017 } else {
12018 set r "unspecified"
12019 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
12020 regexp "(.*): $attr: (.*)" $line m f r
12022 set path_attr_cache($attr,$path) $r
12024 if {$r eq "unspecified"} {
12025 return $default
12027 return $r
12030 proc cache_gitattr {attr pathlist} {
12031 global path_attr_cache
12032 set newlist {}
12033 foreach path $pathlist {
12034 if {![info exists path_attr_cache($attr,$path)]} {
12035 lappend newlist $path
12038 set lim 1000
12039 if {[tk windowingsystem] == "win32"} {
12040 # windows has a 32k limit on the arguments to a command...
12041 set lim 30
12043 while {$newlist ne {}} {
12044 set head [lrange $newlist 0 [expr {$lim - 1}]]
12045 set newlist [lrange $newlist $lim end]
12046 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
12047 foreach row [split $rlist "\n"] {
12048 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12049 if {[string index $path 0] eq "\""} {
12050 set path [encoding convertfrom [lindex $path 0]]
12052 set path_attr_cache($attr,$path) $value
12059 proc get_path_encoding {path} {
12060 global gui_encoding perfile_attrs
12061 set tcl_enc $gui_encoding
12062 if {$path ne {} && $perfile_attrs} {
12063 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12064 if {$enc2 ne {}} {
12065 set tcl_enc $enc2
12068 return $tcl_enc
12071 ## For msgcat loading, first locate the installation location.
12072 if { [info exists ::env(GITK_MSGSDIR)] } {
12073 ## Msgsdir was manually set in the environment.
12074 set gitk_msgsdir $::env(GITK_MSGSDIR)
12075 } else {
12076 ## Let's guess the prefix from argv0.
12077 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12078 set gitk_libdir [file join $gitk_prefix share gitk lib]
12079 set gitk_msgsdir [file join $gitk_libdir msgs]
12080 unset gitk_prefix
12083 ## Internationalization (i18n) through msgcat and gettext. See
12084 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12085 package require msgcat
12086 namespace import ::msgcat::mc
12087 ## And eventually load the actual message catalog
12088 ::msgcat::mcload $gitk_msgsdir
12090 # First check that Tcl/Tk is recent enough
12091 if {[catch {package require Tk 8.4} err]} {
12092 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12093 Gitk requires at least Tcl/Tk 8.4."]
12094 exit 1
12097 # on OSX bring the current Wish process window to front
12098 if {[tk windowingsystem] eq "aqua"} {
12099 exec osascript -e [format {
12100 tell application "System Events"
12101 set frontmost of processes whose unix id is %d to true
12102 end tell
12103 } [pid] ]
12106 # Unset GIT_TRACE var if set
12107 if { [info exists ::env(GIT_TRACE)] } {
12108 unset ::env(GIT_TRACE)
12111 # defaults...
12112 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12114 set gitencoding {}
12115 catch {
12116 set gitencoding [exec git config --get i18n.commitencoding]
12118 catch {
12119 set gitencoding [exec git config --get i18n.logoutputencoding]
12121 if {$gitencoding == ""} {
12122 set gitencoding "utf-8"
12124 set tclencoding [tcl_encoding $gitencoding]
12125 if {$tclencoding == {}} {
12126 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12129 set gui_encoding [encoding system]
12130 catch {
12131 set enc [exec git config --get gui.encoding]
12132 if {$enc ne {}} {
12133 set tclenc [tcl_encoding $enc]
12134 if {$tclenc ne {}} {
12135 set gui_encoding $tclenc
12136 } else {
12137 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12142 set log_showroot true
12143 catch {
12144 set log_showroot [exec git config --bool --get log.showroot]
12147 if {[tk windowingsystem] eq "aqua"} {
12148 set mainfont {{Lucida Grande} 9}
12149 set textfont {Monaco 9}
12150 set uifont {{Lucida Grande} 9 bold}
12151 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12152 # fontconfig!
12153 set mainfont {sans 9}
12154 set textfont {monospace 9}
12155 set uifont {sans 9 bold}
12156 } else {
12157 set mainfont {Helvetica 9}
12158 set textfont {Courier 9}
12159 set uifont {Helvetica 9 bold}
12161 set tabstop 8
12162 set findmergefiles 0
12163 set maxgraphpct 50
12164 set maxwidth 16
12165 set revlistorder 0
12166 set fastdate 0
12167 set uparrowlen 5
12168 set downarrowlen 5
12169 set mingaplen 100
12170 set cmitmode "patch"
12171 set wrapcomment "none"
12172 set showneartags 1
12173 set hideremotes 0
12174 set maxrefs 20
12175 set visiblerefs {"master"}
12176 set maxlinelen 200
12177 set showlocalchanges 1
12178 set limitdiffs 1
12179 set datetimeformat "%Y-%m-%d %H:%M:%S"
12180 set autoselect 1
12181 set autosellen 40
12182 set perfile_attrs 0
12183 set want_ttk 1
12185 if {[tk windowingsystem] eq "aqua"} {
12186 set extdifftool "opendiff"
12187 } else {
12188 set extdifftool "meld"
12191 set colors {lime red blue magenta darkgrey brown orange}
12192 if {[tk windowingsystem] eq "win32"} {
12193 set uicolor SystemButtonFace
12194 set uifgcolor SystemButtonText
12195 set uifgdisabledcolor SystemDisabledText
12196 set bgcolor SystemWindow
12197 set fgcolor SystemWindowText
12198 set selectbgcolor SystemHighlight
12199 } else {
12200 set uicolor grey85
12201 set uifgcolor black
12202 set uifgdisabledcolor "#999"
12203 set bgcolor white
12204 set fgcolor black
12205 set selectbgcolor gray85
12207 set diffcolors {red "#00a000" blue}
12208 set diffcontext 3
12209 set mergecolors {red blue lime purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12210 set ignorespace 0
12211 set worddiff ""
12212 set markbgcolor "#e0e0ff"
12214 set headbgcolor lime
12215 set headfgcolor black
12216 set headoutlinecolor black
12217 set remotebgcolor #ffddaa
12218 set tagbgcolor yellow
12219 set tagfgcolor black
12220 set tagoutlinecolor black
12221 set reflinecolor black
12222 set filesepbgcolor #aaaaaa
12223 set filesepfgcolor black
12224 set linehoverbgcolor #ffff80
12225 set linehoverfgcolor black
12226 set linehoveroutlinecolor black
12227 set mainheadcirclecolor yellow
12228 set workingfilescirclecolor red
12229 set indexcirclecolor lime
12230 set circlecolors {white blue gray blue blue}
12231 set linkfgcolor blue
12232 set circleoutlinecolor $fgcolor
12233 set foundbgcolor yellow
12234 set currentsearchhitbgcolor orange
12236 # button for popping up context menus
12237 if {[tk windowingsystem] eq "aqua"} {
12238 set ctxbut <Button-2>
12239 } else {
12240 set ctxbut <Button-3>
12243 catch {
12244 # follow the XDG base directory specification by default. See
12245 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12246 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12247 # XDG_CONFIG_HOME environment variable is set
12248 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12249 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12250 } else {
12251 # default XDG_CONFIG_HOME
12252 set config_file "~/.config/git/gitk"
12253 set config_file_tmp "~/.config/git/gitk-tmp"
12255 if {![file exists $config_file]} {
12256 # for backward compatibility use the old config file if it exists
12257 if {[file exists "~/.gitk"]} {
12258 set config_file "~/.gitk"
12259 set config_file_tmp "~/.gitk-tmp"
12260 } elseif {![file exists [file dirname $config_file]]} {
12261 file mkdir [file dirname $config_file]
12264 source $config_file
12266 config_check_tmp_exists 50
12268 set config_variables {
12269 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12270 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12271 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12272 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12273 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12274 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12275 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12276 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12277 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12278 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12280 foreach var $config_variables {
12281 config_init_trace $var
12282 trace add variable $var write config_variable_change_cb
12285 parsefont mainfont $mainfont
12286 eval font create mainfont [fontflags mainfont]
12287 eval font create mainfontbold [fontflags mainfont 1]
12289 parsefont textfont $textfont
12290 eval font create textfont [fontflags textfont]
12291 eval font create textfontbold [fontflags textfont 1]
12293 parsefont uifont $uifont
12294 eval font create uifont [fontflags uifont]
12296 setui $uicolor
12298 setoptions
12300 # check that we can find a .git directory somewhere...
12301 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12302 show_error {} . [mc "Cannot find a git repository here."]
12303 exit 1
12306 set selecthead {}
12307 set selectheadid {}
12309 set revtreeargs {}
12310 set cmdline_files {}
12311 set i 0
12312 set revtreeargscmd {}
12313 foreach arg $argv {
12314 switch -glob -- $arg {
12315 "" { }
12316 "--" {
12317 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12318 break
12320 "--select-commit=*" {
12321 set selecthead [string range $arg 16 end]
12323 "--argscmd=*" {
12324 set revtreeargscmd [string range $arg 10 end]
12326 default {
12327 lappend revtreeargs $arg
12330 incr i
12333 if {$selecthead eq "HEAD"} {
12334 set selecthead {}
12337 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12338 # no -- on command line, but some arguments (other than --argscmd)
12339 if {[catch {
12340 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12341 set cmdline_files [split $f "\n"]
12342 set n [llength $cmdline_files]
12343 set revtreeargs [lrange $revtreeargs 0 end-$n]
12344 # Unfortunately git rev-parse doesn't produce an error when
12345 # something is both a revision and a filename. To be consistent
12346 # with git log and git rev-list, check revtreeargs for filenames.
12347 foreach arg $revtreeargs {
12348 if {[file exists $arg]} {
12349 show_error {} . [mc "Ambiguous argument '%s': both revision\
12350 and filename" $arg]
12351 exit 1
12354 } err]} {
12355 # unfortunately we get both stdout and stderr in $err,
12356 # so look for "fatal:".
12357 set i [string first "fatal:" $err]
12358 if {$i > 0} {
12359 set err [string range $err [expr {$i + 6}] end]
12361 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12362 exit 1
12366 set nullid "0000000000000000000000000000000000000000"
12367 set nullid2 "0000000000000000000000000000000000000001"
12368 set nullfile "/dev/null"
12370 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12371 if {![info exists have_ttk]} {
12372 set have_ttk [llength [info commands ::ttk::style]]
12374 set use_ttk [expr {$have_ttk && $want_ttk}]
12375 set NS [expr {$use_ttk ? "ttk" : ""}]
12377 if {$use_ttk} {
12378 setttkstyle
12381 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12383 set show_notes {}
12384 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12385 set show_notes "--show-notes"
12388 set appname "gitk"
12390 set runq {}
12391 set history {}
12392 set historyindex 0
12393 set fh_serial 0
12394 set nhl_names {}
12395 set highlight_paths {}
12396 set findpattern {}
12397 set searchdirn -forwards
12398 set boldids {}
12399 set boldnameids {}
12400 set diffelide {0 0}
12401 set markingmatches 0
12402 set linkentercount 0
12403 set need_redisplay 0
12404 set nrows_drawn 0
12405 set firsttabstop 0
12407 set nextviewnum 1
12408 set curview 0
12409 set selectedview 0
12410 set selectedhlview [mc "None"]
12411 set highlight_related [mc "None"]
12412 set highlight_files {}
12413 set viewfiles(0) {}
12414 set viewperm(0) 0
12415 set viewchanged(0) 0
12416 set viewargs(0) {}
12417 set viewargscmd(0) {}
12419 set selectedline {}
12420 set numcommits 0
12421 set loginstance 0
12422 set cmdlineok 0
12423 set stopped 0
12424 set stuffsaved 0
12425 set patchnum 0
12426 set lserial 0
12427 set hasworktree [hasworktree]
12428 set cdup {}
12429 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12430 set cdup [exec git rev-parse --show-cdup]
12432 set worktree [exec git rev-parse --show-toplevel]
12433 setcoords
12434 makewindow
12435 catch {
12436 image create photo gitlogo -width 16 -height 16
12438 image create photo gitlogominus -width 4 -height 2
12439 gitlogominus put #C00000 -to 0 0 4 2
12440 gitlogo copy gitlogominus -to 1 5
12441 gitlogo copy gitlogominus -to 6 5
12442 gitlogo copy gitlogominus -to 11 5
12443 image delete gitlogominus
12445 image create photo gitlogoplus -width 4 -height 4
12446 gitlogoplus put #008000 -to 1 0 3 4
12447 gitlogoplus put #008000 -to 0 1 4 3
12448 gitlogo copy gitlogoplus -to 1 9
12449 gitlogo copy gitlogoplus -to 6 9
12450 gitlogo copy gitlogoplus -to 11 9
12451 image delete gitlogoplus
12453 image create photo gitlogo32 -width 32 -height 32
12454 gitlogo32 copy gitlogo -zoom 2 2
12456 wm iconphoto . -default gitlogo gitlogo32
12458 # wait for the window to become visible
12459 tkwait visibility .
12460 set_window_title
12461 update
12462 readrefs
12464 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12465 # create a view for the files/dirs specified on the command line
12466 set curview 1
12467 set selectedview 1
12468 set nextviewnum 2
12469 set viewname(1) [mc "Command line"]
12470 set viewfiles(1) $cmdline_files
12471 set viewargs(1) $revtreeargs
12472 set viewargscmd(1) $revtreeargscmd
12473 set viewperm(1) 0
12474 set viewchanged(1) 0
12475 set vdatemode(1) 0
12476 addviewmenu 1
12477 .bar.view entryconf [mca "&Edit view..."] -state normal
12478 .bar.view entryconf [mca "&Delete view"] -state normal
12481 if {[info exists permviews]} {
12482 foreach v $permviews {
12483 set n $nextviewnum
12484 incr nextviewnum
12485 set viewname($n) [lindex $v 0]
12486 set viewfiles($n) [lindex $v 1]
12487 set viewargs($n) [lindex $v 2]
12488 set viewargscmd($n) [lindex $v 3]
12489 set viewperm($n) 1
12490 set viewchanged($n) 0
12491 addviewmenu $n
12495 if {[tk windowingsystem] eq "win32"} {
12496 focus -force .
12499 getcommits {}
12501 # Local variables:
12502 # mode: tcl
12503 # indent-tabs-mode: t
12504 # tab-width: 8
12505 # End: