Merge branch 'rs/show-branch-simplify' into maint
[git/debian.git] / gitk-git / gitk
blob23d9dd1fe0d024c4af344c35faf01365ec8a6c58
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2016 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 if {[catch {set _gitworktree [exec git config --get core.worktree]}]} {
38 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
42 return $_gitworktree
45 # A simple scheduler for compute-intensive stuff.
46 # The aim is to make sure that event handlers for GUI actions can
47 # run at least every 50-100 ms. Unfortunately fileevent handlers are
48 # run before X event handlers, so reading from a fast source can
49 # make the GUI completely unresponsive.
50 proc run args {
51 global isonrunq runq currunq
53 set script $args
54 if {[info exists isonrunq($script)]} return
55 if {$runq eq {} && ![info exists currunq]} {
56 after idle dorunq
58 lappend runq [list {} $script]
59 set isonrunq($script) 1
62 proc filerun {fd script} {
63 fileevent $fd readable [list filereadable $fd $script]
66 proc filereadable {fd script} {
67 global runq currunq
69 fileevent $fd readable {}
70 if {$runq eq {} && ![info exists currunq]} {
71 after idle dorunq
73 lappend runq [list $fd $script]
76 proc nukefile {fd} {
77 global runq
79 for {set i 0} {$i < [llength $runq]} {} {
80 if {[lindex $runq $i 0] eq $fd} {
81 set runq [lreplace $runq $i $i]
82 } else {
83 incr i
88 proc dorunq {} {
89 global isonrunq runq currunq
91 set tstart [clock clicks -milliseconds]
92 set t0 $tstart
93 while {[llength $runq] > 0} {
94 set fd [lindex $runq 0 0]
95 set script [lindex $runq 0 1]
96 set currunq [lindex $runq 0]
97 set runq [lrange $runq 1 end]
98 set repeat [eval $script]
99 unset currunq
100 set t1 [clock clicks -milliseconds]
101 set t [expr {$t1 - $t0}]
102 if {$repeat ne {} && $repeat} {
103 if {$fd eq {} || $repeat == 2} {
104 # script returns 1 if it wants to be readded
105 # file readers return 2 if they could do more straight away
106 lappend runq [list $fd $script]
107 } else {
108 fileevent $fd readable [list filereadable $fd $script]
110 } elseif {$fd eq {}} {
111 unset isonrunq($script)
113 set t0 $t1
114 if {$t1 - $tstart >= 80} break
116 if {$runq ne {}} {
117 after idle dorunq
121 proc reg_instance {fd} {
122 global commfd leftover loginstance
124 set i [incr loginstance]
125 set commfd($i) $fd
126 set leftover($i) {}
127 return $i
130 proc unmerged_files {files} {
131 global nr_unmerged
133 # find the list of unmerged files
134 set mlist {}
135 set nr_unmerged 0
136 if {[catch {
137 set fd [open "| git ls-files -u" r]
138 } err]} {
139 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
140 exit 1
142 while {[gets $fd line] >= 0} {
143 set i [string first "\t" $line]
144 if {$i < 0} continue
145 set fname [string range $line [expr {$i+1}] end]
146 if {[lsearch -exact $mlist $fname] >= 0} continue
147 incr nr_unmerged
148 if {$files eq {} || [path_filter $files $fname]} {
149 lappend mlist $fname
152 catch {close $fd}
153 return $mlist
156 proc parseviewargs {n arglist} {
157 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
158 global vinlinediff
159 global worddiff git_version
161 set vdatemode($n) 0
162 set vmergeonly($n) 0
163 set vinlinediff($n) 0
164 set glflags {}
165 set diffargs {}
166 set nextisval 0
167 set revargs {}
168 set origargs $arglist
169 set allknown 1
170 set filtered 0
171 set i -1
172 foreach arg $arglist {
173 incr i
174 if {$nextisval} {
175 lappend glflags $arg
176 set nextisval 0
177 continue
179 switch -glob -- $arg {
180 "-d" -
181 "--date-order" {
182 set vdatemode($n) 1
183 # remove from origargs in case we hit an unknown option
184 set origargs [lreplace $origargs $i $i]
185 incr i -1
187 "-[puabwcrRBMC]" -
188 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
189 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
190 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
191 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
192 "--ignore-space-change" - "-U*" - "--unified=*" {
193 # These request or affect diff output, which we don't want.
194 # Some could be used to set our defaults for diff display.
195 lappend diffargs $arg
197 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
198 "--name-only" - "--name-status" - "--color" -
199 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
200 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
201 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
202 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
203 "--objects" - "--objects-edge" - "--reverse" {
204 # These cause our parsing of git log's output to fail, or else
205 # they're options we want to set ourselves, so ignore them.
207 "--color-words*" - "--word-diff=color" {
208 # These trigger a word diff in the console interface,
209 # so help the user by enabling our own support
210 if {[package vcompare $git_version "1.7.2"] >= 0} {
211 set worddiff [mc "Color words"]
214 "--word-diff*" {
215 if {[package vcompare $git_version "1.7.2"] >= 0} {
216 set worddiff [mc "Markup words"]
219 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
220 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
221 "--full-history" - "--dense" - "--sparse" -
222 "--follow" - "--left-right" - "--encoding=*" {
223 # These are harmless, and some are even useful
224 lappend glflags $arg
226 "--diff-filter=*" - "--no-merges" - "--unpacked" -
227 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
228 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
229 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
230 "--remove-empty" - "--first-parent" - "--cherry-pick" -
231 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
232 "--simplify-by-decoration" {
233 # These mean that we get a subset of the commits
234 set filtered 1
235 lappend glflags $arg
237 "-L*" {
238 # Line-log with 'stuck' argument (unstuck form is
239 # not supported)
240 set filtered 1
241 set vinlinediff($n) 1
242 set allknown 0
243 lappend glflags $arg
245 "-n" {
246 # This appears to be the only one that has a value as a
247 # separate word following it
248 set filtered 1
249 set nextisval 1
250 lappend glflags $arg
252 "--not" - "--all" {
253 lappend revargs $arg
255 "--merge" {
256 set vmergeonly($n) 1
257 # git rev-parse doesn't understand --merge
258 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
260 "--no-replace-objects" {
261 set env(GIT_NO_REPLACE_OBJECTS) "1"
263 "-*" {
264 # Other flag arguments including -<n>
265 if {[string is digit -strict [string range $arg 1 end]]} {
266 set filtered 1
267 } else {
268 # a flag argument that we don't recognize;
269 # that means we can't optimize
270 set allknown 0
272 lappend glflags $arg
274 default {
275 # Non-flag arguments specify commits or ranges of commits
276 if {[string match "*...*" $arg]} {
277 lappend revargs --gitk-symmetric-diff-marker
279 lappend revargs $arg
283 set vdflags($n) $diffargs
284 set vflags($n) $glflags
285 set vrevs($n) $revargs
286 set vfiltered($n) $filtered
287 set vorigargs($n) $origargs
288 return $allknown
291 proc parseviewrevs {view revs} {
292 global vposids vnegids
294 if {$revs eq {}} {
295 set revs HEAD
296 } elseif {[lsearch -exact $revs --all] >= 0} {
297 lappend revs HEAD
299 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
300 # we get stdout followed by stderr in $err
301 # for an unknown rev, git rev-parse echoes it and then errors out
302 set errlines [split $err "\n"]
303 set badrev {}
304 for {set l 0} {$l < [llength $errlines]} {incr l} {
305 set line [lindex $errlines $l]
306 if {!([string length $line] == 40 && [string is xdigit $line])} {
307 if {[string match "fatal:*" $line]} {
308 if {[string match "fatal: ambiguous argument*" $line]
309 && $badrev ne {}} {
310 if {[llength $badrev] == 1} {
311 set err "unknown revision $badrev"
312 } else {
313 set err "unknown revisions: [join $badrev ", "]"
315 } else {
316 set err [join [lrange $errlines $l end] "\n"]
318 break
320 lappend badrev $line
323 error_popup "[mc "Error parsing revisions:"] $err"
324 return {}
326 set ret {}
327 set pos {}
328 set neg {}
329 set sdm 0
330 foreach id [split $ids "\n"] {
331 if {$id eq "--gitk-symmetric-diff-marker"} {
332 set sdm 4
333 } elseif {[string match "^*" $id]} {
334 if {$sdm != 1} {
335 lappend ret $id
336 if {$sdm == 3} {
337 set sdm 0
340 lappend neg [string range $id 1 end]
341 } else {
342 if {$sdm != 2} {
343 lappend ret $id
344 } else {
345 lset ret end $id...[lindex $ret end]
347 lappend pos $id
349 incr sdm -1
351 set vposids($view) $pos
352 set vnegids($view) $neg
353 return $ret
356 # Start off a git log process and arrange to read its output
357 proc start_rev_list {view} {
358 global startmsecs commitidx viewcomplete curview
359 global tclencoding
360 global viewargs viewargscmd viewfiles vfilelimit
361 global showlocalchanges
362 global viewactive viewinstances vmergeonly
363 global mainheadid viewmainheadid viewmainheadid_orig
364 global vcanopt vflags vrevs vorigargs
365 global show_notes
367 set startmsecs [clock clicks -milliseconds]
368 set commitidx($view) 0
369 # these are set this way for the error exits
370 set viewcomplete($view) 1
371 set viewactive($view) 0
372 varcinit $view
374 set args $viewargs($view)
375 if {$viewargscmd($view) ne {}} {
376 if {[catch {
377 set str [exec sh -c $viewargscmd($view)]
378 } err]} {
379 error_popup "[mc "Error executing --argscmd command:"] $err"
380 return 0
382 set args [concat $args [split $str "\n"]]
384 set vcanopt($view) [parseviewargs $view $args]
386 set files $viewfiles($view)
387 if {$vmergeonly($view)} {
388 set files [unmerged_files $files]
389 if {$files eq {}} {
390 global nr_unmerged
391 if {$nr_unmerged == 0} {
392 error_popup [mc "No files selected: --merge specified but\
393 no files are unmerged."]
394 } else {
395 error_popup [mc "No files selected: --merge specified but\
396 no unmerged files are within file limit."]
398 return 0
401 set vfilelimit($view) $files
403 if {$vcanopt($view)} {
404 set revs [parseviewrevs $view $vrevs($view)]
405 if {$revs eq {}} {
406 return 0
408 set args [concat $vflags($view) $revs]
409 } else {
410 set args $vorigargs($view)
413 if {[catch {
414 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
415 --parents --boundary $args "--" $files] r]
416 } err]} {
417 error_popup "[mc "Error executing git log:"] $err"
418 return 0
420 set i [reg_instance $fd]
421 set viewinstances($view) [list $i]
422 set viewmainheadid($view) $mainheadid
423 set viewmainheadid_orig($view) $mainheadid
424 if {$files ne {} && $mainheadid ne {}} {
425 get_viewmainhead $view
427 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
428 interestedin $viewmainheadid($view) dodiffindex
430 fconfigure $fd -blocking 0 -translation lf -eofchar {}
431 if {$tclencoding != {}} {
432 fconfigure $fd -encoding $tclencoding
434 filerun $fd [list getcommitlines $fd $i $view 0]
435 nowbusy $view [mc "Reading"]
436 set viewcomplete($view) 0
437 set viewactive($view) 1
438 return 1
441 proc stop_instance {inst} {
442 global commfd leftover
444 set fd $commfd($inst)
445 catch {
446 set pid [pid $fd]
448 if {$::tcl_platform(platform) eq {windows}} {
449 exec taskkill /pid $pid
450 } else {
451 exec kill $pid
454 catch {close $fd}
455 nukefile $fd
456 unset commfd($inst)
457 unset leftover($inst)
460 proc stop_backends {} {
461 global commfd
463 foreach inst [array names commfd] {
464 stop_instance $inst
468 proc stop_rev_list {view} {
469 global viewinstances
471 foreach inst $viewinstances($view) {
472 stop_instance $inst
474 set viewinstances($view) {}
477 proc reset_pending_select {selid} {
478 global pending_select mainheadid selectheadid
480 if {$selid ne {}} {
481 set pending_select $selid
482 } elseif {$selectheadid ne {}} {
483 set pending_select $selectheadid
484 } else {
485 set pending_select $mainheadid
489 proc getcommits {selid} {
490 global canv curview need_redisplay viewactive
492 initlayout
493 if {[start_rev_list $curview]} {
494 reset_pending_select $selid
495 show_status [mc "Reading commits..."]
496 set need_redisplay 1
497 } else {
498 show_status [mc "No commits selected"]
502 proc updatecommits {} {
503 global curview vcanopt vorigargs vfilelimit viewinstances
504 global viewactive viewcomplete tclencoding
505 global startmsecs showneartags showlocalchanges
506 global mainheadid viewmainheadid viewmainheadid_orig pending_select
507 global hasworktree
508 global varcid vposids vnegids vflags vrevs
509 global show_notes
511 set hasworktree [hasworktree]
512 rereadrefs
513 set view $curview
514 if {$mainheadid ne $viewmainheadid_orig($view)} {
515 if {$showlocalchanges} {
516 dohidelocalchanges
518 set viewmainheadid($view) $mainheadid
519 set viewmainheadid_orig($view) $mainheadid
520 if {$vfilelimit($view) ne {}} {
521 get_viewmainhead $view
524 if {$showlocalchanges} {
525 doshowlocalchanges
527 if {$vcanopt($view)} {
528 set oldpos $vposids($view)
529 set oldneg $vnegids($view)
530 set revs [parseviewrevs $view $vrevs($view)]
531 if {$revs eq {}} {
532 return
534 # note: getting the delta when negative refs change is hard,
535 # and could require multiple git log invocations, so in that
536 # case we ask git log for all the commits (not just the delta)
537 if {$oldneg eq $vnegids($view)} {
538 set newrevs {}
539 set npos 0
540 # take out positive refs that we asked for before or
541 # that we have already seen
542 foreach rev $revs {
543 if {[string length $rev] == 40} {
544 if {[lsearch -exact $oldpos $rev] < 0
545 && ![info exists varcid($view,$rev)]} {
546 lappend newrevs $rev
547 incr npos
549 } else {
550 lappend $newrevs $rev
553 if {$npos == 0} return
554 set revs $newrevs
555 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
557 set args [concat $vflags($view) $revs --not $oldpos]
558 } else {
559 set args $vorigargs($view)
561 if {[catch {
562 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
563 --parents --boundary $args "--" $vfilelimit($view)] r]
564 } err]} {
565 error_popup "[mc "Error executing git log:"] $err"
566 return
568 if {$viewactive($view) == 0} {
569 set startmsecs [clock clicks -milliseconds]
571 set i [reg_instance $fd]
572 lappend viewinstances($view) $i
573 fconfigure $fd -blocking 0 -translation lf -eofchar {}
574 if {$tclencoding != {}} {
575 fconfigure $fd -encoding $tclencoding
577 filerun $fd [list getcommitlines $fd $i $view 1]
578 incr viewactive($view)
579 set viewcomplete($view) 0
580 reset_pending_select {}
581 nowbusy $view [mc "Reading"]
582 if {$showneartags} {
583 getallcommits
587 proc reloadcommits {} {
588 global curview viewcomplete selectedline currentid thickerline
589 global showneartags treediffs commitinterest cached_commitrow
590 global targetid commitinfo
592 set selid {}
593 if {$selectedline ne {}} {
594 set selid $currentid
597 if {!$viewcomplete($curview)} {
598 stop_rev_list $curview
600 resetvarcs $curview
601 set selectedline {}
602 unset -nocomplain currentid
603 unset -nocomplain thickerline
604 unset -nocomplain treediffs
605 readrefs
606 changedrefs
607 if {$showneartags} {
608 getallcommits
610 clear_display
611 unset -nocomplain commitinfo
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 curview numcommits
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 if {$v == $curview} {
1344 set numcommits $commitidx($v)
1346 set scripts [check_interest $p $scripts]
1349 if {$missing_parents > 0} {
1350 foreach s $scripts {
1351 eval $s
1356 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1357 # Assumes we already have an arc for $rwid.
1358 proc rewrite_commit {v id rwid} {
1359 global children parents varcid varctok vtokmod varccommits
1361 foreach ch $children($v,$id) {
1362 # make $rwid be $ch's parent in place of $id
1363 set i [lsearch -exact $parents($v,$ch) $id]
1364 if {$i < 0} {
1365 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1367 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1368 # add $ch to $rwid's children and sort the list if necessary
1369 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1370 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1371 $children($v,$rwid)]
1373 # fix the graph after joining $id to $rwid
1374 set a $varcid($v,$ch)
1375 fix_reversal $rwid $a $v
1376 # parentlist is wrong for the last element of arc $a
1377 # even if displayorder is right, hence the 3rd arg here
1378 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1382 # Mechanism for registering a command to be executed when we come
1383 # across a particular commit. To handle the case when only the
1384 # prefix of the commit is known, the commitinterest array is now
1385 # indexed by the first 4 characters of the ID. Each element is a
1386 # list of id, cmd pairs.
1387 proc interestedin {id cmd} {
1388 global commitinterest
1390 lappend commitinterest([string range $id 0 3]) $id $cmd
1393 proc check_interest {id scripts} {
1394 global commitinterest
1396 set prefix [string range $id 0 3]
1397 if {[info exists commitinterest($prefix)]} {
1398 set newlist {}
1399 foreach {i script} $commitinterest($prefix) {
1400 if {[string match "$i*" $id]} {
1401 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1402 } else {
1403 lappend newlist $i $script
1406 if {$newlist ne {}} {
1407 set commitinterest($prefix) $newlist
1408 } else {
1409 unset commitinterest($prefix)
1412 return $scripts
1415 proc getcommitlines {fd inst view updating} {
1416 global cmitlisted leftover
1417 global commitidx commitdata vdatemode
1418 global parents children curview hlview
1419 global idpending ordertok
1420 global varccommits varcid varctok vtokmod vfilelimit vshortids
1422 set stuff [read $fd 500000]
1423 # git log doesn't terminate the last commit with a null...
1424 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1425 set stuff "\0"
1427 if {$stuff == {}} {
1428 if {![eof $fd]} {
1429 return 1
1431 global commfd viewcomplete viewactive viewname
1432 global viewinstances
1433 unset commfd($inst)
1434 set i [lsearch -exact $viewinstances($view) $inst]
1435 if {$i >= 0} {
1436 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1438 # set it blocking so we wait for the process to terminate
1439 fconfigure $fd -blocking 1
1440 if {[catch {close $fd} err]} {
1441 set fv {}
1442 if {$view != $curview} {
1443 set fv " for the \"$viewname($view)\" view"
1445 if {[string range $err 0 4] == "usage"} {
1446 set err "Gitk: error reading commits$fv:\
1447 bad arguments to git log."
1448 if {$viewname($view) eq [mc "Command line"]} {
1449 append err \
1450 " (Note: arguments to gitk are passed to git log\
1451 to allow selection of commits to be displayed.)"
1453 } else {
1454 set err "Error reading commits$fv: $err"
1456 error_popup $err
1458 if {[incr viewactive($view) -1] <= 0} {
1459 set viewcomplete($view) 1
1460 # Check if we have seen any ids listed as parents that haven't
1461 # appeared in the list
1462 closevarcs $view
1463 notbusy $view
1465 if {$view == $curview} {
1466 run chewcommits
1468 return 0
1470 set start 0
1471 set gotsome 0
1472 set scripts {}
1473 while 1 {
1474 set i [string first "\0" $stuff $start]
1475 if {$i < 0} {
1476 append leftover($inst) [string range $stuff $start end]
1477 break
1479 if {$start == 0} {
1480 set cmit $leftover($inst)
1481 append cmit [string range $stuff 0 [expr {$i - 1}]]
1482 set leftover($inst) {}
1483 } else {
1484 set cmit [string range $stuff $start [expr {$i - 1}]]
1486 set start [expr {$i + 1}]
1487 set j [string first "\n" $cmit]
1488 set ok 0
1489 set listed 1
1490 if {$j >= 0 && [string match "commit *" $cmit]} {
1491 set ids [string range $cmit 7 [expr {$j - 1}]]
1492 if {[string match {[-^<>]*} $ids]} {
1493 switch -- [string index $ids 0] {
1494 "-" {set listed 0}
1495 "^" {set listed 2}
1496 "<" {set listed 3}
1497 ">" {set listed 4}
1499 set ids [string range $ids 1 end]
1501 set ok 1
1502 foreach id $ids {
1503 if {[string length $id] != 40} {
1504 set ok 0
1505 break
1509 if {!$ok} {
1510 set shortcmit $cmit
1511 if {[string length $shortcmit] > 80} {
1512 set shortcmit "[string range $shortcmit 0 80]..."
1514 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1515 exit 1
1517 set id [lindex $ids 0]
1518 set vid $view,$id
1520 lappend vshortids($view,[string range $id 0 3]) $id
1522 if {!$listed && $updating && ![info exists varcid($vid)] &&
1523 $vfilelimit($view) ne {}} {
1524 # git log doesn't rewrite parents for unlisted commits
1525 # when doing path limiting, so work around that here
1526 # by working out the rewritten parent with git rev-list
1527 # and if we already know about it, using the rewritten
1528 # parent as a substitute parent for $id's children.
1529 if {![catch {
1530 set rwid [exec git rev-list --first-parent --max-count=1 \
1531 $id -- $vfilelimit($view)]
1532 }]} {
1533 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1534 # use $rwid in place of $id
1535 rewrite_commit $view $id $rwid
1536 continue
1541 set a 0
1542 if {[info exists varcid($vid)]} {
1543 if {$cmitlisted($vid) || !$listed} continue
1544 set a $varcid($vid)
1546 if {$listed} {
1547 set olds [lrange $ids 1 end]
1548 } else {
1549 set olds {}
1551 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1552 set cmitlisted($vid) $listed
1553 set parents($vid) $olds
1554 if {![info exists children($vid)]} {
1555 set children($vid) {}
1556 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1557 set k [lindex $children($vid) 0]
1558 if {[llength $parents($view,$k)] == 1 &&
1559 (!$vdatemode($view) ||
1560 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1561 set a $varcid($view,$k)
1564 if {$a == 0} {
1565 # new arc
1566 set a [newvarc $view $id]
1568 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1569 modify_arc $view $a
1571 if {![info exists varcid($vid)]} {
1572 set varcid($vid) $a
1573 lappend varccommits($view,$a) $id
1574 incr commitidx($view)
1577 set i 0
1578 foreach p $olds {
1579 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1580 set vp $view,$p
1581 if {[llength [lappend children($vp) $id]] > 1 &&
1582 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1583 set children($vp) [lsort -command [list vtokcmp $view] \
1584 $children($vp)]
1585 unset -nocomplain ordertok
1587 if {[info exists varcid($view,$p)]} {
1588 fix_reversal $p $a $view
1591 incr i
1594 set scripts [check_interest $id $scripts]
1595 set gotsome 1
1597 if {$gotsome} {
1598 global numcommits hlview
1600 if {$view == $curview} {
1601 set numcommits $commitidx($view)
1602 run chewcommits
1604 if {[info exists hlview] && $view == $hlview} {
1605 # we never actually get here...
1606 run vhighlightmore
1608 foreach s $scripts {
1609 eval $s
1612 return 2
1615 proc chewcommits {} {
1616 global curview hlview viewcomplete
1617 global pending_select
1619 layoutmore
1620 if {$viewcomplete($curview)} {
1621 global commitidx varctok
1622 global numcommits startmsecs
1624 if {[info exists pending_select]} {
1625 update
1626 reset_pending_select {}
1628 if {[commitinview $pending_select $curview]} {
1629 selectline [rowofcommit $pending_select] 1
1630 } else {
1631 set row [first_real_row]
1632 selectline $row 1
1635 if {$commitidx($curview) > 0} {
1636 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1637 #puts "overall $ms ms for $numcommits commits"
1638 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1639 } else {
1640 show_status [mc "No commits selected"]
1642 notbusy layout
1644 return 0
1647 proc do_readcommit {id} {
1648 global tclencoding
1650 # Invoke git-log to handle automatic encoding conversion
1651 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1652 # Read the results using i18n.logoutputencoding
1653 fconfigure $fd -translation lf -eofchar {}
1654 if {$tclencoding != {}} {
1655 fconfigure $fd -encoding $tclencoding
1657 set contents [read $fd]
1658 close $fd
1659 # Remove the heading line
1660 regsub {^commit [0-9a-f]+\n} $contents {} contents
1662 return $contents
1665 proc readcommit {id} {
1666 if {[catch {set contents [do_readcommit $id]}]} return
1667 parsecommit $id $contents 1
1670 proc parsecommit {id contents listed} {
1671 global commitinfo
1673 set inhdr 1
1674 set comment {}
1675 set headline {}
1676 set auname {}
1677 set audate {}
1678 set comname {}
1679 set comdate {}
1680 set hdrend [string first "\n\n" $contents]
1681 if {$hdrend < 0} {
1682 # should never happen...
1683 set hdrend [string length $contents]
1685 set header [string range $contents 0 [expr {$hdrend - 1}]]
1686 set comment [string range $contents [expr {$hdrend + 2}] end]
1687 foreach line [split $header "\n"] {
1688 set line [split $line " "]
1689 set tag [lindex $line 0]
1690 if {$tag == "author"} {
1691 set audate [lrange $line end-1 end]
1692 set auname [join [lrange $line 1 end-2] " "]
1693 } elseif {$tag == "committer"} {
1694 set comdate [lrange $line end-1 end]
1695 set comname [join [lrange $line 1 end-2] " "]
1698 set headline {}
1699 # take the first non-blank line of the comment as the headline
1700 set headline [string trimleft $comment]
1701 set i [string first "\n" $headline]
1702 if {$i >= 0} {
1703 set headline [string range $headline 0 $i]
1705 set headline [string trimright $headline]
1706 set i [string first "\r" $headline]
1707 if {$i >= 0} {
1708 set headline [string trimright [string range $headline 0 $i]]
1710 if {!$listed} {
1711 # git log indents the comment by 4 spaces;
1712 # if we got this via git cat-file, add the indentation
1713 set newcomment {}
1714 foreach line [split $comment "\n"] {
1715 append newcomment " "
1716 append newcomment $line
1717 append newcomment "\n"
1719 set comment $newcomment
1721 set hasnote [string first "\nNotes:\n" $contents]
1722 set diff ""
1723 # If there is diff output shown in the git-log stream, split it
1724 # out. But get rid of the empty line that always precedes the
1725 # diff.
1726 set i [string first "\n\ndiff" $comment]
1727 if {$i >= 0} {
1728 set diff [string range $comment $i+1 end]
1729 set comment [string range $comment 0 $i-1]
1731 set commitinfo($id) [list $headline $auname $audate \
1732 $comname $comdate $comment $hasnote $diff]
1735 proc getcommit {id} {
1736 global commitdata commitinfo
1738 if {[info exists commitdata($id)]} {
1739 parsecommit $id $commitdata($id) 1
1740 } else {
1741 readcommit $id
1742 if {![info exists commitinfo($id)]} {
1743 set commitinfo($id) [list [mc "No commit information available"]]
1746 return 1
1749 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1750 # and are present in the current view.
1751 # This is fairly slow...
1752 proc longid {prefix} {
1753 global varcid curview vshortids
1755 set ids {}
1756 if {[string length $prefix] >= 4} {
1757 set vshortid $curview,[string range $prefix 0 3]
1758 if {[info exists vshortids($vshortid)]} {
1759 foreach id $vshortids($vshortid) {
1760 if {[string match "$prefix*" $id]} {
1761 if {[lsearch -exact $ids $id] < 0} {
1762 lappend ids $id
1763 if {[llength $ids] >= 2} break
1768 } else {
1769 foreach match [array names varcid "$curview,$prefix*"] {
1770 lappend ids [lindex [split $match ","] 1]
1771 if {[llength $ids] >= 2} break
1774 return $ids
1777 proc readrefs {} {
1778 global tagids idtags headids idheads tagobjid
1779 global otherrefids idotherrefs mainhead mainheadid
1780 global selecthead selectheadid
1781 global hideremotes
1782 global tclencoding
1784 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1785 unset -nocomplain $v
1787 set refd [open [list | git show-ref -d] r]
1788 if {$tclencoding != {}} {
1789 fconfigure $refd -encoding $tclencoding
1791 while {[gets $refd line] >= 0} {
1792 if {[string index $line 40] ne " "} continue
1793 set id [string range $line 0 39]
1794 set ref [string range $line 41 end]
1795 if {![string match "refs/*" $ref]} continue
1796 set name [string range $ref 5 end]
1797 if {[string match "remotes/*" $name]} {
1798 if {![string match "*/HEAD" $name] && !$hideremotes} {
1799 set headids($name) $id
1800 lappend idheads($id) $name
1802 } elseif {[string match "heads/*" $name]} {
1803 set name [string range $name 6 end]
1804 set headids($name) $id
1805 lappend idheads($id) $name
1806 } elseif {[string match "tags/*" $name]} {
1807 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1808 # which is what we want since the former is the commit ID
1809 set name [string range $name 5 end]
1810 if {[string match "*^{}" $name]} {
1811 set name [string range $name 0 end-3]
1812 } else {
1813 set tagobjid($name) $id
1815 set tagids($name) $id
1816 lappend idtags($id) $name
1817 } else {
1818 set otherrefids($name) $id
1819 lappend idotherrefs($id) $name
1822 catch {close $refd}
1823 set mainhead {}
1824 set mainheadid {}
1825 catch {
1826 set mainheadid [exec git rev-parse HEAD]
1827 set thehead [exec git symbolic-ref HEAD]
1828 if {[string match "refs/heads/*" $thehead]} {
1829 set mainhead [string range $thehead 11 end]
1832 set selectheadid {}
1833 if {$selecthead ne {}} {
1834 catch {
1835 set selectheadid [exec git rev-parse --verify $selecthead]
1840 # skip over fake commits
1841 proc first_real_row {} {
1842 global nullid nullid2 numcommits
1844 for {set row 0} {$row < $numcommits} {incr row} {
1845 set id [commitonrow $row]
1846 if {$id ne $nullid && $id ne $nullid2} {
1847 break
1850 return $row
1853 # update things for a head moved to a child of its previous location
1854 proc movehead {id name} {
1855 global headids idheads
1857 removehead $headids($name) $name
1858 set headids($name) $id
1859 lappend idheads($id) $name
1862 # update things when a head has been removed
1863 proc removehead {id name} {
1864 global headids idheads
1866 if {$idheads($id) eq $name} {
1867 unset idheads($id)
1868 } else {
1869 set i [lsearch -exact $idheads($id) $name]
1870 if {$i >= 0} {
1871 set idheads($id) [lreplace $idheads($id) $i $i]
1874 unset headids($name)
1877 proc ttk_toplevel {w args} {
1878 global use_ttk
1879 eval [linsert $args 0 ::toplevel $w]
1880 if {$use_ttk} {
1881 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1883 return $w
1886 proc make_transient {window origin} {
1887 global have_tk85
1889 # In MacOS Tk 8.4 transient appears to work by setting
1890 # overrideredirect, which is utterly useless, since the
1891 # windows get no border, and are not even kept above
1892 # the parent.
1893 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1895 wm transient $window $origin
1897 # Windows fails to place transient windows normally, so
1898 # schedule a callback to center them on the parent.
1899 if {[tk windowingsystem] eq {win32}} {
1900 after idle [list tk::PlaceWindow $window widget $origin]
1904 proc show_error {w top msg} {
1905 global NS
1906 if {![info exists NS]} {set NS ""}
1907 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1908 message $w.m -text $msg -justify center -aspect 400
1909 pack $w.m -side top -fill x -padx 20 -pady 20
1910 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1911 pack $w.ok -side bottom -fill x
1912 bind $top <Visibility> "grab $top; focus $top"
1913 bind $top <Key-Return> "destroy $top"
1914 bind $top <Key-space> "destroy $top"
1915 bind $top <Key-Escape> "destroy $top"
1916 tkwait window $top
1919 proc error_popup {msg {owner .}} {
1920 if {[tk windowingsystem] eq "win32"} {
1921 tk_messageBox -icon error -type ok -title [wm title .] \
1922 -parent $owner -message $msg
1923 } else {
1924 set w .error
1925 ttk_toplevel $w
1926 make_transient $w $owner
1927 show_error $w $w $msg
1931 proc confirm_popup {msg {owner .}} {
1932 global confirm_ok NS
1933 set confirm_ok 0
1934 set w .confirm
1935 ttk_toplevel $w
1936 make_transient $w $owner
1937 message $w.m -text $msg -justify center -aspect 400
1938 pack $w.m -side top -fill x -padx 20 -pady 20
1939 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1940 pack $w.ok -side left -fill x
1941 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1942 pack $w.cancel -side right -fill x
1943 bind $w <Visibility> "grab $w; focus $w"
1944 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1945 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1946 bind $w <Key-Escape> "destroy $w"
1947 tk::PlaceWindow $w widget $owner
1948 tkwait window $w
1949 return $confirm_ok
1952 proc setoptions {} {
1953 global use_ttk
1955 if {[tk windowingsystem] ne "win32"} {
1956 option add *Panedwindow.showHandle 1 startupFile
1957 option add *Panedwindow.sashRelief raised startupFile
1958 if {[tk windowingsystem] ne "aqua"} {
1959 option add *Menu.font uifont startupFile
1961 } else {
1962 option add *Menu.TearOff 0 startupFile
1964 option add *Button.font uifont startupFile
1965 option add *Checkbutton.font uifont startupFile
1966 option add *Radiobutton.font uifont startupFile
1967 option add *Menubutton.font uifont startupFile
1968 option add *Label.font uifont startupFile
1969 option add *Message.font uifont startupFile
1970 option add *Entry.font textfont startupFile
1971 option add *Text.font textfont startupFile
1972 option add *Labelframe.font uifont startupFile
1973 option add *Spinbox.font textfont startupFile
1974 option add *Listbox.font mainfont startupFile
1977 proc setttkstyle {} {
1978 eval font configure TkDefaultFont [fontflags mainfont]
1979 eval font configure TkTextFont [fontflags textfont]
1980 eval font configure TkHeadingFont [fontflags mainfont]
1981 eval font configure TkCaptionFont [fontflags mainfont] -weight bold
1982 eval font configure TkTooltipFont [fontflags uifont]
1983 eval font configure TkFixedFont [fontflags textfont]
1984 eval font configure TkIconFont [fontflags uifont]
1985 eval font configure TkMenuFont [fontflags uifont]
1986 eval font configure TkSmallCaptionFont [fontflags uifont]
1989 # Make a menu and submenus.
1990 # m is the window name for the menu, items is the list of menu items to add.
1991 # Each item is a list {mc label type description options...}
1992 # mc is ignored; it's so we can put mc there to alert xgettext
1993 # label is the string that appears in the menu
1994 # type is cascade, command or radiobutton (should add checkbutton)
1995 # description depends on type; it's the sublist for cascade, the
1996 # command to invoke for command, or {variable value} for radiobutton
1997 proc makemenu {m items} {
1998 menu $m
1999 if {[tk windowingsystem] eq {aqua}} {
2000 set Meta1 Cmd
2001 } else {
2002 set Meta1 Ctrl
2004 foreach i $items {
2005 set name [mc [lindex $i 1]]
2006 set type [lindex $i 2]
2007 set thing [lindex $i 3]
2008 set params [list $type]
2009 if {$name ne {}} {
2010 set u [string first "&" [string map {&& x} $name]]
2011 lappend params -label [string map {&& & & {}} $name]
2012 if {$u >= 0} {
2013 lappend params -underline $u
2016 switch -- $type {
2017 "cascade" {
2018 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
2019 lappend params -menu $m.$submenu
2021 "command" {
2022 lappend params -command $thing
2024 "radiobutton" {
2025 lappend params -variable [lindex $thing 0] \
2026 -value [lindex $thing 1]
2029 set tail [lrange $i 4 end]
2030 regsub -all {\yMeta1\y} $tail $Meta1 tail
2031 eval $m add $params $tail
2032 if {$type eq "cascade"} {
2033 makemenu $m.$submenu $thing
2038 # translate string and remove ampersands
2039 proc mca {str} {
2040 return [string map {&& & & {}} [mc $str]]
2043 proc cleardropsel {w} {
2044 $w selection clear
2046 proc makedroplist {w varname args} {
2047 global use_ttk
2048 if {$use_ttk} {
2049 set width 0
2050 foreach label $args {
2051 set cx [string length $label]
2052 if {$cx > $width} {set width $cx}
2054 set gm [ttk::combobox $w -width $width -state readonly\
2055 -textvariable $varname -values $args \
2056 -exportselection false]
2057 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2058 } else {
2059 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2061 return $gm
2064 proc makewindow {} {
2065 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2066 global tabstop
2067 global findtype findtypemenu findloc findstring fstring geometry
2068 global entries sha1entry sha1string sha1but
2069 global diffcontextstring diffcontext
2070 global ignorespace
2071 global maincursor textcursor curtextcursor
2072 global rowctxmenu fakerowmenu mergemax wrapcomment
2073 global highlight_files gdttype
2074 global searchstring sstring
2075 global bgcolor fgcolor bglist fglist diffcolors diffbgcolors selectbgcolor
2076 global uifgcolor uifgdisabledcolor
2077 global filesepbgcolor filesepfgcolor
2078 global mergecolors foundbgcolor currentsearchhitbgcolor
2079 global headctxmenu progresscanv progressitem progresscoords statusw
2080 global fprogitem fprogcoord lastprogupdate progupdatepending
2081 global rprogitem rprogcoord rownumsel numcommits
2082 global have_tk85 use_ttk NS
2083 global git_version
2084 global worddiff
2086 # The "mc" arguments here are purely so that xgettext
2087 # sees the following string as needing to be translated
2088 set file {
2089 mc "&File" cascade {
2090 {mc "&Update" command updatecommits -accelerator F5}
2091 {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2092 {mc "Reread re&ferences" command rereadrefs}
2093 {mc "&List references" command showrefs -accelerator F2}
2094 {xx "" separator}
2095 {mc "Start git &gui" command {exec git gui &}}
2096 {xx "" separator}
2097 {mc "&Quit" command doquit -accelerator Meta1-Q}
2099 set edit {
2100 mc "&Edit" cascade {
2101 {mc "&Preferences" command doprefs}
2103 set view {
2104 mc "&View" cascade {
2105 {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2106 {mc "&Edit view..." command editview -state disabled -accelerator F4}
2107 {mc "&Delete view" command delview -state disabled}
2108 {xx "" separator}
2109 {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2111 if {[tk windowingsystem] ne "aqua"} {
2112 set help {
2113 mc "&Help" cascade {
2114 {mc "&About gitk" command about}
2115 {mc "&Key bindings" command keys}
2117 set bar [list $file $edit $view $help]
2118 } else {
2119 proc ::tk::mac::ShowPreferences {} {doprefs}
2120 proc ::tk::mac::Quit {} {doquit}
2121 lset file end [lreplace [lindex $file end] end-1 end]
2122 set apple {
2123 xx "&Apple" cascade {
2124 {mc "&About gitk" command about}
2125 {xx "" separator}
2127 set help {
2128 mc "&Help" cascade {
2129 {mc "&Key bindings" command keys}
2131 set bar [list $apple $file $view $help]
2133 makemenu .bar $bar
2134 . configure -menu .bar
2136 if {$use_ttk} {
2137 # cover the non-themed toplevel with a themed frame.
2138 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2141 # the gui has upper and lower half, parts of a paned window.
2142 ${NS}::panedwindow .ctop -orient vertical
2144 # possibly use assumed geometry
2145 if {![info exists geometry(pwsash0)]} {
2146 set geometry(topheight) [expr {15 * $linespc}]
2147 set geometry(topwidth) [expr {80 * $charspc}]
2148 set geometry(botheight) [expr {15 * $linespc}]
2149 set geometry(botwidth) [expr {50 * $charspc}]
2150 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2151 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2154 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2155 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2156 ${NS}::frame .tf.histframe
2157 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2158 if {!$use_ttk} {
2159 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2162 # create three canvases
2163 set cscroll .tf.histframe.csb
2164 set canv .tf.histframe.pwclist.canv
2165 canvas $canv \
2166 -selectbackground $selectbgcolor \
2167 -background $bgcolor -bd 0 \
2168 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2169 .tf.histframe.pwclist add $canv
2170 set canv2 .tf.histframe.pwclist.canv2
2171 canvas $canv2 \
2172 -selectbackground $selectbgcolor \
2173 -background $bgcolor -bd 0 -yscrollincr $linespc
2174 .tf.histframe.pwclist add $canv2
2175 set canv3 .tf.histframe.pwclist.canv3
2176 canvas $canv3 \
2177 -selectbackground $selectbgcolor \
2178 -background $bgcolor -bd 0 -yscrollincr $linespc
2179 .tf.histframe.pwclist add $canv3
2180 if {$use_ttk} {
2181 bind .tf.histframe.pwclist <Map> {
2182 bind %W <Map> {}
2183 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2184 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2186 } else {
2187 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2188 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2191 # a scroll bar to rule them
2192 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2193 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2194 pack $cscroll -side right -fill y
2195 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2196 lappend bglist $canv $canv2 $canv3
2197 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2199 # we have two button bars at bottom of top frame. Bar 1
2200 ${NS}::frame .tf.bar
2201 ${NS}::frame .tf.lbar -height 15
2203 set sha1entry .tf.bar.sha1
2204 set entries $sha1entry
2205 set sha1but .tf.bar.sha1label
2206 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2207 -command gotocommit -width 8
2208 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2209 pack .tf.bar.sha1label -side left
2210 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2211 trace add variable sha1string write sha1change
2212 pack $sha1entry -side left -pady 2
2214 set bm_left_data {
2215 #define left_width 16
2216 #define left_height 16
2217 static unsigned char left_bits[] = {
2218 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2219 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2220 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2222 set bm_right_data {
2223 #define right_width 16
2224 #define right_height 16
2225 static unsigned char right_bits[] = {
2226 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2227 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2228 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2230 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2231 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2232 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2233 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2235 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2236 if {$use_ttk} {
2237 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2238 } else {
2239 .tf.bar.leftbut configure -image bm-left
2241 pack .tf.bar.leftbut -side left -fill y
2242 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2243 if {$use_ttk} {
2244 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2245 } else {
2246 .tf.bar.rightbut configure -image bm-right
2248 pack .tf.bar.rightbut -side left -fill y
2250 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2251 set rownumsel {}
2252 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2253 -relief sunken -anchor e
2254 ${NS}::label .tf.bar.rowlabel2 -text "/"
2255 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2256 -relief sunken -anchor e
2257 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2258 -side left
2259 if {!$use_ttk} {
2260 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2262 global selectedline
2263 trace add variable selectedline write selectedline_change
2265 # Status label and progress bar
2266 set statusw .tf.bar.status
2267 ${NS}::label $statusw -width 15 -relief sunken
2268 pack $statusw -side left -padx 5
2269 if {$use_ttk} {
2270 set progresscanv [ttk::progressbar .tf.bar.progress]
2271 } else {
2272 set h [expr {[font metrics uifont -linespace] + 2}]
2273 set progresscanv .tf.bar.progress
2274 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2275 set progressitem [$progresscanv create rect -1 0 0 $h -fill "#00ff00"]
2276 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2277 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2279 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2280 set progresscoords {0 0}
2281 set fprogcoord 0
2282 set rprogcoord 0
2283 bind $progresscanv <Configure> adjustprogress
2284 set lastprogupdate [clock clicks -milliseconds]
2285 set progupdatepending 0
2287 # build up the bottom bar of upper window
2288 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2290 set bm_down_data {
2291 #define down_width 16
2292 #define down_height 16
2293 static unsigned char down_bits[] = {
2294 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2295 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2296 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2297 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2299 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2300 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2301 .tf.lbar.fnext configure -image bm-down
2303 set bm_up_data {
2304 #define up_width 16
2305 #define up_height 16
2306 static unsigned char up_bits[] = {
2307 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2308 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2309 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2310 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2312 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2313 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2314 .tf.lbar.fprev configure -image bm-up
2316 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2318 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2319 -side left -fill y
2320 set gdttype [mc "containing:"]
2321 set gm [makedroplist .tf.lbar.gdttype gdttype \
2322 [mc "containing:"] \
2323 [mc "touching paths:"] \
2324 [mc "adding/removing string:"] \
2325 [mc "changing lines matching:"]]
2326 trace add variable gdttype write gdttype_change
2327 pack .tf.lbar.gdttype -side left -fill y
2329 set findstring {}
2330 set fstring .tf.lbar.findstring
2331 lappend entries $fstring
2332 ${NS}::entry $fstring -width 30 -textvariable findstring
2333 trace add variable findstring write find_change
2334 set findtype [mc "Exact"]
2335 set findtypemenu [makedroplist .tf.lbar.findtype \
2336 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2337 trace add variable findtype write findcom_change
2338 set findloc [mc "All fields"]
2339 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2340 [mc "Comments"] [mc "Author"] [mc "Committer"]
2341 trace add variable findloc write find_change
2342 pack .tf.lbar.findloc -side right
2343 pack .tf.lbar.findtype -side right
2344 pack $fstring -side left -expand 1 -fill x
2346 # Finish putting the upper half of the viewer together
2347 pack .tf.lbar -in .tf -side bottom -fill x
2348 pack .tf.bar -in .tf -side bottom -fill x
2349 pack .tf.histframe -fill both -side top -expand 1
2350 .ctop add .tf
2351 if {!$use_ttk} {
2352 .ctop paneconfigure .tf -height $geometry(topheight)
2353 .ctop paneconfigure .tf -width $geometry(topwidth)
2356 # now build up the bottom
2357 ${NS}::panedwindow .pwbottom -orient horizontal
2359 # lower left, a text box over search bar, scroll bar to the right
2360 # if we know window height, then that will set the lower text height, otherwise
2361 # we set lower text height which will drive window height
2362 if {[info exists geometry(main)]} {
2363 ${NS}::frame .bleft -width $geometry(botwidth)
2364 } else {
2365 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2367 ${NS}::frame .bleft.top
2368 ${NS}::frame .bleft.mid
2369 ${NS}::frame .bleft.bottom
2371 # gap between sub-widgets
2372 set wgap [font measure uifont "i"]
2374 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2375 pack .bleft.top.search -side left -padx 5
2376 set sstring .bleft.top.sstring
2377 set searchstring ""
2378 ${NS}::entry $sstring -width 20 -textvariable searchstring
2379 lappend entries $sstring
2380 trace add variable searchstring write incrsearch
2381 pack $sstring -side left -expand 1 -fill x
2382 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2383 -command changediffdisp -variable diffelide -value {0 0}
2384 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2385 -command changediffdisp -variable diffelide -value {0 1}
2386 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2387 -command changediffdisp -variable diffelide -value {1 0}
2389 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2390 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left -ipadx $wgap
2391 spinbox .bleft.mid.diffcontext -width 5 \
2392 -from 0 -increment 1 -to 10000000 \
2393 -validate all -validatecommand "diffcontextvalidate %P" \
2394 -textvariable diffcontextstring
2395 .bleft.mid.diffcontext set $diffcontext
2396 trace add variable diffcontextstring write diffcontextchange
2397 lappend entries .bleft.mid.diffcontext
2398 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left -ipadx $wgap
2399 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2400 -command changeignorespace -variable ignorespace
2401 pack .bleft.mid.ignspace -side left -padx 5
2403 set worddiff [mc "Line diff"]
2404 if {[package vcompare $git_version "1.7.2"] >= 0} {
2405 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2406 [mc "Markup words"] [mc "Color words"]
2407 trace add variable worddiff write changeworddiff
2408 pack .bleft.mid.worddiff -side left -padx 5
2411 set ctext .bleft.bottom.ctext
2412 text $ctext -background $bgcolor -foreground $fgcolor \
2413 -state disabled -undo 0 -font textfont \
2414 -yscrollcommand scrolltext -wrap none \
2415 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2416 if {$have_tk85} {
2417 $ctext conf -tabstyle wordprocessor
2419 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2420 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2421 pack .bleft.top -side top -fill x
2422 pack .bleft.mid -side top -fill x
2423 grid $ctext .bleft.bottom.sb -sticky nsew
2424 grid .bleft.bottom.sbhorizontal -sticky ew
2425 grid columnconfigure .bleft.bottom 0 -weight 1
2426 grid rowconfigure .bleft.bottom 0 -weight 1
2427 grid rowconfigure .bleft.bottom 1 -weight 0
2428 pack .bleft.bottom -side top -fill both -expand 1
2429 lappend bglist $ctext
2430 lappend fglist $ctext
2432 $ctext tag conf comment -wrap $wrapcomment
2433 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2434 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2435 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2436 $ctext tag conf d0 -back [lindex $diffbgcolors 0]
2437 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2438 $ctext tag conf dresult -back [lindex $diffbgcolors 1]
2439 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2440 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2441 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2442 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2443 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2444 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2445 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2446 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2447 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2448 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2449 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2450 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2451 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2452 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2453 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2454 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2455 $ctext tag conf mmax -fore darkgrey
2456 set mergemax 16
2457 $ctext tag conf mresult -font textfontbold
2458 $ctext tag conf msep -font textfontbold
2459 $ctext tag conf found -back $foundbgcolor
2460 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2461 $ctext tag conf wwrap -wrap word -lmargin2 1c
2462 $ctext tag conf bold -font textfontbold
2463 # set these to the lowest priority:
2464 $ctext tag lower currentsearchhit
2465 $ctext tag lower found
2466 $ctext tag lower filesep
2467 $ctext tag lower dresult
2468 $ctext tag lower d0
2470 .pwbottom add .bleft
2471 if {!$use_ttk} {
2472 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2475 # lower right
2476 ${NS}::frame .bright
2477 ${NS}::frame .bright.mode
2478 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2479 -command reselectline -variable cmitmode -value "patch"
2480 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2481 -command reselectline -variable cmitmode -value "tree"
2482 grid .bright.mode.patch .bright.mode.tree -sticky ew
2483 pack .bright.mode -side top -fill x
2484 set cflist .bright.cfiles
2485 set indent [font measure mainfont "nn"]
2486 text $cflist \
2487 -selectbackground $selectbgcolor \
2488 -background $bgcolor -foreground $fgcolor \
2489 -font mainfont \
2490 -tabs [list $indent [expr {2 * $indent}]] \
2491 -yscrollcommand ".bright.sb set" \
2492 -cursor [. cget -cursor] \
2493 -spacing1 1 -spacing3 1
2494 lappend bglist $cflist
2495 lappend fglist $cflist
2496 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2497 pack .bright.sb -side right -fill y
2498 pack $cflist -side left -fill both -expand 1
2499 $cflist tag configure highlight \
2500 -background [$cflist cget -selectbackground]
2501 $cflist tag configure bold -font mainfontbold
2503 .pwbottom add .bright
2504 .ctop add .pwbottom
2506 # restore window width & height if known
2507 if {[info exists geometry(main)]} {
2508 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2509 if {$w > [winfo screenwidth .]} {
2510 set w [winfo screenwidth .]
2512 if {$h > [winfo screenheight .]} {
2513 set h [winfo screenheight .]
2515 wm geometry . "${w}x$h"
2519 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2520 wm state . $geometry(state)
2523 if {[tk windowingsystem] eq {aqua}} {
2524 set M1B M1
2525 set ::BM "3"
2526 } else {
2527 set M1B Control
2528 set ::BM "2"
2531 if {$use_ttk} {
2532 bind .ctop <Map> {
2533 bind %W <Map> {}
2534 %W sashpos 0 $::geometry(topheight)
2536 bind .pwbottom <Map> {
2537 bind %W <Map> {}
2538 %W sashpos 0 $::geometry(botwidth)
2540 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2543 pack .ctop -fill both -expand 1
2544 bindall <1> {selcanvline %W %x %y}
2545 #bindall <B1-Motion> {selcanvline %W %x %y}
2546 if {[tk windowingsystem] == "win32"} {
2547 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2548 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2549 } else {
2550 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2551 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2552 bind $ctext <Button> {
2553 if {"%b" eq 6} {
2554 $ctext xview scroll -5 units
2555 } elseif {"%b" eq 7} {
2556 $ctext xview scroll 5 units
2559 if {[tk windowingsystem] eq "aqua"} {
2560 bindall <MouseWheel> {
2561 set delta [expr {- (%D)}]
2562 allcanvs yview scroll $delta units
2564 bindall <Shift-MouseWheel> {
2565 set delta [expr {- (%D)}]
2566 $canv xview scroll $delta units
2570 bindall <$::BM> "canvscan mark %W %x %y"
2571 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2572 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2573 bind . <$M1B-Key-w> doquit
2574 bindkey <Home> selfirstline
2575 bindkey <End> sellastline
2576 bind . <Key-Up> "selnextline -1"
2577 bind . <Key-Down> "selnextline 1"
2578 bind . <Shift-Key-Up> "dofind -1 0"
2579 bind . <Shift-Key-Down> "dofind 1 0"
2580 bindkey <Key-Right> "goforw"
2581 bindkey <Key-Left> "goback"
2582 bind . <Key-Prior> "selnextpage -1"
2583 bind . <Key-Next> "selnextpage 1"
2584 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2585 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2586 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2587 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2588 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2589 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2590 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2591 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2592 bindkey <Key-space> "$ctext yview scroll 1 pages"
2593 bindkey p "selnextline -1"
2594 bindkey n "selnextline 1"
2595 bindkey z "goback"
2596 bindkey x "goforw"
2597 bindkey k "selnextline -1"
2598 bindkey j "selnextline 1"
2599 bindkey h "goback"
2600 bindkey l "goforw"
2601 bindkey b prevfile
2602 bindkey d "$ctext yview scroll 18 units"
2603 bindkey u "$ctext yview scroll -18 units"
2604 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2605 bindkey / {focus $fstring}
2606 bindkey <Key-KP_Divide> {focus $fstring}
2607 bindkey <Key-Return> {dofind 1 1}
2608 bindkey ? {dofind -1 1}
2609 bindkey f nextfile
2610 bind . <F5> updatecommits
2611 bindmodfunctionkey Shift 5 reloadcommits
2612 bind . <F2> showrefs
2613 bindmodfunctionkey Shift 4 {newview 0}
2614 bind . <F4> edit_or_newview
2615 bind . <$M1B-q> doquit
2616 bind . <$M1B-f> {dofind 1 1}
2617 bind . <$M1B-g> {dofind 1 0}
2618 bind . <$M1B-r> dosearchback
2619 bind . <$M1B-s> dosearch
2620 bind . <$M1B-equal> {incrfont 1}
2621 bind . <$M1B-plus> {incrfont 1}
2622 bind . <$M1B-KP_Add> {incrfont 1}
2623 bind . <$M1B-minus> {incrfont -1}
2624 bind . <$M1B-KP_Subtract> {incrfont -1}
2625 wm protocol . WM_DELETE_WINDOW doquit
2626 bind . <Destroy> {stop_backends}
2627 bind . <Button-1> "click %W"
2628 bind $fstring <Key-Return> {dofind 1 1}
2629 bind $sha1entry <Key-Return> {gotocommit; break}
2630 bind $sha1entry <<PasteSelection>> clearsha1
2631 bind $sha1entry <<Paste>> clearsha1
2632 bind $cflist <1> {sel_flist %W %x %y; break}
2633 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2634 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2635 global ctxbut
2636 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2637 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2638 bind $ctext <Button-1> {focus %W}
2639 bind $ctext <<Selection>> rehighlight_search_results
2640 for {set i 1} {$i < 10} {incr i} {
2641 bind . <$M1B-Key-$i> [list go_to_parent $i]
2644 set maincursor [. cget -cursor]
2645 set textcursor [$ctext cget -cursor]
2646 set curtextcursor $textcursor
2648 set rowctxmenu .rowctxmenu
2649 makemenu $rowctxmenu {
2650 {mc "Diff this -> selected" command {diffvssel 0}}
2651 {mc "Diff selected -> this" command {diffvssel 1}}
2652 {mc "Make patch" command mkpatch}
2653 {mc "Create tag" command mktag}
2654 {mc "Copy commit reference" command copyreference}
2655 {mc "Write commit to file" command writecommit}
2656 {mc "Create new branch" command mkbranch}
2657 {mc "Cherry-pick this commit" command cherrypick}
2658 {mc "Reset HEAD branch to here" command resethead}
2659 {mc "Mark this commit" command markhere}
2660 {mc "Return to mark" command gotomark}
2661 {mc "Find descendant of this and mark" command find_common_desc}
2662 {mc "Compare with marked commit" command compare_commits}
2663 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2664 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2665 {mc "Revert this commit" command revert}
2667 $rowctxmenu configure -tearoff 0
2669 set fakerowmenu .fakerowmenu
2670 makemenu $fakerowmenu {
2671 {mc "Diff this -> selected" command {diffvssel 0}}
2672 {mc "Diff selected -> this" command {diffvssel 1}}
2673 {mc "Make patch" command mkpatch}
2674 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2675 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2677 $fakerowmenu configure -tearoff 0
2679 set headctxmenu .headctxmenu
2680 makemenu $headctxmenu {
2681 {mc "Check out this branch" command cobranch}
2682 {mc "Rename this branch" command mvbranch}
2683 {mc "Remove this branch" command rmbranch}
2684 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2686 $headctxmenu configure -tearoff 0
2688 global flist_menu
2689 set flist_menu .flistctxmenu
2690 makemenu $flist_menu {
2691 {mc "Highlight this too" command {flist_hl 0}}
2692 {mc "Highlight this only" command {flist_hl 1}}
2693 {mc "External diff" command {external_diff}}
2694 {mc "Blame parent commit" command {external_blame 1}}
2695 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2697 $flist_menu configure -tearoff 0
2699 global diff_menu
2700 set diff_menu .diffctxmenu
2701 makemenu $diff_menu {
2702 {mc "Show origin of this line" command show_line_source}
2703 {mc "Run git gui blame on this line" command {external_blame_diff}}
2705 $diff_menu configure -tearoff 0
2708 # Windows sends all mouse wheel events to the current focused window, not
2709 # the one where the mouse hovers, so bind those events here and redirect
2710 # to the correct window
2711 proc windows_mousewheel_redirector {W X Y D} {
2712 global canv canv2 canv3
2713 set w [winfo containing -displayof $W $X $Y]
2714 if {$w ne ""} {
2715 set u [expr {$D < 0 ? 5 : -5}]
2716 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2717 allcanvs yview scroll $u units
2718 } else {
2719 catch {
2720 $w yview scroll $u units
2726 # Update row number label when selectedline changes
2727 proc selectedline_change {n1 n2 op} {
2728 global selectedline rownumsel
2730 if {$selectedline eq {}} {
2731 set rownumsel {}
2732 } else {
2733 set rownumsel [expr {$selectedline + 1}]
2737 # mouse-2 makes all windows scan vertically, but only the one
2738 # the cursor is in scans horizontally
2739 proc canvscan {op w x y} {
2740 global canv canv2 canv3
2741 foreach c [list $canv $canv2 $canv3] {
2742 if {$c == $w} {
2743 $c scan $op $x $y
2744 } else {
2745 $c scan $op 0 $y
2750 proc scrollcanv {cscroll f0 f1} {
2751 $cscroll set $f0 $f1
2752 drawvisible
2753 flushhighlights
2756 # when we make a key binding for the toplevel, make sure
2757 # it doesn't get triggered when that key is pressed in the
2758 # find string entry widget.
2759 proc bindkey {ev script} {
2760 global entries
2761 bind . $ev $script
2762 set escript [bind Entry $ev]
2763 if {$escript == {}} {
2764 set escript [bind Entry <Key>]
2766 foreach e $entries {
2767 bind $e $ev "$escript; break"
2771 proc bindmodfunctionkey {mod n script} {
2772 bind . <$mod-F$n> $script
2773 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2776 # set the focus back to the toplevel for any click outside
2777 # the entry widgets
2778 proc click {w} {
2779 global ctext entries
2780 foreach e [concat $entries $ctext] {
2781 if {$w == $e} return
2783 focus .
2786 # Adjust the progress bar for a change in requested extent or canvas size
2787 proc adjustprogress {} {
2788 global progresscanv progressitem progresscoords
2789 global fprogitem fprogcoord lastprogupdate progupdatepending
2790 global rprogitem rprogcoord use_ttk
2792 if {$use_ttk} {
2793 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2794 return
2797 set w [expr {[winfo width $progresscanv] - 4}]
2798 set x0 [expr {$w * [lindex $progresscoords 0]}]
2799 set x1 [expr {$w * [lindex $progresscoords 1]}]
2800 set h [winfo height $progresscanv]
2801 $progresscanv coords $progressitem $x0 0 $x1 $h
2802 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2803 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2804 set now [clock clicks -milliseconds]
2805 if {$now >= $lastprogupdate + 100} {
2806 set progupdatepending 0
2807 update
2808 } elseif {!$progupdatepending} {
2809 set progupdatepending 1
2810 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2814 proc doprogupdate {} {
2815 global lastprogupdate progupdatepending
2817 if {$progupdatepending} {
2818 set progupdatepending 0
2819 set lastprogupdate [clock clicks -milliseconds]
2820 update
2824 proc config_check_tmp_exists {tries_left} {
2825 global config_file_tmp
2827 if {[file exists $config_file_tmp]} {
2828 incr tries_left -1
2829 if {$tries_left > 0} {
2830 after 100 [list config_check_tmp_exists $tries_left]
2831 } else {
2832 error_popup "There appears to be a stale $config_file_tmp\
2833 file, which will prevent gitk from saving its configuration on exit.\
2834 Please remove it if it is not being used by any existing gitk process."
2839 proc config_init_trace {name} {
2840 global config_variable_changed config_variable_original
2842 upvar #0 $name var
2843 set config_variable_changed($name) 0
2844 set config_variable_original($name) $var
2847 proc config_variable_change_cb {name name2 op} {
2848 global config_variable_changed config_variable_original
2850 upvar #0 $name var
2851 if {$op eq "write" &&
2852 (![info exists config_variable_original($name)] ||
2853 $config_variable_original($name) ne $var)} {
2854 set config_variable_changed($name) 1
2858 proc savestuff {w} {
2859 global stuffsaved
2860 global config_file config_file_tmp
2861 global config_variables config_variable_changed
2862 global viewchanged
2864 upvar #0 viewname current_viewname
2865 upvar #0 viewfiles current_viewfiles
2866 upvar #0 viewargs current_viewargs
2867 upvar #0 viewargscmd current_viewargscmd
2868 upvar #0 viewperm current_viewperm
2869 upvar #0 nextviewnum current_nextviewnum
2870 upvar #0 use_ttk current_use_ttk
2872 if {$stuffsaved} return
2873 if {![winfo viewable .]} return
2874 set remove_tmp 0
2875 if {[catch {
2876 set try_count 0
2877 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2878 if {[incr try_count] > 50} {
2879 error "Unable to write config file: $config_file_tmp exists"
2881 after 100
2883 set remove_tmp 1
2884 if {$::tcl_platform(platform) eq {windows}} {
2885 file attributes $config_file_tmp -hidden true
2887 if {[file exists $config_file]} {
2888 source $config_file
2890 foreach var_name $config_variables {
2891 upvar #0 $var_name var
2892 upvar 0 $var_name old_var
2893 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2894 puts $f [list set $var_name $old_var]
2895 } else {
2896 puts $f [list set $var_name $var]
2900 puts $f "set geometry(main) [wm geometry .]"
2901 puts $f "set geometry(state) [wm state .]"
2902 puts $f "set geometry(topwidth) [winfo width .tf]"
2903 puts $f "set geometry(topheight) [winfo height .tf]"
2904 if {$current_use_ttk} {
2905 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2906 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2907 } else {
2908 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2909 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2911 puts $f "set geometry(botwidth) [winfo width .bleft]"
2912 puts $f "set geometry(botheight) [winfo height .bleft]"
2914 array set view_save {}
2915 array set views {}
2916 if {![info exists permviews]} { set permviews {} }
2917 foreach view $permviews {
2918 set view_save([lindex $view 0]) 1
2919 set views([lindex $view 0]) $view
2921 puts -nonewline $f "set permviews {"
2922 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2923 if {$viewchanged($v)} {
2924 if {$current_viewperm($v)} {
2925 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2926 } else {
2927 set view_save($current_viewname($v)) 0
2931 # write old and updated view to their places and append remaining to the end
2932 foreach view $permviews {
2933 set view_name [lindex $view 0]
2934 if {$view_save($view_name)} {
2935 puts $f "{$views($view_name)}"
2937 unset views($view_name)
2939 foreach view_name [array names views] {
2940 puts $f "{$views($view_name)}"
2942 puts $f "}"
2943 close $f
2944 file rename -force $config_file_tmp $config_file
2945 set remove_tmp 0
2946 } err]} {
2947 puts "Error saving config: $err"
2949 if {$remove_tmp} {
2950 file delete -force $config_file_tmp
2952 set stuffsaved 1
2955 proc resizeclistpanes {win w} {
2956 global oldwidth oldsash use_ttk
2957 if {[info exists oldwidth($win)]} {
2958 if {[info exists oldsash($win)]} {
2959 set s0 [lindex $oldsash($win) 0]
2960 set s1 [lindex $oldsash($win) 1]
2961 } elseif {$use_ttk} {
2962 set s0 [$win sashpos 0]
2963 set s1 [$win sashpos 1]
2964 } else {
2965 set s0 [$win sash coord 0]
2966 set s1 [$win sash coord 1]
2968 if {$w < 60} {
2969 set sash0 [expr {int($w/2 - 2)}]
2970 set sash1 [expr {int($w*5/6 - 2)}]
2971 } else {
2972 set factor [expr {1.0 * $w / $oldwidth($win)}]
2973 set sash0 [expr {int($factor * [lindex $s0 0])}]
2974 set sash1 [expr {int($factor * [lindex $s1 0])}]
2975 if {$sash0 < 30} {
2976 set sash0 30
2978 if {$sash1 < $sash0 + 20} {
2979 set sash1 [expr {$sash0 + 20}]
2981 if {$sash1 > $w - 10} {
2982 set sash1 [expr {$w - 10}]
2983 if {$sash0 > $sash1 - 20} {
2984 set sash0 [expr {$sash1 - 20}]
2988 if {$use_ttk} {
2989 $win sashpos 0 $sash0
2990 $win sashpos 1 $sash1
2991 } else {
2992 $win sash place 0 $sash0 [lindex $s0 1]
2993 $win sash place 1 $sash1 [lindex $s1 1]
2995 set oldsash($win) [list $sash0 $sash1]
2997 set oldwidth($win) $w
3000 proc resizecdetpanes {win w} {
3001 global oldwidth oldsash use_ttk
3002 if {[info exists oldwidth($win)]} {
3003 if {[info exists oldsash($win)]} {
3004 set s0 $oldsash($win)
3005 } elseif {$use_ttk} {
3006 set s0 [$win sashpos 0]
3007 } else {
3008 set s0 [$win sash coord 0]
3010 if {$w < 60} {
3011 set sash0 [expr {int($w*3/4 - 2)}]
3012 } else {
3013 set factor [expr {1.0 * $w / $oldwidth($win)}]
3014 set sash0 [expr {int($factor * [lindex $s0 0])}]
3015 if {$sash0 < 45} {
3016 set sash0 45
3018 if {$sash0 > $w - 15} {
3019 set sash0 [expr {$w - 15}]
3022 if {$use_ttk} {
3023 $win sashpos 0 $sash0
3024 } else {
3025 $win sash place 0 $sash0 [lindex $s0 1]
3027 set oldsash($win) $sash0
3029 set oldwidth($win) $w
3032 proc allcanvs args {
3033 global canv canv2 canv3
3034 eval $canv $args
3035 eval $canv2 $args
3036 eval $canv3 $args
3039 proc bindall {event action} {
3040 global canv canv2 canv3
3041 bind $canv $event $action
3042 bind $canv2 $event $action
3043 bind $canv3 $event $action
3046 proc about {} {
3047 global bgcolor NS
3048 set w .about
3049 if {[winfo exists $w]} {
3050 raise $w
3051 return
3053 ttk_toplevel $w
3054 wm title $w [mc "About gitk"]
3055 make_transient $w .
3056 message $w.m -text [mc "
3057 Gitk - a commit viewer for git
3059 Copyright \u00a9 2005-2016 Paul Mackerras
3061 Use and redistribute under the terms of the GNU General Public License"] \
3062 -justify center -aspect 400 -border 2 -bg $bgcolor -relief groove
3063 pack $w.m -side top -fill x -padx 2 -pady 2
3064 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3065 pack $w.ok -side bottom
3066 bind $w <Visibility> "focus $w.ok"
3067 bind $w <Key-Escape> "destroy $w"
3068 bind $w <Key-Return> "destroy $w"
3069 tk::PlaceWindow $w widget .
3072 proc keys {} {
3073 global bgcolor NS
3074 set w .keys
3075 if {[winfo exists $w]} {
3076 raise $w
3077 return
3079 if {[tk windowingsystem] eq {aqua}} {
3080 set M1T Cmd
3081 } else {
3082 set M1T Ctrl
3084 ttk_toplevel $w
3085 wm title $w [mc "Gitk key bindings"]
3086 make_transient $w .
3087 message $w.m -text "
3088 [mc "Gitk key bindings:"]
3090 [mc "<%s-Q> Quit" $M1T]
3091 [mc "<%s-W> Close window" $M1T]
3092 [mc "<Home> Move to first commit"]
3093 [mc "<End> Move to last commit"]
3094 [mc "<Up>, p, k Move up one commit"]
3095 [mc "<Down>, n, j Move down one commit"]
3096 [mc "<Left>, z, h Go back in history list"]
3097 [mc "<Right>, x, l Go forward in history list"]
3098 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3099 [mc "<PageUp> Move up one page in commit list"]
3100 [mc "<PageDown> Move down one page in commit list"]
3101 [mc "<%s-Home> Scroll to top of commit list" $M1T]
3102 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
3103 [mc "<%s-Up> Scroll commit list up one line" $M1T]
3104 [mc "<%s-Down> Scroll commit list down one line" $M1T]
3105 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3106 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3107 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3108 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3109 [mc "<Delete>, b Scroll diff view up one page"]
3110 [mc "<Backspace> Scroll diff view up one page"]
3111 [mc "<Space> Scroll diff view down one page"]
3112 [mc "u Scroll diff view up 18 lines"]
3113 [mc "d Scroll diff view down 18 lines"]
3114 [mc "<%s-F> Find" $M1T]
3115 [mc "<%s-G> Move to next find hit" $M1T]
3116 [mc "<Return> Move to next find hit"]
3117 [mc "g Go to commit"]
3118 [mc "/ Focus the search box"]
3119 [mc "? Move to previous find hit"]
3120 [mc "f Scroll diff view to next file"]
3121 [mc "<%s-S> Search for next hit in diff view" $M1T]
3122 [mc "<%s-R> Search for previous hit in diff view" $M1T]
3123 [mc "<%s-KP+> Increase font size" $M1T]
3124 [mc "<%s-plus> Increase font size" $M1T]
3125 [mc "<%s-KP-> Decrease font size" $M1T]
3126 [mc "<%s-minus> Decrease font size" $M1T]
3127 [mc "<F5> Update"]
3129 -justify left -bg $bgcolor -border 2 -relief groove
3130 pack $w.m -side top -fill both -padx 2 -pady 2
3131 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3132 bind $w <Key-Escape> [list destroy $w]
3133 pack $w.ok -side bottom
3134 bind $w <Visibility> "focus $w.ok"
3135 bind $w <Key-Escape> "destroy $w"
3136 bind $w <Key-Return> "destroy $w"
3139 # Procedures for manipulating the file list window at the
3140 # bottom right of the overall window.
3142 proc treeview {w l openlevs} {
3143 global treecontents treediropen treeheight treeparent treeindex
3145 set ix 0
3146 set treeindex() 0
3147 set lev 0
3148 set prefix {}
3149 set prefixend -1
3150 set prefendstack {}
3151 set htstack {}
3152 set ht 0
3153 set treecontents() {}
3154 $w conf -state normal
3155 foreach f $l {
3156 while {[string range $f 0 $prefixend] ne $prefix} {
3157 if {$lev <= $openlevs} {
3158 $w mark set e:$treeindex($prefix) "end -1c"
3159 $w mark gravity e:$treeindex($prefix) left
3161 set treeheight($prefix) $ht
3162 incr ht [lindex $htstack end]
3163 set htstack [lreplace $htstack end end]
3164 set prefixend [lindex $prefendstack end]
3165 set prefendstack [lreplace $prefendstack end end]
3166 set prefix [string range $prefix 0 $prefixend]
3167 incr lev -1
3169 set tail [string range $f [expr {$prefixend+1}] end]
3170 while {[set slash [string first "/" $tail]] >= 0} {
3171 lappend htstack $ht
3172 set ht 0
3173 lappend prefendstack $prefixend
3174 incr prefixend [expr {$slash + 1}]
3175 set d [string range $tail 0 $slash]
3176 lappend treecontents($prefix) $d
3177 set oldprefix $prefix
3178 append prefix $d
3179 set treecontents($prefix) {}
3180 set treeindex($prefix) [incr ix]
3181 set treeparent($prefix) $oldprefix
3182 set tail [string range $tail [expr {$slash+1}] end]
3183 if {$lev <= $openlevs} {
3184 set ht 1
3185 set treediropen($prefix) [expr {$lev < $openlevs}]
3186 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3187 $w mark set d:$ix "end -1c"
3188 $w mark gravity d:$ix left
3189 set str "\n"
3190 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3191 $w insert end $str
3192 $w image create end -align center -image $bm -padx 1 \
3193 -name a:$ix
3194 $w insert end $d [highlight_tag $prefix]
3195 $w mark set s:$ix "end -1c"
3196 $w mark gravity s:$ix left
3198 incr lev
3200 if {$tail ne {}} {
3201 if {$lev <= $openlevs} {
3202 incr ht
3203 set str "\n"
3204 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3205 $w insert end $str
3206 $w insert end $tail [highlight_tag $f]
3208 lappend treecontents($prefix) $tail
3211 while {$htstack ne {}} {
3212 set treeheight($prefix) $ht
3213 incr ht [lindex $htstack end]
3214 set htstack [lreplace $htstack end end]
3215 set prefixend [lindex $prefendstack end]
3216 set prefendstack [lreplace $prefendstack end end]
3217 set prefix [string range $prefix 0 $prefixend]
3219 $w conf -state disabled
3222 proc linetoelt {l} {
3223 global treeheight treecontents
3225 set y 2
3226 set prefix {}
3227 while {1} {
3228 foreach e $treecontents($prefix) {
3229 if {$y == $l} {
3230 return "$prefix$e"
3232 set n 1
3233 if {[string index $e end] eq "/"} {
3234 set n $treeheight($prefix$e)
3235 if {$y + $n > $l} {
3236 append prefix $e
3237 incr y
3238 break
3241 incr y $n
3246 proc highlight_tree {y prefix} {
3247 global treeheight treecontents cflist
3249 foreach e $treecontents($prefix) {
3250 set path $prefix$e
3251 if {[highlight_tag $path] ne {}} {
3252 $cflist tag add bold $y.0 "$y.0 lineend"
3254 incr y
3255 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3256 set y [highlight_tree $y $path]
3259 return $y
3262 proc treeclosedir {w dir} {
3263 global treediropen treeheight treeparent treeindex
3265 set ix $treeindex($dir)
3266 $w conf -state normal
3267 $w delete s:$ix e:$ix
3268 set treediropen($dir) 0
3269 $w image configure a:$ix -image tri-rt
3270 $w conf -state disabled
3271 set n [expr {1 - $treeheight($dir)}]
3272 while {$dir ne {}} {
3273 incr treeheight($dir) $n
3274 set dir $treeparent($dir)
3278 proc treeopendir {w dir} {
3279 global treediropen treeheight treeparent treecontents treeindex
3281 set ix $treeindex($dir)
3282 $w conf -state normal
3283 $w image configure a:$ix -image tri-dn
3284 $w mark set e:$ix s:$ix
3285 $w mark gravity e:$ix right
3286 set lev 0
3287 set str "\n"
3288 set n [llength $treecontents($dir)]
3289 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3290 incr lev
3291 append str "\t"
3292 incr treeheight($x) $n
3294 foreach e $treecontents($dir) {
3295 set de $dir$e
3296 if {[string index $e end] eq "/"} {
3297 set iy $treeindex($de)
3298 $w mark set d:$iy e:$ix
3299 $w mark gravity d:$iy left
3300 $w insert e:$ix $str
3301 set treediropen($de) 0
3302 $w image create e:$ix -align center -image tri-rt -padx 1 \
3303 -name a:$iy
3304 $w insert e:$ix $e [highlight_tag $de]
3305 $w mark set s:$iy e:$ix
3306 $w mark gravity s:$iy left
3307 set treeheight($de) 1
3308 } else {
3309 $w insert e:$ix $str
3310 $w insert e:$ix $e [highlight_tag $de]
3313 $w mark gravity e:$ix right
3314 $w conf -state disabled
3315 set treediropen($dir) 1
3316 set top [lindex [split [$w index @0,0] .] 0]
3317 set ht [$w cget -height]
3318 set l [lindex [split [$w index s:$ix] .] 0]
3319 if {$l < $top} {
3320 $w yview $l.0
3321 } elseif {$l + $n + 1 > $top + $ht} {
3322 set top [expr {$l + $n + 2 - $ht}]
3323 if {$l < $top} {
3324 set top $l
3326 $w yview $top.0
3330 proc treeclick {w x y} {
3331 global treediropen cmitmode ctext cflist cflist_top
3333 if {$cmitmode ne "tree"} return
3334 if {![info exists cflist_top]} return
3335 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3336 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3337 $cflist tag add highlight $l.0 "$l.0 lineend"
3338 set cflist_top $l
3339 if {$l == 1} {
3340 $ctext yview 1.0
3341 return
3343 set e [linetoelt $l]
3344 if {[string index $e end] ne "/"} {
3345 showfile $e
3346 } elseif {$treediropen($e)} {
3347 treeclosedir $w $e
3348 } else {
3349 treeopendir $w $e
3353 proc setfilelist {id} {
3354 global treefilelist cflist jump_to_here
3356 treeview $cflist $treefilelist($id) 0
3357 if {$jump_to_here ne {}} {
3358 set f [lindex $jump_to_here 0]
3359 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3360 showfile $f
3365 image create bitmap tri-rt -background black -foreground blue -data {
3366 #define tri-rt_width 13
3367 #define tri-rt_height 13
3368 static unsigned char tri-rt_bits[] = {
3369 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3370 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3371 0x00, 0x00};
3372 } -maskdata {
3373 #define tri-rt-mask_width 13
3374 #define tri-rt-mask_height 13
3375 static unsigned char tri-rt-mask_bits[] = {
3376 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3377 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3378 0x08, 0x00};
3380 image create bitmap tri-dn -background black -foreground blue -data {
3381 #define tri-dn_width 13
3382 #define tri-dn_height 13
3383 static unsigned char tri-dn_bits[] = {
3384 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3385 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3386 0x00, 0x00};
3387 } -maskdata {
3388 #define tri-dn-mask_width 13
3389 #define tri-dn-mask_height 13
3390 static unsigned char tri-dn-mask_bits[] = {
3391 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3392 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3393 0x00, 0x00};
3396 image create bitmap reficon-T -background black -foreground yellow -data {
3397 #define tagicon_width 13
3398 #define tagicon_height 9
3399 static unsigned char tagicon_bits[] = {
3400 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3401 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3402 } -maskdata {
3403 #define tagicon-mask_width 13
3404 #define tagicon-mask_height 9
3405 static unsigned char tagicon-mask_bits[] = {
3406 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3407 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3409 set rectdata {
3410 #define headicon_width 13
3411 #define headicon_height 9
3412 static unsigned char headicon_bits[] = {
3413 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3414 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3416 set rectmask {
3417 #define headicon-mask_width 13
3418 #define headicon-mask_height 9
3419 static unsigned char headicon-mask_bits[] = {
3420 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3421 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3423 image create bitmap reficon-H -background black -foreground "#00ff00" \
3424 -data $rectdata -maskdata $rectmask
3425 image create bitmap reficon-R -background black -foreground "#ffddaa" \
3426 -data $rectdata -maskdata $rectmask
3427 image create bitmap reficon-o -background black -foreground "#ddddff" \
3428 -data $rectdata -maskdata $rectmask
3430 proc init_flist {first} {
3431 global cflist cflist_top difffilestart
3433 $cflist conf -state normal
3434 $cflist delete 0.0 end
3435 if {$first ne {}} {
3436 $cflist insert end $first
3437 set cflist_top 1
3438 $cflist tag add highlight 1.0 "1.0 lineend"
3439 } else {
3440 unset -nocomplain cflist_top
3442 $cflist conf -state disabled
3443 set difffilestart {}
3446 proc highlight_tag {f} {
3447 global highlight_paths
3449 foreach p $highlight_paths {
3450 if {[string match $p $f]} {
3451 return "bold"
3454 return {}
3457 proc highlight_filelist {} {
3458 global cmitmode cflist
3460 $cflist conf -state normal
3461 if {$cmitmode ne "tree"} {
3462 set end [lindex [split [$cflist index end] .] 0]
3463 for {set l 2} {$l < $end} {incr l} {
3464 set line [$cflist get $l.0 "$l.0 lineend"]
3465 if {[highlight_tag $line] ne {}} {
3466 $cflist tag add bold $l.0 "$l.0 lineend"
3469 } else {
3470 highlight_tree 2 {}
3472 $cflist conf -state disabled
3475 proc unhighlight_filelist {} {
3476 global cflist
3478 $cflist conf -state normal
3479 $cflist tag remove bold 1.0 end
3480 $cflist conf -state disabled
3483 proc add_flist {fl} {
3484 global cflist
3486 $cflist conf -state normal
3487 foreach f $fl {
3488 $cflist insert end "\n"
3489 $cflist insert end $f [highlight_tag $f]
3491 $cflist conf -state disabled
3494 proc sel_flist {w x y} {
3495 global ctext difffilestart cflist cflist_top cmitmode
3497 if {$cmitmode eq "tree"} return
3498 if {![info exists cflist_top]} return
3499 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3500 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3501 $cflist tag add highlight $l.0 "$l.0 lineend"
3502 set cflist_top $l
3503 if {$l == 1} {
3504 $ctext yview 1.0
3505 } else {
3506 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3508 suppress_highlighting_file_for_current_scrollpos
3511 proc pop_flist_menu {w X Y x y} {
3512 global ctext cflist cmitmode flist_menu flist_menu_file
3513 global treediffs diffids
3515 stopfinding
3516 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3517 if {$l <= 1} return
3518 if {$cmitmode eq "tree"} {
3519 set e [linetoelt $l]
3520 if {[string index $e end] eq "/"} return
3521 } else {
3522 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3524 set flist_menu_file $e
3525 set xdiffstate "normal"
3526 if {$cmitmode eq "tree"} {
3527 set xdiffstate "disabled"
3529 # Disable "External diff" item in tree mode
3530 $flist_menu entryconf 2 -state $xdiffstate
3531 tk_popup $flist_menu $X $Y
3534 proc find_ctext_fileinfo {line} {
3535 global ctext_file_names ctext_file_lines
3537 set ok [bsearch $ctext_file_lines $line]
3538 set tline [lindex $ctext_file_lines $ok]
3540 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3541 return {}
3542 } else {
3543 return [list [lindex $ctext_file_names $ok] $tline]
3547 proc pop_diff_menu {w X Y x y} {
3548 global ctext diff_menu flist_menu_file
3549 global diff_menu_txtpos diff_menu_line
3550 global diff_menu_filebase
3552 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3553 set diff_menu_line [lindex $diff_menu_txtpos 0]
3554 # don't pop up the menu on hunk-separator or file-separator lines
3555 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3556 return
3558 stopfinding
3559 set f [find_ctext_fileinfo $diff_menu_line]
3560 if {$f eq {}} return
3561 set flist_menu_file [lindex $f 0]
3562 set diff_menu_filebase [lindex $f 1]
3563 tk_popup $diff_menu $X $Y
3566 proc flist_hl {only} {
3567 global flist_menu_file findstring gdttype
3569 set x [shellquote $flist_menu_file]
3570 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3571 set findstring $x
3572 } else {
3573 append findstring " " $x
3575 set gdttype [mc "touching paths:"]
3578 proc gitknewtmpdir {} {
3579 global diffnum gitktmpdir gitdir env
3581 if {![info exists gitktmpdir]} {
3582 if {[info exists env(GITK_TMPDIR)]} {
3583 set tmpdir $env(GITK_TMPDIR)
3584 } elseif {[info exists env(TMPDIR)]} {
3585 set tmpdir $env(TMPDIR)
3586 } else {
3587 set tmpdir $gitdir
3589 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3590 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3591 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3593 if {[catch {file mkdir $gitktmpdir} err]} {
3594 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3595 unset gitktmpdir
3596 return {}
3598 set diffnum 0
3600 incr diffnum
3601 set diffdir [file join $gitktmpdir $diffnum]
3602 if {[catch {file mkdir $diffdir} err]} {
3603 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3604 return {}
3606 return $diffdir
3609 proc save_file_from_commit {filename output what} {
3610 global nullfile
3612 if {[catch {exec git show $filename -- > $output} err]} {
3613 if {[string match "fatal: bad revision *" $err]} {
3614 return $nullfile
3616 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3617 return {}
3619 return $output
3622 proc external_diff_get_one_file {diffid filename diffdir} {
3623 global nullid nullid2 nullfile
3624 global worktree
3626 if {$diffid == $nullid} {
3627 set difffile [file join $worktree $filename]
3628 if {[file exists $difffile]} {
3629 return $difffile
3631 return $nullfile
3633 if {$diffid == $nullid2} {
3634 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3635 return [save_file_from_commit :$filename $difffile index]
3637 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3638 return [save_file_from_commit $diffid:$filename $difffile \
3639 "revision $diffid"]
3642 proc external_diff {} {
3643 global nullid nullid2
3644 global flist_menu_file
3645 global diffids
3646 global extdifftool
3648 if {[llength $diffids] == 1} {
3649 # no reference commit given
3650 set diffidto [lindex $diffids 0]
3651 if {$diffidto eq $nullid} {
3652 # diffing working copy with index
3653 set diffidfrom $nullid2
3654 } elseif {$diffidto eq $nullid2} {
3655 # diffing index with HEAD
3656 set diffidfrom "HEAD"
3657 } else {
3658 # use first parent commit
3659 global parentlist selectedline
3660 set diffidfrom [lindex $parentlist $selectedline 0]
3662 } else {
3663 set diffidfrom [lindex $diffids 0]
3664 set diffidto [lindex $diffids 1]
3667 # make sure that several diffs wont collide
3668 set diffdir [gitknewtmpdir]
3669 if {$diffdir eq {}} return
3671 # gather files to diff
3672 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3673 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3675 if {$difffromfile ne {} && $difftofile ne {}} {
3676 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3677 if {[catch {set fl [open |$cmd r]} err]} {
3678 file delete -force $diffdir
3679 error_popup "$extdifftool: [mc "command failed:"] $err"
3680 } else {
3681 fconfigure $fl -blocking 0
3682 filerun $fl [list delete_at_eof $fl $diffdir]
3687 proc find_hunk_blamespec {base line} {
3688 global ctext
3690 # Find and parse the hunk header
3691 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3692 if {$s_lix eq {}} return
3694 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3695 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3696 s_line old_specs osz osz1 new_line nsz]} {
3697 return
3700 # base lines for the parents
3701 set base_lines [list $new_line]
3702 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3703 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3704 old_spec old_line osz]} {
3705 return
3707 lappend base_lines $old_line
3710 # Now scan the lines to determine offset within the hunk
3711 set max_parent [expr {[llength $base_lines]-2}]
3712 set dline 0
3713 set s_lno [lindex [split $s_lix "."] 0]
3715 # Determine if the line is removed
3716 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3717 if {[string match {[-+ ]*} $chunk]} {
3718 set removed_idx [string first "-" $chunk]
3719 # Choose a parent index
3720 if {$removed_idx >= 0} {
3721 set parent $removed_idx
3722 } else {
3723 set unchanged_idx [string first " " $chunk]
3724 if {$unchanged_idx >= 0} {
3725 set parent $unchanged_idx
3726 } else {
3727 # blame the current commit
3728 set parent -1
3731 # then count other lines that belong to it
3732 for {set i $line} {[incr i -1] > $s_lno} {} {
3733 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3734 # Determine if the line is removed
3735 set removed_idx [string first "-" $chunk]
3736 if {$parent >= 0} {
3737 set code [string index $chunk $parent]
3738 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3739 incr dline
3741 } else {
3742 if {$removed_idx < 0} {
3743 incr dline
3747 incr parent
3748 } else {
3749 set parent 0
3752 incr dline [lindex $base_lines $parent]
3753 return [list $parent $dline]
3756 proc external_blame_diff {} {
3757 global currentid cmitmode
3758 global diff_menu_txtpos diff_menu_line
3759 global diff_menu_filebase flist_menu_file
3761 if {$cmitmode eq "tree"} {
3762 set parent_idx 0
3763 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3764 } else {
3765 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3766 if {$hinfo ne {}} {
3767 set parent_idx [lindex $hinfo 0]
3768 set line [lindex $hinfo 1]
3769 } else {
3770 set parent_idx 0
3771 set line 0
3775 external_blame $parent_idx $line
3778 # Find the SHA1 ID of the blob for file $fname in the index
3779 # at stage 0 or 2
3780 proc index_sha1 {fname} {
3781 set f [open [list | git ls-files -s $fname] r]
3782 while {[gets $f line] >= 0} {
3783 set info [lindex [split $line "\t"] 0]
3784 set stage [lindex $info 2]
3785 if {$stage eq "0" || $stage eq "2"} {
3786 close $f
3787 return [lindex $info 1]
3790 close $f
3791 return {}
3794 # Turn an absolute path into one relative to the current directory
3795 proc make_relative {f} {
3796 if {[file pathtype $f] eq "relative"} {
3797 return $f
3799 set elts [file split $f]
3800 set here [file split [pwd]]
3801 set ei 0
3802 set hi 0
3803 set res {}
3804 foreach d $here {
3805 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3806 lappend res ".."
3807 } else {
3808 incr ei
3810 incr hi
3812 set elts [concat $res [lrange $elts $ei end]]
3813 return [eval file join $elts]
3816 proc external_blame {parent_idx {line {}}} {
3817 global flist_menu_file cdup
3818 global nullid nullid2
3819 global parentlist selectedline currentid
3821 if {$parent_idx > 0} {
3822 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3823 } else {
3824 set base_commit $currentid
3827 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3828 error_popup [mc "No such commit"]
3829 return
3832 set cmdline [list git gui blame]
3833 if {$line ne {} && $line > 1} {
3834 lappend cmdline "--line=$line"
3836 set f [file join $cdup $flist_menu_file]
3837 # Unfortunately it seems git gui blame doesn't like
3838 # being given an absolute path...
3839 set f [make_relative $f]
3840 lappend cmdline $base_commit $f
3841 if {[catch {eval exec $cmdline &} err]} {
3842 error_popup "[mc "git gui blame: command failed:"] $err"
3846 proc show_line_source {} {
3847 global cmitmode currentid parents curview blamestuff blameinst
3848 global diff_menu_line diff_menu_filebase flist_menu_file
3849 global nullid nullid2 gitdir cdup
3851 set from_index {}
3852 if {$cmitmode eq "tree"} {
3853 set id $currentid
3854 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3855 } else {
3856 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3857 if {$h eq {}} return
3858 set pi [lindex $h 0]
3859 if {$pi == 0} {
3860 mark_ctext_line $diff_menu_line
3861 return
3863 incr pi -1
3864 if {$currentid eq $nullid} {
3865 if {$pi > 0} {
3866 # must be a merge in progress...
3867 if {[catch {
3868 # get the last line from .git/MERGE_HEAD
3869 set f [open [file join $gitdir MERGE_HEAD] r]
3870 set id [lindex [split [read $f] "\n"] end-1]
3871 close $f
3872 } err]} {
3873 error_popup [mc "Couldn't read merge head: %s" $err]
3874 return
3876 } elseif {$parents($curview,$currentid) eq $nullid2} {
3877 # need to do the blame from the index
3878 if {[catch {
3879 set from_index [index_sha1 $flist_menu_file]
3880 } err]} {
3881 error_popup [mc "Error reading index: %s" $err]
3882 return
3884 } else {
3885 set id $parents($curview,$currentid)
3887 } else {
3888 set id [lindex $parents($curview,$currentid) $pi]
3890 set line [lindex $h 1]
3892 set blameargs {}
3893 if {$from_index ne {}} {
3894 lappend blameargs | git cat-file blob $from_index
3896 lappend blameargs | git blame -p -L$line,+1
3897 if {$from_index ne {}} {
3898 lappend blameargs --contents -
3899 } else {
3900 lappend blameargs $id
3902 lappend blameargs -- [file join $cdup $flist_menu_file]
3903 if {[catch {
3904 set f [open $blameargs r]
3905 } err]} {
3906 error_popup [mc "Couldn't start git blame: %s" $err]
3907 return
3909 nowbusy blaming [mc "Searching"]
3910 fconfigure $f -blocking 0
3911 set i [reg_instance $f]
3912 set blamestuff($i) {}
3913 set blameinst $i
3914 filerun $f [list read_line_source $f $i]
3917 proc stopblaming {} {
3918 global blameinst
3920 if {[info exists blameinst]} {
3921 stop_instance $blameinst
3922 unset blameinst
3923 notbusy blaming
3927 proc read_line_source {fd inst} {
3928 global blamestuff curview commfd blameinst nullid nullid2
3930 while {[gets $fd line] >= 0} {
3931 lappend blamestuff($inst) $line
3933 if {![eof $fd]} {
3934 return 1
3936 unset commfd($inst)
3937 unset blameinst
3938 notbusy blaming
3939 fconfigure $fd -blocking 1
3940 if {[catch {close $fd} err]} {
3941 error_popup [mc "Error running git blame: %s" $err]
3942 return 0
3945 set fname {}
3946 set line [split [lindex $blamestuff($inst) 0] " "]
3947 set id [lindex $line 0]
3948 set lnum [lindex $line 1]
3949 if {[string length $id] == 40 && [string is xdigit $id] &&
3950 [string is digit -strict $lnum]} {
3951 # look for "filename" line
3952 foreach l $blamestuff($inst) {
3953 if {[string match "filename *" $l]} {
3954 set fname [string range $l 9 end]
3955 break
3959 if {$fname ne {}} {
3960 # all looks good, select it
3961 if {$id eq $nullid} {
3962 # blame uses all-zeroes to mean not committed,
3963 # which would mean a change in the index
3964 set id $nullid2
3966 if {[commitinview $id $curview]} {
3967 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3968 } else {
3969 error_popup [mc "That line comes from commit %s, \
3970 which is not in this view" [shortids $id]]
3972 } else {
3973 puts "oops couldn't parse git blame output"
3975 return 0
3978 # delete $dir when we see eof on $f (presumably because the child has exited)
3979 proc delete_at_eof {f dir} {
3980 while {[gets $f line] >= 0} {}
3981 if {[eof $f]} {
3982 if {[catch {close $f} err]} {
3983 error_popup "[mc "External diff viewer failed:"] $err"
3985 file delete -force $dir
3986 return 0
3988 return 1
3991 # Functions for adding and removing shell-type quoting
3993 proc shellquote {str} {
3994 if {![string match "*\['\"\\ \t]*" $str]} {
3995 return $str
3997 if {![string match "*\['\"\\]*" $str]} {
3998 return "\"$str\""
4000 if {![string match "*'*" $str]} {
4001 return "'$str'"
4003 return "\"[string map {\" \\\" \\ \\\\} $str]\""
4006 proc shellarglist {l} {
4007 set str {}
4008 foreach a $l {
4009 if {$str ne {}} {
4010 append str " "
4012 append str [shellquote $a]
4014 return $str
4017 proc shelldequote {str} {
4018 set ret {}
4019 set used -1
4020 while {1} {
4021 incr used
4022 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
4023 append ret [string range $str $used end]
4024 set used [string length $str]
4025 break
4027 set first [lindex $first 0]
4028 set ch [string index $str $first]
4029 if {$first > $used} {
4030 append ret [string range $str $used [expr {$first - 1}]]
4031 set used $first
4033 if {$ch eq " " || $ch eq "\t"} break
4034 incr used
4035 if {$ch eq "'"} {
4036 set first [string first "'" $str $used]
4037 if {$first < 0} {
4038 error "unmatched single-quote"
4040 append ret [string range $str $used [expr {$first - 1}]]
4041 set used $first
4042 continue
4044 if {$ch eq "\\"} {
4045 if {$used >= [string length $str]} {
4046 error "trailing backslash"
4048 append ret [string index $str $used]
4049 continue
4051 # here ch == "\""
4052 while {1} {
4053 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4054 error "unmatched double-quote"
4056 set first [lindex $first 0]
4057 set ch [string index $str $first]
4058 if {$first > $used} {
4059 append ret [string range $str $used [expr {$first - 1}]]
4060 set used $first
4062 if {$ch eq "\""} break
4063 incr used
4064 append ret [string index $str $used]
4065 incr used
4068 return [list $used $ret]
4071 proc shellsplit {str} {
4072 set l {}
4073 while {1} {
4074 set str [string trimleft $str]
4075 if {$str eq {}} break
4076 set dq [shelldequote $str]
4077 set n [lindex $dq 0]
4078 set word [lindex $dq 1]
4079 set str [string range $str $n end]
4080 lappend l $word
4082 return $l
4085 proc set_window_title {} {
4086 global appname curview viewname vrevs
4087 set rev [mc "All files"]
4088 if {$curview ne 0} {
4089 if {$viewname($curview) eq [mc "Command line"]} {
4090 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4091 } else {
4092 set rev $viewname($curview)
4095 wm title . "[reponame]: $rev - $appname"
4098 # Code to implement multiple views
4100 proc newview {ishighlight} {
4101 global nextviewnum newviewname newishighlight
4102 global revtreeargs viewargscmd newviewopts curview
4104 set newishighlight $ishighlight
4105 set top .gitkview
4106 if {[winfo exists $top]} {
4107 raise $top
4108 return
4110 decode_view_opts $nextviewnum $revtreeargs
4111 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4112 set newviewopts($nextviewnum,perm) 0
4113 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4114 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4117 set known_view_options {
4118 {perm b . {} {mc "Remember this view"}}
4119 {reflabel l + {} {mc "References (space separated list):"}}
4120 {refs t15 .. {} {mc "Branches & tags:"}}
4121 {allrefs b *. "--all" {mc "All refs"}}
4122 {branches b . "--branches" {mc "All (local) branches"}}
4123 {tags b . "--tags" {mc "All tags"}}
4124 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4125 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4126 {author t15 .. "--author=*" {mc "Author:"}}
4127 {committer t15 . "--committer=*" {mc "Committer:"}}
4128 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4129 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4130 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4131 {changes_l l + {} {mc "Changes to Files:"}}
4132 {pickaxe_s r0 . {} {mc "Fixed String"}}
4133 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4134 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4135 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4136 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4137 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4138 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4139 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4140 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4141 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4142 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4143 {lright b . "--left-right" {mc "Mark branch sides"}}
4144 {first b . "--first-parent" {mc "Limit to first parent"}}
4145 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4146 {args t50 *. {} {mc "Additional arguments to git log:"}}
4147 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4148 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4151 # Convert $newviewopts($n, ...) into args for git log.
4152 proc encode_view_opts {n} {
4153 global known_view_options newviewopts
4155 set rargs [list]
4156 foreach opt $known_view_options {
4157 set patterns [lindex $opt 3]
4158 if {$patterns eq {}} continue
4159 set pattern [lindex $patterns 0]
4161 if {[lindex $opt 1] eq "b"} {
4162 set val $newviewopts($n,[lindex $opt 0])
4163 if {$val} {
4164 lappend rargs $pattern
4166 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4167 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4168 set val $newviewopts($n,$button_id)
4169 if {$val eq $value} {
4170 lappend rargs $pattern
4172 } else {
4173 set val $newviewopts($n,[lindex $opt 0])
4174 set val [string trim $val]
4175 if {$val ne {}} {
4176 set pfix [string range $pattern 0 end-1]
4177 lappend rargs $pfix$val
4181 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4182 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4185 # Fill $newviewopts($n, ...) based on args for git log.
4186 proc decode_view_opts {n view_args} {
4187 global known_view_options newviewopts
4189 foreach opt $known_view_options {
4190 set id [lindex $opt 0]
4191 if {[lindex $opt 1] eq "b"} {
4192 # Checkboxes
4193 set val 0
4194 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4195 # Radiobuttons
4196 regexp {^(.*_)} $id uselessvar id
4197 set val 0
4198 } else {
4199 # Text fields
4200 set val {}
4202 set newviewopts($n,$id) $val
4204 set oargs [list]
4205 set refargs [list]
4206 foreach arg $view_args {
4207 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4208 && ![info exists found(limit)]} {
4209 set newviewopts($n,limit) $cnt
4210 set found(limit) 1
4211 continue
4213 catch { unset val }
4214 foreach opt $known_view_options {
4215 set id [lindex $opt 0]
4216 if {[info exists found($id)]} continue
4217 foreach pattern [lindex $opt 3] {
4218 if {![string match $pattern $arg]} continue
4219 if {[lindex $opt 1] eq "b"} {
4220 # Check buttons
4221 set val 1
4222 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4223 # Radio buttons
4224 regexp {^(.*_)} $id uselessvar id
4225 set val $num
4226 } else {
4227 # Text input fields
4228 set size [string length $pattern]
4229 set val [string range $arg [expr {$size-1}] end]
4231 set newviewopts($n,$id) $val
4232 set found($id) 1
4233 break
4235 if {[info exists val]} break
4237 if {[info exists val]} continue
4238 if {[regexp {^-} $arg]} {
4239 lappend oargs $arg
4240 } else {
4241 lappend refargs $arg
4244 set newviewopts($n,refs) [shellarglist $refargs]
4245 set newviewopts($n,args) [shellarglist $oargs]
4248 proc edit_or_newview {} {
4249 global curview
4251 if {$curview > 0} {
4252 editview
4253 } else {
4254 newview 0
4258 proc editview {} {
4259 global curview
4260 global viewname viewperm newviewname newviewopts
4261 global viewargs viewargscmd
4263 set top .gitkvedit-$curview
4264 if {[winfo exists $top]} {
4265 raise $top
4266 return
4268 decode_view_opts $curview $viewargs($curview)
4269 set newviewname($curview) $viewname($curview)
4270 set newviewopts($curview,perm) $viewperm($curview)
4271 set newviewopts($curview,cmd) $viewargscmd($curview)
4272 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4275 proc vieweditor {top n title} {
4276 global newviewname newviewopts viewfiles bgcolor
4277 global known_view_options NS
4279 ttk_toplevel $top
4280 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4281 make_transient $top .
4283 # View name
4284 ${NS}::frame $top.nfr
4285 ${NS}::label $top.nl -text [mc "View Name"]
4286 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4287 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4288 pack $top.nl -in $top.nfr -side left -padx {0 5}
4289 pack $top.name -in $top.nfr -side left -padx {0 25}
4291 # View options
4292 set cframe $top.nfr
4293 set cexpand 0
4294 set cnt 0
4295 foreach opt $known_view_options {
4296 set id [lindex $opt 0]
4297 set type [lindex $opt 1]
4298 set flags [lindex $opt 2]
4299 set title [eval [lindex $opt 4]]
4300 set lxpad 0
4302 if {$flags eq "+" || $flags eq "*"} {
4303 set cframe $top.fr$cnt
4304 incr cnt
4305 ${NS}::frame $cframe
4306 pack $cframe -in $top -fill x -pady 3 -padx 3
4307 set cexpand [expr {$flags eq "*"}]
4308 } elseif {$flags eq ".." || $flags eq "*."} {
4309 set cframe $top.fr$cnt
4310 incr cnt
4311 ${NS}::frame $cframe
4312 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4313 set cexpand [expr {$flags eq "*."}]
4314 } else {
4315 set lxpad 5
4318 if {$type eq "l"} {
4319 ${NS}::label $cframe.l_$id -text $title
4320 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4321 } elseif {$type eq "b"} {
4322 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4323 pack $cframe.c_$id -in $cframe -side left \
4324 -padx [list $lxpad 0] -expand $cexpand -anchor w
4325 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4326 regexp {^(.*_)} $id uselessvar button_id
4327 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4328 pack $cframe.c_$id -in $cframe -side left \
4329 -padx [list $lxpad 0] -expand $cexpand -anchor w
4330 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4331 ${NS}::label $cframe.l_$id -text $title
4332 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4333 -textvariable newviewopts($n,$id)
4334 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4335 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4336 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4337 ${NS}::label $cframe.l_$id -text $title
4338 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4339 -textvariable newviewopts($n,$id)
4340 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4341 pack $cframe.e_$id -in $cframe -side top -fill x
4342 } elseif {$type eq "path"} {
4343 ${NS}::label $top.l -text $title
4344 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4345 text $top.t -width 40 -height 5 -background $bgcolor
4346 if {[info exists viewfiles($n)]} {
4347 foreach f $viewfiles($n) {
4348 $top.t insert end $f
4349 $top.t insert end "\n"
4351 $top.t delete {end - 1c} end
4352 $top.t mark set insert 0.0
4354 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4358 ${NS}::frame $top.buts
4359 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4360 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4361 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4362 bind $top <Control-Return> [list newviewok $top $n]
4363 bind $top <F5> [list newviewok $top $n 1]
4364 bind $top <Escape> [list destroy $top]
4365 grid $top.buts.ok $top.buts.apply $top.buts.can
4366 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4367 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4368 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4369 pack $top.buts -in $top -side top -fill x
4370 focus $top.t
4373 proc doviewmenu {m first cmd op argv} {
4374 set nmenu [$m index end]
4375 for {set i $first} {$i <= $nmenu} {incr i} {
4376 if {[$m entrycget $i -command] eq $cmd} {
4377 eval $m $op $i $argv
4378 break
4383 proc allviewmenus {n op args} {
4384 # global viewhlmenu
4386 doviewmenu .bar.view 5 [list showview $n] $op $args
4387 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4390 proc newviewok {top n {apply 0}} {
4391 global nextviewnum newviewperm newviewname newishighlight
4392 global viewname viewfiles viewperm viewchanged selectedview curview
4393 global viewargs viewargscmd newviewopts viewhlmenu
4395 if {[catch {
4396 set newargs [encode_view_opts $n]
4397 } err]} {
4398 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4399 return
4401 set files {}
4402 foreach f [split [$top.t get 0.0 end] "\n"] {
4403 set ft [string trim $f]
4404 if {$ft ne {}} {
4405 lappend files $ft
4408 if {![info exists viewfiles($n)]} {
4409 # creating a new view
4410 incr nextviewnum
4411 set viewname($n) $newviewname($n)
4412 set viewperm($n) $newviewopts($n,perm)
4413 set viewchanged($n) 1
4414 set viewfiles($n) $files
4415 set viewargs($n) $newargs
4416 set viewargscmd($n) $newviewopts($n,cmd)
4417 addviewmenu $n
4418 if {!$newishighlight} {
4419 run showview $n
4420 } else {
4421 run addvhighlight $n
4423 } else {
4424 # editing an existing view
4425 set viewperm($n) $newviewopts($n,perm)
4426 set viewchanged($n) 1
4427 if {$newviewname($n) ne $viewname($n)} {
4428 set viewname($n) $newviewname($n)
4429 doviewmenu .bar.view 5 [list showview $n] \
4430 entryconf [list -label $viewname($n)]
4431 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4432 # entryconf [list -label $viewname($n) -value $viewname($n)]
4434 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4435 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4436 set viewfiles($n) $files
4437 set viewargs($n) $newargs
4438 set viewargscmd($n) $newviewopts($n,cmd)
4439 if {$curview == $n} {
4440 run reloadcommits
4444 if {$apply} return
4445 catch {destroy $top}
4448 proc delview {} {
4449 global curview viewperm hlview selectedhlview viewchanged
4451 if {$curview == 0} return
4452 if {[info exists hlview] && $hlview == $curview} {
4453 set selectedhlview [mc "None"]
4454 unset hlview
4456 allviewmenus $curview delete
4457 set viewperm($curview) 0
4458 set viewchanged($curview) 1
4459 showview 0
4462 proc addviewmenu {n} {
4463 global viewname viewhlmenu
4465 .bar.view add radiobutton -label $viewname($n) \
4466 -command [list showview $n] -variable selectedview -value $n
4467 #$viewhlmenu add radiobutton -label $viewname($n) \
4468 # -command [list addvhighlight $n] -variable selectedhlview
4471 proc showview {n} {
4472 global curview cached_commitrow ordertok
4473 global displayorder parentlist rowidlist rowisopt rowfinal
4474 global colormap rowtextx nextcolor canvxmax
4475 global numcommits viewcomplete
4476 global selectedline currentid canv canvy0
4477 global treediffs
4478 global pending_select mainheadid
4479 global commitidx
4480 global selectedview
4481 global hlview selectedhlview commitinterest
4483 if {$n == $curview} return
4484 set selid {}
4485 set ymax [lindex [$canv cget -scrollregion] 3]
4486 set span [$canv yview]
4487 set ytop [expr {[lindex $span 0] * $ymax}]
4488 set ybot [expr {[lindex $span 1] * $ymax}]
4489 set yscreen [expr {($ybot - $ytop) / 2}]
4490 if {$selectedline ne {}} {
4491 set selid $currentid
4492 set y [yc $selectedline]
4493 if {$ytop < $y && $y < $ybot} {
4494 set yscreen [expr {$y - $ytop}]
4496 } elseif {[info exists pending_select]} {
4497 set selid $pending_select
4498 unset pending_select
4500 unselectline
4501 normalline
4502 unset -nocomplain treediffs
4503 clear_display
4504 if {[info exists hlview] && $hlview == $n} {
4505 unset hlview
4506 set selectedhlview [mc "None"]
4508 unset -nocomplain commitinterest
4509 unset -nocomplain cached_commitrow
4510 unset -nocomplain ordertok
4512 set curview $n
4513 set selectedview $n
4514 .bar.view entryconf [mca "&Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4515 .bar.view entryconf [mca "&Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4517 run refill_reflist
4518 if {![info exists viewcomplete($n)]} {
4519 getcommits $selid
4520 return
4523 set displayorder {}
4524 set parentlist {}
4525 set rowidlist {}
4526 set rowisopt {}
4527 set rowfinal {}
4528 set numcommits $commitidx($n)
4530 unset -nocomplain colormap
4531 unset -nocomplain rowtextx
4532 set nextcolor 0
4533 set canvxmax [$canv cget -width]
4534 set curview $n
4535 set row 0
4536 setcanvscroll
4537 set yf 0
4538 set row {}
4539 if {$selid ne {} && [commitinview $selid $n]} {
4540 set row [rowofcommit $selid]
4541 # try to get the selected row in the same position on the screen
4542 set ymax [lindex [$canv cget -scrollregion] 3]
4543 set ytop [expr {[yc $row] - $yscreen}]
4544 if {$ytop < 0} {
4545 set ytop 0
4547 set yf [expr {$ytop * 1.0 / $ymax}]
4549 allcanvs yview moveto $yf
4550 drawvisible
4551 if {$row ne {}} {
4552 selectline $row 0
4553 } elseif {!$viewcomplete($n)} {
4554 reset_pending_select $selid
4555 } else {
4556 reset_pending_select {}
4558 if {[commitinview $pending_select $curview]} {
4559 selectline [rowofcommit $pending_select] 1
4560 } else {
4561 set row [first_real_row]
4562 if {$row < $numcommits} {
4563 selectline $row 0
4567 if {!$viewcomplete($n)} {
4568 if {$numcommits == 0} {
4569 show_status [mc "Reading commits..."]
4571 } elseif {$numcommits == 0} {
4572 show_status [mc "No commits selected"]
4574 set_window_title
4577 # Stuff relating to the highlighting facility
4579 proc ishighlighted {id} {
4580 global vhighlights fhighlights nhighlights rhighlights
4582 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4583 return $nhighlights($id)
4585 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4586 return $vhighlights($id)
4588 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4589 return $fhighlights($id)
4591 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4592 return $rhighlights($id)
4594 return 0
4597 proc bolden {id font} {
4598 global canv linehtag currentid boldids need_redisplay markedid
4600 # need_redisplay = 1 means the display is stale and about to be redrawn
4601 if {$need_redisplay} return
4602 lappend boldids $id
4603 $canv itemconf $linehtag($id) -font $font
4604 if {[info exists currentid] && $id eq $currentid} {
4605 $canv delete secsel
4606 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4607 -outline {{}} -tags secsel \
4608 -fill [$canv cget -selectbackground]]
4609 $canv lower $t
4611 if {[info exists markedid] && $id eq $markedid} {
4612 make_idmark $id
4616 proc bolden_name {id font} {
4617 global canv2 linentag currentid boldnameids need_redisplay
4619 if {$need_redisplay} return
4620 lappend boldnameids $id
4621 $canv2 itemconf $linentag($id) -font $font
4622 if {[info exists currentid] && $id eq $currentid} {
4623 $canv2 delete secsel
4624 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4625 -outline {{}} -tags secsel \
4626 -fill [$canv2 cget -selectbackground]]
4627 $canv2 lower $t
4631 proc unbolden {} {
4632 global boldids
4634 set stillbold {}
4635 foreach id $boldids {
4636 if {![ishighlighted $id]} {
4637 bolden $id mainfont
4638 } else {
4639 lappend stillbold $id
4642 set boldids $stillbold
4645 proc addvhighlight {n} {
4646 global hlview viewcomplete curview vhl_done commitidx
4648 if {[info exists hlview]} {
4649 delvhighlight
4651 set hlview $n
4652 if {$n != $curview && ![info exists viewcomplete($n)]} {
4653 start_rev_list $n
4655 set vhl_done $commitidx($hlview)
4656 if {$vhl_done > 0} {
4657 drawvisible
4661 proc delvhighlight {} {
4662 global hlview vhighlights
4664 if {![info exists hlview]} return
4665 unset hlview
4666 unset -nocomplain vhighlights
4667 unbolden
4670 proc vhighlightmore {} {
4671 global hlview vhl_done commitidx vhighlights curview
4673 set max $commitidx($hlview)
4674 set vr [visiblerows]
4675 set r0 [lindex $vr 0]
4676 set r1 [lindex $vr 1]
4677 for {set i $vhl_done} {$i < $max} {incr i} {
4678 set id [commitonrow $i $hlview]
4679 if {[commitinview $id $curview]} {
4680 set row [rowofcommit $id]
4681 if {$r0 <= $row && $row <= $r1} {
4682 if {![highlighted $row]} {
4683 bolden $id mainfontbold
4685 set vhighlights($id) 1
4689 set vhl_done $max
4690 return 0
4693 proc askvhighlight {row id} {
4694 global hlview vhighlights iddrawn
4696 if {[commitinview $id $hlview]} {
4697 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4698 bolden $id mainfontbold
4700 set vhighlights($id) 1
4701 } else {
4702 set vhighlights($id) 0
4706 proc hfiles_change {} {
4707 global highlight_files filehighlight fhighlights fh_serial
4708 global highlight_paths
4710 if {[info exists filehighlight]} {
4711 # delete previous highlights
4712 catch {close $filehighlight}
4713 unset filehighlight
4714 unset -nocomplain fhighlights
4715 unbolden
4716 unhighlight_filelist
4718 set highlight_paths {}
4719 after cancel do_file_hl $fh_serial
4720 incr fh_serial
4721 if {$highlight_files ne {}} {
4722 after 300 do_file_hl $fh_serial
4726 proc gdttype_change {name ix op} {
4727 global gdttype highlight_files findstring findpattern
4729 stopfinding
4730 if {$findstring ne {}} {
4731 if {$gdttype eq [mc "containing:"]} {
4732 if {$highlight_files ne {}} {
4733 set highlight_files {}
4734 hfiles_change
4736 findcom_change
4737 } else {
4738 if {$findpattern ne {}} {
4739 set findpattern {}
4740 findcom_change
4742 set highlight_files $findstring
4743 hfiles_change
4745 drawvisible
4747 # enable/disable findtype/findloc menus too
4750 proc find_change {name ix op} {
4751 global gdttype findstring highlight_files
4753 stopfinding
4754 if {$gdttype eq [mc "containing:"]} {
4755 findcom_change
4756 } else {
4757 if {$highlight_files ne $findstring} {
4758 set highlight_files $findstring
4759 hfiles_change
4762 drawvisible
4765 proc findcom_change args {
4766 global nhighlights boldnameids
4767 global findpattern findtype findstring gdttype
4769 stopfinding
4770 # delete previous highlights, if any
4771 foreach id $boldnameids {
4772 bolden_name $id mainfont
4774 set boldnameids {}
4775 unset -nocomplain nhighlights
4776 unbolden
4777 unmarkmatches
4778 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4779 set findpattern {}
4780 } elseif {$findtype eq [mc "Regexp"]} {
4781 set findpattern $findstring
4782 } else {
4783 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4784 $findstring]
4785 set findpattern "*$e*"
4789 proc makepatterns {l} {
4790 set ret {}
4791 foreach e $l {
4792 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4793 if {[string index $ee end] eq "/"} {
4794 lappend ret "$ee*"
4795 } else {
4796 lappend ret $ee
4797 lappend ret "$ee/*"
4800 return $ret
4803 proc do_file_hl {serial} {
4804 global highlight_files filehighlight highlight_paths gdttype fhl_list
4805 global cdup findtype
4807 if {$gdttype eq [mc "touching paths:"]} {
4808 # If "exact" match then convert backslashes to forward slashes.
4809 # Most useful to support Windows-flavoured file paths.
4810 if {$findtype eq [mc "Exact"]} {
4811 set highlight_files [string map {"\\" "/"} $highlight_files]
4813 if {[catch {set paths [shellsplit $highlight_files]}]} return
4814 set highlight_paths [makepatterns $paths]
4815 highlight_filelist
4816 set relative_paths {}
4817 foreach path $paths {
4818 lappend relative_paths [file join $cdup $path]
4820 set gdtargs [concat -- $relative_paths]
4821 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4822 set gdtargs [list "-S$highlight_files"]
4823 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4824 set gdtargs [list "-G$highlight_files"]
4825 } else {
4826 # must be "containing:", i.e. we're searching commit info
4827 return
4829 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4830 set filehighlight [open $cmd r+]
4831 fconfigure $filehighlight -blocking 0
4832 filerun $filehighlight readfhighlight
4833 set fhl_list {}
4834 drawvisible
4835 flushhighlights
4838 proc flushhighlights {} {
4839 global filehighlight fhl_list
4841 if {[info exists filehighlight]} {
4842 lappend fhl_list {}
4843 puts $filehighlight ""
4844 flush $filehighlight
4848 proc askfilehighlight {row id} {
4849 global filehighlight fhighlights fhl_list
4851 lappend fhl_list $id
4852 set fhighlights($id) -1
4853 puts $filehighlight $id
4856 proc readfhighlight {} {
4857 global filehighlight fhighlights curview iddrawn
4858 global fhl_list find_dirn
4860 if {![info exists filehighlight]} {
4861 return 0
4863 set nr 0
4864 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4865 set line [string trim $line]
4866 set i [lsearch -exact $fhl_list $line]
4867 if {$i < 0} continue
4868 for {set j 0} {$j < $i} {incr j} {
4869 set id [lindex $fhl_list $j]
4870 set fhighlights($id) 0
4872 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4873 if {$line eq {}} continue
4874 if {![commitinview $line $curview]} continue
4875 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4876 bolden $line mainfontbold
4878 set fhighlights($line) 1
4880 if {[eof $filehighlight]} {
4881 # strange...
4882 puts "oops, git diff-tree died"
4883 catch {close $filehighlight}
4884 unset filehighlight
4885 return 0
4887 if {[info exists find_dirn]} {
4888 run findmore
4890 return 1
4893 proc doesmatch {f} {
4894 global findtype findpattern
4896 if {$findtype eq [mc "Regexp"]} {
4897 return [regexp $findpattern $f]
4898 } elseif {$findtype eq [mc "IgnCase"]} {
4899 return [string match -nocase $findpattern $f]
4900 } else {
4901 return [string match $findpattern $f]
4905 proc askfindhighlight {row id} {
4906 global nhighlights commitinfo iddrawn
4907 global findloc
4908 global markingmatches
4910 if {![info exists commitinfo($id)]} {
4911 getcommit $id
4913 set info $commitinfo($id)
4914 set isbold 0
4915 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4916 foreach f $info ty $fldtypes {
4917 if {$ty eq ""} continue
4918 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4919 [doesmatch $f]} {
4920 if {$ty eq [mc "Author"]} {
4921 set isbold 2
4922 break
4924 set isbold 1
4927 if {$isbold && [info exists iddrawn($id)]} {
4928 if {![ishighlighted $id]} {
4929 bolden $id mainfontbold
4930 if {$isbold > 1} {
4931 bolden_name $id mainfontbold
4934 if {$markingmatches} {
4935 markrowmatches $row $id
4938 set nhighlights($id) $isbold
4941 proc markrowmatches {row id} {
4942 global canv canv2 linehtag linentag commitinfo findloc
4944 set headline [lindex $commitinfo($id) 0]
4945 set author [lindex $commitinfo($id) 1]
4946 $canv delete match$row
4947 $canv2 delete match$row
4948 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4949 set m [findmatches $headline]
4950 if {$m ne {}} {
4951 markmatches $canv $row $headline $linehtag($id) $m \
4952 [$canv itemcget $linehtag($id) -font] $row
4955 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4956 set m [findmatches $author]
4957 if {$m ne {}} {
4958 markmatches $canv2 $row $author $linentag($id) $m \
4959 [$canv2 itemcget $linentag($id) -font] $row
4964 proc vrel_change {name ix op} {
4965 global highlight_related
4967 rhighlight_none
4968 if {$highlight_related ne [mc "None"]} {
4969 run drawvisible
4973 # prepare for testing whether commits are descendents or ancestors of a
4974 proc rhighlight_sel {a} {
4975 global descendent desc_todo ancestor anc_todo
4976 global highlight_related
4978 unset -nocomplain descendent
4979 set desc_todo [list $a]
4980 unset -nocomplain ancestor
4981 set anc_todo [list $a]
4982 if {$highlight_related ne [mc "None"]} {
4983 rhighlight_none
4984 run drawvisible
4988 proc rhighlight_none {} {
4989 global rhighlights
4991 unset -nocomplain rhighlights
4992 unbolden
4995 proc is_descendent {a} {
4996 global curview children descendent desc_todo
4998 set v $curview
4999 set la [rowofcommit $a]
5000 set todo $desc_todo
5001 set leftover {}
5002 set done 0
5003 for {set i 0} {$i < [llength $todo]} {incr i} {
5004 set do [lindex $todo $i]
5005 if {[rowofcommit $do] < $la} {
5006 lappend leftover $do
5007 continue
5009 foreach nk $children($v,$do) {
5010 if {![info exists descendent($nk)]} {
5011 set descendent($nk) 1
5012 lappend todo $nk
5013 if {$nk eq $a} {
5014 set done 1
5018 if {$done} {
5019 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5020 return
5023 set descendent($a) 0
5024 set desc_todo $leftover
5027 proc is_ancestor {a} {
5028 global curview parents ancestor anc_todo
5030 set v $curview
5031 set la [rowofcommit $a]
5032 set todo $anc_todo
5033 set leftover {}
5034 set done 0
5035 for {set i 0} {$i < [llength $todo]} {incr i} {
5036 set do [lindex $todo $i]
5037 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
5038 lappend leftover $do
5039 continue
5041 foreach np $parents($v,$do) {
5042 if {![info exists ancestor($np)]} {
5043 set ancestor($np) 1
5044 lappend todo $np
5045 if {$np eq $a} {
5046 set done 1
5050 if {$done} {
5051 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5052 return
5055 set ancestor($a) 0
5056 set anc_todo $leftover
5059 proc askrelhighlight {row id} {
5060 global descendent highlight_related iddrawn rhighlights
5061 global selectedline ancestor
5063 if {$selectedline eq {}} return
5064 set isbold 0
5065 if {$highlight_related eq [mc "Descendant"] ||
5066 $highlight_related eq [mc "Not descendant"]} {
5067 if {![info exists descendent($id)]} {
5068 is_descendent $id
5070 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5071 set isbold 1
5073 } elseif {$highlight_related eq [mc "Ancestor"] ||
5074 $highlight_related eq [mc "Not ancestor"]} {
5075 if {![info exists ancestor($id)]} {
5076 is_ancestor $id
5078 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5079 set isbold 1
5082 if {[info exists iddrawn($id)]} {
5083 if {$isbold && ![ishighlighted $id]} {
5084 bolden $id mainfontbold
5087 set rhighlights($id) $isbold
5090 # Graph layout functions
5092 proc shortids {ids} {
5093 set res {}
5094 foreach id $ids {
5095 if {[llength $id] > 1} {
5096 lappend res [shortids $id]
5097 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5098 lappend res [string range $id 0 7]
5099 } else {
5100 lappend res $id
5103 return $res
5106 proc ntimes {n o} {
5107 set ret {}
5108 set o [list $o]
5109 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5110 if {($n & $mask) != 0} {
5111 set ret [concat $ret $o]
5113 set o [concat $o $o]
5115 return $ret
5118 proc ordertoken {id} {
5119 global ordertok curview varcid varcstart varctok curview parents children
5120 global nullid nullid2
5122 if {[info exists ordertok($id)]} {
5123 return $ordertok($id)
5125 set origid $id
5126 set todo {}
5127 while {1} {
5128 if {[info exists varcid($curview,$id)]} {
5129 set a $varcid($curview,$id)
5130 set p [lindex $varcstart($curview) $a]
5131 } else {
5132 set p [lindex $children($curview,$id) 0]
5134 if {[info exists ordertok($p)]} {
5135 set tok $ordertok($p)
5136 break
5138 set id [first_real_child $curview,$p]
5139 if {$id eq {}} {
5140 # it's a root
5141 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5142 break
5144 if {[llength $parents($curview,$id)] == 1} {
5145 lappend todo [list $p {}]
5146 } else {
5147 set j [lsearch -exact $parents($curview,$id) $p]
5148 if {$j < 0} {
5149 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5151 lappend todo [list $p [strrep $j]]
5154 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5155 set p [lindex $todo $i 0]
5156 append tok [lindex $todo $i 1]
5157 set ordertok($p) $tok
5159 set ordertok($origid) $tok
5160 return $tok
5163 # Work out where id should go in idlist so that order-token
5164 # values increase from left to right
5165 proc idcol {idlist id {i 0}} {
5166 set t [ordertoken $id]
5167 if {$i < 0} {
5168 set i 0
5170 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5171 if {$i > [llength $idlist]} {
5172 set i [llength $idlist]
5174 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5175 incr i
5176 } else {
5177 if {$t > [ordertoken [lindex $idlist $i]]} {
5178 while {[incr i] < [llength $idlist] &&
5179 $t >= [ordertoken [lindex $idlist $i]]} {}
5182 return $i
5185 proc initlayout {} {
5186 global rowidlist rowisopt rowfinal displayorder parentlist
5187 global numcommits canvxmax canv
5188 global nextcolor
5189 global colormap rowtextx
5191 set numcommits 0
5192 set displayorder {}
5193 set parentlist {}
5194 set nextcolor 0
5195 set rowidlist {}
5196 set rowisopt {}
5197 set rowfinal {}
5198 set canvxmax [$canv cget -width]
5199 unset -nocomplain colormap
5200 unset -nocomplain rowtextx
5201 setcanvscroll
5204 proc setcanvscroll {} {
5205 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5206 global lastscrollset lastscrollrows
5208 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5209 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5210 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5211 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5212 set lastscrollset [clock clicks -milliseconds]
5213 set lastscrollrows $numcommits
5216 proc visiblerows {} {
5217 global canv numcommits linespc
5219 set ymax [lindex [$canv cget -scrollregion] 3]
5220 if {$ymax eq {} || $ymax == 0} return
5221 set f [$canv yview]
5222 set y0 [expr {int([lindex $f 0] * $ymax)}]
5223 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5224 if {$r0 < 0} {
5225 set r0 0
5227 set y1 [expr {int([lindex $f 1] * $ymax)}]
5228 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5229 if {$r1 >= $numcommits} {
5230 set r1 [expr {$numcommits - 1}]
5232 return [list $r0 $r1]
5235 proc layoutmore {} {
5236 global commitidx viewcomplete curview
5237 global numcommits pending_select curview
5238 global lastscrollset lastscrollrows
5240 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5241 [clock clicks -milliseconds] - $lastscrollset > 500} {
5242 setcanvscroll
5244 if {[info exists pending_select] &&
5245 [commitinview $pending_select $curview]} {
5246 update
5247 selectline [rowofcommit $pending_select] 1
5249 drawvisible
5252 # With path limiting, we mightn't get the actual HEAD commit,
5253 # so ask git rev-list what is the first ancestor of HEAD that
5254 # touches a file in the path limit.
5255 proc get_viewmainhead {view} {
5256 global viewmainheadid vfilelimit viewinstances mainheadid
5258 catch {
5259 set rfd [open [concat | git rev-list -1 $mainheadid \
5260 -- $vfilelimit($view)] r]
5261 set j [reg_instance $rfd]
5262 lappend viewinstances($view) $j
5263 fconfigure $rfd -blocking 0
5264 filerun $rfd [list getviewhead $rfd $j $view]
5265 set viewmainheadid($curview) {}
5269 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5270 proc getviewhead {fd inst view} {
5271 global viewmainheadid commfd curview viewinstances showlocalchanges
5273 set id {}
5274 if {[gets $fd line] < 0} {
5275 if {![eof $fd]} {
5276 return 1
5278 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5279 set id $line
5281 set viewmainheadid($view) $id
5282 close $fd
5283 unset commfd($inst)
5284 set i [lsearch -exact $viewinstances($view) $inst]
5285 if {$i >= 0} {
5286 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5288 if {$showlocalchanges && $id ne {} && $view == $curview} {
5289 doshowlocalchanges
5291 return 0
5294 proc doshowlocalchanges {} {
5295 global curview viewmainheadid
5297 if {$viewmainheadid($curview) eq {}} return
5298 if {[commitinview $viewmainheadid($curview) $curview]} {
5299 dodiffindex
5300 } else {
5301 interestedin $viewmainheadid($curview) dodiffindex
5305 proc dohidelocalchanges {} {
5306 global nullid nullid2 lserial curview
5308 if {[commitinview $nullid $curview]} {
5309 removefakerow $nullid
5311 if {[commitinview $nullid2 $curview]} {
5312 removefakerow $nullid2
5314 incr lserial
5317 # spawn off a process to do git diff-index --cached HEAD
5318 proc dodiffindex {} {
5319 global lserial showlocalchanges vfilelimit curview
5320 global hasworktree git_version
5322 if {!$showlocalchanges || !$hasworktree} return
5323 incr lserial
5324 if {[package vcompare $git_version "1.7.2"] >= 0} {
5325 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5326 } else {
5327 set cmd "|git diff-index --cached HEAD"
5329 if {$vfilelimit($curview) ne {}} {
5330 set cmd [concat $cmd -- $vfilelimit($curview)]
5332 set fd [open $cmd r]
5333 fconfigure $fd -blocking 0
5334 set i [reg_instance $fd]
5335 filerun $fd [list readdiffindex $fd $lserial $i]
5338 proc readdiffindex {fd serial inst} {
5339 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5340 global vfilelimit
5342 set isdiff 1
5343 if {[gets $fd line] < 0} {
5344 if {![eof $fd]} {
5345 return 1
5347 set isdiff 0
5349 # we only need to see one line and we don't really care what it says...
5350 stop_instance $inst
5352 if {$serial != $lserial} {
5353 return 0
5356 # now see if there are any local changes not checked in to the index
5357 set cmd "|git diff-files"
5358 if {$vfilelimit($curview) ne {}} {
5359 set cmd [concat $cmd -- $vfilelimit($curview)]
5361 set fd [open $cmd r]
5362 fconfigure $fd -blocking 0
5363 set i [reg_instance $fd]
5364 filerun $fd [list readdifffiles $fd $serial $i]
5366 if {$isdiff && ![commitinview $nullid2 $curview]} {
5367 # add the line for the changes in the index to the graph
5368 set hl [mc "Local changes checked in to index but not committed"]
5369 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5370 set commitdata($nullid2) "\n $hl\n"
5371 if {[commitinview $nullid $curview]} {
5372 removefakerow $nullid
5374 insertfakerow $nullid2 $viewmainheadid($curview)
5375 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5376 if {[commitinview $nullid $curview]} {
5377 removefakerow $nullid
5379 removefakerow $nullid2
5381 return 0
5384 proc readdifffiles {fd serial inst} {
5385 global viewmainheadid nullid nullid2 curview
5386 global commitinfo commitdata lserial
5388 set isdiff 1
5389 if {[gets $fd line] < 0} {
5390 if {![eof $fd]} {
5391 return 1
5393 set isdiff 0
5395 # we only need to see one line and we don't really care what it says...
5396 stop_instance $inst
5398 if {$serial != $lserial} {
5399 return 0
5402 if {$isdiff && ![commitinview $nullid $curview]} {
5403 # add the line for the local diff to the graph
5404 set hl [mc "Local uncommitted changes, not checked in to index"]
5405 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5406 set commitdata($nullid) "\n $hl\n"
5407 if {[commitinview $nullid2 $curview]} {
5408 set p $nullid2
5409 } else {
5410 set p $viewmainheadid($curview)
5412 insertfakerow $nullid $p
5413 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5414 removefakerow $nullid
5416 return 0
5419 proc nextuse {id row} {
5420 global curview children
5422 if {[info exists children($curview,$id)]} {
5423 foreach kid $children($curview,$id) {
5424 if {![commitinview $kid $curview]} {
5425 return -1
5427 if {[rowofcommit $kid] > $row} {
5428 return [rowofcommit $kid]
5432 if {[commitinview $id $curview]} {
5433 return [rowofcommit $id]
5435 return -1
5438 proc prevuse {id row} {
5439 global curview children
5441 set ret -1
5442 if {[info exists children($curview,$id)]} {
5443 foreach kid $children($curview,$id) {
5444 if {![commitinview $kid $curview]} break
5445 if {[rowofcommit $kid] < $row} {
5446 set ret [rowofcommit $kid]
5450 return $ret
5453 proc make_idlist {row} {
5454 global displayorder parentlist uparrowlen downarrowlen mingaplen
5455 global commitidx curview children
5457 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5458 if {$r < 0} {
5459 set r 0
5461 set ra [expr {$row - $downarrowlen}]
5462 if {$ra < 0} {
5463 set ra 0
5465 set rb [expr {$row + $uparrowlen}]
5466 if {$rb > $commitidx($curview)} {
5467 set rb $commitidx($curview)
5469 make_disporder $r [expr {$rb + 1}]
5470 set ids {}
5471 for {} {$r < $ra} {incr r} {
5472 set nextid [lindex $displayorder [expr {$r + 1}]]
5473 foreach p [lindex $parentlist $r] {
5474 if {$p eq $nextid} continue
5475 set rn [nextuse $p $r]
5476 if {$rn >= $row &&
5477 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5478 lappend ids [list [ordertoken $p] $p]
5482 for {} {$r < $row} {incr r} {
5483 set nextid [lindex $displayorder [expr {$r + 1}]]
5484 foreach p [lindex $parentlist $r] {
5485 if {$p eq $nextid} continue
5486 set rn [nextuse $p $r]
5487 if {$rn < 0 || $rn >= $row} {
5488 lappend ids [list [ordertoken $p] $p]
5492 set id [lindex $displayorder $row]
5493 lappend ids [list [ordertoken $id] $id]
5494 while {$r < $rb} {
5495 foreach p [lindex $parentlist $r] {
5496 set firstkid [lindex $children($curview,$p) 0]
5497 if {[rowofcommit $firstkid] < $row} {
5498 lappend ids [list [ordertoken $p] $p]
5501 incr r
5502 set id [lindex $displayorder $r]
5503 if {$id ne {}} {
5504 set firstkid [lindex $children($curview,$id) 0]
5505 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5506 lappend ids [list [ordertoken $id] $id]
5510 set idlist {}
5511 foreach idx [lsort -unique $ids] {
5512 lappend idlist [lindex $idx 1]
5514 return $idlist
5517 proc rowsequal {a b} {
5518 while {[set i [lsearch -exact $a {}]] >= 0} {
5519 set a [lreplace $a $i $i]
5521 while {[set i [lsearch -exact $b {}]] >= 0} {
5522 set b [lreplace $b $i $i]
5524 return [expr {$a eq $b}]
5527 proc makeupline {id row rend col} {
5528 global rowidlist uparrowlen downarrowlen mingaplen
5530 for {set r $rend} {1} {set r $rstart} {
5531 set rstart [prevuse $id $r]
5532 if {$rstart < 0} return
5533 if {$rstart < $row} break
5535 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5536 set rstart [expr {$rend - $uparrowlen - 1}]
5538 for {set r $rstart} {[incr r] <= $row} {} {
5539 set idlist [lindex $rowidlist $r]
5540 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5541 set col [idcol $idlist $id $col]
5542 lset rowidlist $r [linsert $idlist $col $id]
5543 changedrow $r
5548 proc layoutrows {row endrow} {
5549 global rowidlist rowisopt rowfinal displayorder
5550 global uparrowlen downarrowlen maxwidth mingaplen
5551 global children parentlist
5552 global commitidx viewcomplete curview
5554 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5555 set idlist {}
5556 if {$row > 0} {
5557 set rm1 [expr {$row - 1}]
5558 foreach id [lindex $rowidlist $rm1] {
5559 if {$id ne {}} {
5560 lappend idlist $id
5563 set final [lindex $rowfinal $rm1]
5565 for {} {$row < $endrow} {incr row} {
5566 set rm1 [expr {$row - 1}]
5567 if {$rm1 < 0 || $idlist eq {}} {
5568 set idlist [make_idlist $row]
5569 set final 1
5570 } else {
5571 set id [lindex $displayorder $rm1]
5572 set col [lsearch -exact $idlist $id]
5573 set idlist [lreplace $idlist $col $col]
5574 foreach p [lindex $parentlist $rm1] {
5575 if {[lsearch -exact $idlist $p] < 0} {
5576 set col [idcol $idlist $p $col]
5577 set idlist [linsert $idlist $col $p]
5578 # if not the first child, we have to insert a line going up
5579 if {$id ne [lindex $children($curview,$p) 0]} {
5580 makeupline $p $rm1 $row $col
5584 set id [lindex $displayorder $row]
5585 if {$row > $downarrowlen} {
5586 set termrow [expr {$row - $downarrowlen - 1}]
5587 foreach p [lindex $parentlist $termrow] {
5588 set i [lsearch -exact $idlist $p]
5589 if {$i < 0} continue
5590 set nr [nextuse $p $termrow]
5591 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5592 set idlist [lreplace $idlist $i $i]
5596 set col [lsearch -exact $idlist $id]
5597 if {$col < 0} {
5598 set col [idcol $idlist $id]
5599 set idlist [linsert $idlist $col $id]
5600 if {$children($curview,$id) ne {}} {
5601 makeupline $id $rm1 $row $col
5604 set r [expr {$row + $uparrowlen - 1}]
5605 if {$r < $commitidx($curview)} {
5606 set x $col
5607 foreach p [lindex $parentlist $r] {
5608 if {[lsearch -exact $idlist $p] >= 0} continue
5609 set fk [lindex $children($curview,$p) 0]
5610 if {[rowofcommit $fk] < $row} {
5611 set x [idcol $idlist $p $x]
5612 set idlist [linsert $idlist $x $p]
5615 if {[incr r] < $commitidx($curview)} {
5616 set p [lindex $displayorder $r]
5617 if {[lsearch -exact $idlist $p] < 0} {
5618 set fk [lindex $children($curview,$p) 0]
5619 if {$fk ne {} && [rowofcommit $fk] < $row} {
5620 set x [idcol $idlist $p $x]
5621 set idlist [linsert $idlist $x $p]
5627 if {$final && !$viewcomplete($curview) &&
5628 $row + $uparrowlen + $mingaplen + $downarrowlen
5629 >= $commitidx($curview)} {
5630 set final 0
5632 set l [llength $rowidlist]
5633 if {$row == $l} {
5634 lappend rowidlist $idlist
5635 lappend rowisopt 0
5636 lappend rowfinal $final
5637 } elseif {$row < $l} {
5638 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5639 lset rowidlist $row $idlist
5640 changedrow $row
5642 lset rowfinal $row $final
5643 } else {
5644 set pad [ntimes [expr {$row - $l}] {}]
5645 set rowidlist [concat $rowidlist $pad]
5646 lappend rowidlist $idlist
5647 set rowfinal [concat $rowfinal $pad]
5648 lappend rowfinal $final
5649 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5652 return $row
5655 proc changedrow {row} {
5656 global displayorder iddrawn rowisopt need_redisplay
5658 set l [llength $rowisopt]
5659 if {$row < $l} {
5660 lset rowisopt $row 0
5661 if {$row + 1 < $l} {
5662 lset rowisopt [expr {$row + 1}] 0
5663 if {$row + 2 < $l} {
5664 lset rowisopt [expr {$row + 2}] 0
5668 set id [lindex $displayorder $row]
5669 if {[info exists iddrawn($id)]} {
5670 set need_redisplay 1
5674 proc insert_pad {row col npad} {
5675 global rowidlist
5677 set pad [ntimes $npad {}]
5678 set idlist [lindex $rowidlist $row]
5679 set bef [lrange $idlist 0 [expr {$col - 1}]]
5680 set aft [lrange $idlist $col end]
5681 set i [lsearch -exact $aft {}]
5682 if {$i > 0} {
5683 set aft [lreplace $aft $i $i]
5685 lset rowidlist $row [concat $bef $pad $aft]
5686 changedrow $row
5689 proc optimize_rows {row col endrow} {
5690 global rowidlist rowisopt displayorder curview children
5692 if {$row < 1} {
5693 set row 1
5695 for {} {$row < $endrow} {incr row; set col 0} {
5696 if {[lindex $rowisopt $row]} continue
5697 set haspad 0
5698 set y0 [expr {$row - 1}]
5699 set ym [expr {$row - 2}]
5700 set idlist [lindex $rowidlist $row]
5701 set previdlist [lindex $rowidlist $y0]
5702 if {$idlist eq {} || $previdlist eq {}} continue
5703 if {$ym >= 0} {
5704 set pprevidlist [lindex $rowidlist $ym]
5705 if {$pprevidlist eq {}} continue
5706 } else {
5707 set pprevidlist {}
5709 set x0 -1
5710 set xm -1
5711 for {} {$col < [llength $idlist]} {incr col} {
5712 set id [lindex $idlist $col]
5713 if {[lindex $previdlist $col] eq $id} continue
5714 if {$id eq {}} {
5715 set haspad 1
5716 continue
5718 set x0 [lsearch -exact $previdlist $id]
5719 if {$x0 < 0} continue
5720 set z [expr {$x0 - $col}]
5721 set isarrow 0
5722 set z0 {}
5723 if {$ym >= 0} {
5724 set xm [lsearch -exact $pprevidlist $id]
5725 if {$xm >= 0} {
5726 set z0 [expr {$xm - $x0}]
5729 if {$z0 eq {}} {
5730 # if row y0 is the first child of $id then it's not an arrow
5731 if {[lindex $children($curview,$id) 0] ne
5732 [lindex $displayorder $y0]} {
5733 set isarrow 1
5736 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5737 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5738 set isarrow 1
5740 # Looking at lines from this row to the previous row,
5741 # make them go straight up if they end in an arrow on
5742 # the previous row; otherwise make them go straight up
5743 # or at 45 degrees.
5744 if {$z < -1 || ($z < 0 && $isarrow)} {
5745 # Line currently goes left too much;
5746 # insert pads in the previous row, then optimize it
5747 set npad [expr {-1 - $z + $isarrow}]
5748 insert_pad $y0 $x0 $npad
5749 if {$y0 > 0} {
5750 optimize_rows $y0 $x0 $row
5752 set previdlist [lindex $rowidlist $y0]
5753 set x0 [lsearch -exact $previdlist $id]
5754 set z [expr {$x0 - $col}]
5755 if {$z0 ne {}} {
5756 set pprevidlist [lindex $rowidlist $ym]
5757 set xm [lsearch -exact $pprevidlist $id]
5758 set z0 [expr {$xm - $x0}]
5760 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5761 # Line currently goes right too much;
5762 # insert pads in this line
5763 set npad [expr {$z - 1 + $isarrow}]
5764 insert_pad $row $col $npad
5765 set idlist [lindex $rowidlist $row]
5766 incr col $npad
5767 set z [expr {$x0 - $col}]
5768 set haspad 1
5770 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5771 # this line links to its first child on row $row-2
5772 set id [lindex $displayorder $ym]
5773 set xc [lsearch -exact $pprevidlist $id]
5774 if {$xc >= 0} {
5775 set z0 [expr {$xc - $x0}]
5778 # avoid lines jigging left then immediately right
5779 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5780 insert_pad $y0 $x0 1
5781 incr x0
5782 optimize_rows $y0 $x0 $row
5783 set previdlist [lindex $rowidlist $y0]
5786 if {!$haspad} {
5787 # Find the first column that doesn't have a line going right
5788 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5789 set id [lindex $idlist $col]
5790 if {$id eq {}} break
5791 set x0 [lsearch -exact $previdlist $id]
5792 if {$x0 < 0} {
5793 # check if this is the link to the first child
5794 set kid [lindex $displayorder $y0]
5795 if {[lindex $children($curview,$id) 0] eq $kid} {
5796 # it is, work out offset to child
5797 set x0 [lsearch -exact $previdlist $kid]
5800 if {$x0 <= $col} break
5802 # Insert a pad at that column as long as it has a line and
5803 # isn't the last column
5804 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5805 set idlist [linsert $idlist $col {}]
5806 lset rowidlist $row $idlist
5807 changedrow $row
5813 proc xc {row col} {
5814 global canvx0 linespc
5815 return [expr {$canvx0 + $col * $linespc}]
5818 proc yc {row} {
5819 global canvy0 linespc
5820 return [expr {$canvy0 + $row * $linespc}]
5823 proc linewidth {id} {
5824 global thickerline lthickness
5826 set wid $lthickness
5827 if {[info exists thickerline] && $id eq $thickerline} {
5828 set wid [expr {2 * $lthickness}]
5830 return $wid
5833 proc rowranges {id} {
5834 global curview children uparrowlen downarrowlen
5835 global rowidlist
5837 set kids $children($curview,$id)
5838 if {$kids eq {}} {
5839 return {}
5841 set ret {}
5842 lappend kids $id
5843 foreach child $kids {
5844 if {![commitinview $child $curview]} break
5845 set row [rowofcommit $child]
5846 if {![info exists prev]} {
5847 lappend ret [expr {$row + 1}]
5848 } else {
5849 if {$row <= $prevrow} {
5850 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5852 # see if the line extends the whole way from prevrow to row
5853 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5854 [lsearch -exact [lindex $rowidlist \
5855 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5856 # it doesn't, see where it ends
5857 set r [expr {$prevrow + $downarrowlen}]
5858 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5859 while {[incr r -1] > $prevrow &&
5860 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5861 } else {
5862 while {[incr r] <= $row &&
5863 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5864 incr r -1
5866 lappend ret $r
5867 # see where it starts up again
5868 set r [expr {$row - $uparrowlen}]
5869 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5870 while {[incr r] < $row &&
5871 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5872 } else {
5873 while {[incr r -1] >= $prevrow &&
5874 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5875 incr r
5877 lappend ret $r
5880 if {$child eq $id} {
5881 lappend ret $row
5883 set prev $child
5884 set prevrow $row
5886 return $ret
5889 proc drawlineseg {id row endrow arrowlow} {
5890 global rowidlist displayorder iddrawn linesegs
5891 global canv colormap linespc curview maxlinelen parentlist
5893 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5894 set le [expr {$row + 1}]
5895 set arrowhigh 1
5896 while {1} {
5897 set c [lsearch -exact [lindex $rowidlist $le] $id]
5898 if {$c < 0} {
5899 incr le -1
5900 break
5902 lappend cols $c
5903 set x [lindex $displayorder $le]
5904 if {$x eq $id} {
5905 set arrowhigh 0
5906 break
5908 if {[info exists iddrawn($x)] || $le == $endrow} {
5909 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5910 if {$c >= 0} {
5911 lappend cols $c
5912 set arrowhigh 0
5914 break
5916 incr le
5918 if {$le <= $row} {
5919 return $row
5922 set lines {}
5923 set i 0
5924 set joinhigh 0
5925 if {[info exists linesegs($id)]} {
5926 set lines $linesegs($id)
5927 foreach li $lines {
5928 set r0 [lindex $li 0]
5929 if {$r0 > $row} {
5930 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5931 set joinhigh 1
5933 break
5935 incr i
5938 set joinlow 0
5939 if {$i > 0} {
5940 set li [lindex $lines [expr {$i-1}]]
5941 set r1 [lindex $li 1]
5942 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5943 set joinlow 1
5947 set x [lindex $cols [expr {$le - $row}]]
5948 set xp [lindex $cols [expr {$le - 1 - $row}]]
5949 set dir [expr {$xp - $x}]
5950 if {$joinhigh} {
5951 set ith [lindex $lines $i 2]
5952 set coords [$canv coords $ith]
5953 set ah [$canv itemcget $ith -arrow]
5954 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5955 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5956 if {$x2 ne {} && $x - $x2 == $dir} {
5957 set coords [lrange $coords 0 end-2]
5959 } else {
5960 set coords [list [xc $le $x] [yc $le]]
5962 if {$joinlow} {
5963 set itl [lindex $lines [expr {$i-1}] 2]
5964 set al [$canv itemcget $itl -arrow]
5965 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5966 } elseif {$arrowlow} {
5967 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5968 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5969 set arrowlow 0
5972 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5973 for {set y $le} {[incr y -1] > $row} {} {
5974 set x $xp
5975 set xp [lindex $cols [expr {$y - 1 - $row}]]
5976 set ndir [expr {$xp - $x}]
5977 if {$dir != $ndir || $xp < 0} {
5978 lappend coords [xc $y $x] [yc $y]
5980 set dir $ndir
5982 if {!$joinlow} {
5983 if {$xp < 0} {
5984 # join parent line to first child
5985 set ch [lindex $displayorder $row]
5986 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5987 if {$xc < 0} {
5988 puts "oops: drawlineseg: child $ch not on row $row"
5989 } elseif {$xc != $x} {
5990 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5991 set d [expr {int(0.5 * $linespc)}]
5992 set x1 [xc $row $x]
5993 if {$xc < $x} {
5994 set x2 [expr {$x1 - $d}]
5995 } else {
5996 set x2 [expr {$x1 + $d}]
5998 set y2 [yc $row]
5999 set y1 [expr {$y2 + $d}]
6000 lappend coords $x1 $y1 $x2 $y2
6001 } elseif {$xc < $x - 1} {
6002 lappend coords [xc $row [expr {$x-1}]] [yc $row]
6003 } elseif {$xc > $x + 1} {
6004 lappend coords [xc $row [expr {$x+1}]] [yc $row]
6006 set x $xc
6008 lappend coords [xc $row $x] [yc $row]
6009 } else {
6010 set xn [xc $row $xp]
6011 set yn [yc $row]
6012 lappend coords $xn $yn
6014 if {!$joinhigh} {
6015 assigncolor $id
6016 set t [$canv create line $coords -width [linewidth $id] \
6017 -fill $colormap($id) -tags lines.$id -arrow $arrow]
6018 $canv lower $t
6019 bindline $t $id
6020 set lines [linsert $lines $i [list $row $le $t]]
6021 } else {
6022 $canv coords $ith $coords
6023 if {$arrow ne $ah} {
6024 $canv itemconf $ith -arrow $arrow
6026 lset lines $i 0 $row
6028 } else {
6029 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
6030 set ndir [expr {$xo - $xp}]
6031 set clow [$canv coords $itl]
6032 if {$dir == $ndir} {
6033 set clow [lrange $clow 2 end]
6035 set coords [concat $coords $clow]
6036 if {!$joinhigh} {
6037 lset lines [expr {$i-1}] 1 $le
6038 } else {
6039 # coalesce two pieces
6040 $canv delete $ith
6041 set b [lindex $lines [expr {$i-1}] 0]
6042 set e [lindex $lines $i 1]
6043 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6045 $canv coords $itl $coords
6046 if {$arrow ne $al} {
6047 $canv itemconf $itl -arrow $arrow
6051 set linesegs($id) $lines
6052 return $le
6055 proc drawparentlinks {id row} {
6056 global rowidlist canv colormap curview parentlist
6057 global idpos linespc
6059 set rowids [lindex $rowidlist $row]
6060 set col [lsearch -exact $rowids $id]
6061 if {$col < 0} return
6062 set olds [lindex $parentlist $row]
6063 set row2 [expr {$row + 1}]
6064 set x [xc $row $col]
6065 set y [yc $row]
6066 set y2 [yc $row2]
6067 set d [expr {int(0.5 * $linespc)}]
6068 set ymid [expr {$y + $d}]
6069 set ids [lindex $rowidlist $row2]
6070 # rmx = right-most X coord used
6071 set rmx 0
6072 foreach p $olds {
6073 set i [lsearch -exact $ids $p]
6074 if {$i < 0} {
6075 puts "oops, parent $p of $id not in list"
6076 continue
6078 set x2 [xc $row2 $i]
6079 if {$x2 > $rmx} {
6080 set rmx $x2
6082 set j [lsearch -exact $rowids $p]
6083 if {$j < 0} {
6084 # drawlineseg will do this one for us
6085 continue
6087 assigncolor $p
6088 # should handle duplicated parents here...
6089 set coords [list $x $y]
6090 if {$i != $col} {
6091 # if attaching to a vertical segment, draw a smaller
6092 # slant for visual distinctness
6093 if {$i == $j} {
6094 if {$i < $col} {
6095 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6096 } else {
6097 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6099 } elseif {$i < $col && $i < $j} {
6100 # segment slants towards us already
6101 lappend coords [xc $row $j] $y
6102 } else {
6103 if {$i < $col - 1} {
6104 lappend coords [expr {$x2 + $linespc}] $y
6105 } elseif {$i > $col + 1} {
6106 lappend coords [expr {$x2 - $linespc}] $y
6108 lappend coords $x2 $y2
6110 } else {
6111 lappend coords $x2 $y2
6113 set t [$canv create line $coords -width [linewidth $p] \
6114 -fill $colormap($p) -tags lines.$p]
6115 $canv lower $t
6116 bindline $t $p
6118 if {$rmx > [lindex $idpos($id) 1]} {
6119 lset idpos($id) 1 $rmx
6120 redrawtags $id
6124 proc drawlines {id} {
6125 global canv
6127 $canv itemconf lines.$id -width [linewidth $id]
6130 proc drawcmittext {id row col} {
6131 global linespc canv canv2 canv3 fgcolor curview
6132 global cmitlisted commitinfo rowidlist parentlist
6133 global rowtextx idpos idtags idheads idotherrefs
6134 global linehtag linentag linedtag selectedline
6135 global canvxmax boldids boldnameids fgcolor markedid
6136 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6137 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6138 global circleoutlinecolor
6140 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6141 set listed $cmitlisted($curview,$id)
6142 if {$id eq $nullid} {
6143 set ofill $workingfilescirclecolor
6144 } elseif {$id eq $nullid2} {
6145 set ofill $indexcirclecolor
6146 } elseif {$id eq $mainheadid} {
6147 set ofill $mainheadcirclecolor
6148 } else {
6149 set ofill [lindex $circlecolors $listed]
6151 set x [xc $row $col]
6152 set y [yc $row]
6153 set orad [expr {$linespc / 3}]
6154 if {$listed <= 2} {
6155 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6156 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6157 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6158 } elseif {$listed == 3} {
6159 # triangle pointing left for left-side commits
6160 set t [$canv create polygon \
6161 [expr {$x - $orad}] $y \
6162 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6163 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6164 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6165 } else {
6166 # triangle pointing right for right-side commits
6167 set t [$canv create polygon \
6168 [expr {$x + $orad - 1}] $y \
6169 [expr {$x - $orad}] [expr {$y - $orad}] \
6170 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6171 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6173 set circleitem($row) $t
6174 $canv raise $t
6175 $canv bind $t <1> {selcanvline {} %x %y}
6176 set rmx [llength [lindex $rowidlist $row]]
6177 set olds [lindex $parentlist $row]
6178 if {$olds ne {}} {
6179 set nextids [lindex $rowidlist [expr {$row + 1}]]
6180 foreach p $olds {
6181 set i [lsearch -exact $nextids $p]
6182 if {$i > $rmx} {
6183 set rmx $i
6187 set xt [xc $row $rmx]
6188 set rowtextx($row) $xt
6189 set idpos($id) [list $x $xt $y]
6190 if {[info exists idtags($id)] || [info exists idheads($id)]
6191 || [info exists idotherrefs($id)]} {
6192 set xt [drawtags $id $x $xt $y]
6194 if {[lindex $commitinfo($id) 6] > 0} {
6195 set xt [drawnotesign $xt $y]
6197 set headline [lindex $commitinfo($id) 0]
6198 set name [lindex $commitinfo($id) 1]
6199 set date [lindex $commitinfo($id) 2]
6200 set date [formatdate $date]
6201 set font mainfont
6202 set nfont mainfont
6203 set isbold [ishighlighted $id]
6204 if {$isbold > 0} {
6205 lappend boldids $id
6206 set font mainfontbold
6207 if {$isbold > 1} {
6208 lappend boldnameids $id
6209 set nfont mainfontbold
6212 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6213 -text $headline -font $font -tags text]
6214 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6215 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6216 -text $name -font $nfont -tags text]
6217 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6218 -text $date -font mainfont -tags text]
6219 if {$selectedline == $row} {
6220 make_secsel $id
6222 if {[info exists markedid] && $markedid eq $id} {
6223 make_idmark $id
6225 set xr [expr {$xt + [font measure $font $headline]}]
6226 if {$xr > $canvxmax} {
6227 set canvxmax $xr
6228 setcanvscroll
6232 proc drawcmitrow {row} {
6233 global displayorder rowidlist nrows_drawn
6234 global iddrawn markingmatches
6235 global commitinfo numcommits
6236 global filehighlight fhighlights findpattern nhighlights
6237 global hlview vhighlights
6238 global highlight_related rhighlights
6240 if {$row >= $numcommits} return
6242 set id [lindex $displayorder $row]
6243 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6244 askvhighlight $row $id
6246 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6247 askfilehighlight $row $id
6249 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6250 askfindhighlight $row $id
6252 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6253 askrelhighlight $row $id
6255 if {![info exists iddrawn($id)]} {
6256 set col [lsearch -exact [lindex $rowidlist $row] $id]
6257 if {$col < 0} {
6258 puts "oops, row $row id $id not in list"
6259 return
6261 if {![info exists commitinfo($id)]} {
6262 getcommit $id
6264 assigncolor $id
6265 drawcmittext $id $row $col
6266 set iddrawn($id) 1
6267 incr nrows_drawn
6269 if {$markingmatches} {
6270 markrowmatches $row $id
6274 proc drawcommits {row {endrow {}}} {
6275 global numcommits iddrawn displayorder curview need_redisplay
6276 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6278 if {$row < 0} {
6279 set row 0
6281 if {$endrow eq {}} {
6282 set endrow $row
6284 if {$endrow >= $numcommits} {
6285 set endrow [expr {$numcommits - 1}]
6288 set rl1 [expr {$row - $downarrowlen - 3}]
6289 if {$rl1 < 0} {
6290 set rl1 0
6292 set ro1 [expr {$row - 3}]
6293 if {$ro1 < 0} {
6294 set ro1 0
6296 set r2 [expr {$endrow + $uparrowlen + 3}]
6297 if {$r2 > $numcommits} {
6298 set r2 $numcommits
6300 for {set r $rl1} {$r < $r2} {incr r} {
6301 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6302 if {$rl1 < $r} {
6303 layoutrows $rl1 $r
6305 set rl1 [expr {$r + 1}]
6308 if {$rl1 < $r} {
6309 layoutrows $rl1 $r
6311 optimize_rows $ro1 0 $r2
6312 if {$need_redisplay || $nrows_drawn > 2000} {
6313 clear_display
6316 # make the lines join to already-drawn rows either side
6317 set r [expr {$row - 1}]
6318 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6319 set r $row
6321 set er [expr {$endrow + 1}]
6322 if {$er >= $numcommits ||
6323 ![info exists iddrawn([lindex $displayorder $er])]} {
6324 set er $endrow
6326 for {} {$r <= $er} {incr r} {
6327 set id [lindex $displayorder $r]
6328 set wasdrawn [info exists iddrawn($id)]
6329 drawcmitrow $r
6330 if {$r == $er} break
6331 set nextid [lindex $displayorder [expr {$r + 1}]]
6332 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6333 drawparentlinks $id $r
6335 set rowids [lindex $rowidlist $r]
6336 foreach lid $rowids {
6337 if {$lid eq {}} continue
6338 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6339 if {$lid eq $id} {
6340 # see if this is the first child of any of its parents
6341 foreach p [lindex $parentlist $r] {
6342 if {[lsearch -exact $rowids $p] < 0} {
6343 # make this line extend up to the child
6344 set lineend($p) [drawlineseg $p $r $er 0]
6347 } else {
6348 set lineend($lid) [drawlineseg $lid $r $er 1]
6354 proc undolayout {row} {
6355 global uparrowlen mingaplen downarrowlen
6356 global rowidlist rowisopt rowfinal need_redisplay
6358 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6359 if {$r < 0} {
6360 set r 0
6362 if {[llength $rowidlist] > $r} {
6363 incr r -1
6364 set rowidlist [lrange $rowidlist 0 $r]
6365 set rowfinal [lrange $rowfinal 0 $r]
6366 set rowisopt [lrange $rowisopt 0 $r]
6367 set need_redisplay 1
6368 run drawvisible
6372 proc drawvisible {} {
6373 global canv linespc curview vrowmod selectedline targetrow targetid
6374 global need_redisplay cscroll numcommits
6376 set fs [$canv yview]
6377 set ymax [lindex [$canv cget -scrollregion] 3]
6378 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6379 set f0 [lindex $fs 0]
6380 set f1 [lindex $fs 1]
6381 set y0 [expr {int($f0 * $ymax)}]
6382 set y1 [expr {int($f1 * $ymax)}]
6384 if {[info exists targetid]} {
6385 if {[commitinview $targetid $curview]} {
6386 set r [rowofcommit $targetid]
6387 if {$r != $targetrow} {
6388 # Fix up the scrollregion and change the scrolling position
6389 # now that our target row has moved.
6390 set diff [expr {($r - $targetrow) * $linespc}]
6391 set targetrow $r
6392 setcanvscroll
6393 set ymax [lindex [$canv cget -scrollregion] 3]
6394 incr y0 $diff
6395 incr y1 $diff
6396 set f0 [expr {$y0 / $ymax}]
6397 set f1 [expr {$y1 / $ymax}]
6398 allcanvs yview moveto $f0
6399 $cscroll set $f0 $f1
6400 set need_redisplay 1
6402 } else {
6403 unset targetid
6407 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6408 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6409 if {$endrow >= $vrowmod($curview)} {
6410 update_arcrows $curview
6412 if {$selectedline ne {} &&
6413 $row <= $selectedline && $selectedline <= $endrow} {
6414 set targetrow $selectedline
6415 } elseif {[info exists targetid]} {
6416 set targetrow [expr {int(($row + $endrow) / 2)}]
6418 if {[info exists targetrow]} {
6419 if {$targetrow >= $numcommits} {
6420 set targetrow [expr {$numcommits - 1}]
6422 set targetid [commitonrow $targetrow]
6424 drawcommits $row $endrow
6427 proc clear_display {} {
6428 global iddrawn linesegs need_redisplay nrows_drawn
6429 global vhighlights fhighlights nhighlights rhighlights
6430 global linehtag linentag linedtag boldids boldnameids
6432 allcanvs delete all
6433 unset -nocomplain iddrawn
6434 unset -nocomplain linesegs
6435 unset -nocomplain linehtag
6436 unset -nocomplain linentag
6437 unset -nocomplain linedtag
6438 set boldids {}
6439 set boldnameids {}
6440 unset -nocomplain vhighlights
6441 unset -nocomplain fhighlights
6442 unset -nocomplain nhighlights
6443 unset -nocomplain rhighlights
6444 set need_redisplay 0
6445 set nrows_drawn 0
6448 proc findcrossings {id} {
6449 global rowidlist parentlist numcommits displayorder
6451 set cross {}
6452 set ccross {}
6453 foreach {s e} [rowranges $id] {
6454 if {$e >= $numcommits} {
6455 set e [expr {$numcommits - 1}]
6457 if {$e <= $s} continue
6458 for {set row $e} {[incr row -1] >= $s} {} {
6459 set x [lsearch -exact [lindex $rowidlist $row] $id]
6460 if {$x < 0} break
6461 set olds [lindex $parentlist $row]
6462 set kid [lindex $displayorder $row]
6463 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6464 if {$kidx < 0} continue
6465 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6466 foreach p $olds {
6467 set px [lsearch -exact $nextrow $p]
6468 if {$px < 0} continue
6469 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6470 if {[lsearch -exact $ccross $p] >= 0} continue
6471 if {$x == $px + ($kidx < $px? -1: 1)} {
6472 lappend ccross $p
6473 } elseif {[lsearch -exact $cross $p] < 0} {
6474 lappend cross $p
6480 return [concat $ccross {{}} $cross]
6483 proc assigncolor {id} {
6484 global colormap colors nextcolor
6485 global parents children children curview
6487 if {[info exists colormap($id)]} return
6488 set ncolors [llength $colors]
6489 if {[info exists children($curview,$id)]} {
6490 set kids $children($curview,$id)
6491 } else {
6492 set kids {}
6494 if {[llength $kids] == 1} {
6495 set child [lindex $kids 0]
6496 if {[info exists colormap($child)]
6497 && [llength $parents($curview,$child)] == 1} {
6498 set colormap($id) $colormap($child)
6499 return
6502 set badcolors {}
6503 set origbad {}
6504 foreach x [findcrossings $id] {
6505 if {$x eq {}} {
6506 # delimiter between corner crossings and other crossings
6507 if {[llength $badcolors] >= $ncolors - 1} break
6508 set origbad $badcolors
6510 if {[info exists colormap($x)]
6511 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6512 lappend badcolors $colormap($x)
6515 if {[llength $badcolors] >= $ncolors} {
6516 set badcolors $origbad
6518 set origbad $badcolors
6519 if {[llength $badcolors] < $ncolors - 1} {
6520 foreach child $kids {
6521 if {[info exists colormap($child)]
6522 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6523 lappend badcolors $colormap($child)
6525 foreach p $parents($curview,$child) {
6526 if {[info exists colormap($p)]
6527 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6528 lappend badcolors $colormap($p)
6532 if {[llength $badcolors] >= $ncolors} {
6533 set badcolors $origbad
6536 for {set i 0} {$i <= $ncolors} {incr i} {
6537 set c [lindex $colors $nextcolor]
6538 if {[incr nextcolor] >= $ncolors} {
6539 set nextcolor 0
6541 if {[lsearch -exact $badcolors $c]} break
6543 set colormap($id) $c
6546 proc bindline {t id} {
6547 global canv
6549 $canv bind $t <Enter> "lineenter %x %y $id"
6550 $canv bind $t <Motion> "linemotion %x %y $id"
6551 $canv bind $t <Leave> "lineleave $id"
6552 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6555 proc graph_pane_width {} {
6556 global use_ttk
6558 if {$use_ttk} {
6559 set g [.tf.histframe.pwclist sashpos 0]
6560 } else {
6561 set g [.tf.histframe.pwclist sash coord 0]
6563 return [lindex $g 0]
6566 proc totalwidth {l font extra} {
6567 set tot 0
6568 foreach str $l {
6569 set tot [expr {$tot + [font measure $font $str] + $extra}]
6571 return $tot
6574 proc drawtags {id x xt y1} {
6575 global idtags idheads idotherrefs mainhead
6576 global linespc lthickness
6577 global canv rowtextx curview fgcolor bgcolor ctxbut
6578 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6579 global tagbgcolor tagfgcolor tagoutlinecolor
6580 global reflinecolor
6582 set marks {}
6583 set ntags 0
6584 set nheads 0
6585 set singletag 0
6586 set maxtags 3
6587 set maxtagpct 25
6588 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6589 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6590 set extra [expr {$delta + $lthickness + $linespc}]
6592 if {[info exists idtags($id)]} {
6593 set marks $idtags($id)
6594 set ntags [llength $marks]
6595 if {$ntags > $maxtags ||
6596 [totalwidth $marks mainfont $extra] > $maxwidth} {
6597 # show just a single "n tags..." tag
6598 set singletag 1
6599 if {$ntags == 1} {
6600 set marks [list "tag..."]
6601 } else {
6602 set marks [list [format "%d tags..." $ntags]]
6604 set ntags 1
6607 if {[info exists idheads($id)]} {
6608 set marks [concat $marks $idheads($id)]
6609 set nheads [llength $idheads($id)]
6611 if {[info exists idotherrefs($id)]} {
6612 set marks [concat $marks $idotherrefs($id)]
6614 if {$marks eq {}} {
6615 return $xt
6618 set yt [expr {$y1 - 0.5 * $linespc}]
6619 set yb [expr {$yt + $linespc - 1}]
6620 set xvals {}
6621 set wvals {}
6622 set i -1
6623 foreach tag $marks {
6624 incr i
6625 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6626 set wid [font measure mainfontbold $tag]
6627 } else {
6628 set wid [font measure mainfont $tag]
6630 lappend xvals $xt
6631 lappend wvals $wid
6632 set xt [expr {$xt + $wid + $extra}]
6634 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6635 -width $lthickness -fill $reflinecolor -tags tag.$id]
6636 $canv lower $t
6637 foreach tag $marks x $xvals wid $wvals {
6638 set tag_quoted [string map {% %%} $tag]
6639 set xl [expr {$x + $delta}]
6640 set xr [expr {$x + $delta + $wid + $lthickness}]
6641 set font mainfont
6642 if {[incr ntags -1] >= 0} {
6643 # draw a tag
6644 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6645 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6646 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6647 -tags tag.$id]
6648 if {$singletag} {
6649 set tagclick [list showtags $id 1]
6650 } else {
6651 set tagclick [list showtag $tag_quoted 1]
6653 $canv bind $t <1> $tagclick
6654 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6655 } else {
6656 # draw a head or other ref
6657 if {[incr nheads -1] >= 0} {
6658 set col $headbgcolor
6659 if {$tag eq $mainhead} {
6660 set font mainfontbold
6662 } else {
6663 set col "#ddddff"
6665 set xl [expr {$xl - $delta/2}]
6666 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6667 -width 1 -outline black -fill $col -tags tag.$id
6668 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6669 set rwid [font measure mainfont $remoteprefix]
6670 set xi [expr {$x + 1}]
6671 set yti [expr {$yt + 1}]
6672 set xri [expr {$x + $rwid}]
6673 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6674 -width 0 -fill $remotebgcolor -tags tag.$id
6677 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6678 -font $font -tags [list tag.$id text]]
6679 if {$ntags >= 0} {
6680 $canv bind $t <1> $tagclick
6681 } elseif {$nheads >= 0} {
6682 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6685 return $xt
6688 proc drawnotesign {xt y} {
6689 global linespc canv fgcolor
6691 set orad [expr {$linespc / 3}]
6692 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6693 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6694 -fill yellow -outline $fgcolor -width 1 -tags circle]
6695 set xt [expr {$xt + $orad * 3}]
6696 return $xt
6699 proc xcoord {i level ln} {
6700 global canvx0 xspc1 xspc2
6702 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6703 if {$i > 0 && $i == $level} {
6704 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6705 } elseif {$i > $level} {
6706 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6708 return $x
6711 proc show_status {msg} {
6712 global canv fgcolor
6714 clear_display
6715 set_window_title
6716 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6717 -tags text -fill $fgcolor
6720 # Don't change the text pane cursor if it is currently the hand cursor,
6721 # showing that we are over a sha1 ID link.
6722 proc settextcursor {c} {
6723 global ctext curtextcursor
6725 if {[$ctext cget -cursor] == $curtextcursor} {
6726 $ctext config -cursor $c
6728 set curtextcursor $c
6731 proc nowbusy {what {name {}}} {
6732 global isbusy busyname statusw
6734 if {[array names isbusy] eq {}} {
6735 . config -cursor watch
6736 settextcursor watch
6738 set isbusy($what) 1
6739 set busyname($what) $name
6740 if {$name ne {}} {
6741 $statusw conf -text $name
6745 proc notbusy {what} {
6746 global isbusy maincursor textcursor busyname statusw
6748 catch {
6749 unset isbusy($what)
6750 if {$busyname($what) ne {} &&
6751 [$statusw cget -text] eq $busyname($what)} {
6752 $statusw conf -text {}
6755 if {[array names isbusy] eq {}} {
6756 . config -cursor $maincursor
6757 settextcursor $textcursor
6761 proc findmatches {f} {
6762 global findtype findstring
6763 if {$findtype == [mc "Regexp"]} {
6764 set matches [regexp -indices -all -inline $findstring $f]
6765 } else {
6766 set fs $findstring
6767 if {$findtype == [mc "IgnCase"]} {
6768 set f [string tolower $f]
6769 set fs [string tolower $fs]
6771 set matches {}
6772 set i 0
6773 set l [string length $fs]
6774 while {[set j [string first $fs $f $i]] >= 0} {
6775 lappend matches [list $j [expr {$j+$l-1}]]
6776 set i [expr {$j + $l}]
6779 return $matches
6782 proc dofind {{dirn 1} {wrap 1}} {
6783 global findstring findstartline findcurline selectedline numcommits
6784 global gdttype filehighlight fh_serial find_dirn findallowwrap
6786 if {[info exists find_dirn]} {
6787 if {$find_dirn == $dirn} return
6788 stopfinding
6790 focus .
6791 if {$findstring eq {} || $numcommits == 0} return
6792 if {$selectedline eq {}} {
6793 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6794 } else {
6795 set findstartline $selectedline
6797 set findcurline $findstartline
6798 nowbusy finding [mc "Searching"]
6799 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6800 after cancel do_file_hl $fh_serial
6801 do_file_hl $fh_serial
6803 set find_dirn $dirn
6804 set findallowwrap $wrap
6805 run findmore
6808 proc stopfinding {} {
6809 global find_dirn findcurline fprogcoord
6811 if {[info exists find_dirn]} {
6812 unset find_dirn
6813 unset findcurline
6814 notbusy finding
6815 set fprogcoord 0
6816 adjustprogress
6818 stopblaming
6821 proc findmore {} {
6822 global commitdata commitinfo numcommits findpattern findloc
6823 global findstartline findcurline findallowwrap
6824 global find_dirn gdttype fhighlights fprogcoord
6825 global curview varcorder vrownum varccommits vrowmod
6827 if {![info exists find_dirn]} {
6828 return 0
6830 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6831 set l $findcurline
6832 set moretodo 0
6833 if {$find_dirn > 0} {
6834 incr l
6835 if {$l >= $numcommits} {
6836 set l 0
6838 if {$l <= $findstartline} {
6839 set lim [expr {$findstartline + 1}]
6840 } else {
6841 set lim $numcommits
6842 set moretodo $findallowwrap
6844 } else {
6845 if {$l == 0} {
6846 set l $numcommits
6848 incr l -1
6849 if {$l >= $findstartline} {
6850 set lim [expr {$findstartline - 1}]
6851 } else {
6852 set lim -1
6853 set moretodo $findallowwrap
6856 set n [expr {($lim - $l) * $find_dirn}]
6857 if {$n > 500} {
6858 set n 500
6859 set moretodo 1
6861 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6862 update_arcrows $curview
6864 set found 0
6865 set domore 1
6866 set ai [bsearch $vrownum($curview) $l]
6867 set a [lindex $varcorder($curview) $ai]
6868 set arow [lindex $vrownum($curview) $ai]
6869 set ids [lindex $varccommits($curview,$a)]
6870 set arowend [expr {$arow + [llength $ids]}]
6871 if {$gdttype eq [mc "containing:"]} {
6872 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6873 if {$l < $arow || $l >= $arowend} {
6874 incr ai $find_dirn
6875 set a [lindex $varcorder($curview) $ai]
6876 set arow [lindex $vrownum($curview) $ai]
6877 set ids [lindex $varccommits($curview,$a)]
6878 set arowend [expr {$arow + [llength $ids]}]
6880 set id [lindex $ids [expr {$l - $arow}]]
6881 # shouldn't happen unless git log doesn't give all the commits...
6882 if {![info exists commitdata($id)] ||
6883 ![doesmatch $commitdata($id)]} {
6884 continue
6886 if {![info exists commitinfo($id)]} {
6887 getcommit $id
6889 set info $commitinfo($id)
6890 foreach f $info ty $fldtypes {
6891 if {$ty eq ""} continue
6892 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6893 [doesmatch $f]} {
6894 set found 1
6895 break
6898 if {$found} break
6900 } else {
6901 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6902 if {$l < $arow || $l >= $arowend} {
6903 incr ai $find_dirn
6904 set a [lindex $varcorder($curview) $ai]
6905 set arow [lindex $vrownum($curview) $ai]
6906 set ids [lindex $varccommits($curview,$a)]
6907 set arowend [expr {$arow + [llength $ids]}]
6909 set id [lindex $ids [expr {$l - $arow}]]
6910 if {![info exists fhighlights($id)]} {
6911 # this sets fhighlights($id) to -1
6912 askfilehighlight $l $id
6914 if {$fhighlights($id) > 0} {
6915 set found $domore
6916 break
6918 if {$fhighlights($id) < 0} {
6919 if {$domore} {
6920 set domore 0
6921 set findcurline [expr {$l - $find_dirn}]
6926 if {$found || ($domore && !$moretodo)} {
6927 unset findcurline
6928 unset find_dirn
6929 notbusy finding
6930 set fprogcoord 0
6931 adjustprogress
6932 if {$found} {
6933 findselectline $l
6934 } else {
6935 bell
6937 return 0
6939 if {!$domore} {
6940 flushhighlights
6941 } else {
6942 set findcurline [expr {$l - $find_dirn}]
6944 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6945 if {$n < 0} {
6946 incr n $numcommits
6948 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6949 adjustprogress
6950 return $domore
6953 proc findselectline {l} {
6954 global findloc commentend ctext findcurline markingmatches gdttype
6956 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6957 set findcurline $l
6958 selectline $l 1
6959 if {$markingmatches &&
6960 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6961 # highlight the matches in the comments
6962 set f [$ctext get 1.0 $commentend]
6963 set matches [findmatches $f]
6964 foreach match $matches {
6965 set start [lindex $match 0]
6966 set end [expr {[lindex $match 1] + 1}]
6967 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6970 drawvisible
6973 # mark the bits of a headline or author that match a find string
6974 proc markmatches {canv l str tag matches font row} {
6975 global selectedline
6977 set bbox [$canv bbox $tag]
6978 set x0 [lindex $bbox 0]
6979 set y0 [lindex $bbox 1]
6980 set y1 [lindex $bbox 3]
6981 foreach match $matches {
6982 set start [lindex $match 0]
6983 set end [lindex $match 1]
6984 if {$start > $end} continue
6985 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6986 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6987 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6988 [expr {$x0+$xlen+2}] $y1 \
6989 -outline {} -tags [list match$l matches] -fill yellow]
6990 $canv lower $t
6991 if {$row == $selectedline} {
6992 $canv raise $t secsel
6997 proc unmarkmatches {} {
6998 global markingmatches
7000 allcanvs delete matches
7001 set markingmatches 0
7002 stopfinding
7005 proc selcanvline {w x y} {
7006 global canv canvy0 ctext linespc
7007 global rowtextx
7008 set ymax [lindex [$canv cget -scrollregion] 3]
7009 if {$ymax == {}} return
7010 set yfrac [lindex [$canv yview] 0]
7011 set y [expr {$y + $yfrac * $ymax}]
7012 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
7013 if {$l < 0} {
7014 set l 0
7016 if {$w eq $canv} {
7017 set xmax [lindex [$canv cget -scrollregion] 2]
7018 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
7019 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
7021 unmarkmatches
7022 selectline $l 1
7025 proc commit_descriptor {p} {
7026 global commitinfo
7027 if {![info exists commitinfo($p)]} {
7028 getcommit $p
7030 set l "..."
7031 if {[llength $commitinfo($p)] > 1} {
7032 set l [lindex $commitinfo($p) 0]
7034 return "$p ($l)\n"
7037 # append some text to the ctext widget, and make any SHA1 ID
7038 # that we know about be a clickable link.
7039 # Also look for URLs of the form "http[s]://..." and make them web links.
7040 proc appendwithlinks {text tags} {
7041 global ctext linknum curview
7043 set start [$ctext index "end - 1c"]
7044 $ctext insert end $text $tags
7045 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
7046 foreach l $links {
7047 set s [lindex $l 0]
7048 set e [lindex $l 1]
7049 set linkid [string range $text $s $e]
7050 incr e
7051 $ctext tag delete link$linknum
7052 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7053 setlink $linkid link$linknum
7054 incr linknum
7056 set wlinks [regexp -indices -all -inline -line \
7057 {https?://[^[:space:]]+} $text]
7058 foreach l $wlinks {
7059 set s2 [lindex $l 0]
7060 set e2 [lindex $l 1]
7061 set url [string range $text $s2 $e2]
7062 incr e2
7063 $ctext tag delete link$linknum
7064 $ctext tag add link$linknum "$start + $s2 c" "$start + $e2 c"
7065 setwlink $url link$linknum
7066 incr linknum
7070 proc setlink {id lk} {
7071 global curview ctext pendinglinks
7072 global linkfgcolor
7074 if {[string range $id 0 1] eq "-g"} {
7075 set id [string range $id 2 end]
7078 set known 0
7079 if {[string length $id] < 40} {
7080 set matches [longid $id]
7081 if {[llength $matches] > 0} {
7082 if {[llength $matches] > 1} return
7083 set known 1
7084 set id [lindex $matches 0]
7086 } else {
7087 set known [commitinview $id $curview]
7089 if {$known} {
7090 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7091 $ctext tag bind $lk <1> [list selbyid $id]
7092 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7093 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7094 } else {
7095 lappend pendinglinks($id) $lk
7096 interestedin $id {makelink %P}
7100 proc setwlink {url lk} {
7101 global ctext
7102 global linkfgcolor
7103 global web_browser
7105 if {$web_browser eq {}} return
7106 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7107 $ctext tag bind $lk <1> [list browseweb $url]
7108 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7109 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7112 proc appendshortlink {id {pre {}} {post {}}} {
7113 global ctext linknum
7115 $ctext insert end $pre
7116 $ctext tag delete link$linknum
7117 $ctext insert end [string range $id 0 7] link$linknum
7118 $ctext insert end $post
7119 setlink $id link$linknum
7120 incr linknum
7123 proc makelink {id} {
7124 global pendinglinks
7126 if {![info exists pendinglinks($id)]} return
7127 foreach lk $pendinglinks($id) {
7128 setlink $id $lk
7130 unset pendinglinks($id)
7133 proc linkcursor {w inc} {
7134 global linkentercount curtextcursor
7136 if {[incr linkentercount $inc] > 0} {
7137 $w configure -cursor hand2
7138 } else {
7139 $w configure -cursor $curtextcursor
7140 if {$linkentercount < 0} {
7141 set linkentercount 0
7146 proc browseweb {url} {
7147 global web_browser
7149 if {$web_browser eq {}} return
7150 # Use eval here in case $web_browser is a command plus some arguments
7151 if {[catch {eval exec $web_browser [list $url] &} err]} {
7152 error_popup "[mc "Error starting web browser:"] $err"
7156 proc viewnextline {dir} {
7157 global canv linespc
7159 $canv delete hover
7160 set ymax [lindex [$canv cget -scrollregion] 3]
7161 set wnow [$canv yview]
7162 set wtop [expr {[lindex $wnow 0] * $ymax}]
7163 set newtop [expr {$wtop + $dir * $linespc}]
7164 if {$newtop < 0} {
7165 set newtop 0
7166 } elseif {$newtop > $ymax} {
7167 set newtop $ymax
7169 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7172 # add a list of tag or branch names at position pos
7173 # returns the number of names inserted
7174 proc appendrefs {pos ids var} {
7175 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7177 if {[catch {$ctext index $pos}]} {
7178 return 0
7180 $ctext conf -state normal
7181 $ctext delete $pos "$pos lineend"
7182 set tags {}
7183 foreach id $ids {
7184 foreach tag [set $var\($id\)] {
7185 lappend tags [list $tag $id]
7189 set sep {}
7190 set tags [lsort -index 0 -decreasing $tags]
7191 set nutags 0
7193 if {[llength $tags] > $maxrefs} {
7194 # If we are displaying heads, and there are too many,
7195 # see if there are some important heads to display.
7196 # Currently that are the current head and heads listed in $visiblerefs option
7197 set itags {}
7198 if {$var eq "idheads"} {
7199 set utags {}
7200 foreach ti $tags {
7201 set hname [lindex $ti 0]
7202 set id [lindex $ti 1]
7203 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7204 [llength $itags] < $maxrefs} {
7205 lappend itags $ti
7206 } else {
7207 lappend utags $ti
7210 set tags $utags
7212 if {$itags ne {}} {
7213 set str [mc "and many more"]
7214 set sep " "
7215 } else {
7216 set str [mc "many"]
7218 $ctext insert $pos "$str ([llength $tags])"
7219 set nutags [llength $tags]
7220 set tags $itags
7223 foreach ti $tags {
7224 set id [lindex $ti 1]
7225 set lk link$linknum
7226 incr linknum
7227 $ctext tag delete $lk
7228 $ctext insert $pos $sep
7229 $ctext insert $pos [lindex $ti 0] $lk
7230 setlink $id $lk
7231 set sep ", "
7233 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7234 $ctext conf -state disabled
7235 return [expr {[llength $tags] + $nutags}]
7238 # called when we have finished computing the nearby tags
7239 proc dispneartags {delay} {
7240 global selectedline currentid showneartags tagphase
7242 if {$selectedline eq {} || !$showneartags} return
7243 after cancel dispnexttag
7244 if {$delay} {
7245 after 200 dispnexttag
7246 set tagphase -1
7247 } else {
7248 after idle dispnexttag
7249 set tagphase 0
7253 proc dispnexttag {} {
7254 global selectedline currentid showneartags tagphase ctext
7256 if {$selectedline eq {} || !$showneartags} return
7257 switch -- $tagphase {
7259 set dtags [desctags $currentid]
7260 if {$dtags ne {}} {
7261 appendrefs precedes $dtags idtags
7265 set atags [anctags $currentid]
7266 if {$atags ne {}} {
7267 appendrefs follows $atags idtags
7271 set dheads [descheads $currentid]
7272 if {$dheads ne {}} {
7273 if {[appendrefs branch $dheads idheads] > 1
7274 && [$ctext get "branch -3c"] eq "h"} {
7275 # turn "Branch" into "Branches"
7276 $ctext conf -state normal
7277 $ctext insert "branch -2c" "es"
7278 $ctext conf -state disabled
7283 if {[incr tagphase] <= 2} {
7284 after idle dispnexttag
7288 proc make_secsel {id} {
7289 global linehtag linentag linedtag canv canv2 canv3
7291 if {![info exists linehtag($id)]} return
7292 $canv delete secsel
7293 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7294 -tags secsel -fill [$canv cget -selectbackground]]
7295 $canv lower $t
7296 $canv2 delete secsel
7297 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7298 -tags secsel -fill [$canv2 cget -selectbackground]]
7299 $canv2 lower $t
7300 $canv3 delete secsel
7301 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7302 -tags secsel -fill [$canv3 cget -selectbackground]]
7303 $canv3 lower $t
7306 proc make_idmark {id} {
7307 global linehtag canv fgcolor
7309 if {![info exists linehtag($id)]} return
7310 $canv delete markid
7311 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7312 -tags markid -outline $fgcolor]
7313 $canv raise $t
7316 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7317 global canv ctext commitinfo selectedline
7318 global canvy0 linespc parents children curview
7319 global currentid sha1entry
7320 global commentend idtags linknum
7321 global mergemax numcommits pending_select
7322 global cmitmode showneartags allcommits
7323 global targetrow targetid lastscrollrows
7324 global autoselect autosellen jump_to_here
7325 global vinlinediff
7327 unset -nocomplain pending_select
7328 $canv delete hover
7329 normalline
7330 unsel_reflist
7331 stopfinding
7332 if {$l < 0 || $l >= $numcommits} return
7333 set id [commitonrow $l]
7334 set targetid $id
7335 set targetrow $l
7336 set selectedline $l
7337 set currentid $id
7338 if {$lastscrollrows < $numcommits} {
7339 setcanvscroll
7342 if {$cmitmode ne "patch" && $switch_to_patch} {
7343 set cmitmode "patch"
7346 set y [expr {$canvy0 + $l * $linespc}]
7347 set ymax [lindex [$canv cget -scrollregion] 3]
7348 set ytop [expr {$y - $linespc - 1}]
7349 set ybot [expr {$y + $linespc + 1}]
7350 set wnow [$canv yview]
7351 set wtop [expr {[lindex $wnow 0] * $ymax}]
7352 set wbot [expr {[lindex $wnow 1] * $ymax}]
7353 set wh [expr {$wbot - $wtop}]
7354 set newtop $wtop
7355 if {$ytop < $wtop} {
7356 if {$ybot < $wtop} {
7357 set newtop [expr {$y - $wh / 2.0}]
7358 } else {
7359 set newtop $ytop
7360 if {$newtop > $wtop - $linespc} {
7361 set newtop [expr {$wtop - $linespc}]
7364 } elseif {$ybot > $wbot} {
7365 if {$ytop > $wbot} {
7366 set newtop [expr {$y - $wh / 2.0}]
7367 } else {
7368 set newtop [expr {$ybot - $wh}]
7369 if {$newtop < $wtop + $linespc} {
7370 set newtop [expr {$wtop + $linespc}]
7374 if {$newtop != $wtop} {
7375 if {$newtop < 0} {
7376 set newtop 0
7378 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7379 drawvisible
7382 make_secsel $id
7384 if {$isnew} {
7385 addtohistory [list selbyid $id 0] savecmitpos
7388 $sha1entry delete 0 end
7389 $sha1entry insert 0 $id
7390 if {$autoselect} {
7391 $sha1entry selection range 0 $autosellen
7393 rhighlight_sel $id
7395 $ctext conf -state normal
7396 clear_ctext
7397 set linknum 0
7398 if {![info exists commitinfo($id)]} {
7399 getcommit $id
7401 set info $commitinfo($id)
7402 set date [formatdate [lindex $info 2]]
7403 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7404 set date [formatdate [lindex $info 4]]
7405 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7406 if {[info exists idtags($id)]} {
7407 $ctext insert end [mc "Tags:"]
7408 foreach tag $idtags($id) {
7409 $ctext insert end " $tag"
7411 $ctext insert end "\n"
7414 set headers {}
7415 set olds $parents($curview,$id)
7416 if {[llength $olds] > 1} {
7417 set np 0
7418 foreach p $olds {
7419 if {$np >= $mergemax} {
7420 set tag mmax
7421 } else {
7422 set tag m$np
7424 $ctext insert end "[mc "Parent"]: " $tag
7425 appendwithlinks [commit_descriptor $p] {}
7426 incr np
7428 } else {
7429 foreach p $olds {
7430 append headers "[mc "Parent"]: [commit_descriptor $p]"
7434 foreach c $children($curview,$id) {
7435 append headers "[mc "Child"]: [commit_descriptor $c]"
7438 # make anything that looks like a SHA1 ID be a clickable link
7439 appendwithlinks $headers {}
7440 if {$showneartags} {
7441 if {![info exists allcommits]} {
7442 getallcommits
7444 $ctext insert end "[mc "Branch"]: "
7445 $ctext mark set branch "end -1c"
7446 $ctext mark gravity branch left
7447 $ctext insert end "\n[mc "Follows"]: "
7448 $ctext mark set follows "end -1c"
7449 $ctext mark gravity follows left
7450 $ctext insert end "\n[mc "Precedes"]: "
7451 $ctext mark set precedes "end -1c"
7452 $ctext mark gravity precedes left
7453 $ctext insert end "\n"
7454 dispneartags 1
7456 $ctext insert end "\n"
7457 set comment [lindex $info 5]
7458 if {[string first "\r" $comment] >= 0} {
7459 set comment [string map {"\r" "\n "} $comment]
7461 appendwithlinks $comment {comment}
7463 $ctext tag remove found 1.0 end
7464 $ctext conf -state disabled
7465 set commentend [$ctext index "end - 1c"]
7467 set jump_to_here $desired_loc
7468 init_flist [mc "Comments"]
7469 if {$cmitmode eq "tree"} {
7470 gettree $id
7471 } elseif {$vinlinediff($curview) == 1} {
7472 showinlinediff $id
7473 } elseif {[llength $olds] <= 1} {
7474 startdiff $id
7475 } else {
7476 mergediff $id
7480 proc selfirstline {} {
7481 unmarkmatches
7482 selectline 0 1
7485 proc sellastline {} {
7486 global numcommits
7487 unmarkmatches
7488 set l [expr {$numcommits - 1}]
7489 selectline $l 1
7492 proc selnextline {dir} {
7493 global selectedline
7494 focus .
7495 if {$selectedline eq {}} return
7496 set l [expr {$selectedline + $dir}]
7497 unmarkmatches
7498 selectline $l 1
7501 proc selnextpage {dir} {
7502 global canv linespc selectedline numcommits
7504 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7505 if {$lpp < 1} {
7506 set lpp 1
7508 allcanvs yview scroll [expr {$dir * $lpp}] units
7509 drawvisible
7510 if {$selectedline eq {}} return
7511 set l [expr {$selectedline + $dir * $lpp}]
7512 if {$l < 0} {
7513 set l 0
7514 } elseif {$l >= $numcommits} {
7515 set l [expr $numcommits - 1]
7517 unmarkmatches
7518 selectline $l 1
7521 proc unselectline {} {
7522 global selectedline currentid
7524 set selectedline {}
7525 unset -nocomplain currentid
7526 allcanvs delete secsel
7527 rhighlight_none
7530 proc reselectline {} {
7531 global selectedline
7533 if {$selectedline ne {}} {
7534 selectline $selectedline 0
7538 proc addtohistory {cmd {saveproc {}}} {
7539 global history historyindex curview
7541 unset_posvars
7542 save_position
7543 set elt [list $curview $cmd $saveproc {}]
7544 if {$historyindex > 0
7545 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7546 return
7549 if {$historyindex < [llength $history]} {
7550 set history [lreplace $history $historyindex end $elt]
7551 } else {
7552 lappend history $elt
7554 incr historyindex
7555 if {$historyindex > 1} {
7556 .tf.bar.leftbut conf -state normal
7557 } else {
7558 .tf.bar.leftbut conf -state disabled
7560 .tf.bar.rightbut conf -state disabled
7563 # save the scrolling position of the diff display pane
7564 proc save_position {} {
7565 global historyindex history
7567 if {$historyindex < 1} return
7568 set hi [expr {$historyindex - 1}]
7569 set fn [lindex $history $hi 2]
7570 if {$fn ne {}} {
7571 lset history $hi 3 [eval $fn]
7575 proc unset_posvars {} {
7576 global last_posvars
7578 if {[info exists last_posvars]} {
7579 foreach {var val} $last_posvars {
7580 global $var
7581 unset -nocomplain $var
7583 unset last_posvars
7587 proc godo {elt} {
7588 global curview last_posvars
7590 set view [lindex $elt 0]
7591 set cmd [lindex $elt 1]
7592 set pv [lindex $elt 3]
7593 if {$curview != $view} {
7594 showview $view
7596 unset_posvars
7597 foreach {var val} $pv {
7598 global $var
7599 set $var $val
7601 set last_posvars $pv
7602 eval $cmd
7605 proc goback {} {
7606 global history historyindex
7607 focus .
7609 if {$historyindex > 1} {
7610 save_position
7611 incr historyindex -1
7612 godo [lindex $history [expr {$historyindex - 1}]]
7613 .tf.bar.rightbut conf -state normal
7615 if {$historyindex <= 1} {
7616 .tf.bar.leftbut conf -state disabled
7620 proc goforw {} {
7621 global history historyindex
7622 focus .
7624 if {$historyindex < [llength $history]} {
7625 save_position
7626 set cmd [lindex $history $historyindex]
7627 incr historyindex
7628 godo $cmd
7629 .tf.bar.leftbut conf -state normal
7631 if {$historyindex >= [llength $history]} {
7632 .tf.bar.rightbut conf -state disabled
7636 proc go_to_parent {i} {
7637 global parents curview targetid
7638 set ps $parents($curview,$targetid)
7639 if {[llength $ps] >= $i} {
7640 selbyid [lindex $ps [expr $i - 1]]
7644 proc gettree {id} {
7645 global treefilelist treeidlist diffids diffmergeid treepending
7646 global nullid nullid2
7648 set diffids $id
7649 unset -nocomplain diffmergeid
7650 if {![info exists treefilelist($id)]} {
7651 if {![info exists treepending]} {
7652 if {$id eq $nullid} {
7653 set cmd [list | git ls-files]
7654 } elseif {$id eq $nullid2} {
7655 set cmd [list | git ls-files --stage -t]
7656 } else {
7657 set cmd [list | git ls-tree -r $id]
7659 if {[catch {set gtf [open $cmd r]}]} {
7660 return
7662 set treepending $id
7663 set treefilelist($id) {}
7664 set treeidlist($id) {}
7665 fconfigure $gtf -blocking 0 -encoding binary
7666 filerun $gtf [list gettreeline $gtf $id]
7668 } else {
7669 setfilelist $id
7673 proc gettreeline {gtf id} {
7674 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7676 set nl 0
7677 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7678 if {$diffids eq $nullid} {
7679 set fname $line
7680 } else {
7681 set i [string first "\t" $line]
7682 if {$i < 0} continue
7683 set fname [string range $line [expr {$i+1}] end]
7684 set line [string range $line 0 [expr {$i-1}]]
7685 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7686 set sha1 [lindex $line 2]
7687 lappend treeidlist($id) $sha1
7689 if {[string index $fname 0] eq "\""} {
7690 set fname [lindex $fname 0]
7692 set fname [encoding convertfrom $fname]
7693 lappend treefilelist($id) $fname
7695 if {![eof $gtf]} {
7696 return [expr {$nl >= 1000? 2: 1}]
7698 close $gtf
7699 unset treepending
7700 if {$cmitmode ne "tree"} {
7701 if {![info exists diffmergeid]} {
7702 gettreediffs $diffids
7704 } elseif {$id ne $diffids} {
7705 gettree $diffids
7706 } else {
7707 setfilelist $id
7709 return 0
7712 proc showfile {f} {
7713 global treefilelist treeidlist diffids nullid nullid2
7714 global ctext_file_names ctext_file_lines
7715 global ctext commentend
7717 set i [lsearch -exact $treefilelist($diffids) $f]
7718 if {$i < 0} {
7719 puts "oops, $f not in list for id $diffids"
7720 return
7722 if {$diffids eq $nullid} {
7723 if {[catch {set bf [open $f r]} err]} {
7724 puts "oops, can't read $f: $err"
7725 return
7727 } else {
7728 set blob [lindex $treeidlist($diffids) $i]
7729 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7730 puts "oops, error reading blob $blob: $err"
7731 return
7734 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7735 filerun $bf [list getblobline $bf $diffids]
7736 $ctext config -state normal
7737 clear_ctext $commentend
7738 lappend ctext_file_names $f
7739 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7740 $ctext insert end "\n"
7741 $ctext insert end "$f\n" filesep
7742 $ctext config -state disabled
7743 $ctext yview $commentend
7744 settabs 0
7747 proc getblobline {bf id} {
7748 global diffids cmitmode ctext
7750 if {$id ne $diffids || $cmitmode ne "tree"} {
7751 catch {close $bf}
7752 return 0
7754 $ctext config -state normal
7755 set nl 0
7756 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7757 $ctext insert end "$line\n"
7759 if {[eof $bf]} {
7760 global jump_to_here ctext_file_names commentend
7762 # delete last newline
7763 $ctext delete "end - 2c" "end - 1c"
7764 close $bf
7765 if {$jump_to_here ne {} &&
7766 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7767 set lnum [expr {[lindex $jump_to_here 1] +
7768 [lindex [split $commentend .] 0]}]
7769 mark_ctext_line $lnum
7771 $ctext config -state disabled
7772 return 0
7774 $ctext config -state disabled
7775 return [expr {$nl >= 1000? 2: 1}]
7778 proc mark_ctext_line {lnum} {
7779 global ctext markbgcolor
7781 $ctext tag delete omark
7782 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7783 $ctext tag conf omark -background $markbgcolor
7784 $ctext see $lnum.0
7787 proc mergediff {id} {
7788 global diffmergeid
7789 global diffids treediffs
7790 global parents curview
7792 set diffmergeid $id
7793 set diffids $id
7794 set treediffs($id) {}
7795 set np [llength $parents($curview,$id)]
7796 settabs $np
7797 getblobdiffs $id
7800 proc startdiff {ids} {
7801 global treediffs diffids treepending diffmergeid nullid nullid2
7803 settabs 1
7804 set diffids $ids
7805 unset -nocomplain diffmergeid
7806 if {![info exists treediffs($ids)] ||
7807 [lsearch -exact $ids $nullid] >= 0 ||
7808 [lsearch -exact $ids $nullid2] >= 0} {
7809 if {![info exists treepending]} {
7810 gettreediffs $ids
7812 } else {
7813 addtocflist $ids
7817 proc showinlinediff {ids} {
7818 global commitinfo commitdata ctext
7819 global treediffs
7821 set info $commitinfo($ids)
7822 set diff [lindex $info 7]
7823 set difflines [split $diff "\n"]
7825 initblobdiffvars
7826 set treediff {}
7828 set inhdr 0
7829 foreach line $difflines {
7830 if {![string compare -length 5 "diff " $line]} {
7831 set inhdr 1
7832 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7833 # offset also accounts for the b/ prefix
7834 lappend treediff [string range $line 6 end]
7835 set inhdr 0
7839 set treediffs($ids) $treediff
7840 add_flist $treediff
7842 $ctext conf -state normal
7843 foreach line $difflines {
7844 parseblobdiffline $ids $line
7846 maybe_scroll_ctext 1
7847 $ctext conf -state disabled
7850 # If the filename (name) is under any of the passed filter paths
7851 # then return true to include the file in the listing.
7852 proc path_filter {filter name} {
7853 set worktree [gitworktree]
7854 foreach p $filter {
7855 set fq_p [file normalize $p]
7856 set fq_n [file normalize [file join $worktree $name]]
7857 if {[string match [file normalize $fq_p]* $fq_n]} {
7858 return 1
7861 return 0
7864 proc addtocflist {ids} {
7865 global treediffs
7867 add_flist $treediffs($ids)
7868 getblobdiffs $ids
7871 proc diffcmd {ids flags} {
7872 global log_showroot nullid nullid2 git_version
7874 set i [lsearch -exact $ids $nullid]
7875 set j [lsearch -exact $ids $nullid2]
7876 if {$i >= 0} {
7877 if {[llength $ids] > 1 && $j < 0} {
7878 # comparing working directory with some specific revision
7879 set cmd [concat | git diff-index $flags]
7880 if {$i == 0} {
7881 lappend cmd -R [lindex $ids 1]
7882 } else {
7883 lappend cmd [lindex $ids 0]
7885 } else {
7886 # comparing working directory with index
7887 set cmd [concat | git diff-files $flags]
7888 if {$j == 1} {
7889 lappend cmd -R
7892 } elseif {$j >= 0} {
7893 if {[package vcompare $git_version "1.7.2"] >= 0} {
7894 set flags "$flags --ignore-submodules=dirty"
7896 set cmd [concat | git diff-index --cached $flags]
7897 if {[llength $ids] > 1} {
7898 # comparing index with specific revision
7899 if {$j == 0} {
7900 lappend cmd -R [lindex $ids 1]
7901 } else {
7902 lappend cmd [lindex $ids 0]
7904 } else {
7905 # comparing index with HEAD
7906 lappend cmd HEAD
7908 } else {
7909 if {$log_showroot} {
7910 lappend flags --root
7912 set cmd [concat | git diff-tree -r $flags $ids]
7914 return $cmd
7917 proc gettreediffs {ids} {
7918 global treediff treepending limitdiffs vfilelimit curview
7920 set cmd [diffcmd $ids {--no-commit-id}]
7921 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7922 set cmd [concat $cmd -- $vfilelimit($curview)]
7924 if {[catch {set gdtf [open $cmd r]}]} return
7926 set treepending $ids
7927 set treediff {}
7928 fconfigure $gdtf -blocking 0 -encoding binary
7929 filerun $gdtf [list gettreediffline $gdtf $ids]
7932 proc gettreediffline {gdtf ids} {
7933 global treediff treediffs treepending diffids diffmergeid
7934 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7936 set nr 0
7937 set sublist {}
7938 set max 1000
7939 if {$perfile_attrs} {
7940 # cache_gitattr is slow, and even slower on win32 where we
7941 # have to invoke it for only about 30 paths at a time
7942 set max 500
7943 if {[tk windowingsystem] == "win32"} {
7944 set max 120
7947 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7948 set i [string first "\t" $line]
7949 if {$i >= 0} {
7950 set file [string range $line [expr {$i+1}] end]
7951 if {[string index $file 0] eq "\""} {
7952 set file [lindex $file 0]
7954 set file [encoding convertfrom $file]
7955 if {$file ne [lindex $treediff end]} {
7956 lappend treediff $file
7957 lappend sublist $file
7961 if {$perfile_attrs} {
7962 cache_gitattr encoding $sublist
7964 if {![eof $gdtf]} {
7965 return [expr {$nr >= $max? 2: 1}]
7967 close $gdtf
7968 set treediffs($ids) $treediff
7969 unset treepending
7970 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7971 gettree $diffids
7972 } elseif {$ids != $diffids} {
7973 if {![info exists diffmergeid]} {
7974 gettreediffs $diffids
7976 } else {
7977 addtocflist $ids
7979 return 0
7982 # empty string or positive integer
7983 proc diffcontextvalidate {v} {
7984 return [regexp {^(|[1-9][0-9]*)$} $v]
7987 proc diffcontextchange {n1 n2 op} {
7988 global diffcontextstring diffcontext
7990 if {[string is integer -strict $diffcontextstring]} {
7991 if {$diffcontextstring >= 0} {
7992 set diffcontext $diffcontextstring
7993 reselectline
7998 proc changeignorespace {} {
7999 reselectline
8002 proc changeworddiff {name ix op} {
8003 reselectline
8006 proc initblobdiffvars {} {
8007 global diffencoding targetline diffnparents
8008 global diffinhdr currdiffsubmod diffseehere
8009 set targetline {}
8010 set diffnparents 0
8011 set diffinhdr 0
8012 set diffencoding [get_path_encoding {}]
8013 set currdiffsubmod ""
8014 set diffseehere -1
8017 proc getblobdiffs {ids} {
8018 global blobdifffd diffids env
8019 global treediffs
8020 global diffcontext
8021 global ignorespace
8022 global worddiff
8023 global limitdiffs vfilelimit curview
8024 global git_version
8026 set textconv {}
8027 if {[package vcompare $git_version "1.6.1"] >= 0} {
8028 set textconv "--textconv"
8030 set submodule {}
8031 if {[package vcompare $git_version "1.6.6"] >= 0} {
8032 set submodule "--submodule"
8034 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
8035 if {$ignorespace} {
8036 append cmd " -w"
8038 if {$worddiff ne [mc "Line diff"]} {
8039 append cmd " --word-diff=porcelain"
8041 if {$limitdiffs && $vfilelimit($curview) ne {}} {
8042 set cmd [concat $cmd -- $vfilelimit($curview)]
8044 if {[catch {set bdf [open $cmd r]} err]} {
8045 error_popup [mc "Error getting diffs: %s" $err]
8046 return
8048 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
8049 set blobdifffd($ids) $bdf
8050 initblobdiffvars
8051 filerun $bdf [list getblobdiffline $bdf $diffids]
8054 proc savecmitpos {} {
8055 global ctext cmitmode
8057 if {$cmitmode eq "tree"} {
8058 return {}
8060 return [list target_scrollpos [$ctext index @0,0]]
8063 proc savectextpos {} {
8064 global ctext
8066 return [list target_scrollpos [$ctext index @0,0]]
8069 proc maybe_scroll_ctext {ateof} {
8070 global ctext target_scrollpos
8072 if {![info exists target_scrollpos]} return
8073 if {!$ateof} {
8074 set nlines [expr {[winfo height $ctext]
8075 / [font metrics textfont -linespace]}]
8076 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
8078 $ctext yview $target_scrollpos
8079 unset target_scrollpos
8082 proc setinlist {var i val} {
8083 global $var
8085 while {[llength [set $var]] < $i} {
8086 lappend $var {}
8088 if {[llength [set $var]] == $i} {
8089 lappend $var $val
8090 } else {
8091 lset $var $i $val
8095 proc makediffhdr {fname ids} {
8096 global ctext curdiffstart treediffs diffencoding
8097 global ctext_file_names jump_to_here targetline diffline
8099 set fname [encoding convertfrom $fname]
8100 set diffencoding [get_path_encoding $fname]
8101 set i [lsearch -exact $treediffs($ids) $fname]
8102 if {$i >= 0} {
8103 setinlist difffilestart $i $curdiffstart
8105 lset ctext_file_names end $fname
8106 set l [expr {(78 - [string length $fname]) / 2}]
8107 set pad [string range "----------------------------------------" 1 $l]
8108 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8109 set targetline {}
8110 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8111 set targetline [lindex $jump_to_here 1]
8113 set diffline 0
8116 proc blobdiffmaybeseehere {ateof} {
8117 global diffseehere
8118 if {$diffseehere >= 0} {
8119 mark_ctext_line [lindex [split $diffseehere .] 0]
8121 maybe_scroll_ctext $ateof
8124 proc getblobdiffline {bdf ids} {
8125 global diffids blobdifffd
8126 global ctext
8128 set nr 0
8129 $ctext conf -state normal
8130 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8131 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8132 # Older diff read. Abort it.
8133 catch {close $bdf}
8134 if {$ids != $diffids} {
8135 array unset blobdifffd $ids
8137 return 0
8139 parseblobdiffline $ids $line
8141 $ctext conf -state disabled
8142 blobdiffmaybeseehere [eof $bdf]
8143 if {[eof $bdf]} {
8144 catch {close $bdf}
8145 array unset blobdifffd $ids
8146 return 0
8148 return [expr {$nr >= 1000? 2: 1}]
8151 proc parseblobdiffline {ids line} {
8152 global ctext curdiffstart
8153 global diffnexthead diffnextnote difffilestart
8154 global ctext_file_names ctext_file_lines
8155 global diffinhdr treediffs mergemax diffnparents
8156 global diffencoding jump_to_here targetline diffline currdiffsubmod
8157 global worddiff diffseehere
8159 if {![string compare -length 5 "diff " $line]} {
8160 if {![regexp {^diff (--cc|--git) } $line m type]} {
8161 set line [encoding convertfrom $line]
8162 $ctext insert end "$line\n" hunksep
8163 continue
8165 # start of a new file
8166 set diffinhdr 1
8167 set currdiffsubmod ""
8169 $ctext insert end "\n"
8170 set curdiffstart [$ctext index "end - 1c"]
8171 lappend ctext_file_names ""
8172 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8173 $ctext insert end "\n" filesep
8175 if {$type eq "--cc"} {
8176 # start of a new file in a merge diff
8177 set fname [string range $line 10 end]
8178 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8179 lappend treediffs($ids) $fname
8180 add_flist [list $fname]
8183 } else {
8184 set line [string range $line 11 end]
8185 # If the name hasn't changed the length will be odd,
8186 # the middle char will be a space, and the two bits either
8187 # side will be a/name and b/name, or "a/name" and "b/name".
8188 # If the name has changed we'll get "rename from" and
8189 # "rename to" or "copy from" and "copy to" lines following
8190 # this, and we'll use them to get the filenames.
8191 # This complexity is necessary because spaces in the
8192 # filename(s) don't get escaped.
8193 set l [string length $line]
8194 set i [expr {$l / 2}]
8195 if {!(($l & 1) && [string index $line $i] eq " " &&
8196 [string range $line 2 [expr {$i - 1}]] eq \
8197 [string range $line [expr {$i + 3}] end])} {
8198 return
8200 # unescape if quoted and chop off the a/ from the front
8201 if {[string index $line 0] eq "\""} {
8202 set fname [string range [lindex $line 0] 2 end]
8203 } else {
8204 set fname [string range $line 2 [expr {$i - 1}]]
8207 makediffhdr $fname $ids
8209 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8210 set fname [encoding convertfrom [string range $line 16 end]]
8211 $ctext insert end "\n"
8212 set curdiffstart [$ctext index "end - 1c"]
8213 lappend ctext_file_names $fname
8214 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8215 $ctext insert end "$line\n" filesep
8216 set i [lsearch -exact $treediffs($ids) $fname]
8217 if {$i >= 0} {
8218 setinlist difffilestart $i $curdiffstart
8221 } elseif {![string compare -length 2 "@@" $line]} {
8222 regexp {^@@+} $line ats
8223 set line [encoding convertfrom $diffencoding $line]
8224 $ctext insert end "$line\n" hunksep
8225 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8226 set diffline $nl
8228 set diffnparents [expr {[string length $ats] - 1}]
8229 set diffinhdr 0
8231 } elseif {![string compare -length 10 "Submodule " $line]} {
8232 # start of a new submodule
8233 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8234 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8235 } else {
8236 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8238 if {$currdiffsubmod != $fname} {
8239 $ctext insert end "\n"; # Add newline after commit message
8241 if {$currdiffsubmod != $fname} {
8242 set curdiffstart [$ctext index "end - 1c"]
8243 lappend ctext_file_names ""
8244 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8245 makediffhdr $fname $ids
8246 set currdiffsubmod $fname
8247 $ctext insert end "\n$line\n" filesep
8248 } else {
8249 $ctext insert end "$line\n" filesep
8251 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " >" $line]} {
8252 set line [encoding convertfrom $diffencoding $line]
8253 $ctext insert end "$line\n" dresult
8254 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " <" $line]} {
8255 set line [encoding convertfrom $diffencoding $line]
8256 $ctext insert end "$line\n" d0
8257 } elseif {$diffinhdr} {
8258 if {![string compare -length 12 "rename from " $line]} {
8259 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8260 if {[string index $fname 0] eq "\""} {
8261 set fname [lindex $fname 0]
8263 set fname [encoding convertfrom $fname]
8264 set i [lsearch -exact $treediffs($ids) $fname]
8265 if {$i >= 0} {
8266 setinlist difffilestart $i $curdiffstart
8268 } elseif {![string compare -length 10 $line "rename to "] ||
8269 ![string compare -length 8 $line "copy to "]} {
8270 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8271 if {[string index $fname 0] eq "\""} {
8272 set fname [lindex $fname 0]
8274 makediffhdr $fname $ids
8275 } elseif {[string compare -length 3 $line "---"] == 0} {
8276 # do nothing
8277 return
8278 } elseif {[string compare -length 3 $line "+++"] == 0} {
8279 set diffinhdr 0
8280 return
8282 $ctext insert end "$line\n" filesep
8284 } else {
8285 set line [string map {\x1A ^Z} \
8286 [encoding convertfrom $diffencoding $line]]
8287 # parse the prefix - one ' ', '-' or '+' for each parent
8288 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8289 set tag [expr {$diffnparents > 1? "m": "d"}]
8290 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8291 set words_pre_markup ""
8292 set words_post_markup ""
8293 if {[string trim $prefix " -+"] eq {}} {
8294 # prefix only has " ", "-" and "+" in it: normal diff line
8295 set num [string first "-" $prefix]
8296 if {$dowords} {
8297 set line [string range $line 1 end]
8299 if {$num >= 0} {
8300 # removed line, first parent with line is $num
8301 if {$num >= $mergemax} {
8302 set num "max"
8304 if {$dowords && $worddiff eq [mc "Markup words"]} {
8305 $ctext insert end "\[-$line-\]" $tag$num
8306 } else {
8307 $ctext insert end "$line" $tag$num
8309 if {!$dowords} {
8310 $ctext insert end "\n" $tag$num
8312 } else {
8313 set tags {}
8314 if {[string first "+" $prefix] >= 0} {
8315 # added line
8316 lappend tags ${tag}result
8317 if {$diffnparents > 1} {
8318 set num [string first " " $prefix]
8319 if {$num >= 0} {
8320 if {$num >= $mergemax} {
8321 set num "max"
8323 lappend tags m$num
8326 set words_pre_markup "{+"
8327 set words_post_markup "+}"
8329 if {$targetline ne {}} {
8330 if {$diffline == $targetline} {
8331 set diffseehere [$ctext index "end - 1 chars"]
8332 set targetline {}
8333 } else {
8334 incr diffline
8337 if {$dowords && $worddiff eq [mc "Markup words"]} {
8338 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8339 } else {
8340 $ctext insert end "$line" $tags
8342 if {!$dowords} {
8343 $ctext insert end "\n" $tags
8346 } elseif {$dowords && $prefix eq "~"} {
8347 $ctext insert end "\n" {}
8348 } else {
8349 # "\ No newline at end of file",
8350 # or something else we don't recognize
8351 $ctext insert end "$line\n" hunksep
8356 proc changediffdisp {} {
8357 global ctext diffelide
8359 $ctext tag conf d0 -elide [lindex $diffelide 0]
8360 $ctext tag conf dresult -elide [lindex $diffelide 1]
8363 proc highlightfile {cline} {
8364 global cflist cflist_top
8366 if {![info exists cflist_top]} return
8368 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8369 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8370 $cflist see $cline.0
8371 set cflist_top $cline
8374 proc highlightfile_for_scrollpos {topidx} {
8375 global cmitmode difffilestart
8377 if {$cmitmode eq "tree"} return
8378 if {![info exists difffilestart]} return
8380 set top [lindex [split $topidx .] 0]
8381 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8382 highlightfile 0
8383 } else {
8384 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8388 proc prevfile {} {
8389 global difffilestart ctext cmitmode
8391 if {$cmitmode eq "tree"} return
8392 set prev 0.0
8393 set here [$ctext index @0,0]
8394 foreach loc $difffilestart {
8395 if {[$ctext compare $loc >= $here]} {
8396 $ctext yview $prev
8397 return
8399 set prev $loc
8401 $ctext yview $prev
8404 proc nextfile {} {
8405 global difffilestart ctext cmitmode
8407 if {$cmitmode eq "tree"} return
8408 set here [$ctext index @0,0]
8409 foreach loc $difffilestart {
8410 if {[$ctext compare $loc > $here]} {
8411 $ctext yview $loc
8412 return
8417 proc clear_ctext {{first 1.0}} {
8418 global ctext smarktop smarkbot
8419 global ctext_file_names ctext_file_lines
8420 global pendinglinks
8422 set l [lindex [split $first .] 0]
8423 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8424 set smarktop $l
8426 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8427 set smarkbot $l
8429 $ctext delete $first end
8430 if {$first eq "1.0"} {
8431 unset -nocomplain pendinglinks
8433 set ctext_file_names {}
8434 set ctext_file_lines {}
8437 proc settabs {{firstab {}}} {
8438 global firsttabstop tabstop ctext have_tk85
8440 if {$firstab ne {} && $have_tk85} {
8441 set firsttabstop $firstab
8443 set w [font measure textfont "0"]
8444 if {$firsttabstop != 0} {
8445 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8446 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8447 } elseif {$have_tk85 || $tabstop != 8} {
8448 $ctext conf -tabs [expr {$tabstop * $w}]
8449 } else {
8450 $ctext conf -tabs {}
8454 proc incrsearch {name ix op} {
8455 global ctext searchstring searchdirn
8457 if {[catch {$ctext index anchor}]} {
8458 # no anchor set, use start of selection, or of visible area
8459 set sel [$ctext tag ranges sel]
8460 if {$sel ne {}} {
8461 $ctext mark set anchor [lindex $sel 0]
8462 } elseif {$searchdirn eq "-forwards"} {
8463 $ctext mark set anchor @0,0
8464 } else {
8465 $ctext mark set anchor @0,[winfo height $ctext]
8468 if {$searchstring ne {}} {
8469 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8470 if {$here ne {}} {
8471 $ctext see $here
8472 set mend "$here + $mlen c"
8473 $ctext tag remove sel 1.0 end
8474 $ctext tag add sel $here $mend
8475 suppress_highlighting_file_for_current_scrollpos
8476 highlightfile_for_scrollpos $here
8479 rehighlight_search_results
8482 proc dosearch {} {
8483 global sstring ctext searchstring searchdirn
8485 focus $sstring
8486 $sstring icursor end
8487 set searchdirn -forwards
8488 if {$searchstring ne {}} {
8489 set sel [$ctext tag ranges sel]
8490 if {$sel ne {}} {
8491 set start "[lindex $sel 0] + 1c"
8492 } elseif {[catch {set start [$ctext index anchor]}]} {
8493 set start "@0,0"
8495 set match [$ctext search -count mlen -- $searchstring $start]
8496 $ctext tag remove sel 1.0 end
8497 if {$match eq {}} {
8498 bell
8499 return
8501 $ctext see $match
8502 suppress_highlighting_file_for_current_scrollpos
8503 highlightfile_for_scrollpos $match
8504 set mend "$match + $mlen c"
8505 $ctext tag add sel $match $mend
8506 $ctext mark unset anchor
8507 rehighlight_search_results
8511 proc dosearchback {} {
8512 global sstring ctext searchstring searchdirn
8514 focus $sstring
8515 $sstring icursor end
8516 set searchdirn -backwards
8517 if {$searchstring ne {}} {
8518 set sel [$ctext tag ranges sel]
8519 if {$sel ne {}} {
8520 set start [lindex $sel 0]
8521 } elseif {[catch {set start [$ctext index anchor]}]} {
8522 set start @0,[winfo height $ctext]
8524 set match [$ctext search -backwards -count ml -- $searchstring $start]
8525 $ctext tag remove sel 1.0 end
8526 if {$match eq {}} {
8527 bell
8528 return
8530 $ctext see $match
8531 suppress_highlighting_file_for_current_scrollpos
8532 highlightfile_for_scrollpos $match
8533 set mend "$match + $ml c"
8534 $ctext tag add sel $match $mend
8535 $ctext mark unset anchor
8536 rehighlight_search_results
8540 proc rehighlight_search_results {} {
8541 global ctext searchstring
8543 $ctext tag remove found 1.0 end
8544 $ctext tag remove currentsearchhit 1.0 end
8546 if {$searchstring ne {}} {
8547 searchmarkvisible 1
8551 proc searchmark {first last} {
8552 global ctext searchstring
8554 set sel [$ctext tag ranges sel]
8556 set mend $first.0
8557 while {1} {
8558 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8559 if {$match eq {}} break
8560 set mend "$match + $mlen c"
8561 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8562 $ctext tag add currentsearchhit $match $mend
8563 } else {
8564 $ctext tag add found $match $mend
8569 proc searchmarkvisible {doall} {
8570 global ctext smarktop smarkbot
8572 set topline [lindex [split [$ctext index @0,0] .] 0]
8573 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8574 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8575 # no overlap with previous
8576 searchmark $topline $botline
8577 set smarktop $topline
8578 set smarkbot $botline
8579 } else {
8580 if {$topline < $smarktop} {
8581 searchmark $topline [expr {$smarktop-1}]
8582 set smarktop $topline
8584 if {$botline > $smarkbot} {
8585 searchmark [expr {$smarkbot+1}] $botline
8586 set smarkbot $botline
8591 proc suppress_highlighting_file_for_current_scrollpos {} {
8592 global ctext suppress_highlighting_file_for_this_scrollpos
8594 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8597 proc scrolltext {f0 f1} {
8598 global searchstring cmitmode ctext
8599 global suppress_highlighting_file_for_this_scrollpos
8601 set topidx [$ctext index @0,0]
8602 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8603 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8604 highlightfile_for_scrollpos $topidx
8607 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8609 .bleft.bottom.sb set $f0 $f1
8610 if {$searchstring ne {}} {
8611 searchmarkvisible 0
8615 proc setcoords {} {
8616 global linespc charspc canvx0 canvy0
8617 global xspc1 xspc2 lthickness
8619 set linespc [font metrics mainfont -linespace]
8620 set charspc [font measure mainfont "m"]
8621 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8622 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8623 set lthickness [expr {int($linespc / 9) + 1}]
8624 set xspc1(0) $linespc
8625 set xspc2 $linespc
8628 proc redisplay {} {
8629 global canv
8630 global selectedline
8632 set ymax [lindex [$canv cget -scrollregion] 3]
8633 if {$ymax eq {} || $ymax == 0} return
8634 set span [$canv yview]
8635 clear_display
8636 setcanvscroll
8637 allcanvs yview moveto [lindex $span 0]
8638 drawvisible
8639 if {$selectedline ne {}} {
8640 selectline $selectedline 0
8641 allcanvs yview moveto [lindex $span 0]
8645 proc parsefont {f n} {
8646 global fontattr
8648 set fontattr($f,family) [lindex $n 0]
8649 set s [lindex $n 1]
8650 if {$s eq {} || $s == 0} {
8651 set s 10
8652 } elseif {$s < 0} {
8653 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8655 set fontattr($f,size) $s
8656 set fontattr($f,weight) normal
8657 set fontattr($f,slant) roman
8658 foreach style [lrange $n 2 end] {
8659 switch -- $style {
8660 "normal" -
8661 "bold" {set fontattr($f,weight) $style}
8662 "roman" -
8663 "italic" {set fontattr($f,slant) $style}
8668 proc fontflags {f {isbold 0}} {
8669 global fontattr
8671 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8672 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8673 -slant $fontattr($f,slant)]
8676 proc fontname {f} {
8677 global fontattr
8679 set n [list $fontattr($f,family) $fontattr($f,size)]
8680 if {$fontattr($f,weight) eq "bold"} {
8681 lappend n "bold"
8683 if {$fontattr($f,slant) eq "italic"} {
8684 lappend n "italic"
8686 return $n
8689 proc incrfont {inc} {
8690 global mainfont textfont ctext canv cflist showrefstop
8691 global stopped entries fontattr
8693 unmarkmatches
8694 set s $fontattr(mainfont,size)
8695 incr s $inc
8696 if {$s < 1} {
8697 set s 1
8699 set fontattr(mainfont,size) $s
8700 font config mainfont -size $s
8701 font config mainfontbold -size $s
8702 set mainfont [fontname mainfont]
8703 set s $fontattr(textfont,size)
8704 incr s $inc
8705 if {$s < 1} {
8706 set s 1
8708 set fontattr(textfont,size) $s
8709 font config textfont -size $s
8710 font config textfontbold -size $s
8711 set textfont [fontname textfont]
8712 setcoords
8713 settabs
8714 redisplay
8717 proc clearsha1 {} {
8718 global sha1entry sha1string
8719 if {[string length $sha1string] == 40} {
8720 $sha1entry delete 0 end
8724 proc sha1change {n1 n2 op} {
8725 global sha1string currentid sha1but
8726 if {$sha1string == {}
8727 || ([info exists currentid] && $sha1string == $currentid)} {
8728 set state disabled
8729 } else {
8730 set state normal
8732 if {[$sha1but cget -state] == $state} return
8733 if {$state == "normal"} {
8734 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8735 } else {
8736 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8740 proc gotocommit {} {
8741 global sha1string tagids headids curview varcid
8743 if {$sha1string == {}
8744 || ([info exists currentid] && $sha1string == $currentid)} return
8745 if {[info exists tagids($sha1string)]} {
8746 set id $tagids($sha1string)
8747 } elseif {[info exists headids($sha1string)]} {
8748 set id $headids($sha1string)
8749 } else {
8750 set id [string tolower $sha1string]
8751 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8752 set matches [longid $id]
8753 if {$matches ne {}} {
8754 if {[llength $matches] > 1} {
8755 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8756 return
8758 set id [lindex $matches 0]
8760 } else {
8761 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8762 error_popup [mc "Revision %s is not known" $sha1string]
8763 return
8767 if {[commitinview $id $curview]} {
8768 selectline [rowofcommit $id] 1
8769 return
8771 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8772 set msg [mc "SHA1 id %s is not known" $sha1string]
8773 } else {
8774 set msg [mc "Revision %s is not in the current view" $sha1string]
8776 error_popup $msg
8779 proc lineenter {x y id} {
8780 global hoverx hovery hoverid hovertimer
8781 global commitinfo canv
8783 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8784 set hoverx $x
8785 set hovery $y
8786 set hoverid $id
8787 if {[info exists hovertimer]} {
8788 after cancel $hovertimer
8790 set hovertimer [after 500 linehover]
8791 $canv delete hover
8794 proc linemotion {x y id} {
8795 global hoverx hovery hoverid hovertimer
8797 if {[info exists hoverid] && $id == $hoverid} {
8798 set hoverx $x
8799 set hovery $y
8800 if {[info exists hovertimer]} {
8801 after cancel $hovertimer
8803 set hovertimer [after 500 linehover]
8807 proc lineleave {id} {
8808 global hoverid hovertimer canv
8810 if {[info exists hoverid] && $id == $hoverid} {
8811 $canv delete hover
8812 if {[info exists hovertimer]} {
8813 after cancel $hovertimer
8814 unset hovertimer
8816 unset hoverid
8820 proc linehover {} {
8821 global hoverx hovery hoverid hovertimer
8822 global canv linespc lthickness
8823 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8825 global commitinfo
8827 set text [lindex $commitinfo($hoverid) 0]
8828 set ymax [lindex [$canv cget -scrollregion] 3]
8829 if {$ymax == {}} return
8830 set yfrac [lindex [$canv yview] 0]
8831 set x [expr {$hoverx + 2 * $linespc}]
8832 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8833 set x0 [expr {$x - 2 * $lthickness}]
8834 set y0 [expr {$y - 2 * $lthickness}]
8835 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8836 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8837 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8838 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8839 -width 1 -tags hover]
8840 $canv raise $t
8841 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8842 -font mainfont -fill $linehoverfgcolor]
8843 $canv raise $t
8846 proc clickisonarrow {id y} {
8847 global lthickness
8849 set ranges [rowranges $id]
8850 set thresh [expr {2 * $lthickness + 6}]
8851 set n [expr {[llength $ranges] - 1}]
8852 for {set i 1} {$i < $n} {incr i} {
8853 set row [lindex $ranges $i]
8854 if {abs([yc $row] - $y) < $thresh} {
8855 return $i
8858 return {}
8861 proc arrowjump {id n y} {
8862 global canv
8864 # 1 <-> 2, 3 <-> 4, etc...
8865 set n [expr {(($n - 1) ^ 1) + 1}]
8866 set row [lindex [rowranges $id] $n]
8867 set yt [yc $row]
8868 set ymax [lindex [$canv cget -scrollregion] 3]
8869 if {$ymax eq {} || $ymax <= 0} return
8870 set view [$canv yview]
8871 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8872 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8873 if {$yfrac < 0} {
8874 set yfrac 0
8876 allcanvs yview moveto $yfrac
8879 proc lineclick {x y id isnew} {
8880 global ctext commitinfo children canv thickerline curview
8882 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8883 unmarkmatches
8884 unselectline
8885 normalline
8886 $canv delete hover
8887 # draw this line thicker than normal
8888 set thickerline $id
8889 drawlines $id
8890 if {$isnew} {
8891 set ymax [lindex [$canv cget -scrollregion] 3]
8892 if {$ymax eq {}} return
8893 set yfrac [lindex [$canv yview] 0]
8894 set y [expr {$y + $yfrac * $ymax}]
8896 set dirn [clickisonarrow $id $y]
8897 if {$dirn ne {}} {
8898 arrowjump $id $dirn $y
8899 return
8902 if {$isnew} {
8903 addtohistory [list lineclick $x $y $id 0] savectextpos
8905 # fill the details pane with info about this line
8906 $ctext conf -state normal
8907 clear_ctext
8908 settabs 0
8909 $ctext insert end "[mc "Parent"]:\t"
8910 $ctext insert end $id link0
8911 setlink $id link0
8912 set info $commitinfo($id)
8913 $ctext insert end "\n\t[lindex $info 0]\n"
8914 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8915 set date [formatdate [lindex $info 2]]
8916 $ctext insert end "\t[mc "Date"]:\t$date\n"
8917 set kids $children($curview,$id)
8918 if {$kids ne {}} {
8919 $ctext insert end "\n[mc "Children"]:"
8920 set i 0
8921 foreach child $kids {
8922 incr i
8923 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8924 set info $commitinfo($child)
8925 $ctext insert end "\n\t"
8926 $ctext insert end $child link$i
8927 setlink $child link$i
8928 $ctext insert end "\n\t[lindex $info 0]"
8929 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8930 set date [formatdate [lindex $info 2]]
8931 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8934 maybe_scroll_ctext 1
8935 $ctext conf -state disabled
8936 init_flist {}
8939 proc normalline {} {
8940 global thickerline
8941 if {[info exists thickerline]} {
8942 set id $thickerline
8943 unset thickerline
8944 drawlines $id
8948 proc selbyid {id {isnew 1}} {
8949 global curview
8950 if {[commitinview $id $curview]} {
8951 selectline [rowofcommit $id] $isnew
8955 proc mstime {} {
8956 global startmstime
8957 if {![info exists startmstime]} {
8958 set startmstime [clock clicks -milliseconds]
8960 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8963 proc rowmenu {x y id} {
8964 global rowctxmenu selectedline rowmenuid curview
8965 global nullid nullid2 fakerowmenu mainhead markedid
8967 stopfinding
8968 set rowmenuid $id
8969 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8970 set state disabled
8971 } else {
8972 set state normal
8974 if {[info exists markedid] && $markedid ne $id} {
8975 set mstate normal
8976 } else {
8977 set mstate disabled
8979 if {$id ne $nullid && $id ne $nullid2} {
8980 set menu $rowctxmenu
8981 if {$mainhead ne {}} {
8982 $menu entryconfigure 8 -label [mc "Reset %s branch to here" $mainhead] -state normal
8983 } else {
8984 $menu entryconfigure 8 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8986 $menu entryconfigure 10 -state $mstate
8987 $menu entryconfigure 11 -state $mstate
8988 $menu entryconfigure 12 -state $mstate
8989 } else {
8990 set menu $fakerowmenu
8992 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8993 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8994 $menu entryconfigure [mca "Make patch"] -state $state
8995 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8996 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8997 tk_popup $menu $x $y
9000 proc markhere {} {
9001 global rowmenuid markedid canv
9003 set markedid $rowmenuid
9004 make_idmark $markedid
9007 proc gotomark {} {
9008 global markedid
9010 if {[info exists markedid]} {
9011 selbyid $markedid
9015 proc replace_by_kids {l r} {
9016 global curview children
9018 set id [commitonrow $r]
9019 set l [lreplace $l 0 0]
9020 foreach kid $children($curview,$id) {
9021 lappend l [rowofcommit $kid]
9023 return [lsort -integer -decreasing -unique $l]
9026 proc find_common_desc {} {
9027 global markedid rowmenuid curview children
9029 if {![info exists markedid]} return
9030 if {![commitinview $markedid $curview] ||
9031 ![commitinview $rowmenuid $curview]} return
9032 #set t1 [clock clicks -milliseconds]
9033 set l1 [list [rowofcommit $markedid]]
9034 set l2 [list [rowofcommit $rowmenuid]]
9035 while 1 {
9036 set r1 [lindex $l1 0]
9037 set r2 [lindex $l2 0]
9038 if {$r1 eq {} || $r2 eq {}} break
9039 if {$r1 == $r2} {
9040 selectline $r1 1
9041 break
9043 if {$r1 > $r2} {
9044 set l1 [replace_by_kids $l1 $r1]
9045 } else {
9046 set l2 [replace_by_kids $l2 $r2]
9049 #set t2 [clock clicks -milliseconds]
9050 #puts "took [expr {$t2-$t1}]ms"
9053 proc compare_commits {} {
9054 global markedid rowmenuid curview children
9056 if {![info exists markedid]} return
9057 if {![commitinview $markedid $curview]} return
9058 addtohistory [list do_cmp_commits $markedid $rowmenuid]
9059 do_cmp_commits $markedid $rowmenuid
9062 proc getpatchid {id} {
9063 global patchids
9065 if {![info exists patchids($id)]} {
9066 set cmd [diffcmd [list $id] {-p --root}]
9067 # trim off the initial "|"
9068 set cmd [lrange $cmd 1 end]
9069 if {[catch {
9070 set x [eval exec $cmd | git patch-id]
9071 set patchids($id) [lindex $x 0]
9072 }]} {
9073 set patchids($id) "error"
9076 return $patchids($id)
9079 proc do_cmp_commits {a b} {
9080 global ctext curview parents children patchids commitinfo
9082 $ctext conf -state normal
9083 clear_ctext
9084 init_flist {}
9085 for {set i 0} {$i < 100} {incr i} {
9086 set skipa 0
9087 set skipb 0
9088 if {[llength $parents($curview,$a)] > 1} {
9089 appendshortlink $a [mc "Skipping merge commit "] "\n"
9090 set skipa 1
9091 } else {
9092 set patcha [getpatchid $a]
9094 if {[llength $parents($curview,$b)] > 1} {
9095 appendshortlink $b [mc "Skipping merge commit "] "\n"
9096 set skipb 1
9097 } else {
9098 set patchb [getpatchid $b]
9100 if {!$skipa && !$skipb} {
9101 set heada [lindex $commitinfo($a) 0]
9102 set headb [lindex $commitinfo($b) 0]
9103 if {$patcha eq "error"} {
9104 appendshortlink $a [mc "Error getting patch ID for "] \
9105 [mc " - stopping\n"]
9106 break
9108 if {$patchb eq "error"} {
9109 appendshortlink $b [mc "Error getting patch ID for "] \
9110 [mc " - stopping\n"]
9111 break
9113 if {$patcha eq $patchb} {
9114 if {$heada eq $headb} {
9115 appendshortlink $a [mc "Commit "]
9116 appendshortlink $b " == " " $heada\n"
9117 } else {
9118 appendshortlink $a [mc "Commit "] " $heada\n"
9119 appendshortlink $b [mc " is the same patch as\n "] \
9120 " $headb\n"
9122 set skipa 1
9123 set skipb 1
9124 } else {
9125 $ctext insert end "\n"
9126 appendshortlink $a [mc "Commit "] " $heada\n"
9127 appendshortlink $b [mc " differs from\n "] \
9128 " $headb\n"
9129 $ctext insert end [mc "Diff of commits:\n\n"]
9130 $ctext conf -state disabled
9131 update
9132 diffcommits $a $b
9133 return
9136 if {$skipa} {
9137 set kids [real_children $curview,$a]
9138 if {[llength $kids] != 1} {
9139 $ctext insert end "\n"
9140 appendshortlink $a [mc "Commit "] \
9141 [mc " has %s children - stopping\n" [llength $kids]]
9142 break
9144 set a [lindex $kids 0]
9146 if {$skipb} {
9147 set kids [real_children $curview,$b]
9148 if {[llength $kids] != 1} {
9149 appendshortlink $b [mc "Commit "] \
9150 [mc " has %s children - stopping\n" [llength $kids]]
9151 break
9153 set b [lindex $kids 0]
9156 $ctext conf -state disabled
9159 proc diffcommits {a b} {
9160 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9162 set tmpdir [gitknewtmpdir]
9163 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9164 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9165 if {[catch {
9166 exec git diff-tree -p --pretty $a >$fna
9167 exec git diff-tree -p --pretty $b >$fnb
9168 } err]} {
9169 error_popup [mc "Error writing commit to file: %s" $err]
9170 return
9172 if {[catch {
9173 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9174 } err]} {
9175 error_popup [mc "Error diffing commits: %s" $err]
9176 return
9178 set diffids [list commits $a $b]
9179 set blobdifffd($diffids) $fd
9180 set diffinhdr 0
9181 set currdiffsubmod ""
9182 filerun $fd [list getblobdiffline $fd $diffids]
9185 proc diffvssel {dirn} {
9186 global rowmenuid selectedline
9188 if {$selectedline eq {}} return
9189 if {$dirn} {
9190 set oldid [commitonrow $selectedline]
9191 set newid $rowmenuid
9192 } else {
9193 set oldid $rowmenuid
9194 set newid [commitonrow $selectedline]
9196 addtohistory [list doseldiff $oldid $newid] savectextpos
9197 doseldiff $oldid $newid
9200 proc diffvsmark {dirn} {
9201 global rowmenuid markedid
9203 if {![info exists markedid]} return
9204 if {$dirn} {
9205 set oldid $markedid
9206 set newid $rowmenuid
9207 } else {
9208 set oldid $rowmenuid
9209 set newid $markedid
9211 addtohistory [list doseldiff $oldid $newid] savectextpos
9212 doseldiff $oldid $newid
9215 proc doseldiff {oldid newid} {
9216 global ctext
9217 global commitinfo
9219 $ctext conf -state normal
9220 clear_ctext
9221 init_flist [mc "Top"]
9222 $ctext insert end "[mc "From"] "
9223 $ctext insert end $oldid link0
9224 setlink $oldid link0
9225 $ctext insert end "\n "
9226 $ctext insert end [lindex $commitinfo($oldid) 0]
9227 $ctext insert end "\n\n[mc "To"] "
9228 $ctext insert end $newid link1
9229 setlink $newid link1
9230 $ctext insert end "\n "
9231 $ctext insert end [lindex $commitinfo($newid) 0]
9232 $ctext insert end "\n"
9233 $ctext conf -state disabled
9234 $ctext tag remove found 1.0 end
9235 startdiff [list $oldid $newid]
9238 proc mkpatch {} {
9239 global rowmenuid currentid commitinfo patchtop patchnum NS
9241 if {![info exists currentid]} return
9242 set oldid $currentid
9243 set oldhead [lindex $commitinfo($oldid) 0]
9244 set newid $rowmenuid
9245 set newhead [lindex $commitinfo($newid) 0]
9246 set top .patch
9247 set patchtop $top
9248 catch {destroy $top}
9249 ttk_toplevel $top
9250 make_transient $top .
9251 ${NS}::label $top.title -text [mc "Generate patch"]
9252 grid $top.title - -pady 10
9253 ${NS}::label $top.from -text [mc "From:"]
9254 ${NS}::entry $top.fromsha1 -width 40
9255 $top.fromsha1 insert 0 $oldid
9256 $top.fromsha1 conf -state readonly
9257 grid $top.from $top.fromsha1 -sticky w
9258 ${NS}::entry $top.fromhead -width 60
9259 $top.fromhead insert 0 $oldhead
9260 $top.fromhead conf -state readonly
9261 grid x $top.fromhead -sticky w
9262 ${NS}::label $top.to -text [mc "To:"]
9263 ${NS}::entry $top.tosha1 -width 40
9264 $top.tosha1 insert 0 $newid
9265 $top.tosha1 conf -state readonly
9266 grid $top.to $top.tosha1 -sticky w
9267 ${NS}::entry $top.tohead -width 60
9268 $top.tohead insert 0 $newhead
9269 $top.tohead conf -state readonly
9270 grid x $top.tohead -sticky w
9271 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9272 grid $top.rev x -pady 10 -padx 5
9273 ${NS}::label $top.flab -text [mc "Output file:"]
9274 ${NS}::entry $top.fname -width 60
9275 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9276 incr patchnum
9277 grid $top.flab $top.fname -sticky w
9278 ${NS}::frame $top.buts
9279 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9280 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9281 bind $top <Key-Return> mkpatchgo
9282 bind $top <Key-Escape> mkpatchcan
9283 grid $top.buts.gen $top.buts.can
9284 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9285 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9286 grid $top.buts - -pady 10 -sticky ew
9287 focus $top.fname
9290 proc mkpatchrev {} {
9291 global patchtop
9293 set oldid [$patchtop.fromsha1 get]
9294 set oldhead [$patchtop.fromhead get]
9295 set newid [$patchtop.tosha1 get]
9296 set newhead [$patchtop.tohead get]
9297 foreach e [list fromsha1 fromhead tosha1 tohead] \
9298 v [list $newid $newhead $oldid $oldhead] {
9299 $patchtop.$e conf -state normal
9300 $patchtop.$e delete 0 end
9301 $patchtop.$e insert 0 $v
9302 $patchtop.$e conf -state readonly
9306 proc mkpatchgo {} {
9307 global patchtop nullid nullid2
9309 set oldid [$patchtop.fromsha1 get]
9310 set newid [$patchtop.tosha1 get]
9311 set fname [$patchtop.fname get]
9312 set cmd [diffcmd [list $oldid $newid] -p]
9313 # trim off the initial "|"
9314 set cmd [lrange $cmd 1 end]
9315 lappend cmd >$fname &
9316 if {[catch {eval exec $cmd} err]} {
9317 error_popup "[mc "Error creating patch:"] $err" $patchtop
9319 catch {destroy $patchtop}
9320 unset patchtop
9323 proc mkpatchcan {} {
9324 global patchtop
9326 catch {destroy $patchtop}
9327 unset patchtop
9330 proc mktag {} {
9331 global rowmenuid mktagtop commitinfo NS
9333 set top .maketag
9334 set mktagtop $top
9335 catch {destroy $top}
9336 ttk_toplevel $top
9337 make_transient $top .
9338 ${NS}::label $top.title -text [mc "Create tag"]
9339 grid $top.title - -pady 10
9340 ${NS}::label $top.id -text [mc "ID:"]
9341 ${NS}::entry $top.sha1 -width 40
9342 $top.sha1 insert 0 $rowmenuid
9343 $top.sha1 conf -state readonly
9344 grid $top.id $top.sha1 -sticky w
9345 ${NS}::entry $top.head -width 60
9346 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9347 $top.head conf -state readonly
9348 grid x $top.head -sticky w
9349 ${NS}::label $top.tlab -text [mc "Tag name:"]
9350 ${NS}::entry $top.tag -width 60
9351 grid $top.tlab $top.tag -sticky w
9352 ${NS}::label $top.op -text [mc "Tag message is optional"]
9353 grid $top.op -columnspan 2 -sticky we
9354 ${NS}::label $top.mlab -text [mc "Tag message:"]
9355 ${NS}::entry $top.msg -width 60
9356 grid $top.mlab $top.msg -sticky w
9357 ${NS}::frame $top.buts
9358 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9359 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9360 bind $top <Key-Return> mktaggo
9361 bind $top <Key-Escape> mktagcan
9362 grid $top.buts.gen $top.buts.can
9363 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9364 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9365 grid $top.buts - -pady 10 -sticky ew
9366 focus $top.tag
9369 proc domktag {} {
9370 global mktagtop env tagids idtags
9372 set id [$mktagtop.sha1 get]
9373 set tag [$mktagtop.tag get]
9374 set msg [$mktagtop.msg get]
9375 if {$tag == {}} {
9376 error_popup [mc "No tag name specified"] $mktagtop
9377 return 0
9379 if {[info exists tagids($tag)]} {
9380 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9381 return 0
9383 if {[catch {
9384 if {$msg != {}} {
9385 exec git tag -a -m $msg $tag $id
9386 } else {
9387 exec git tag $tag $id
9389 } err]} {
9390 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9391 return 0
9394 set tagids($tag) $id
9395 lappend idtags($id) $tag
9396 redrawtags $id
9397 addedtag $id
9398 dispneartags 0
9399 run refill_reflist
9400 return 1
9403 proc redrawtags {id} {
9404 global canv linehtag idpos currentid curview cmitlisted markedid
9405 global canvxmax iddrawn circleitem mainheadid circlecolors
9406 global mainheadcirclecolor
9408 if {![commitinview $id $curview]} return
9409 if {![info exists iddrawn($id)]} return
9410 set row [rowofcommit $id]
9411 if {$id eq $mainheadid} {
9412 set ofill $mainheadcirclecolor
9413 } else {
9414 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9416 $canv itemconf $circleitem($row) -fill $ofill
9417 $canv delete tag.$id
9418 set xt [eval drawtags $id $idpos($id)]
9419 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9420 set text [$canv itemcget $linehtag($id) -text]
9421 set font [$canv itemcget $linehtag($id) -font]
9422 set xr [expr {$xt + [font measure $font $text]}]
9423 if {$xr > $canvxmax} {
9424 set canvxmax $xr
9425 setcanvscroll
9427 if {[info exists currentid] && $currentid == $id} {
9428 make_secsel $id
9430 if {[info exists markedid] && $markedid eq $id} {
9431 make_idmark $id
9435 proc mktagcan {} {
9436 global mktagtop
9438 catch {destroy $mktagtop}
9439 unset mktagtop
9442 proc mktaggo {} {
9443 if {![domktag]} return
9444 mktagcan
9447 proc copyreference {} {
9448 global rowmenuid autosellen
9450 set format "%h (\"%s\", %ad)"
9451 set cmd [list git show -s --pretty=format:$format --date=short]
9452 if {$autosellen < 40} {
9453 lappend cmd --abbrev=$autosellen
9455 set reference [eval exec $cmd $rowmenuid]
9457 clipboard clear
9458 clipboard append $reference
9461 proc writecommit {} {
9462 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9464 set top .writecommit
9465 set wrcomtop $top
9466 catch {destroy $top}
9467 ttk_toplevel $top
9468 make_transient $top .
9469 ${NS}::label $top.title -text [mc "Write commit to file"]
9470 grid $top.title - -pady 10
9471 ${NS}::label $top.id -text [mc "ID:"]
9472 ${NS}::entry $top.sha1 -width 40
9473 $top.sha1 insert 0 $rowmenuid
9474 $top.sha1 conf -state readonly
9475 grid $top.id $top.sha1 -sticky w
9476 ${NS}::entry $top.head -width 60
9477 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9478 $top.head conf -state readonly
9479 grid x $top.head -sticky w
9480 ${NS}::label $top.clab -text [mc "Command:"]
9481 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9482 grid $top.clab $top.cmd -sticky w -pady 10
9483 ${NS}::label $top.flab -text [mc "Output file:"]
9484 ${NS}::entry $top.fname -width 60
9485 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9486 grid $top.flab $top.fname -sticky w
9487 ${NS}::frame $top.buts
9488 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9489 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9490 bind $top <Key-Return> wrcomgo
9491 bind $top <Key-Escape> wrcomcan
9492 grid $top.buts.gen $top.buts.can
9493 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9494 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9495 grid $top.buts - -pady 10 -sticky ew
9496 focus $top.fname
9499 proc wrcomgo {} {
9500 global wrcomtop
9502 set id [$wrcomtop.sha1 get]
9503 set cmd "echo $id | [$wrcomtop.cmd get]"
9504 set fname [$wrcomtop.fname get]
9505 if {[catch {exec sh -c $cmd >$fname &} err]} {
9506 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9508 catch {destroy $wrcomtop}
9509 unset wrcomtop
9512 proc wrcomcan {} {
9513 global wrcomtop
9515 catch {destroy $wrcomtop}
9516 unset wrcomtop
9519 proc mkbranch {} {
9520 global NS rowmenuid
9522 set top .branchdialog
9524 set val(name) ""
9525 set val(id) $rowmenuid
9526 set val(command) [list mkbrgo $top]
9528 set ui(title) [mc "Create branch"]
9529 set ui(accept) [mc "Create"]
9531 branchdia $top val ui
9534 proc mvbranch {} {
9535 global NS
9536 global headmenuid headmenuhead
9538 set top .branchdialog
9540 set val(name) $headmenuhead
9541 set val(id) $headmenuid
9542 set val(command) [list mvbrgo $top $headmenuhead]
9544 set ui(title) [mc "Rename branch %s" $headmenuhead]
9545 set ui(accept) [mc "Rename"]
9547 branchdia $top val ui
9550 proc branchdia {top valvar uivar} {
9551 global NS commitinfo
9552 upvar $valvar val $uivar ui
9554 catch {destroy $top}
9555 ttk_toplevel $top
9556 make_transient $top .
9557 ${NS}::label $top.title -text $ui(title)
9558 grid $top.title - -pady 10
9559 ${NS}::label $top.id -text [mc "ID:"]
9560 ${NS}::entry $top.sha1 -width 40
9561 $top.sha1 insert 0 $val(id)
9562 $top.sha1 conf -state readonly
9563 grid $top.id $top.sha1 -sticky w
9564 ${NS}::entry $top.head -width 60
9565 $top.head insert 0 [lindex $commitinfo($val(id)) 0]
9566 $top.head conf -state readonly
9567 grid x $top.head -sticky ew
9568 grid columnconfigure $top 1 -weight 1
9569 ${NS}::label $top.nlab -text [mc "Name:"]
9570 ${NS}::entry $top.name -width 40
9571 $top.name insert 0 $val(name)
9572 grid $top.nlab $top.name -sticky w
9573 ${NS}::frame $top.buts
9574 ${NS}::button $top.buts.go -text $ui(accept) -command $val(command)
9575 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9576 bind $top <Key-Return> $val(command)
9577 bind $top <Key-Escape> "catch {destroy $top}"
9578 grid $top.buts.go $top.buts.can
9579 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9580 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9581 grid $top.buts - -pady 10 -sticky ew
9582 focus $top.name
9585 proc mkbrgo {top} {
9586 global headids idheads
9588 set name [$top.name get]
9589 set id [$top.sha1 get]
9590 set cmdargs {}
9591 set old_id {}
9592 if {$name eq {}} {
9593 error_popup [mc "Please specify a name for the new branch"] $top
9594 return
9596 if {[info exists headids($name)]} {
9597 if {![confirm_popup [mc \
9598 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9599 return
9601 set old_id $headids($name)
9602 lappend cmdargs -f
9604 catch {destroy $top}
9605 lappend cmdargs $name $id
9606 nowbusy newbranch
9607 update
9608 if {[catch {
9609 eval exec git branch $cmdargs
9610 } err]} {
9611 notbusy newbranch
9612 error_popup $err
9613 } else {
9614 notbusy newbranch
9615 if {$old_id ne {}} {
9616 movehead $id $name
9617 movedhead $id $name
9618 redrawtags $old_id
9619 redrawtags $id
9620 } else {
9621 set headids($name) $id
9622 lappend idheads($id) $name
9623 addedhead $id $name
9624 redrawtags $id
9626 dispneartags 0
9627 run refill_reflist
9631 proc mvbrgo {top prevname} {
9632 global headids idheads mainhead mainheadid
9634 set name [$top.name get]
9635 set id [$top.sha1 get]
9636 set cmdargs {}
9637 if {$name eq $prevname} {
9638 catch {destroy $top}
9639 return
9641 if {$name eq {}} {
9642 error_popup [mc "Please specify a new name for the branch"] $top
9643 return
9645 catch {destroy $top}
9646 lappend cmdargs -m $prevname $name
9647 nowbusy renamebranch
9648 update
9649 if {[catch {
9650 eval exec git branch $cmdargs
9651 } err]} {
9652 notbusy renamebranch
9653 error_popup $err
9654 } else {
9655 notbusy renamebranch
9656 removehead $id $prevname
9657 removedhead $id $prevname
9658 set headids($name) $id
9659 lappend idheads($id) $name
9660 addedhead $id $name
9661 if {$prevname eq $mainhead} {
9662 set mainhead $name
9663 set mainheadid $id
9665 redrawtags $id
9666 dispneartags 0
9667 run refill_reflist
9671 proc exec_citool {tool_args {baseid {}}} {
9672 global commitinfo env
9674 set save_env [array get env GIT_AUTHOR_*]
9676 if {$baseid ne {}} {
9677 if {![info exists commitinfo($baseid)]} {
9678 getcommit $baseid
9680 set author [lindex $commitinfo($baseid) 1]
9681 set date [lindex $commitinfo($baseid) 2]
9682 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9683 $author author name email]
9684 && $date ne {}} {
9685 set env(GIT_AUTHOR_NAME) $name
9686 set env(GIT_AUTHOR_EMAIL) $email
9687 set env(GIT_AUTHOR_DATE) $date
9691 eval exec git citool $tool_args &
9693 array unset env GIT_AUTHOR_*
9694 array set env $save_env
9697 proc cherrypick {} {
9698 global rowmenuid curview
9699 global mainhead mainheadid
9700 global gitdir
9702 set oldhead [exec git rev-parse HEAD]
9703 set dheads [descheads $rowmenuid]
9704 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9705 set ok [confirm_popup [mc "Commit %s is already\
9706 included in branch %s -- really re-apply it?" \
9707 [string range $rowmenuid 0 7] $mainhead]]
9708 if {!$ok} return
9710 nowbusy cherrypick [mc "Cherry-picking"]
9711 update
9712 # Unfortunately git-cherry-pick writes stuff to stderr even when
9713 # no error occurs, and exec takes that as an indication of error...
9714 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9715 notbusy cherrypick
9716 if {[regexp -line \
9717 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9718 $err msg fname]} {
9719 error_popup [mc "Cherry-pick failed because of local changes\
9720 to file '%s'.\nPlease commit, reset or stash\
9721 your changes and try again." $fname]
9722 } elseif {[regexp -line \
9723 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9724 $err]} {
9725 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9726 conflict.\nDo you wish to run git citool to\
9727 resolve it?"]]} {
9728 # Force citool to read MERGE_MSG
9729 file delete [file join $gitdir "GITGUI_MSG"]
9730 exec_citool {} $rowmenuid
9732 } else {
9733 error_popup $err
9735 run updatecommits
9736 return
9738 set newhead [exec git rev-parse HEAD]
9739 if {$newhead eq $oldhead} {
9740 notbusy cherrypick
9741 error_popup [mc "No changes committed"]
9742 return
9744 addnewchild $newhead $oldhead
9745 if {[commitinview $oldhead $curview]} {
9746 # XXX this isn't right if we have a path limit...
9747 insertrow $newhead $oldhead $curview
9748 if {$mainhead ne {}} {
9749 movehead $newhead $mainhead
9750 movedhead $newhead $mainhead
9752 set mainheadid $newhead
9753 redrawtags $oldhead
9754 redrawtags $newhead
9755 selbyid $newhead
9757 notbusy cherrypick
9760 proc revert {} {
9761 global rowmenuid curview
9762 global mainhead mainheadid
9763 global gitdir
9765 set oldhead [exec git rev-parse HEAD]
9766 set dheads [descheads $rowmenuid]
9767 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9768 set ok [confirm_popup [mc "Commit %s is not\
9769 included in branch %s -- really revert it?" \
9770 [string range $rowmenuid 0 7] $mainhead]]
9771 if {!$ok} return
9773 nowbusy revert [mc "Reverting"]
9774 update
9776 if [catch {exec git revert --no-edit $rowmenuid} err] {
9777 notbusy revert
9778 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9779 $err match files] {
9780 regsub {\n( |\t)+} $files "\n" files
9781 error_popup [mc "Revert failed because of local changes to\
9782 the following files:%s Please commit, reset or stash \
9783 your changes and try again." $files]
9784 } elseif [regexp {error: could not revert} $err] {
9785 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9786 Do you wish to run git citool to resolve it?"]] {
9787 # Force citool to read MERGE_MSG
9788 file delete [file join $gitdir "GITGUI_MSG"]
9789 exec_citool {} $rowmenuid
9791 } else { error_popup $err }
9792 run updatecommits
9793 return
9796 set newhead [exec git rev-parse HEAD]
9797 if { $newhead eq $oldhead } {
9798 notbusy revert
9799 error_popup [mc "No changes committed"]
9800 return
9803 addnewchild $newhead $oldhead
9805 if [commitinview $oldhead $curview] {
9806 # XXX this isn't right if we have a path limit...
9807 insertrow $newhead $oldhead $curview
9808 if {$mainhead ne {}} {
9809 movehead $newhead $mainhead
9810 movedhead $newhead $mainhead
9812 set mainheadid $newhead
9813 redrawtags $oldhead
9814 redrawtags $newhead
9815 selbyid $newhead
9818 notbusy revert
9821 proc resethead {} {
9822 global mainhead rowmenuid confirm_ok resettype NS
9824 set confirm_ok 0
9825 set w ".confirmreset"
9826 ttk_toplevel $w
9827 make_transient $w .
9828 wm title $w [mc "Confirm reset"]
9829 ${NS}::label $w.m -text \
9830 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9831 pack $w.m -side top -fill x -padx 20 -pady 20
9832 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9833 set resettype mixed
9834 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9835 -text [mc "Soft: Leave working tree and index untouched"]
9836 grid $w.f.soft -sticky w
9837 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9838 -text [mc "Mixed: Leave working tree untouched, reset index"]
9839 grid $w.f.mixed -sticky w
9840 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9841 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9842 grid $w.f.hard -sticky w
9843 pack $w.f -side top -fill x -padx 4
9844 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9845 pack $w.ok -side left -fill x -padx 20 -pady 20
9846 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9847 bind $w <Key-Escape> [list destroy $w]
9848 pack $w.cancel -side right -fill x -padx 20 -pady 20
9849 bind $w <Visibility> "grab $w; focus $w"
9850 tkwait window $w
9851 if {!$confirm_ok} return
9852 if {[catch {set fd [open \
9853 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9854 error_popup $err
9855 } else {
9856 dohidelocalchanges
9857 filerun $fd [list readresetstat $fd]
9858 nowbusy reset [mc "Resetting"]
9859 selbyid $rowmenuid
9863 proc readresetstat {fd} {
9864 global mainhead mainheadid showlocalchanges rprogcoord
9866 if {[gets $fd line] >= 0} {
9867 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9868 set rprogcoord [expr {1.0 * $m / $n}]
9869 adjustprogress
9871 return 1
9873 set rprogcoord 0
9874 adjustprogress
9875 notbusy reset
9876 if {[catch {close $fd} err]} {
9877 error_popup $err
9879 set oldhead $mainheadid
9880 set newhead [exec git rev-parse HEAD]
9881 if {$newhead ne $oldhead} {
9882 movehead $newhead $mainhead
9883 movedhead $newhead $mainhead
9884 set mainheadid $newhead
9885 redrawtags $oldhead
9886 redrawtags $newhead
9888 if {$showlocalchanges} {
9889 doshowlocalchanges
9891 return 0
9894 # context menu for a head
9895 proc headmenu {x y id head} {
9896 global headmenuid headmenuhead headctxmenu mainhead headids
9898 stopfinding
9899 set headmenuid $id
9900 set headmenuhead $head
9901 array set state {0 normal 1 normal 2 normal}
9902 if {[string match "remotes/*" $head]} {
9903 set localhead [string range $head [expr [string last / $head] + 1] end]
9904 if {[info exists headids($localhead)]} {
9905 set state(0) disabled
9907 array set state {1 disabled 2 disabled}
9909 if {$head eq $mainhead} {
9910 array set state {0 disabled 2 disabled}
9912 foreach i {0 1 2} {
9913 $headctxmenu entryconfigure $i -state $state($i)
9915 tk_popup $headctxmenu $x $y
9918 proc cobranch {} {
9919 global headmenuid headmenuhead headids
9920 global showlocalchanges
9922 # check the tree is clean first??
9923 set newhead $headmenuhead
9924 set command [list | git checkout]
9925 if {[string match "remotes/*" $newhead]} {
9926 set remote $newhead
9927 set newhead [string range $newhead [expr [string last / $newhead] + 1] end]
9928 # The following check is redundant - the menu option should
9929 # be disabled to begin with...
9930 if {[info exists headids($newhead)]} {
9931 error_popup [mc "A local branch named %s exists already" $newhead]
9932 return
9934 lappend command -b $newhead --track $remote
9935 } else {
9936 lappend command $newhead
9938 lappend command 2>@1
9939 nowbusy checkout [mc "Checking out"]
9940 update
9941 dohidelocalchanges
9942 if {[catch {
9943 set fd [open $command r]
9944 } err]} {
9945 notbusy checkout
9946 error_popup $err
9947 if {$showlocalchanges} {
9948 dodiffindex
9950 } else {
9951 filerun $fd [list readcheckoutstat $fd $newhead $headmenuid]
9955 proc readcheckoutstat {fd newhead newheadid} {
9956 global mainhead mainheadid headids idheads showlocalchanges progresscoords
9957 global viewmainheadid curview
9959 if {[gets $fd line] >= 0} {
9960 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9961 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9962 adjustprogress
9964 return 1
9966 set progresscoords {0 0}
9967 adjustprogress
9968 notbusy checkout
9969 if {[catch {close $fd} err]} {
9970 error_popup $err
9971 return
9973 set oldmainid $mainheadid
9974 if {! [info exists headids($newhead)]} {
9975 set headids($newhead) $newheadid
9976 lappend idheads($newheadid) $newhead
9977 addedhead $newheadid $newhead
9979 set mainhead $newhead
9980 set mainheadid $newheadid
9981 set viewmainheadid($curview) $newheadid
9982 redrawtags $oldmainid
9983 redrawtags $newheadid
9984 selbyid $newheadid
9985 if {$showlocalchanges} {
9986 dodiffindex
9990 proc rmbranch {} {
9991 global headmenuid headmenuhead mainhead
9992 global idheads
9994 set head $headmenuhead
9995 set id $headmenuid
9996 # this check shouldn't be needed any more...
9997 if {$head eq $mainhead} {
9998 error_popup [mc "Cannot delete the currently checked-out branch"]
9999 return
10001 set dheads [descheads $id]
10002 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
10003 # the stuff on this branch isn't on any other branch
10004 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
10005 branch.\nReally delete branch %s?" $head $head]]} return
10007 nowbusy rmbranch
10008 update
10009 if {[catch {exec git branch -D $head} err]} {
10010 notbusy rmbranch
10011 error_popup $err
10012 return
10014 removehead $id $head
10015 removedhead $id $head
10016 redrawtags $id
10017 notbusy rmbranch
10018 dispneartags 0
10019 run refill_reflist
10022 # Display a list of tags and heads
10023 proc showrefs {} {
10024 global showrefstop bgcolor fgcolor selectbgcolor NS
10025 global bglist fglist reflistfilter reflist maincursor
10027 set top .showrefs
10028 set showrefstop $top
10029 if {[winfo exists $top]} {
10030 raise $top
10031 refill_reflist
10032 return
10034 ttk_toplevel $top
10035 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
10036 make_transient $top .
10037 text $top.list -background $bgcolor -foreground $fgcolor \
10038 -selectbackground $selectbgcolor -font mainfont \
10039 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
10040 -width 30 -height 20 -cursor $maincursor \
10041 -spacing1 1 -spacing3 1 -state disabled
10042 $top.list tag configure highlight -background $selectbgcolor
10043 if {![lsearch -exact $bglist $top.list]} {
10044 lappend bglist $top.list
10045 lappend fglist $top.list
10047 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
10048 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
10049 grid $top.list $top.ysb -sticky nsew
10050 grid $top.xsb x -sticky ew
10051 ${NS}::frame $top.f
10052 ${NS}::label $top.f.l -text "[mc "Filter"]: "
10053 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
10054 set reflistfilter "*"
10055 trace add variable reflistfilter write reflistfilter_change
10056 pack $top.f.e -side right -fill x -expand 1
10057 pack $top.f.l -side left
10058 grid $top.f - -sticky ew -pady 2
10059 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
10060 bind $top <Key-Escape> [list destroy $top]
10061 grid $top.close -
10062 grid columnconfigure $top 0 -weight 1
10063 grid rowconfigure $top 0 -weight 1
10064 bind $top.list <1> {break}
10065 bind $top.list <B1-Motion> {break}
10066 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
10067 set reflist {}
10068 refill_reflist
10071 proc sel_reflist {w x y} {
10072 global showrefstop reflist headids tagids otherrefids
10074 if {![winfo exists $showrefstop]} return
10075 set l [lindex [split [$w index "@$x,$y"] "."] 0]
10076 set ref [lindex $reflist [expr {$l-1}]]
10077 set n [lindex $ref 0]
10078 switch -- [lindex $ref 1] {
10079 "H" {selbyid $headids($n)}
10080 "R" {selbyid $headids($n)}
10081 "T" {selbyid $tagids($n)}
10082 "o" {selbyid $otherrefids($n)}
10084 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
10087 proc unsel_reflist {} {
10088 global showrefstop
10090 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10091 $showrefstop.list tag remove highlight 0.0 end
10094 proc reflistfilter_change {n1 n2 op} {
10095 global reflistfilter
10097 after cancel refill_reflist
10098 after 200 refill_reflist
10101 proc refill_reflist {} {
10102 global reflist reflistfilter showrefstop headids tagids otherrefids
10103 global curview
10105 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10106 set refs {}
10107 foreach n [array names headids] {
10108 if {[string match $reflistfilter $n]} {
10109 if {[commitinview $headids($n) $curview]} {
10110 if {[string match "remotes/*" $n]} {
10111 lappend refs [list $n R]
10112 } else {
10113 lappend refs [list $n H]
10115 } else {
10116 interestedin $headids($n) {run refill_reflist}
10120 foreach n [array names tagids] {
10121 if {[string match $reflistfilter $n]} {
10122 if {[commitinview $tagids($n) $curview]} {
10123 lappend refs [list $n T]
10124 } else {
10125 interestedin $tagids($n) {run refill_reflist}
10129 foreach n [array names otherrefids] {
10130 if {[string match $reflistfilter $n]} {
10131 if {[commitinview $otherrefids($n) $curview]} {
10132 lappend refs [list $n o]
10133 } else {
10134 interestedin $otherrefids($n) {run refill_reflist}
10138 set refs [lsort -index 0 $refs]
10139 if {$refs eq $reflist} return
10141 # Update the contents of $showrefstop.list according to the
10142 # differences between $reflist (old) and $refs (new)
10143 $showrefstop.list conf -state normal
10144 $showrefstop.list insert end "\n"
10145 set i 0
10146 set j 0
10147 while {$i < [llength $reflist] || $j < [llength $refs]} {
10148 if {$i < [llength $reflist]} {
10149 if {$j < [llength $refs]} {
10150 set cmp [string compare [lindex $reflist $i 0] \
10151 [lindex $refs $j 0]]
10152 if {$cmp == 0} {
10153 set cmp [string compare [lindex $reflist $i 1] \
10154 [lindex $refs $j 1]]
10156 } else {
10157 set cmp -1
10159 } else {
10160 set cmp 1
10162 switch -- $cmp {
10163 -1 {
10164 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
10165 incr i
10168 incr i
10169 incr j
10172 set l [expr {$j + 1}]
10173 $showrefstop.list image create $l.0 -align baseline \
10174 -image reficon-[lindex $refs $j 1] -padx 2
10175 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
10176 incr j
10180 set reflist $refs
10181 # delete last newline
10182 $showrefstop.list delete end-2c end-1c
10183 $showrefstop.list conf -state disabled
10186 # Stuff for finding nearby tags
10187 proc getallcommits {} {
10188 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
10189 global idheads idtags idotherrefs allparents tagobjid
10190 global gitdir
10192 if {![info exists allcommits]} {
10193 set nextarc 0
10194 set allcommits 0
10195 set seeds {}
10196 set allcwait 0
10197 set cachedarcs 0
10198 set allccache [file join $gitdir "gitk.cache"]
10199 if {![catch {
10200 set f [open $allccache r]
10201 set allcwait 1
10202 getcache $f
10203 }]} return
10206 if {$allcwait} {
10207 return
10209 set cmd [list | git rev-list --parents]
10210 set allcupdate [expr {$seeds ne {}}]
10211 if {!$allcupdate} {
10212 set ids "--all"
10213 } else {
10214 set refs [concat [array names idheads] [array names idtags] \
10215 [array names idotherrefs]]
10216 set ids {}
10217 set tagobjs {}
10218 foreach name [array names tagobjid] {
10219 lappend tagobjs $tagobjid($name)
10221 foreach id [lsort -unique $refs] {
10222 if {![info exists allparents($id)] &&
10223 [lsearch -exact $tagobjs $id] < 0} {
10224 lappend ids $id
10227 if {$ids ne {}} {
10228 foreach id $seeds {
10229 lappend ids "^$id"
10233 if {$ids ne {}} {
10234 set fd [open [concat $cmd $ids] r]
10235 fconfigure $fd -blocking 0
10236 incr allcommits
10237 nowbusy allcommits
10238 filerun $fd [list getallclines $fd]
10239 } else {
10240 dispneartags 0
10244 # Since most commits have 1 parent and 1 child, we group strings of
10245 # such commits into "arcs" joining branch/merge points (BMPs), which
10246 # are commits that either don't have 1 parent or don't have 1 child.
10248 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10249 # arcout(id) - outgoing arcs for BMP
10250 # arcids(a) - list of IDs on arc including end but not start
10251 # arcstart(a) - BMP ID at start of arc
10252 # arcend(a) - BMP ID at end of arc
10253 # growing(a) - arc a is still growing
10254 # arctags(a) - IDs out of arcids (excluding end) that have tags
10255 # archeads(a) - IDs out of arcids (excluding end) that have heads
10256 # The start of an arc is at the descendent end, so "incoming" means
10257 # coming from descendents, and "outgoing" means going towards ancestors.
10259 proc getallclines {fd} {
10260 global allparents allchildren idtags idheads nextarc
10261 global arcnos arcids arctags arcout arcend arcstart archeads growing
10262 global seeds allcommits cachedarcs allcupdate
10264 set nid 0
10265 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10266 set id [lindex $line 0]
10267 if {[info exists allparents($id)]} {
10268 # seen it already
10269 continue
10271 set cachedarcs 0
10272 set olds [lrange $line 1 end]
10273 set allparents($id) $olds
10274 if {![info exists allchildren($id)]} {
10275 set allchildren($id) {}
10276 set arcnos($id) {}
10277 lappend seeds $id
10278 } else {
10279 set a $arcnos($id)
10280 if {[llength $olds] == 1 && [llength $a] == 1} {
10281 lappend arcids($a) $id
10282 if {[info exists idtags($id)]} {
10283 lappend arctags($a) $id
10285 if {[info exists idheads($id)]} {
10286 lappend archeads($a) $id
10288 if {[info exists allparents($olds)]} {
10289 # seen parent already
10290 if {![info exists arcout($olds)]} {
10291 splitarc $olds
10293 lappend arcids($a) $olds
10294 set arcend($a) $olds
10295 unset growing($a)
10297 lappend allchildren($olds) $id
10298 lappend arcnos($olds) $a
10299 continue
10302 foreach a $arcnos($id) {
10303 lappend arcids($a) $id
10304 set arcend($a) $id
10305 unset growing($a)
10308 set ao {}
10309 foreach p $olds {
10310 lappend allchildren($p) $id
10311 set a [incr nextarc]
10312 set arcstart($a) $id
10313 set archeads($a) {}
10314 set arctags($a) {}
10315 set archeads($a) {}
10316 set arcids($a) {}
10317 lappend ao $a
10318 set growing($a) 1
10319 if {[info exists allparents($p)]} {
10320 # seen it already, may need to make a new branch
10321 if {![info exists arcout($p)]} {
10322 splitarc $p
10324 lappend arcids($a) $p
10325 set arcend($a) $p
10326 unset growing($a)
10328 lappend arcnos($p) $a
10330 set arcout($id) $ao
10332 if {$nid > 0} {
10333 global cached_dheads cached_dtags cached_atags
10334 unset -nocomplain cached_dheads
10335 unset -nocomplain cached_dtags
10336 unset -nocomplain cached_atags
10338 if {![eof $fd]} {
10339 return [expr {$nid >= 1000? 2: 1}]
10341 set cacheok 1
10342 if {[catch {
10343 fconfigure $fd -blocking 1
10344 close $fd
10345 } err]} {
10346 # got an error reading the list of commits
10347 # if we were updating, try rereading the whole thing again
10348 if {$allcupdate} {
10349 incr allcommits -1
10350 dropcache $err
10351 return
10353 error_popup "[mc "Error reading commit topology information;\
10354 branch and preceding/following tag information\
10355 will be incomplete."]\n($err)"
10356 set cacheok 0
10358 if {[incr allcommits -1] == 0} {
10359 notbusy allcommits
10360 if {$cacheok} {
10361 run savecache
10364 dispneartags 0
10365 return 0
10368 proc recalcarc {a} {
10369 global arctags archeads arcids idtags idheads
10371 set at {}
10372 set ah {}
10373 foreach id [lrange $arcids($a) 0 end-1] {
10374 if {[info exists idtags($id)]} {
10375 lappend at $id
10377 if {[info exists idheads($id)]} {
10378 lappend ah $id
10381 set arctags($a) $at
10382 set archeads($a) $ah
10385 proc splitarc {p} {
10386 global arcnos arcids nextarc arctags archeads idtags idheads
10387 global arcstart arcend arcout allparents growing
10389 set a $arcnos($p)
10390 if {[llength $a] != 1} {
10391 puts "oops splitarc called but [llength $a] arcs already"
10392 return
10394 set a [lindex $a 0]
10395 set i [lsearch -exact $arcids($a) $p]
10396 if {$i < 0} {
10397 puts "oops splitarc $p not in arc $a"
10398 return
10400 set na [incr nextarc]
10401 if {[info exists arcend($a)]} {
10402 set arcend($na) $arcend($a)
10403 } else {
10404 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10405 set j [lsearch -exact $arcnos($l) $a]
10406 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10408 set tail [lrange $arcids($a) [expr {$i+1}] end]
10409 set arcids($a) [lrange $arcids($a) 0 $i]
10410 set arcend($a) $p
10411 set arcstart($na) $p
10412 set arcout($p) $na
10413 set arcids($na) $tail
10414 if {[info exists growing($a)]} {
10415 set growing($na) 1
10416 unset growing($a)
10419 foreach id $tail {
10420 if {[llength $arcnos($id)] == 1} {
10421 set arcnos($id) $na
10422 } else {
10423 set j [lsearch -exact $arcnos($id) $a]
10424 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10428 # reconstruct tags and heads lists
10429 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10430 recalcarc $a
10431 recalcarc $na
10432 } else {
10433 set arctags($na) {}
10434 set archeads($na) {}
10438 # Update things for a new commit added that is a child of one
10439 # existing commit. Used when cherry-picking.
10440 proc addnewchild {id p} {
10441 global allparents allchildren idtags nextarc
10442 global arcnos arcids arctags arcout arcend arcstart archeads growing
10443 global seeds allcommits
10445 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10446 set allparents($id) [list $p]
10447 set allchildren($id) {}
10448 set arcnos($id) {}
10449 lappend seeds $id
10450 lappend allchildren($p) $id
10451 set a [incr nextarc]
10452 set arcstart($a) $id
10453 set archeads($a) {}
10454 set arctags($a) {}
10455 set arcids($a) [list $p]
10456 set arcend($a) $p
10457 if {![info exists arcout($p)]} {
10458 splitarc $p
10460 lappend arcnos($p) $a
10461 set arcout($id) [list $a]
10464 # This implements a cache for the topology information.
10465 # The cache saves, for each arc, the start and end of the arc,
10466 # the ids on the arc, and the outgoing arcs from the end.
10467 proc readcache {f} {
10468 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10469 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10470 global allcwait
10472 set a $nextarc
10473 set lim $cachedarcs
10474 if {$lim - $a > 500} {
10475 set lim [expr {$a + 500}]
10477 if {[catch {
10478 if {$a == $lim} {
10479 # finish reading the cache and setting up arctags, etc.
10480 set line [gets $f]
10481 if {$line ne "1"} {error "bad final version"}
10482 close $f
10483 foreach id [array names idtags] {
10484 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10485 [llength $allparents($id)] == 1} {
10486 set a [lindex $arcnos($id) 0]
10487 if {$arctags($a) eq {}} {
10488 recalcarc $a
10492 foreach id [array names idheads] {
10493 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10494 [llength $allparents($id)] == 1} {
10495 set a [lindex $arcnos($id) 0]
10496 if {$archeads($a) eq {}} {
10497 recalcarc $a
10501 foreach id [lsort -unique $possible_seeds] {
10502 if {$arcnos($id) eq {}} {
10503 lappend seeds $id
10506 set allcwait 0
10507 } else {
10508 while {[incr a] <= $lim} {
10509 set line [gets $f]
10510 if {[llength $line] != 3} {error "bad line"}
10511 set s [lindex $line 0]
10512 set arcstart($a) $s
10513 lappend arcout($s) $a
10514 if {![info exists arcnos($s)]} {
10515 lappend possible_seeds $s
10516 set arcnos($s) {}
10518 set e [lindex $line 1]
10519 if {$e eq {}} {
10520 set growing($a) 1
10521 } else {
10522 set arcend($a) $e
10523 if {![info exists arcout($e)]} {
10524 set arcout($e) {}
10527 set arcids($a) [lindex $line 2]
10528 foreach id $arcids($a) {
10529 lappend allparents($s) $id
10530 set s $id
10531 lappend arcnos($id) $a
10533 if {![info exists allparents($s)]} {
10534 set allparents($s) {}
10536 set arctags($a) {}
10537 set archeads($a) {}
10539 set nextarc [expr {$a - 1}]
10541 } err]} {
10542 dropcache $err
10543 return 0
10545 if {!$allcwait} {
10546 getallcommits
10548 return $allcwait
10551 proc getcache {f} {
10552 global nextarc cachedarcs possible_seeds
10554 if {[catch {
10555 set line [gets $f]
10556 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10557 # make sure it's an integer
10558 set cachedarcs [expr {int([lindex $line 1])}]
10559 if {$cachedarcs < 0} {error "bad number of arcs"}
10560 set nextarc 0
10561 set possible_seeds {}
10562 run readcache $f
10563 } err]} {
10564 dropcache $err
10566 return 0
10569 proc dropcache {err} {
10570 global allcwait nextarc cachedarcs seeds
10572 #puts "dropping cache ($err)"
10573 foreach v {arcnos arcout arcids arcstart arcend growing \
10574 arctags archeads allparents allchildren} {
10575 global $v
10576 unset -nocomplain $v
10578 set allcwait 0
10579 set nextarc 0
10580 set cachedarcs 0
10581 set seeds {}
10582 getallcommits
10585 proc writecache {f} {
10586 global cachearc cachedarcs allccache
10587 global arcstart arcend arcnos arcids arcout
10589 set a $cachearc
10590 set lim $cachedarcs
10591 if {$lim - $a > 1000} {
10592 set lim [expr {$a + 1000}]
10594 if {[catch {
10595 while {[incr a] <= $lim} {
10596 if {[info exists arcend($a)]} {
10597 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10598 } else {
10599 puts $f [list $arcstart($a) {} $arcids($a)]
10602 } err]} {
10603 catch {close $f}
10604 catch {file delete $allccache}
10605 #puts "writing cache failed ($err)"
10606 return 0
10608 set cachearc [expr {$a - 1}]
10609 if {$a > $cachedarcs} {
10610 puts $f "1"
10611 close $f
10612 return 0
10614 return 1
10617 proc savecache {} {
10618 global nextarc cachedarcs cachearc allccache
10620 if {$nextarc == $cachedarcs} return
10621 set cachearc 0
10622 set cachedarcs $nextarc
10623 catch {
10624 set f [open $allccache w]
10625 puts $f [list 1 $cachedarcs]
10626 run writecache $f
10630 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10631 # or 0 if neither is true.
10632 proc anc_or_desc {a b} {
10633 global arcout arcstart arcend arcnos cached_isanc
10635 if {$arcnos($a) eq $arcnos($b)} {
10636 # Both are on the same arc(s); either both are the same BMP,
10637 # or if one is not a BMP, the other is also not a BMP or is
10638 # the BMP at end of the arc (and it only has 1 incoming arc).
10639 # Or both can be BMPs with no incoming arcs.
10640 if {$a eq $b || $arcnos($a) eq {}} {
10641 return 0
10643 # assert {[llength $arcnos($a)] == 1}
10644 set arc [lindex $arcnos($a) 0]
10645 set i [lsearch -exact $arcids($arc) $a]
10646 set j [lsearch -exact $arcids($arc) $b]
10647 if {$i < 0 || $i > $j} {
10648 return 1
10649 } else {
10650 return -1
10654 if {![info exists arcout($a)]} {
10655 set arc [lindex $arcnos($a) 0]
10656 if {[info exists arcend($arc)]} {
10657 set aend $arcend($arc)
10658 } else {
10659 set aend {}
10661 set a $arcstart($arc)
10662 } else {
10663 set aend $a
10665 if {![info exists arcout($b)]} {
10666 set arc [lindex $arcnos($b) 0]
10667 if {[info exists arcend($arc)]} {
10668 set bend $arcend($arc)
10669 } else {
10670 set bend {}
10672 set b $arcstart($arc)
10673 } else {
10674 set bend $b
10676 if {$a eq $bend} {
10677 return 1
10679 if {$b eq $aend} {
10680 return -1
10682 if {[info exists cached_isanc($a,$bend)]} {
10683 if {$cached_isanc($a,$bend)} {
10684 return 1
10687 if {[info exists cached_isanc($b,$aend)]} {
10688 if {$cached_isanc($b,$aend)} {
10689 return -1
10691 if {[info exists cached_isanc($a,$bend)]} {
10692 return 0
10696 set todo [list $a $b]
10697 set anc($a) a
10698 set anc($b) b
10699 for {set i 0} {$i < [llength $todo]} {incr i} {
10700 set x [lindex $todo $i]
10701 if {$anc($x) eq {}} {
10702 continue
10704 foreach arc $arcnos($x) {
10705 set xd $arcstart($arc)
10706 if {$xd eq $bend} {
10707 set cached_isanc($a,$bend) 1
10708 set cached_isanc($b,$aend) 0
10709 return 1
10710 } elseif {$xd eq $aend} {
10711 set cached_isanc($b,$aend) 1
10712 set cached_isanc($a,$bend) 0
10713 return -1
10715 if {![info exists anc($xd)]} {
10716 set anc($xd) $anc($x)
10717 lappend todo $xd
10718 } elseif {$anc($xd) ne $anc($x)} {
10719 set anc($xd) {}
10723 set cached_isanc($a,$bend) 0
10724 set cached_isanc($b,$aend) 0
10725 return 0
10728 # This identifies whether $desc has an ancestor that is
10729 # a growing tip of the graph and which is not an ancestor of $anc
10730 # and returns 0 if so and 1 if not.
10731 # If we subsequently discover a tag on such a growing tip, and that
10732 # turns out to be a descendent of $anc (which it could, since we
10733 # don't necessarily see children before parents), then $desc
10734 # isn't a good choice to display as a descendent tag of
10735 # $anc (since it is the descendent of another tag which is
10736 # a descendent of $anc). Similarly, $anc isn't a good choice to
10737 # display as a ancestor tag of $desc.
10739 proc is_certain {desc anc} {
10740 global arcnos arcout arcstart arcend growing problems
10742 set certain {}
10743 if {[llength $arcnos($anc)] == 1} {
10744 # tags on the same arc are certain
10745 if {$arcnos($desc) eq $arcnos($anc)} {
10746 return 1
10748 if {![info exists arcout($anc)]} {
10749 # if $anc is partway along an arc, use the start of the arc instead
10750 set a [lindex $arcnos($anc) 0]
10751 set anc $arcstart($a)
10754 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10755 set x $desc
10756 } else {
10757 set a [lindex $arcnos($desc) 0]
10758 set x $arcend($a)
10760 if {$x == $anc} {
10761 return 1
10763 set anclist [list $x]
10764 set dl($x) 1
10765 set nnh 1
10766 set ngrowanc 0
10767 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10768 set x [lindex $anclist $i]
10769 if {$dl($x)} {
10770 incr nnh -1
10772 set done($x) 1
10773 foreach a $arcout($x) {
10774 if {[info exists growing($a)]} {
10775 if {![info exists growanc($x)] && $dl($x)} {
10776 set growanc($x) 1
10777 incr ngrowanc
10779 } else {
10780 set y $arcend($a)
10781 if {[info exists dl($y)]} {
10782 if {$dl($y)} {
10783 if {!$dl($x)} {
10784 set dl($y) 0
10785 if {![info exists done($y)]} {
10786 incr nnh -1
10788 if {[info exists growanc($x)]} {
10789 incr ngrowanc -1
10791 set xl [list $y]
10792 for {set k 0} {$k < [llength $xl]} {incr k} {
10793 set z [lindex $xl $k]
10794 foreach c $arcout($z) {
10795 if {[info exists arcend($c)]} {
10796 set v $arcend($c)
10797 if {[info exists dl($v)] && $dl($v)} {
10798 set dl($v) 0
10799 if {![info exists done($v)]} {
10800 incr nnh -1
10802 if {[info exists growanc($v)]} {
10803 incr ngrowanc -1
10805 lappend xl $v
10812 } elseif {$y eq $anc || !$dl($x)} {
10813 set dl($y) 0
10814 lappend anclist $y
10815 } else {
10816 set dl($y) 1
10817 lappend anclist $y
10818 incr nnh
10823 foreach x [array names growanc] {
10824 if {$dl($x)} {
10825 return 0
10827 return 0
10829 return 1
10832 proc validate_arctags {a} {
10833 global arctags idtags
10835 set i -1
10836 set na $arctags($a)
10837 foreach id $arctags($a) {
10838 incr i
10839 if {![info exists idtags($id)]} {
10840 set na [lreplace $na $i $i]
10841 incr i -1
10844 set arctags($a) $na
10847 proc validate_archeads {a} {
10848 global archeads idheads
10850 set i -1
10851 set na $archeads($a)
10852 foreach id $archeads($a) {
10853 incr i
10854 if {![info exists idheads($id)]} {
10855 set na [lreplace $na $i $i]
10856 incr i -1
10859 set archeads($a) $na
10862 # Return the list of IDs that have tags that are descendents of id,
10863 # ignoring IDs that are descendents of IDs already reported.
10864 proc desctags {id} {
10865 global arcnos arcstart arcids arctags idtags allparents
10866 global growing cached_dtags
10868 if {![info exists allparents($id)]} {
10869 return {}
10871 set t1 [clock clicks -milliseconds]
10872 set argid $id
10873 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10874 # part-way along an arc; check that arc first
10875 set a [lindex $arcnos($id) 0]
10876 if {$arctags($a) ne {}} {
10877 validate_arctags $a
10878 set i [lsearch -exact $arcids($a) $id]
10879 set tid {}
10880 foreach t $arctags($a) {
10881 set j [lsearch -exact $arcids($a) $t]
10882 if {$j >= $i} break
10883 set tid $t
10885 if {$tid ne {}} {
10886 return $tid
10889 set id $arcstart($a)
10890 if {[info exists idtags($id)]} {
10891 return $id
10894 if {[info exists cached_dtags($id)]} {
10895 return $cached_dtags($id)
10898 set origid $id
10899 set todo [list $id]
10900 set queued($id) 1
10901 set nc 1
10902 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10903 set id [lindex $todo $i]
10904 set done($id) 1
10905 set ta [info exists hastaggedancestor($id)]
10906 if {!$ta} {
10907 incr nc -1
10909 # ignore tags on starting node
10910 if {!$ta && $i > 0} {
10911 if {[info exists idtags($id)]} {
10912 set tagloc($id) $id
10913 set ta 1
10914 } elseif {[info exists cached_dtags($id)]} {
10915 set tagloc($id) $cached_dtags($id)
10916 set ta 1
10919 foreach a $arcnos($id) {
10920 set d $arcstart($a)
10921 if {!$ta && $arctags($a) ne {}} {
10922 validate_arctags $a
10923 if {$arctags($a) ne {}} {
10924 lappend tagloc($id) [lindex $arctags($a) end]
10927 if {$ta || $arctags($a) ne {}} {
10928 set tomark [list $d]
10929 for {set j 0} {$j < [llength $tomark]} {incr j} {
10930 set dd [lindex $tomark $j]
10931 if {![info exists hastaggedancestor($dd)]} {
10932 if {[info exists done($dd)]} {
10933 foreach b $arcnos($dd) {
10934 lappend tomark $arcstart($b)
10936 if {[info exists tagloc($dd)]} {
10937 unset tagloc($dd)
10939 } elseif {[info exists queued($dd)]} {
10940 incr nc -1
10942 set hastaggedancestor($dd) 1
10946 if {![info exists queued($d)]} {
10947 lappend todo $d
10948 set queued($d) 1
10949 if {![info exists hastaggedancestor($d)]} {
10950 incr nc
10955 set tags {}
10956 foreach id [array names tagloc] {
10957 if {![info exists hastaggedancestor($id)]} {
10958 foreach t $tagloc($id) {
10959 if {[lsearch -exact $tags $t] < 0} {
10960 lappend tags $t
10965 set t2 [clock clicks -milliseconds]
10966 set loopix $i
10968 # remove tags that are descendents of other tags
10969 for {set i 0} {$i < [llength $tags]} {incr i} {
10970 set a [lindex $tags $i]
10971 for {set j 0} {$j < $i} {incr j} {
10972 set b [lindex $tags $j]
10973 set r [anc_or_desc $a $b]
10974 if {$r == 1} {
10975 set tags [lreplace $tags $j $j]
10976 incr j -1
10977 incr i -1
10978 } elseif {$r == -1} {
10979 set tags [lreplace $tags $i $i]
10980 incr i -1
10981 break
10986 if {[array names growing] ne {}} {
10987 # graph isn't finished, need to check if any tag could get
10988 # eclipsed by another tag coming later. Simply ignore any
10989 # tags that could later get eclipsed.
10990 set ctags {}
10991 foreach t $tags {
10992 if {[is_certain $t $origid]} {
10993 lappend ctags $t
10996 if {$tags eq $ctags} {
10997 set cached_dtags($origid) $tags
10998 } else {
10999 set tags $ctags
11001 } else {
11002 set cached_dtags($origid) $tags
11004 set t3 [clock clicks -milliseconds]
11005 if {0 && $t3 - $t1 >= 100} {
11006 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
11007 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
11009 return $tags
11012 proc anctags {id} {
11013 global arcnos arcids arcout arcend arctags idtags allparents
11014 global growing cached_atags
11016 if {![info exists allparents($id)]} {
11017 return {}
11019 set t1 [clock clicks -milliseconds]
11020 set argid $id
11021 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
11022 # part-way along an arc; check that arc first
11023 set a [lindex $arcnos($id) 0]
11024 if {$arctags($a) ne {}} {
11025 validate_arctags $a
11026 set i [lsearch -exact $arcids($a) $id]
11027 foreach t $arctags($a) {
11028 set j [lsearch -exact $arcids($a) $t]
11029 if {$j > $i} {
11030 return $t
11034 if {![info exists arcend($a)]} {
11035 return {}
11037 set id $arcend($a)
11038 if {[info exists idtags($id)]} {
11039 return $id
11042 if {[info exists cached_atags($id)]} {
11043 return $cached_atags($id)
11046 set origid $id
11047 set todo [list $id]
11048 set queued($id) 1
11049 set taglist {}
11050 set nc 1
11051 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
11052 set id [lindex $todo $i]
11053 set done($id) 1
11054 set td [info exists hastaggeddescendent($id)]
11055 if {!$td} {
11056 incr nc -1
11058 # ignore tags on starting node
11059 if {!$td && $i > 0} {
11060 if {[info exists idtags($id)]} {
11061 set tagloc($id) $id
11062 set td 1
11063 } elseif {[info exists cached_atags($id)]} {
11064 set tagloc($id) $cached_atags($id)
11065 set td 1
11068 foreach a $arcout($id) {
11069 if {!$td && $arctags($a) ne {}} {
11070 validate_arctags $a
11071 if {$arctags($a) ne {}} {
11072 lappend tagloc($id) [lindex $arctags($a) 0]
11075 if {![info exists arcend($a)]} continue
11076 set d $arcend($a)
11077 if {$td || $arctags($a) ne {}} {
11078 set tomark [list $d]
11079 for {set j 0} {$j < [llength $tomark]} {incr j} {
11080 set dd [lindex $tomark $j]
11081 if {![info exists hastaggeddescendent($dd)]} {
11082 if {[info exists done($dd)]} {
11083 foreach b $arcout($dd) {
11084 if {[info exists arcend($b)]} {
11085 lappend tomark $arcend($b)
11088 if {[info exists tagloc($dd)]} {
11089 unset tagloc($dd)
11091 } elseif {[info exists queued($dd)]} {
11092 incr nc -1
11094 set hastaggeddescendent($dd) 1
11098 if {![info exists queued($d)]} {
11099 lappend todo $d
11100 set queued($d) 1
11101 if {![info exists hastaggeddescendent($d)]} {
11102 incr nc
11107 set t2 [clock clicks -milliseconds]
11108 set loopix $i
11109 set tags {}
11110 foreach id [array names tagloc] {
11111 if {![info exists hastaggeddescendent($id)]} {
11112 foreach t $tagloc($id) {
11113 if {[lsearch -exact $tags $t] < 0} {
11114 lappend tags $t
11120 # remove tags that are ancestors of other tags
11121 for {set i 0} {$i < [llength $tags]} {incr i} {
11122 set a [lindex $tags $i]
11123 for {set j 0} {$j < $i} {incr j} {
11124 set b [lindex $tags $j]
11125 set r [anc_or_desc $a $b]
11126 if {$r == -1} {
11127 set tags [lreplace $tags $j $j]
11128 incr j -1
11129 incr i -1
11130 } elseif {$r == 1} {
11131 set tags [lreplace $tags $i $i]
11132 incr i -1
11133 break
11138 if {[array names growing] ne {}} {
11139 # graph isn't finished, need to check if any tag could get
11140 # eclipsed by another tag coming later. Simply ignore any
11141 # tags that could later get eclipsed.
11142 set ctags {}
11143 foreach t $tags {
11144 if {[is_certain $origid $t]} {
11145 lappend ctags $t
11148 if {$tags eq $ctags} {
11149 set cached_atags($origid) $tags
11150 } else {
11151 set tags $ctags
11153 } else {
11154 set cached_atags($origid) $tags
11156 set t3 [clock clicks -milliseconds]
11157 if {0 && $t3 - $t1 >= 100} {
11158 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
11159 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
11161 return $tags
11164 # Return the list of IDs that have heads that are descendents of id,
11165 # including id itself if it has a head.
11166 proc descheads {id} {
11167 global arcnos arcstart arcids archeads idheads cached_dheads
11168 global allparents arcout
11170 if {![info exists allparents($id)]} {
11171 return {}
11173 set aret {}
11174 if {![info exists arcout($id)]} {
11175 # part-way along an arc; check it first
11176 set a [lindex $arcnos($id) 0]
11177 if {$archeads($a) ne {}} {
11178 validate_archeads $a
11179 set i [lsearch -exact $arcids($a) $id]
11180 foreach t $archeads($a) {
11181 set j [lsearch -exact $arcids($a) $t]
11182 if {$j > $i} break
11183 lappend aret $t
11186 set id $arcstart($a)
11188 set origid $id
11189 set todo [list $id]
11190 set seen($id) 1
11191 set ret {}
11192 for {set i 0} {$i < [llength $todo]} {incr i} {
11193 set id [lindex $todo $i]
11194 if {[info exists cached_dheads($id)]} {
11195 set ret [concat $ret $cached_dheads($id)]
11196 } else {
11197 if {[info exists idheads($id)]} {
11198 lappend ret $id
11200 foreach a $arcnos($id) {
11201 if {$archeads($a) ne {}} {
11202 validate_archeads $a
11203 if {$archeads($a) ne {}} {
11204 set ret [concat $ret $archeads($a)]
11207 set d $arcstart($a)
11208 if {![info exists seen($d)]} {
11209 lappend todo $d
11210 set seen($d) 1
11215 set ret [lsort -unique $ret]
11216 set cached_dheads($origid) $ret
11217 return [concat $ret $aret]
11220 proc addedtag {id} {
11221 global arcnos arcout cached_dtags cached_atags
11223 if {![info exists arcnos($id)]} return
11224 if {![info exists arcout($id)]} {
11225 recalcarc [lindex $arcnos($id) 0]
11227 unset -nocomplain cached_dtags
11228 unset -nocomplain cached_atags
11231 proc addedhead {hid head} {
11232 global arcnos arcout cached_dheads
11234 if {![info exists arcnos($hid)]} return
11235 if {![info exists arcout($hid)]} {
11236 recalcarc [lindex $arcnos($hid) 0]
11238 unset -nocomplain cached_dheads
11241 proc removedhead {hid head} {
11242 global cached_dheads
11244 unset -nocomplain cached_dheads
11247 proc movedhead {hid head} {
11248 global arcnos arcout cached_dheads
11250 if {![info exists arcnos($hid)]} return
11251 if {![info exists arcout($hid)]} {
11252 recalcarc [lindex $arcnos($hid) 0]
11254 unset -nocomplain cached_dheads
11257 proc changedrefs {} {
11258 global cached_dheads cached_dtags cached_atags cached_tagcontent
11259 global arctags archeads arcnos arcout idheads idtags
11261 foreach id [concat [array names idheads] [array names idtags]] {
11262 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11263 set a [lindex $arcnos($id) 0]
11264 if {![info exists donearc($a)]} {
11265 recalcarc $a
11266 set donearc($a) 1
11270 unset -nocomplain cached_tagcontent
11271 unset -nocomplain cached_dtags
11272 unset -nocomplain cached_atags
11273 unset -nocomplain cached_dheads
11276 proc rereadrefs {} {
11277 global idtags idheads idotherrefs mainheadid
11279 set refids [concat [array names idtags] \
11280 [array names idheads] [array names idotherrefs]]
11281 foreach id $refids {
11282 if {![info exists ref($id)]} {
11283 set ref($id) [listrefs $id]
11286 set oldmainhead $mainheadid
11287 readrefs
11288 changedrefs
11289 set refids [lsort -unique [concat $refids [array names idtags] \
11290 [array names idheads] [array names idotherrefs]]]
11291 foreach id $refids {
11292 set v [listrefs $id]
11293 if {![info exists ref($id)] || $ref($id) != $v} {
11294 redrawtags $id
11297 if {$oldmainhead ne $mainheadid} {
11298 redrawtags $oldmainhead
11299 redrawtags $mainheadid
11301 run refill_reflist
11304 proc listrefs {id} {
11305 global idtags idheads idotherrefs
11307 set x {}
11308 if {[info exists idtags($id)]} {
11309 set x $idtags($id)
11311 set y {}
11312 if {[info exists idheads($id)]} {
11313 set y $idheads($id)
11315 set z {}
11316 if {[info exists idotherrefs($id)]} {
11317 set z $idotherrefs($id)
11319 return [list $x $y $z]
11322 proc add_tag_ctext {tag} {
11323 global ctext cached_tagcontent tagids
11325 if {![info exists cached_tagcontent($tag)]} {
11326 catch {
11327 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11330 $ctext insert end "[mc "Tag"]: $tag\n" bold
11331 if {[info exists cached_tagcontent($tag)]} {
11332 set text $cached_tagcontent($tag)
11333 } else {
11334 set text "[mc "Id"]: $tagids($tag)"
11336 appendwithlinks $text {}
11339 proc showtag {tag isnew} {
11340 global ctext cached_tagcontent tagids linknum tagobjid
11342 if {$isnew} {
11343 addtohistory [list showtag $tag 0] savectextpos
11345 $ctext conf -state normal
11346 clear_ctext
11347 settabs 0
11348 set linknum 0
11349 add_tag_ctext $tag
11350 maybe_scroll_ctext 1
11351 $ctext conf -state disabled
11352 init_flist {}
11355 proc showtags {id isnew} {
11356 global idtags ctext linknum
11358 if {$isnew} {
11359 addtohistory [list showtags $id 0] savectextpos
11361 $ctext conf -state normal
11362 clear_ctext
11363 settabs 0
11364 set linknum 0
11365 set sep {}
11366 foreach tag $idtags($id) {
11367 $ctext insert end $sep
11368 add_tag_ctext $tag
11369 set sep "\n\n"
11371 maybe_scroll_ctext 1
11372 $ctext conf -state disabled
11373 init_flist {}
11376 proc doquit {} {
11377 global stopped
11378 global gitktmpdir
11380 set stopped 100
11381 savestuff .
11382 destroy .
11384 if {[info exists gitktmpdir]} {
11385 catch {file delete -force $gitktmpdir}
11389 proc mkfontdisp {font top which} {
11390 global fontattr fontpref $font NS use_ttk
11392 set fontpref($font) [set $font]
11393 ${NS}::button $top.${font}but -text $which \
11394 -command [list choosefont $font $which]
11395 ${NS}::label $top.$font -relief flat -font $font \
11396 -text $fontattr($font,family) -justify left
11397 grid x $top.${font}but $top.$font -sticky w
11400 proc choosefont {font which} {
11401 global fontparam fontlist fonttop fontattr
11402 global prefstop NS
11404 set fontparam(which) $which
11405 set fontparam(font) $font
11406 set fontparam(family) [font actual $font -family]
11407 set fontparam(size) $fontattr($font,size)
11408 set fontparam(weight) $fontattr($font,weight)
11409 set fontparam(slant) $fontattr($font,slant)
11410 set top .gitkfont
11411 set fonttop $top
11412 if {![winfo exists $top]} {
11413 font create sample
11414 eval font config sample [font actual $font]
11415 ttk_toplevel $top
11416 make_transient $top $prefstop
11417 wm title $top [mc "Gitk font chooser"]
11418 ${NS}::label $top.l -textvariable fontparam(which)
11419 pack $top.l -side top
11420 set fontlist [lsort [font families]]
11421 ${NS}::frame $top.f
11422 listbox $top.f.fam -listvariable fontlist \
11423 -yscrollcommand [list $top.f.sb set]
11424 bind $top.f.fam <<ListboxSelect>> selfontfam
11425 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11426 pack $top.f.sb -side right -fill y
11427 pack $top.f.fam -side left -fill both -expand 1
11428 pack $top.f -side top -fill both -expand 1
11429 ${NS}::frame $top.g
11430 spinbox $top.g.size -from 4 -to 40 -width 4 \
11431 -textvariable fontparam(size) \
11432 -validatecommand {string is integer -strict %s}
11433 checkbutton $top.g.bold -padx 5 \
11434 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11435 -variable fontparam(weight) -onvalue bold -offvalue normal
11436 checkbutton $top.g.ital -padx 5 \
11437 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11438 -variable fontparam(slant) -onvalue italic -offvalue roman
11439 pack $top.g.size $top.g.bold $top.g.ital -side left
11440 pack $top.g -side top
11441 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11442 -background white
11443 $top.c create text 100 25 -anchor center -text $which -font sample \
11444 -fill black -tags text
11445 bind $top.c <Configure> [list centertext $top.c]
11446 pack $top.c -side top -fill x
11447 ${NS}::frame $top.buts
11448 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11449 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11450 bind $top <Key-Return> fontok
11451 bind $top <Key-Escape> fontcan
11452 grid $top.buts.ok $top.buts.can
11453 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11454 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11455 pack $top.buts -side bottom -fill x
11456 trace add variable fontparam write chg_fontparam
11457 } else {
11458 raise $top
11459 $top.c itemconf text -text $which
11461 set i [lsearch -exact $fontlist $fontparam(family)]
11462 if {$i >= 0} {
11463 $top.f.fam selection set $i
11464 $top.f.fam see $i
11468 proc centertext {w} {
11469 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11472 proc fontok {} {
11473 global fontparam fontpref prefstop
11475 set f $fontparam(font)
11476 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11477 if {$fontparam(weight) eq "bold"} {
11478 lappend fontpref($f) "bold"
11480 if {$fontparam(slant) eq "italic"} {
11481 lappend fontpref($f) "italic"
11483 set w $prefstop.notebook.fonts.$f
11484 $w conf -text $fontparam(family) -font $fontpref($f)
11486 fontcan
11489 proc fontcan {} {
11490 global fonttop fontparam
11492 if {[info exists fonttop]} {
11493 catch {destroy $fonttop}
11494 catch {font delete sample}
11495 unset fonttop
11496 unset fontparam
11500 if {[package vsatisfies [package provide Tk] 8.6]} {
11501 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11502 # function to make use of it.
11503 proc choosefont {font which} {
11504 tk fontchooser configure -title $which -font $font \
11505 -command [list on_choosefont $font $which]
11506 tk fontchooser show
11508 proc on_choosefont {font which newfont} {
11509 global fontparam
11510 puts stderr "$font $newfont"
11511 array set f [font actual $newfont]
11512 set fontparam(which) $which
11513 set fontparam(font) $font
11514 set fontparam(family) $f(-family)
11515 set fontparam(size) $f(-size)
11516 set fontparam(weight) $f(-weight)
11517 set fontparam(slant) $f(-slant)
11518 fontok
11522 proc selfontfam {} {
11523 global fonttop fontparam
11525 set i [$fonttop.f.fam curselection]
11526 if {$i ne {}} {
11527 set fontparam(family) [$fonttop.f.fam get $i]
11531 proc chg_fontparam {v sub op} {
11532 global fontparam
11534 font config sample -$sub $fontparam($sub)
11537 # Create a property sheet tab page
11538 proc create_prefs_page {w} {
11539 global NS
11540 set parent [join [lrange [split $w .] 0 end-1] .]
11541 if {[winfo class $parent] eq "TNotebook"} {
11542 ${NS}::frame $w
11543 } else {
11544 ${NS}::labelframe $w
11548 proc prefspage_general {notebook} {
11549 global NS maxwidth maxgraphpct showneartags showlocalchanges
11550 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11551 global hideremotes want_ttk have_ttk maxrefs web_browser
11553 set page [create_prefs_page $notebook.general]
11555 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11556 grid $page.ldisp - -sticky w -pady 10
11557 ${NS}::label $page.spacer -text " "
11558 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11559 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11560 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11561 #xgettext:no-tcl-format
11562 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11563 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11564 grid x $page.maxpctl $page.maxpct -sticky w
11565 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11566 -variable showlocalchanges
11567 grid x $page.showlocal -sticky w
11568 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11569 -variable autoselect
11570 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11571 grid x $page.autoselect $page.autosellen -sticky w
11572 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11573 -variable hideremotes
11574 grid x $page.hideremotes -sticky w
11576 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11577 grid $page.ddisp - -sticky w -pady 10
11578 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11579 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11580 grid x $page.tabstopl $page.tabstop -sticky w
11581 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11582 -variable showneartags
11583 grid x $page.ntag -sticky w
11584 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11585 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11586 grid x $page.maxrefsl $page.maxrefs -sticky w
11587 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11588 -variable limitdiffs
11589 grid x $page.ldiff -sticky w
11590 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11591 -variable perfile_attrs
11592 grid x $page.lattr -sticky w
11594 ${NS}::entry $page.extdifft -textvariable extdifftool
11595 ${NS}::frame $page.extdifff
11596 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11597 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11598 pack $page.extdifff.l $page.extdifff.b -side left
11599 pack configure $page.extdifff.l -padx 10
11600 grid x $page.extdifff $page.extdifft -sticky ew
11602 ${NS}::entry $page.webbrowser -textvariable web_browser
11603 ${NS}::frame $page.webbrowserf
11604 ${NS}::label $page.webbrowserf.l -text [mc "Web browser" ]
11605 pack $page.webbrowserf.l -side left
11606 pack configure $page.webbrowserf.l -padx 10
11607 grid x $page.webbrowserf $page.webbrowser -sticky ew
11609 ${NS}::label $page.lgen -text [mc "General options"]
11610 grid $page.lgen - -sticky w -pady 10
11611 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11612 -text [mc "Use themed widgets"]
11613 if {$have_ttk} {
11614 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11615 } else {
11616 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11618 grid x $page.want_ttk $page.ttk_note -sticky w
11619 return $page
11622 proc prefspage_colors {notebook} {
11623 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11624 global diffbgcolors
11626 set page [create_prefs_page $notebook.colors]
11628 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11629 grid $page.cdisp - -sticky w -pady 10
11630 label $page.ui -padx 40 -relief sunk -background $uicolor
11631 ${NS}::button $page.uibut -text [mc "Interface"] \
11632 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11633 grid x $page.uibut $page.ui -sticky w
11634 label $page.bg -padx 40 -relief sunk -background $bgcolor
11635 ${NS}::button $page.bgbut -text [mc "Background"] \
11636 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11637 grid x $page.bgbut $page.bg -sticky w
11638 label $page.fg -padx 40 -relief sunk -background $fgcolor
11639 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11640 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11641 grid x $page.fgbut $page.fg -sticky w
11642 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11643 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11644 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11645 [list $ctext tag conf d0 -foreground]]
11646 grid x $page.diffoldbut $page.diffold -sticky w
11647 label $page.diffoldbg -padx 40 -relief sunk -background [lindex $diffbgcolors 0]
11648 ${NS}::button $page.diffoldbgbut -text [mc "Diff: old lines bg"] \
11649 -command [list choosecolor diffbgcolors 0 $page.diffoldbg \
11650 [mc "diff old lines bg"] \
11651 [list $ctext tag conf d0 -background]]
11652 grid x $page.diffoldbgbut $page.diffoldbg -sticky w
11653 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11654 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11655 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11656 [list $ctext tag conf dresult -foreground]]
11657 grid x $page.diffnewbut $page.diffnew -sticky w
11658 label $page.diffnewbg -padx 40 -relief sunk -background [lindex $diffbgcolors 1]
11659 ${NS}::button $page.diffnewbgbut -text [mc "Diff: new lines bg"] \
11660 -command [list choosecolor diffbgcolors 1 $page.diffnewbg \
11661 [mc "diff new lines bg"] \
11662 [list $ctext tag conf dresult -background]]
11663 grid x $page.diffnewbgbut $page.diffnewbg -sticky w
11664 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11665 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11666 -command [list choosecolor diffcolors 2 $page.hunksep \
11667 [mc "diff hunk header"] \
11668 [list $ctext tag conf hunksep -foreground]]
11669 grid x $page.hunksepbut $page.hunksep -sticky w
11670 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11671 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11672 -command [list choosecolor markbgcolor {} $page.markbgsep \
11673 [mc "marked line background"] \
11674 [list $ctext tag conf omark -background]]
11675 grid x $page.markbgbut $page.markbgsep -sticky w
11676 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11677 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11678 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11679 grid x $page.selbgbut $page.selbgsep -sticky w
11680 return $page
11683 proc prefspage_fonts {notebook} {
11684 global NS
11685 set page [create_prefs_page $notebook.fonts]
11686 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11687 grid $page.cfont - -sticky w -pady 10
11688 mkfontdisp mainfont $page [mc "Main font"]
11689 mkfontdisp textfont $page [mc "Diff display font"]
11690 mkfontdisp uifont $page [mc "User interface font"]
11691 return $page
11694 proc doprefs {} {
11695 global maxwidth maxgraphpct use_ttk NS
11696 global oldprefs prefstop showneartags showlocalchanges
11697 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11698 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11699 global hideremotes want_ttk have_ttk
11701 set top .gitkprefs
11702 set prefstop $top
11703 if {[winfo exists $top]} {
11704 raise $top
11705 return
11707 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11708 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11709 set oldprefs($v) [set $v]
11711 ttk_toplevel $top
11712 wm title $top [mc "Gitk preferences"]
11713 make_transient $top .
11715 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11716 set notebook [ttk::notebook $top.notebook]
11717 } else {
11718 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11721 lappend pages [prefspage_general $notebook] [mc "General"]
11722 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11723 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11724 set col 0
11725 foreach {page title} $pages {
11726 if {$use_notebook} {
11727 $notebook add $page -text $title
11728 } else {
11729 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11730 -text $title -command [list raise $page]]
11731 $page configure -text $title
11732 grid $btn -row 0 -column [incr col] -sticky w
11733 grid $page -row 1 -column 0 -sticky news -columnspan 100
11737 if {!$use_notebook} {
11738 grid columnconfigure $notebook 0 -weight 1
11739 grid rowconfigure $notebook 1 -weight 1
11740 raise [lindex $pages 0]
11743 grid $notebook -sticky news -padx 2 -pady 2
11744 grid rowconfigure $top 0 -weight 1
11745 grid columnconfigure $top 0 -weight 1
11747 ${NS}::frame $top.buts
11748 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11749 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11750 bind $top <Key-Return> prefsok
11751 bind $top <Key-Escape> prefscan
11752 grid $top.buts.ok $top.buts.can
11753 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11754 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11755 grid $top.buts - - -pady 10 -sticky ew
11756 grid columnconfigure $top 2 -weight 1
11757 bind $top <Visibility> [list focus $top.buts.ok]
11760 proc choose_extdiff {} {
11761 global extdifftool
11763 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11764 if {$prog ne {}} {
11765 set extdifftool $prog
11769 proc choosecolor {v vi w x cmd} {
11770 global $v
11772 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11773 -title [mc "Gitk: choose color for %s" $x]]
11774 if {$c eq {}} return
11775 $w conf -background $c
11776 lset $v $vi $c
11777 eval $cmd $c
11780 proc setselbg {c} {
11781 global bglist cflist
11782 foreach w $bglist {
11783 if {[winfo exists $w]} {
11784 $w configure -selectbackground $c
11787 $cflist tag configure highlight \
11788 -background [$cflist cget -selectbackground]
11789 allcanvs itemconf secsel -fill $c
11792 # This sets the background color and the color scheme for the whole UI.
11793 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11794 # if we don't specify one ourselves, which makes the checkbuttons and
11795 # radiobuttons look bad. This chooses white for selectColor if the
11796 # background color is light, or black if it is dark.
11797 proc setui {c} {
11798 if {[tk windowingsystem] eq "win32"} { return }
11799 set bg [winfo rgb . $c]
11800 set selc black
11801 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11802 set selc white
11804 tk_setPalette background $c selectColor $selc
11807 proc setbg {c} {
11808 global bglist
11810 foreach w $bglist {
11811 if {[winfo exists $w]} {
11812 $w conf -background $c
11817 proc setfg {c} {
11818 global fglist canv
11820 foreach w $fglist {
11821 if {[winfo exists $w]} {
11822 $w conf -foreground $c
11825 allcanvs itemconf text -fill $c
11826 $canv itemconf circle -outline $c
11827 $canv itemconf markid -outline $c
11830 proc prefscan {} {
11831 global oldprefs prefstop
11833 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11834 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11835 global $v
11836 set $v $oldprefs($v)
11838 catch {destroy $prefstop}
11839 unset prefstop
11840 fontcan
11843 proc prefsok {} {
11844 global maxwidth maxgraphpct
11845 global oldprefs prefstop showneartags showlocalchanges
11846 global fontpref mainfont textfont uifont
11847 global limitdiffs treediffs perfile_attrs
11848 global hideremotes
11850 catch {destroy $prefstop}
11851 unset prefstop
11852 fontcan
11853 set fontchanged 0
11854 if {$mainfont ne $fontpref(mainfont)} {
11855 set mainfont $fontpref(mainfont)
11856 parsefont mainfont $mainfont
11857 eval font configure mainfont [fontflags mainfont]
11858 eval font configure mainfontbold [fontflags mainfont 1]
11859 setcoords
11860 set fontchanged 1
11862 if {$textfont ne $fontpref(textfont)} {
11863 set textfont $fontpref(textfont)
11864 parsefont textfont $textfont
11865 eval font configure textfont [fontflags textfont]
11866 eval font configure textfontbold [fontflags textfont 1]
11868 if {$uifont ne $fontpref(uifont)} {
11869 set uifont $fontpref(uifont)
11870 parsefont uifont $uifont
11871 eval font configure uifont [fontflags uifont]
11873 settabs
11874 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11875 if {$showlocalchanges} {
11876 doshowlocalchanges
11877 } else {
11878 dohidelocalchanges
11881 if {$limitdiffs != $oldprefs(limitdiffs) ||
11882 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11883 # treediffs elements are limited by path;
11884 # won't have encodings cached if perfile_attrs was just turned on
11885 unset -nocomplain treediffs
11887 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11888 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11889 redisplay
11890 } elseif {$showneartags != $oldprefs(showneartags) ||
11891 $limitdiffs != $oldprefs(limitdiffs)} {
11892 reselectline
11894 if {$hideremotes != $oldprefs(hideremotes)} {
11895 rereadrefs
11899 proc formatdate {d} {
11900 global datetimeformat
11901 if {$d ne {}} {
11902 # If $datetimeformat includes a timezone, display in the
11903 # timezone of the argument. Otherwise, display in local time.
11904 if {[string match {*%[zZ]*} $datetimeformat]} {
11905 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11906 # Tcl < 8.5 does not support -timezone. Emulate it by
11907 # setting TZ (e.g. TZ=<-0430>+04:30).
11908 global env
11909 if {[info exists env(TZ)]} {
11910 set savedTZ $env(TZ)
11912 set zone [lindex $d 1]
11913 set sign [string map {+ - - +} [string index $zone 0]]
11914 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11915 set d [clock format [lindex $d 0] -format $datetimeformat]
11916 if {[info exists savedTZ]} {
11917 set env(TZ) $savedTZ
11918 } else {
11919 unset env(TZ)
11922 } else {
11923 set d [clock format [lindex $d 0] -format $datetimeformat]
11926 return $d
11929 # This list of encoding names and aliases is distilled from
11930 # http://www.iana.org/assignments/character-sets.
11931 # Not all of them are supported by Tcl.
11932 set encoding_aliases {
11933 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11934 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11935 { ISO-10646-UTF-1 csISO10646UTF1 }
11936 { ISO_646.basic:1983 ref csISO646basic1983 }
11937 { INVARIANT csINVARIANT }
11938 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11939 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11940 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11941 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11942 { NATS-DANO iso-ir-9-1 csNATSDANO }
11943 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11944 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11945 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11946 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11947 { ISO-2022-KR csISO2022KR }
11948 { EUC-KR csEUCKR }
11949 { ISO-2022-JP csISO2022JP }
11950 { ISO-2022-JP-2 csISO2022JP2 }
11951 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11952 csISO13JISC6220jp }
11953 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11954 { IT iso-ir-15 ISO646-IT csISO15Italian }
11955 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11956 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11957 { greek7-old iso-ir-18 csISO18Greek7Old }
11958 { latin-greek iso-ir-19 csISO19LatinGreek }
11959 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11960 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11961 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11962 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11963 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11964 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11965 { INIS iso-ir-49 csISO49INIS }
11966 { INIS-8 iso-ir-50 csISO50INIS8 }
11967 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11968 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11969 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11970 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11971 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11972 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11973 csISO60Norwegian1 }
11974 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11975 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11976 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11977 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11978 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11979 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11980 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11981 { greek7 iso-ir-88 csISO88Greek7 }
11982 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11983 { iso-ir-90 csISO90 }
11984 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11985 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11986 csISO92JISC62991984b }
11987 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11988 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11989 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11990 csISO95JIS62291984handadd }
11991 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11992 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11993 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11994 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11995 CP819 csISOLatin1 }
11996 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11997 { T.61-7bit iso-ir-102 csISO102T617bit }
11998 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11999 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
12000 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
12001 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
12002 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
12003 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
12004 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
12005 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
12006 arabic csISOLatinArabic }
12007 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
12008 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
12009 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
12010 greek greek8 csISOLatinGreek }
12011 { T.101-G2 iso-ir-128 csISO128T101G2 }
12012 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
12013 csISOLatinHebrew }
12014 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
12015 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
12016 { CSN_369103 iso-ir-139 csISO139CSN369103 }
12017 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
12018 { ISO_6937-2-add iso-ir-142 csISOTextComm }
12019 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
12020 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
12021 csISOLatinCyrillic }
12022 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
12023 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
12024 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
12025 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
12026 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
12027 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
12028 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
12029 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
12030 { ISO_10367-box iso-ir-155 csISO10367Box }
12031 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
12032 { latin-lap lap iso-ir-158 csISO158Lap }
12033 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
12034 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
12035 { us-dk csUSDK }
12036 { dk-us csDKUS }
12037 { JIS_X0201 X0201 csHalfWidthKatakana }
12038 { KSC5636 ISO646-KR csKSC5636 }
12039 { ISO-10646-UCS-2 csUnicode }
12040 { ISO-10646-UCS-4 csUCS4 }
12041 { DEC-MCS dec csDECMCS }
12042 { hp-roman8 roman8 r8 csHPRoman8 }
12043 { macintosh mac csMacintosh }
12044 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
12045 csIBM037 }
12046 { IBM038 EBCDIC-INT cp038 csIBM038 }
12047 { IBM273 CP273 csIBM273 }
12048 { IBM274 EBCDIC-BE CP274 csIBM274 }
12049 { IBM275 EBCDIC-BR cp275 csIBM275 }
12050 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
12051 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
12052 { IBM280 CP280 ebcdic-cp-it csIBM280 }
12053 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
12054 { IBM284 CP284 ebcdic-cp-es csIBM284 }
12055 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
12056 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
12057 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
12058 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
12059 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
12060 { IBM424 cp424 ebcdic-cp-he csIBM424 }
12061 { IBM437 cp437 437 csPC8CodePage437 }
12062 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
12063 { IBM775 cp775 csPC775Baltic }
12064 { IBM850 cp850 850 csPC850Multilingual }
12065 { IBM851 cp851 851 csIBM851 }
12066 { IBM852 cp852 852 csPCp852 }
12067 { IBM855 cp855 855 csIBM855 }
12068 { IBM857 cp857 857 csIBM857 }
12069 { IBM860 cp860 860 csIBM860 }
12070 { IBM861 cp861 861 cp-is csIBM861 }
12071 { IBM862 cp862 862 csPC862LatinHebrew }
12072 { IBM863 cp863 863 csIBM863 }
12073 { IBM864 cp864 csIBM864 }
12074 { IBM865 cp865 865 csIBM865 }
12075 { IBM866 cp866 866 csIBM866 }
12076 { IBM868 CP868 cp-ar csIBM868 }
12077 { IBM869 cp869 869 cp-gr csIBM869 }
12078 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
12079 { IBM871 CP871 ebcdic-cp-is csIBM871 }
12080 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
12081 { IBM891 cp891 csIBM891 }
12082 { IBM903 cp903 csIBM903 }
12083 { IBM904 cp904 904 csIBBM904 }
12084 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
12085 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
12086 { IBM1026 CP1026 csIBM1026 }
12087 { EBCDIC-AT-DE csIBMEBCDICATDE }
12088 { EBCDIC-AT-DE-A csEBCDICATDEA }
12089 { EBCDIC-CA-FR csEBCDICCAFR }
12090 { EBCDIC-DK-NO csEBCDICDKNO }
12091 { EBCDIC-DK-NO-A csEBCDICDKNOA }
12092 { EBCDIC-FI-SE csEBCDICFISE }
12093 { EBCDIC-FI-SE-A csEBCDICFISEA }
12094 { EBCDIC-FR csEBCDICFR }
12095 { EBCDIC-IT csEBCDICIT }
12096 { EBCDIC-PT csEBCDICPT }
12097 { EBCDIC-ES csEBCDICES }
12098 { EBCDIC-ES-A csEBCDICESA }
12099 { EBCDIC-ES-S csEBCDICESS }
12100 { EBCDIC-UK csEBCDICUK }
12101 { EBCDIC-US csEBCDICUS }
12102 { UNKNOWN-8BIT csUnknown8BiT }
12103 { MNEMONIC csMnemonic }
12104 { MNEM csMnem }
12105 { VISCII csVISCII }
12106 { VIQR csVIQR }
12107 { KOI8-R csKOI8R }
12108 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
12109 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
12110 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
12111 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
12112 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
12113 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
12114 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
12115 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
12116 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
12117 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
12118 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
12119 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
12120 { IBM1047 IBM-1047 }
12121 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
12122 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
12123 { UNICODE-1-1 csUnicode11 }
12124 { CESU-8 csCESU-8 }
12125 { BOCU-1 csBOCU-1 }
12126 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
12127 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
12128 l8 }
12129 { ISO-8859-15 ISO_8859-15 Latin-9 }
12130 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
12131 { GBK CP936 MS936 windows-936 }
12132 { JIS_Encoding csJISEncoding }
12133 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
12134 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
12135 EUC-JP }
12136 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
12137 { ISO-10646-UCS-Basic csUnicodeASCII }
12138 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
12139 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
12140 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
12141 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
12142 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
12143 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
12144 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
12145 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
12146 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
12147 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
12148 { Adobe-Standard-Encoding csAdobeStandardEncoding }
12149 { Ventura-US csVenturaUS }
12150 { Ventura-International csVenturaInternational }
12151 { PC8-Danish-Norwegian csPC8DanishNorwegian }
12152 { PC8-Turkish csPC8Turkish }
12153 { IBM-Symbols csIBMSymbols }
12154 { IBM-Thai csIBMThai }
12155 { HP-Legal csHPLegal }
12156 { HP-Pi-font csHPPiFont }
12157 { HP-Math8 csHPMath8 }
12158 { Adobe-Symbol-Encoding csHPPSMath }
12159 { HP-DeskTop csHPDesktop }
12160 { Ventura-Math csVenturaMath }
12161 { Microsoft-Publishing csMicrosoftPublishing }
12162 { Windows-31J csWindows31J }
12163 { GB2312 csGB2312 }
12164 { Big5 csBig5 }
12167 proc tcl_encoding {enc} {
12168 global encoding_aliases tcl_encoding_cache
12169 if {[info exists tcl_encoding_cache($enc)]} {
12170 return $tcl_encoding_cache($enc)
12172 set names [encoding names]
12173 set lcnames [string tolower $names]
12174 set enc [string tolower $enc]
12175 set i [lsearch -exact $lcnames $enc]
12176 if {$i < 0} {
12177 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
12178 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
12179 set i [lsearch -exact $lcnames $encx]
12182 if {$i < 0} {
12183 foreach l $encoding_aliases {
12184 set ll [string tolower $l]
12185 if {[lsearch -exact $ll $enc] < 0} continue
12186 # look through the aliases for one that tcl knows about
12187 foreach e $ll {
12188 set i [lsearch -exact $lcnames $e]
12189 if {$i < 0} {
12190 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
12191 set i [lsearch -exact $lcnames $ex]
12194 if {$i >= 0} break
12196 break
12199 set tclenc {}
12200 if {$i >= 0} {
12201 set tclenc [lindex $names $i]
12203 set tcl_encoding_cache($enc) $tclenc
12204 return $tclenc
12207 proc gitattr {path attr default} {
12208 global path_attr_cache
12209 if {[info exists path_attr_cache($attr,$path)]} {
12210 set r $path_attr_cache($attr,$path)
12211 } else {
12212 set r "unspecified"
12213 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
12214 regexp "(.*): $attr: (.*)" $line m f r
12216 set path_attr_cache($attr,$path) $r
12218 if {$r eq "unspecified"} {
12219 return $default
12221 return $r
12224 proc cache_gitattr {attr pathlist} {
12225 global path_attr_cache
12226 set newlist {}
12227 foreach path $pathlist {
12228 if {![info exists path_attr_cache($attr,$path)]} {
12229 lappend newlist $path
12232 set lim 1000
12233 if {[tk windowingsystem] == "win32"} {
12234 # windows has a 32k limit on the arguments to a command...
12235 set lim 30
12237 while {$newlist ne {}} {
12238 set head [lrange $newlist 0 [expr {$lim - 1}]]
12239 set newlist [lrange $newlist $lim end]
12240 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
12241 foreach row [split $rlist "\n"] {
12242 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12243 if {[string index $path 0] eq "\""} {
12244 set path [encoding convertfrom [lindex $path 0]]
12246 set path_attr_cache($attr,$path) $value
12253 proc get_path_encoding {path} {
12254 global gui_encoding perfile_attrs
12255 set tcl_enc $gui_encoding
12256 if {$path ne {} && $perfile_attrs} {
12257 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12258 if {$enc2 ne {}} {
12259 set tcl_enc $enc2
12262 return $tcl_enc
12265 ## For msgcat loading, first locate the installation location.
12266 if { [info exists ::env(GITK_MSGSDIR)] } {
12267 ## Msgsdir was manually set in the environment.
12268 set gitk_msgsdir $::env(GITK_MSGSDIR)
12269 } else {
12270 ## Let's guess the prefix from argv0.
12271 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12272 set gitk_libdir [file join $gitk_prefix share gitk lib]
12273 set gitk_msgsdir [file join $gitk_libdir msgs]
12274 unset gitk_prefix
12277 ## Internationalization (i18n) through msgcat and gettext. See
12278 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12279 package require msgcat
12280 namespace import ::msgcat::mc
12281 ## And eventually load the actual message catalog
12282 ::msgcat::mcload $gitk_msgsdir
12284 # First check that Tcl/Tk is recent enough
12285 if {[catch {package require Tk 8.4} err]} {
12286 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12287 Gitk requires at least Tcl/Tk 8.4."]
12288 exit 1
12291 # on OSX bring the current Wish process window to front
12292 if {[tk windowingsystem] eq "aqua"} {
12293 exec osascript -e [format {
12294 tell application "System Events"
12295 set frontmost of processes whose unix id is %d to true
12296 end tell
12297 } [pid] ]
12300 # Unset GIT_TRACE var if set
12301 if { [info exists ::env(GIT_TRACE)] } {
12302 unset ::env(GIT_TRACE)
12305 # defaults...
12306 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12308 set gitencoding {}
12309 catch {
12310 set gitencoding [exec git config --get i18n.commitencoding]
12312 catch {
12313 set gitencoding [exec git config --get i18n.logoutputencoding]
12315 if {$gitencoding == ""} {
12316 set gitencoding "utf-8"
12318 set tclencoding [tcl_encoding $gitencoding]
12319 if {$tclencoding == {}} {
12320 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12323 set gui_encoding [encoding system]
12324 catch {
12325 set enc [exec git config --get gui.encoding]
12326 if {$enc ne {}} {
12327 set tclenc [tcl_encoding $enc]
12328 if {$tclenc ne {}} {
12329 set gui_encoding $tclenc
12330 } else {
12331 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12336 set log_showroot true
12337 catch {
12338 set log_showroot [exec git config --bool --get log.showroot]
12341 if {[tk windowingsystem] eq "aqua"} {
12342 set mainfont {{Lucida Grande} 9}
12343 set textfont {Monaco 9}
12344 set uifont {{Lucida Grande} 9 bold}
12345 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12346 # fontconfig!
12347 set mainfont {sans 9}
12348 set textfont {monospace 9}
12349 set uifont {sans 9 bold}
12350 } else {
12351 set mainfont {Helvetica 9}
12352 set textfont {Courier 9}
12353 set uifont {Helvetica 9 bold}
12355 set tabstop 8
12356 set findmergefiles 0
12357 set maxgraphpct 50
12358 set maxwidth 16
12359 set revlistorder 0
12360 set fastdate 0
12361 set uparrowlen 5
12362 set downarrowlen 5
12363 set mingaplen 100
12364 set cmitmode "patch"
12365 set wrapcomment "none"
12366 set showneartags 1
12367 set hideremotes 0
12368 set maxrefs 20
12369 set visiblerefs {"master"}
12370 set maxlinelen 200
12371 set showlocalchanges 1
12372 set limitdiffs 1
12373 set datetimeformat "%Y-%m-%d %H:%M:%S"
12374 set autoselect 1
12375 set autosellen 40
12376 set perfile_attrs 0
12377 set want_ttk 1
12379 if {[tk windowingsystem] eq "aqua"} {
12380 set extdifftool "opendiff"
12381 } else {
12382 set extdifftool "meld"
12385 set colors {"#00ff00" red blue magenta darkgrey brown orange}
12386 if {[tk windowingsystem] eq "win32"} {
12387 set uicolor SystemButtonFace
12388 set uifgcolor SystemButtonText
12389 set uifgdisabledcolor SystemDisabledText
12390 set bgcolor SystemWindow
12391 set fgcolor SystemWindowText
12392 set selectbgcolor SystemHighlight
12393 set web_browser "cmd /c start"
12394 } else {
12395 set uicolor grey85
12396 set uifgcolor black
12397 set uifgdisabledcolor "#999"
12398 set bgcolor white
12399 set fgcolor black
12400 set selectbgcolor gray85
12401 if {[tk windowingsystem] eq "aqua"} {
12402 set web_browser "open"
12403 } else {
12404 set web_browser "xdg-open"
12407 set diffcolors {"#c30000" "#009800" blue}
12408 set diffbgcolors {"#fff3f3" "#f0fff0"}
12409 set diffcontext 3
12410 set mergecolors {red blue "#00ff00" purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12411 set ignorespace 0
12412 set worddiff ""
12413 set markbgcolor "#e0e0ff"
12415 set headbgcolor "#00ff00"
12416 set headfgcolor black
12417 set headoutlinecolor black
12418 set remotebgcolor #ffddaa
12419 set tagbgcolor yellow
12420 set tagfgcolor black
12421 set tagoutlinecolor black
12422 set reflinecolor black
12423 set filesepbgcolor #aaaaaa
12424 set filesepfgcolor black
12425 set linehoverbgcolor #ffff80
12426 set linehoverfgcolor black
12427 set linehoveroutlinecolor black
12428 set mainheadcirclecolor yellow
12429 set workingfilescirclecolor red
12430 set indexcirclecolor "#00ff00"
12431 set circlecolors {white blue gray blue blue}
12432 set linkfgcolor blue
12433 set circleoutlinecolor $fgcolor
12434 set foundbgcolor yellow
12435 set currentsearchhitbgcolor orange
12437 # button for popping up context menus
12438 if {[tk windowingsystem] eq "aqua"} {
12439 set ctxbut <Button-2>
12440 } else {
12441 set ctxbut <Button-3>
12444 catch {
12445 # follow the XDG base directory specification by default. See
12446 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12447 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12448 # XDG_CONFIG_HOME environment variable is set
12449 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12450 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12451 } else {
12452 # default XDG_CONFIG_HOME
12453 set config_file "~/.config/git/gitk"
12454 set config_file_tmp "~/.config/git/gitk-tmp"
12456 if {![file exists $config_file]} {
12457 # for backward compatibility use the old config file if it exists
12458 if {[file exists "~/.gitk"]} {
12459 set config_file "~/.gitk"
12460 set config_file_tmp "~/.gitk-tmp"
12461 } elseif {![file exists [file dirname $config_file]]} {
12462 file mkdir [file dirname $config_file]
12465 source $config_file
12467 config_check_tmp_exists 50
12469 set config_variables {
12470 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12471 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12472 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12473 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12474 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12475 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12476 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12477 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12478 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12479 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor diffbgcolors
12480 web_browser
12482 foreach var $config_variables {
12483 config_init_trace $var
12484 trace add variable $var write config_variable_change_cb
12487 parsefont mainfont $mainfont
12488 eval font create mainfont [fontflags mainfont]
12489 eval font create mainfontbold [fontflags mainfont 1]
12491 parsefont textfont $textfont
12492 eval font create textfont [fontflags textfont]
12493 eval font create textfontbold [fontflags textfont 1]
12495 parsefont uifont $uifont
12496 eval font create uifont [fontflags uifont]
12498 setui $uicolor
12500 setoptions
12502 # check that we can find a .git directory somewhere...
12503 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12504 show_error {} . [mc "Cannot find a git repository here."]
12505 exit 1
12508 set selecthead {}
12509 set selectheadid {}
12511 set revtreeargs {}
12512 set cmdline_files {}
12513 set i 0
12514 set revtreeargscmd {}
12515 foreach arg $argv {
12516 switch -glob -- $arg {
12517 "" { }
12518 "--" {
12519 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12520 break
12522 "--select-commit=*" {
12523 set selecthead [string range $arg 16 end]
12525 "--argscmd=*" {
12526 set revtreeargscmd [string range $arg 10 end]
12528 default {
12529 lappend revtreeargs $arg
12532 incr i
12535 if {$selecthead eq "HEAD"} {
12536 set selecthead {}
12539 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12540 # no -- on command line, but some arguments (other than --argscmd)
12541 if {[catch {
12542 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12543 set cmdline_files [split $f "\n"]
12544 set n [llength $cmdline_files]
12545 set revtreeargs [lrange $revtreeargs 0 end-$n]
12546 # Unfortunately git rev-parse doesn't produce an error when
12547 # something is both a revision and a filename. To be consistent
12548 # with git log and git rev-list, check revtreeargs for filenames.
12549 foreach arg $revtreeargs {
12550 if {[file exists $arg]} {
12551 show_error {} . [mc "Ambiguous argument '%s': both revision\
12552 and filename" $arg]
12553 exit 1
12556 } err]} {
12557 # unfortunately we get both stdout and stderr in $err,
12558 # so look for "fatal:".
12559 set i [string first "fatal:" $err]
12560 if {$i > 0} {
12561 set err [string range $err [expr {$i + 6}] end]
12563 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12564 exit 1
12568 set nullid "0000000000000000000000000000000000000000"
12569 set nullid2 "0000000000000000000000000000000000000001"
12570 set nullfile "/dev/null"
12572 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12573 if {![info exists have_ttk]} {
12574 set have_ttk [llength [info commands ::ttk::style]]
12576 set use_ttk [expr {$have_ttk && $want_ttk}]
12577 set NS [expr {$use_ttk ? "ttk" : ""}]
12579 if {$use_ttk} {
12580 setttkstyle
12583 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12585 set show_notes {}
12586 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12587 set show_notes "--show-notes"
12590 set appname "gitk"
12592 set runq {}
12593 set history {}
12594 set historyindex 0
12595 set fh_serial 0
12596 set nhl_names {}
12597 set highlight_paths {}
12598 set findpattern {}
12599 set searchdirn -forwards
12600 set boldids {}
12601 set boldnameids {}
12602 set diffelide {0 0}
12603 set markingmatches 0
12604 set linkentercount 0
12605 set need_redisplay 0
12606 set nrows_drawn 0
12607 set firsttabstop 0
12609 set nextviewnum 1
12610 set curview 0
12611 set selectedview 0
12612 set selectedhlview [mc "None"]
12613 set highlight_related [mc "None"]
12614 set highlight_files {}
12615 set viewfiles(0) {}
12616 set viewperm(0) 0
12617 set viewchanged(0) 0
12618 set viewargs(0) {}
12619 set viewargscmd(0) {}
12621 set selectedline {}
12622 set numcommits 0
12623 set loginstance 0
12624 set cmdlineok 0
12625 set stopped 0
12626 set stuffsaved 0
12627 set patchnum 0
12628 set lserial 0
12629 set hasworktree [hasworktree]
12630 set cdup {}
12631 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12632 set cdup [exec git rev-parse --show-cdup]
12634 set worktree [gitworktree]
12635 setcoords
12636 makewindow
12637 catch {
12638 image create photo gitlogo -width 16 -height 16
12640 image create photo gitlogominus -width 4 -height 2
12641 gitlogominus put #C00000 -to 0 0 4 2
12642 gitlogo copy gitlogominus -to 1 5
12643 gitlogo copy gitlogominus -to 6 5
12644 gitlogo copy gitlogominus -to 11 5
12645 image delete gitlogominus
12647 image create photo gitlogoplus -width 4 -height 4
12648 gitlogoplus put #008000 -to 1 0 3 4
12649 gitlogoplus put #008000 -to 0 1 4 3
12650 gitlogo copy gitlogoplus -to 1 9
12651 gitlogo copy gitlogoplus -to 6 9
12652 gitlogo copy gitlogoplus -to 11 9
12653 image delete gitlogoplus
12655 image create photo gitlogo32 -width 32 -height 32
12656 gitlogo32 copy gitlogo -zoom 2 2
12658 wm iconphoto . -default gitlogo gitlogo32
12660 # wait for the window to become visible
12661 tkwait visibility .
12662 set_window_title
12663 update
12664 readrefs
12666 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12667 # create a view for the files/dirs specified on the command line
12668 set curview 1
12669 set selectedview 1
12670 set nextviewnum 2
12671 set viewname(1) [mc "Command line"]
12672 set viewfiles(1) $cmdline_files
12673 set viewargs(1) $revtreeargs
12674 set viewargscmd(1) $revtreeargscmd
12675 set viewperm(1) 0
12676 set viewchanged(1) 0
12677 set vdatemode(1) 0
12678 addviewmenu 1
12679 .bar.view entryconf [mca "&Edit view..."] -state normal
12680 .bar.view entryconf [mca "&Delete view"] -state normal
12683 if {[info exists permviews]} {
12684 foreach v $permviews {
12685 set n $nextviewnum
12686 incr nextviewnum
12687 set viewname($n) [lindex $v 0]
12688 set viewfiles($n) [lindex $v 1]
12689 set viewargs($n) [lindex $v 2]
12690 set viewargscmd($n) [lindex $v 3]
12691 set viewperm($n) 1
12692 set viewchanged($n) 0
12693 addviewmenu $n
12697 if {[tk windowingsystem] eq "win32"} {
12698 focus -force .
12701 getcommits {}
12703 # Local variables:
12704 # mode: tcl
12705 # indent-tabs-mode: t
12706 # tab-width: 8
12707 # End: