gitk: Work around empty back and forward images when buttons are disabled
[git/mingw/j6t.git] / gitk
blob379582a5f763e37ade59622794bfba3c2e391078
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2011 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 package require Tk
12 proc hasworktree {} {
13 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
14 [exec git rev-parse --is-inside-git-dir] == "false"}]
17 proc reponame {} {
18 global gitdir
19 set n [file normalize $gitdir]
20 if {[string match "*/.git" $n]} {
21 set n [string range $n 0 end-5]
23 return [file tail $n]
26 proc gitworktree {} {
27 variable _gitworktree
28 if {[info exists _gitworktree]} {
29 return $_gitworktree
31 # v1.7.0 introduced --show-toplevel to return the canonical work-tree
32 if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
33 # try to set work tree from environment, core.worktree or use
34 # cdup to obtain a relative path to the top of the worktree. If
35 # run from the top, the ./ prefix ensures normalize expands pwd.
36 if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
37 catch {set _gitworktree [exec git config --get core.worktree]}
38 if {$_gitworktree eq ""} {
39 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
43 return $_gitworktree
46 # A simple scheduler for compute-intensive stuff.
47 # The aim is to make sure that event handlers for GUI actions can
48 # run at least every 50-100 ms. Unfortunately fileevent handlers are
49 # run before X event handlers, so reading from a fast source can
50 # make the GUI completely unresponsive.
51 proc run args {
52 global isonrunq runq currunq
54 set script $args
55 if {[info exists isonrunq($script)]} return
56 if {$runq eq {} && ![info exists currunq]} {
57 after idle dorunq
59 lappend runq [list {} $script]
60 set isonrunq($script) 1
63 proc filerun {fd script} {
64 fileevent $fd readable [list filereadable $fd $script]
67 proc filereadable {fd script} {
68 global runq currunq
70 fileevent $fd readable {}
71 if {$runq eq {} && ![info exists currunq]} {
72 after idle dorunq
74 lappend runq [list $fd $script]
77 proc nukefile {fd} {
78 global runq
80 for {set i 0} {$i < [llength $runq]} {} {
81 if {[lindex $runq $i 0] eq $fd} {
82 set runq [lreplace $runq $i $i]
83 } else {
84 incr i
89 proc dorunq {} {
90 global isonrunq runq currunq
92 set tstart [clock clicks -milliseconds]
93 set t0 $tstart
94 while {[llength $runq] > 0} {
95 set fd [lindex $runq 0 0]
96 set script [lindex $runq 0 1]
97 set currunq [lindex $runq 0]
98 set runq [lrange $runq 1 end]
99 set repeat [eval $script]
100 unset currunq
101 set t1 [clock clicks -milliseconds]
102 set t [expr {$t1 - $t0}]
103 if {$repeat ne {} && $repeat} {
104 if {$fd eq {} || $repeat == 2} {
105 # script returns 1 if it wants to be readded
106 # file readers return 2 if they could do more straight away
107 lappend runq [list $fd $script]
108 } else {
109 fileevent $fd readable [list filereadable $fd $script]
111 } elseif {$fd eq {}} {
112 unset isonrunq($script)
114 set t0 $t1
115 if {$t1 - $tstart >= 80} break
117 if {$runq ne {}} {
118 after idle dorunq
122 proc reg_instance {fd} {
123 global commfd leftover loginstance
125 set i [incr loginstance]
126 set commfd($i) $fd
127 set leftover($i) {}
128 return $i
131 proc unmerged_files {files} {
132 global nr_unmerged
134 # find the list of unmerged files
135 set mlist {}
136 set nr_unmerged 0
137 if {[catch {
138 set fd [open "| git ls-files -u" r]
139 } err]} {
140 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
141 exit 1
143 while {[gets $fd line] >= 0} {
144 set i [string first "\t" $line]
145 if {$i < 0} continue
146 set fname [string range $line [expr {$i+1}] end]
147 if {[lsearch -exact $mlist $fname] >= 0} continue
148 incr nr_unmerged
149 if {$files eq {} || [path_filter $files $fname]} {
150 lappend mlist $fname
153 catch {close $fd}
154 return $mlist
157 proc parseviewargs {n arglist} {
158 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
159 global worddiff git_version
161 set vdatemode($n) 0
162 set vmergeonly($n) 0
163 set glflags {}
164 set diffargs {}
165 set nextisval 0
166 set revargs {}
167 set origargs $arglist
168 set allknown 1
169 set filtered 0
170 set i -1
171 foreach arg $arglist {
172 incr i
173 if {$nextisval} {
174 lappend glflags $arg
175 set nextisval 0
176 continue
178 switch -glob -- $arg {
179 "-d" -
180 "--date-order" {
181 set vdatemode($n) 1
182 # remove from origargs in case we hit an unknown option
183 set origargs [lreplace $origargs $i $i]
184 incr i -1
186 "-[puabwcrRBMC]" -
187 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
188 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
189 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
190 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
191 "--ignore-space-change" - "-U*" - "--unified=*" {
192 # These request or affect diff output, which we don't want.
193 # Some could be used to set our defaults for diff display.
194 lappend diffargs $arg
196 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
197 "--name-only" - "--name-status" - "--color" -
198 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
199 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
200 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
201 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
202 "--objects" - "--objects-edge" - "--reverse" {
203 # These cause our parsing of git log's output to fail, or else
204 # they're options we want to set ourselves, so ignore them.
206 "--color-words*" - "--word-diff=color" {
207 # These trigger a word diff in the console interface,
208 # so help the user by enabling our own support
209 if {[package vcompare $git_version "1.7.2"] >= 0} {
210 set worddiff [mc "Color words"]
213 "--word-diff*" {
214 if {[package vcompare $git_version "1.7.2"] >= 0} {
215 set worddiff [mc "Markup words"]
218 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
219 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
220 "--full-history" - "--dense" - "--sparse" -
221 "--follow" - "--left-right" - "--encoding=*" {
222 # These are harmless, and some are even useful
223 lappend glflags $arg
225 "--diff-filter=*" - "--no-merges" - "--unpacked" -
226 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
227 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
228 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
229 "--remove-empty" - "--first-parent" - "--cherry-pick" -
230 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
231 "--simplify-by-decoration" {
232 # These mean that we get a subset of the commits
233 set filtered 1
234 lappend glflags $arg
236 "-n" {
237 # This appears to be the only one that has a value as a
238 # separate word following it
239 set filtered 1
240 set nextisval 1
241 lappend glflags $arg
243 "--not" - "--all" {
244 lappend revargs $arg
246 "--merge" {
247 set vmergeonly($n) 1
248 # git rev-parse doesn't understand --merge
249 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
251 "--no-replace-objects" {
252 set env(GIT_NO_REPLACE_OBJECTS) "1"
254 "-*" {
255 # Other flag arguments including -<n>
256 if {[string is digit -strict [string range $arg 1 end]]} {
257 set filtered 1
258 } else {
259 # a flag argument that we don't recognize;
260 # that means we can't optimize
261 set allknown 0
263 lappend glflags $arg
265 default {
266 # Non-flag arguments specify commits or ranges of commits
267 if {[string match "*...*" $arg]} {
268 lappend revargs --gitk-symmetric-diff-marker
270 lappend revargs $arg
274 set vdflags($n) $diffargs
275 set vflags($n) $glflags
276 set vrevs($n) $revargs
277 set vfiltered($n) $filtered
278 set vorigargs($n) $origargs
279 return $allknown
282 proc parseviewrevs {view revs} {
283 global vposids vnegids
285 if {$revs eq {}} {
286 set revs HEAD
288 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
289 # we get stdout followed by stderr in $err
290 # for an unknown rev, git rev-parse echoes it and then errors out
291 set errlines [split $err "\n"]
292 set badrev {}
293 for {set l 0} {$l < [llength $errlines]} {incr l} {
294 set line [lindex $errlines $l]
295 if {!([string length $line] == 40 && [string is xdigit $line])} {
296 if {[string match "fatal:*" $line]} {
297 if {[string match "fatal: ambiguous argument*" $line]
298 && $badrev ne {}} {
299 if {[llength $badrev] == 1} {
300 set err "unknown revision $badrev"
301 } else {
302 set err "unknown revisions: [join $badrev ", "]"
304 } else {
305 set err [join [lrange $errlines $l end] "\n"]
307 break
309 lappend badrev $line
312 error_popup "[mc "Error parsing revisions:"] $err"
313 return {}
315 set ret {}
316 set pos {}
317 set neg {}
318 set sdm 0
319 foreach id [split $ids "\n"] {
320 if {$id eq "--gitk-symmetric-diff-marker"} {
321 set sdm 4
322 } elseif {[string match "^*" $id]} {
323 if {$sdm != 1} {
324 lappend ret $id
325 if {$sdm == 3} {
326 set sdm 0
329 lappend neg [string range $id 1 end]
330 } else {
331 if {$sdm != 2} {
332 lappend ret $id
333 } else {
334 lset ret end $id...[lindex $ret end]
336 lappend pos $id
338 incr sdm -1
340 set vposids($view) $pos
341 set vnegids($view) $neg
342 return $ret
345 # Start off a git log process and arrange to read its output
346 proc start_rev_list {view} {
347 global startmsecs commitidx viewcomplete curview
348 global tclencoding
349 global viewargs viewargscmd viewfiles vfilelimit
350 global showlocalchanges
351 global viewactive viewinstances vmergeonly
352 global mainheadid viewmainheadid viewmainheadid_orig
353 global vcanopt vflags vrevs vorigargs
354 global show_notes
356 set startmsecs [clock clicks -milliseconds]
357 set commitidx($view) 0
358 # these are set this way for the error exits
359 set viewcomplete($view) 1
360 set viewactive($view) 0
361 varcinit $view
363 set args $viewargs($view)
364 if {$viewargscmd($view) ne {}} {
365 if {[catch {
366 set str [exec sh -c $viewargscmd($view)]
367 } err]} {
368 error_popup "[mc "Error executing --argscmd command:"] $err"
369 return 0
371 set args [concat $args [split $str "\n"]]
373 set vcanopt($view) [parseviewargs $view $args]
375 set files $viewfiles($view)
376 if {$vmergeonly($view)} {
377 set files [unmerged_files $files]
378 if {$files eq {}} {
379 global nr_unmerged
380 if {$nr_unmerged == 0} {
381 error_popup [mc "No files selected: --merge specified but\
382 no files are unmerged."]
383 } else {
384 error_popup [mc "No files selected: --merge specified but\
385 no unmerged files are within file limit."]
387 return 0
390 set vfilelimit($view) $files
392 if {$vcanopt($view)} {
393 set revs [parseviewrevs $view $vrevs($view)]
394 if {$revs eq {}} {
395 return 0
397 set args [concat $vflags($view) $revs]
398 } else {
399 set args $vorigargs($view)
402 if {[catch {
403 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
404 --parents --boundary $args "--" $files] r]
405 } err]} {
406 error_popup "[mc "Error executing git log:"] $err"
407 return 0
409 set i [reg_instance $fd]
410 set viewinstances($view) [list $i]
411 set viewmainheadid($view) $mainheadid
412 set viewmainheadid_orig($view) $mainheadid
413 if {$files ne {} && $mainheadid ne {}} {
414 get_viewmainhead $view
416 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
417 interestedin $viewmainheadid($view) dodiffindex
419 fconfigure $fd -blocking 0 -translation lf -eofchar {}
420 if {$tclencoding != {}} {
421 fconfigure $fd -encoding $tclencoding
423 filerun $fd [list getcommitlines $fd $i $view 0]
424 nowbusy $view [mc "Reading"]
425 set viewcomplete($view) 0
426 set viewactive($view) 1
427 return 1
430 proc stop_instance {inst} {
431 global commfd leftover
433 set fd $commfd($inst)
434 catch {
435 set pid [pid $fd]
437 if {$::tcl_platform(platform) eq {windows}} {
438 exec kill -f $pid
439 } else {
440 exec kill $pid
443 catch {close $fd}
444 nukefile $fd
445 unset commfd($inst)
446 unset leftover($inst)
449 proc stop_backends {} {
450 global commfd
452 foreach inst [array names commfd] {
453 stop_instance $inst
457 proc stop_rev_list {view} {
458 global viewinstances
460 foreach inst $viewinstances($view) {
461 stop_instance $inst
463 set viewinstances($view) {}
466 proc reset_pending_select {selid} {
467 global pending_select mainheadid selectheadid
469 if {$selid ne {}} {
470 set pending_select $selid
471 } elseif {$selectheadid ne {}} {
472 set pending_select $selectheadid
473 } else {
474 set pending_select $mainheadid
478 proc getcommits {selid} {
479 global canv curview need_redisplay viewactive
481 initlayout
482 if {[start_rev_list $curview]} {
483 reset_pending_select $selid
484 show_status [mc "Reading commits..."]
485 set need_redisplay 1
486 } else {
487 show_status [mc "No commits selected"]
491 proc updatecommits {} {
492 global curview vcanopt vorigargs vfilelimit viewinstances
493 global viewactive viewcomplete tclencoding
494 global startmsecs showneartags showlocalchanges
495 global mainheadid viewmainheadid viewmainheadid_orig pending_select
496 global hasworktree
497 global varcid vposids vnegids vflags vrevs
498 global show_notes
500 set hasworktree [hasworktree]
501 rereadrefs
502 set view $curview
503 if {$mainheadid ne $viewmainheadid_orig($view)} {
504 if {$showlocalchanges} {
505 dohidelocalchanges
507 set viewmainheadid($view) $mainheadid
508 set viewmainheadid_orig($view) $mainheadid
509 if {$vfilelimit($view) ne {}} {
510 get_viewmainhead $view
513 if {$showlocalchanges} {
514 doshowlocalchanges
516 if {$vcanopt($view)} {
517 set oldpos $vposids($view)
518 set oldneg $vnegids($view)
519 set revs [parseviewrevs $view $vrevs($view)]
520 if {$revs eq {}} {
521 return
523 # note: getting the delta when negative refs change is hard,
524 # and could require multiple git log invocations, so in that
525 # case we ask git log for all the commits (not just the delta)
526 if {$oldneg eq $vnegids($view)} {
527 set newrevs {}
528 set npos 0
529 # take out positive refs that we asked for before or
530 # that we have already seen
531 foreach rev $revs {
532 if {[string length $rev] == 40} {
533 if {[lsearch -exact $oldpos $rev] < 0
534 && ![info exists varcid($view,$rev)]} {
535 lappend newrevs $rev
536 incr npos
538 } else {
539 lappend $newrevs $rev
542 if {$npos == 0} return
543 set revs $newrevs
544 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
546 set args [concat $vflags($view) $revs --not $oldpos]
547 } else {
548 set args $vorigargs($view)
550 if {[catch {
551 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
552 --parents --boundary $args "--" $vfilelimit($view)] r]
553 } err]} {
554 error_popup "[mc "Error executing git log:"] $err"
555 return
557 if {$viewactive($view) == 0} {
558 set startmsecs [clock clicks -milliseconds]
560 set i [reg_instance $fd]
561 lappend viewinstances($view) $i
562 fconfigure $fd -blocking 0 -translation lf -eofchar {}
563 if {$tclencoding != {}} {
564 fconfigure $fd -encoding $tclencoding
566 filerun $fd [list getcommitlines $fd $i $view 1]
567 incr viewactive($view)
568 set viewcomplete($view) 0
569 reset_pending_select {}
570 nowbusy $view [mc "Reading"]
571 if {$showneartags} {
572 getallcommits
576 proc reloadcommits {} {
577 global curview viewcomplete selectedline currentid thickerline
578 global showneartags treediffs commitinterest cached_commitrow
579 global targetid
581 set selid {}
582 if {$selectedline ne {}} {
583 set selid $currentid
586 if {!$viewcomplete($curview)} {
587 stop_rev_list $curview
589 resetvarcs $curview
590 set selectedline {}
591 catch {unset currentid}
592 catch {unset thickerline}
593 catch {unset treediffs}
594 readrefs
595 changedrefs
596 if {$showneartags} {
597 getallcommits
599 clear_display
600 catch {unset commitinterest}
601 catch {unset cached_commitrow}
602 catch {unset targetid}
603 setcanvscroll
604 getcommits $selid
605 return 0
608 # This makes a string representation of a positive integer which
609 # sorts as a string in numerical order
610 proc strrep {n} {
611 if {$n < 16} {
612 return [format "%x" $n]
613 } elseif {$n < 256} {
614 return [format "x%.2x" $n]
615 } elseif {$n < 65536} {
616 return [format "y%.4x" $n]
618 return [format "z%.8x" $n]
621 # Procedures used in reordering commits from git log (without
622 # --topo-order) into the order for display.
624 proc varcinit {view} {
625 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
626 global vtokmod varcmod vrowmod varcix vlastins
628 set varcstart($view) {{}}
629 set vupptr($view) {0}
630 set vdownptr($view) {0}
631 set vleftptr($view) {0}
632 set vbackptr($view) {0}
633 set varctok($view) {{}}
634 set varcrow($view) {{}}
635 set vtokmod($view) {}
636 set varcmod($view) 0
637 set vrowmod($view) 0
638 set varcix($view) {{}}
639 set vlastins($view) {0}
642 proc resetvarcs {view} {
643 global varcid varccommits parents children vseedcount ordertok
644 global vshortids
646 foreach vid [array names varcid $view,*] {
647 unset varcid($vid)
648 unset children($vid)
649 unset parents($vid)
651 foreach vid [array names vshortids $view,*] {
652 unset vshortids($vid)
654 # some commits might have children but haven't been seen yet
655 foreach vid [array names children $view,*] {
656 unset children($vid)
658 foreach va [array names varccommits $view,*] {
659 unset varccommits($va)
661 foreach vd [array names vseedcount $view,*] {
662 unset vseedcount($vd)
664 catch {unset ordertok}
667 # returns a list of the commits with no children
668 proc seeds {v} {
669 global vdownptr vleftptr varcstart
671 set ret {}
672 set a [lindex $vdownptr($v) 0]
673 while {$a != 0} {
674 lappend ret [lindex $varcstart($v) $a]
675 set a [lindex $vleftptr($v) $a]
677 return $ret
680 proc newvarc {view id} {
681 global varcid varctok parents children vdatemode
682 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
683 global commitdata commitinfo vseedcount varccommits vlastins
685 set a [llength $varctok($view)]
686 set vid $view,$id
687 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
688 if {![info exists commitinfo($id)]} {
689 parsecommit $id $commitdata($id) 1
691 set cdate [lindex [lindex $commitinfo($id) 4] 0]
692 if {![string is integer -strict $cdate]} {
693 set cdate 0
695 if {![info exists vseedcount($view,$cdate)]} {
696 set vseedcount($view,$cdate) -1
698 set c [incr vseedcount($view,$cdate)]
699 set cdate [expr {$cdate ^ 0xffffffff}]
700 set tok "s[strrep $cdate][strrep $c]"
701 } else {
702 set tok {}
704 set ka 0
705 if {[llength $children($vid)] > 0} {
706 set kid [lindex $children($vid) end]
707 set k $varcid($view,$kid)
708 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
709 set ki $kid
710 set ka $k
711 set tok [lindex $varctok($view) $k]
714 if {$ka != 0} {
715 set i [lsearch -exact $parents($view,$ki) $id]
716 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
717 append tok [strrep $j]
719 set c [lindex $vlastins($view) $ka]
720 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
721 set c $ka
722 set b [lindex $vdownptr($view) $ka]
723 } else {
724 set b [lindex $vleftptr($view) $c]
726 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
727 set c $b
728 set b [lindex $vleftptr($view) $c]
730 if {$c == $ka} {
731 lset vdownptr($view) $ka $a
732 lappend vbackptr($view) 0
733 } else {
734 lset vleftptr($view) $c $a
735 lappend vbackptr($view) $c
737 lset vlastins($view) $ka $a
738 lappend vupptr($view) $ka
739 lappend vleftptr($view) $b
740 if {$b != 0} {
741 lset vbackptr($view) $b $a
743 lappend varctok($view) $tok
744 lappend varcstart($view) $id
745 lappend vdownptr($view) 0
746 lappend varcrow($view) {}
747 lappend varcix($view) {}
748 set varccommits($view,$a) {}
749 lappend vlastins($view) 0
750 return $a
753 proc splitvarc {p v} {
754 global varcid varcstart varccommits varctok vtokmod
755 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
757 set oa $varcid($v,$p)
758 set otok [lindex $varctok($v) $oa]
759 set ac $varccommits($v,$oa)
760 set i [lsearch -exact $varccommits($v,$oa) $p]
761 if {$i <= 0} return
762 set na [llength $varctok($v)]
763 # "%" sorts before "0"...
764 set tok "$otok%[strrep $i]"
765 lappend varctok($v) $tok
766 lappend varcrow($v) {}
767 lappend varcix($v) {}
768 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
769 set varccommits($v,$na) [lrange $ac $i end]
770 lappend varcstart($v) $p
771 foreach id $varccommits($v,$na) {
772 set varcid($v,$id) $na
774 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
775 lappend vlastins($v) [lindex $vlastins($v) $oa]
776 lset vdownptr($v) $oa $na
777 lset vlastins($v) $oa 0
778 lappend vupptr($v) $oa
779 lappend vleftptr($v) 0
780 lappend vbackptr($v) 0
781 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
782 lset vupptr($v) $b $na
784 if {[string compare $otok $vtokmod($v)] <= 0} {
785 modify_arc $v $oa
789 proc renumbervarc {a v} {
790 global parents children varctok varcstart varccommits
791 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
793 set t1 [clock clicks -milliseconds]
794 set todo {}
795 set isrelated($a) 1
796 set kidchanged($a) 1
797 set ntot 0
798 while {$a != 0} {
799 if {[info exists isrelated($a)]} {
800 lappend todo $a
801 set id [lindex $varccommits($v,$a) end]
802 foreach p $parents($v,$id) {
803 if {[info exists varcid($v,$p)]} {
804 set isrelated($varcid($v,$p)) 1
808 incr ntot
809 set b [lindex $vdownptr($v) $a]
810 if {$b == 0} {
811 while {$a != 0} {
812 set b [lindex $vleftptr($v) $a]
813 if {$b != 0} break
814 set a [lindex $vupptr($v) $a]
817 set a $b
819 foreach a $todo {
820 if {![info exists kidchanged($a)]} continue
821 set id [lindex $varcstart($v) $a]
822 if {[llength $children($v,$id)] > 1} {
823 set children($v,$id) [lsort -command [list vtokcmp $v] \
824 $children($v,$id)]
826 set oldtok [lindex $varctok($v) $a]
827 if {!$vdatemode($v)} {
828 set tok {}
829 } else {
830 set tok $oldtok
832 set ka 0
833 set kid [last_real_child $v,$id]
834 if {$kid ne {}} {
835 set k $varcid($v,$kid)
836 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
837 set ki $kid
838 set ka $k
839 set tok [lindex $varctok($v) $k]
842 if {$ka != 0} {
843 set i [lsearch -exact $parents($v,$ki) $id]
844 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
845 append tok [strrep $j]
847 if {$tok eq $oldtok} {
848 continue
850 set id [lindex $varccommits($v,$a) end]
851 foreach p $parents($v,$id) {
852 if {[info exists varcid($v,$p)]} {
853 set kidchanged($varcid($v,$p)) 1
854 } else {
855 set sortkids($p) 1
858 lset varctok($v) $a $tok
859 set b [lindex $vupptr($v) $a]
860 if {$b != $ka} {
861 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
862 modify_arc $v $ka
864 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
865 modify_arc $v $b
867 set c [lindex $vbackptr($v) $a]
868 set d [lindex $vleftptr($v) $a]
869 if {$c == 0} {
870 lset vdownptr($v) $b $d
871 } else {
872 lset vleftptr($v) $c $d
874 if {$d != 0} {
875 lset vbackptr($v) $d $c
877 if {[lindex $vlastins($v) $b] == $a} {
878 lset vlastins($v) $b $c
880 lset vupptr($v) $a $ka
881 set c [lindex $vlastins($v) $ka]
882 if {$c == 0 || \
883 [string compare $tok [lindex $varctok($v) $c]] < 0} {
884 set c $ka
885 set b [lindex $vdownptr($v) $ka]
886 } else {
887 set b [lindex $vleftptr($v) $c]
889 while {$b != 0 && \
890 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
891 set c $b
892 set b [lindex $vleftptr($v) $c]
894 if {$c == $ka} {
895 lset vdownptr($v) $ka $a
896 lset vbackptr($v) $a 0
897 } else {
898 lset vleftptr($v) $c $a
899 lset vbackptr($v) $a $c
901 lset vleftptr($v) $a $b
902 if {$b != 0} {
903 lset vbackptr($v) $b $a
905 lset vlastins($v) $ka $a
908 foreach id [array names sortkids] {
909 if {[llength $children($v,$id)] > 1} {
910 set children($v,$id) [lsort -command [list vtokcmp $v] \
911 $children($v,$id)]
914 set t2 [clock clicks -milliseconds]
915 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
918 # Fix up the graph after we have found out that in view $v,
919 # $p (a commit that we have already seen) is actually the parent
920 # of the last commit in arc $a.
921 proc fix_reversal {p a v} {
922 global varcid varcstart varctok vupptr
924 set pa $varcid($v,$p)
925 if {$p ne [lindex $varcstart($v) $pa]} {
926 splitvarc $p $v
927 set pa $varcid($v,$p)
929 # seeds always need to be renumbered
930 if {[lindex $vupptr($v) $pa] == 0 ||
931 [string compare [lindex $varctok($v) $a] \
932 [lindex $varctok($v) $pa]] > 0} {
933 renumbervarc $pa $v
937 proc insertrow {id p v} {
938 global cmitlisted children parents varcid varctok vtokmod
939 global varccommits ordertok commitidx numcommits curview
940 global targetid targetrow vshortids
942 readcommit $id
943 set vid $v,$id
944 set cmitlisted($vid) 1
945 set children($vid) {}
946 set parents($vid) [list $p]
947 set a [newvarc $v $id]
948 set varcid($vid) $a
949 lappend vshortids($v,[string range $id 0 3]) $id
950 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
951 modify_arc $v $a
953 lappend varccommits($v,$a) $id
954 set vp $v,$p
955 if {[llength [lappend children($vp) $id]] > 1} {
956 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
957 catch {unset ordertok}
959 fix_reversal $p $a $v
960 incr commitidx($v)
961 if {$v == $curview} {
962 set numcommits $commitidx($v)
963 setcanvscroll
964 if {[info exists targetid]} {
965 if {![comes_before $targetid $p]} {
966 incr targetrow
972 proc insertfakerow {id p} {
973 global varcid varccommits parents children cmitlisted
974 global commitidx varctok vtokmod targetid targetrow curview numcommits
976 set v $curview
977 set a $varcid($v,$p)
978 set i [lsearch -exact $varccommits($v,$a) $p]
979 if {$i < 0} {
980 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
981 return
983 set children($v,$id) {}
984 set parents($v,$id) [list $p]
985 set varcid($v,$id) $a
986 lappend children($v,$p) $id
987 set cmitlisted($v,$id) 1
988 set numcommits [incr commitidx($v)]
989 # note we deliberately don't update varcstart($v) even if $i == 0
990 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
991 modify_arc $v $a $i
992 if {[info exists targetid]} {
993 if {![comes_before $targetid $p]} {
994 incr targetrow
997 setcanvscroll
998 drawvisible
1001 proc removefakerow {id} {
1002 global varcid varccommits parents children commitidx
1003 global varctok vtokmod cmitlisted currentid selectedline
1004 global targetid curview numcommits
1006 set v $curview
1007 if {[llength $parents($v,$id)] != 1} {
1008 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1009 return
1011 set p [lindex $parents($v,$id) 0]
1012 set a $varcid($v,$id)
1013 set i [lsearch -exact $varccommits($v,$a) $id]
1014 if {$i < 0} {
1015 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1016 return
1018 unset varcid($v,$id)
1019 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1020 unset parents($v,$id)
1021 unset children($v,$id)
1022 unset cmitlisted($v,$id)
1023 set numcommits [incr commitidx($v) -1]
1024 set j [lsearch -exact $children($v,$p) $id]
1025 if {$j >= 0} {
1026 set children($v,$p) [lreplace $children($v,$p) $j $j]
1028 modify_arc $v $a $i
1029 if {[info exist currentid] && $id eq $currentid} {
1030 unset currentid
1031 set selectedline {}
1033 if {[info exists targetid] && $targetid eq $id} {
1034 set targetid $p
1036 setcanvscroll
1037 drawvisible
1040 proc real_children {vp} {
1041 global children nullid nullid2
1043 set kids {}
1044 foreach id $children($vp) {
1045 if {$id ne $nullid && $id ne $nullid2} {
1046 lappend kids $id
1049 return $kids
1052 proc first_real_child {vp} {
1053 global children nullid nullid2
1055 foreach id $children($vp) {
1056 if {$id ne $nullid && $id ne $nullid2} {
1057 return $id
1060 return {}
1063 proc last_real_child {vp} {
1064 global children nullid nullid2
1066 set kids $children($vp)
1067 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1068 set id [lindex $kids $i]
1069 if {$id ne $nullid && $id ne $nullid2} {
1070 return $id
1073 return {}
1076 proc vtokcmp {v a b} {
1077 global varctok varcid
1079 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1080 [lindex $varctok($v) $varcid($v,$b)]]
1083 # This assumes that if lim is not given, the caller has checked that
1084 # arc a's token is less than $vtokmod($v)
1085 proc modify_arc {v a {lim {}}} {
1086 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1088 if {$lim ne {}} {
1089 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1090 if {$c > 0} return
1091 if {$c == 0} {
1092 set r [lindex $varcrow($v) $a]
1093 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1096 set vtokmod($v) [lindex $varctok($v) $a]
1097 set varcmod($v) $a
1098 if {$v == $curview} {
1099 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1100 set a [lindex $vupptr($v) $a]
1101 set lim {}
1103 set r 0
1104 if {$a != 0} {
1105 if {$lim eq {}} {
1106 set lim [llength $varccommits($v,$a)]
1108 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1110 set vrowmod($v) $r
1111 undolayout $r
1115 proc update_arcrows {v} {
1116 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1117 global varcid vrownum varcorder varcix varccommits
1118 global vupptr vdownptr vleftptr varctok
1119 global displayorder parentlist curview cached_commitrow
1121 if {$vrowmod($v) == $commitidx($v)} return
1122 if {$v == $curview} {
1123 if {[llength $displayorder] > $vrowmod($v)} {
1124 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1125 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1127 catch {unset cached_commitrow}
1129 set narctot [expr {[llength $varctok($v)] - 1}]
1130 set a $varcmod($v)
1131 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1132 # go up the tree until we find something that has a row number,
1133 # or we get to a seed
1134 set a [lindex $vupptr($v) $a]
1136 if {$a == 0} {
1137 set a [lindex $vdownptr($v) 0]
1138 if {$a == 0} return
1139 set vrownum($v) {0}
1140 set varcorder($v) [list $a]
1141 lset varcix($v) $a 0
1142 lset varcrow($v) $a 0
1143 set arcn 0
1144 set row 0
1145 } else {
1146 set arcn [lindex $varcix($v) $a]
1147 if {[llength $vrownum($v)] > $arcn + 1} {
1148 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1149 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1151 set row [lindex $varcrow($v) $a]
1153 while {1} {
1154 set p $a
1155 incr row [llength $varccommits($v,$a)]
1156 # go down if possible
1157 set b [lindex $vdownptr($v) $a]
1158 if {$b == 0} {
1159 # if not, go left, or go up until we can go left
1160 while {$a != 0} {
1161 set b [lindex $vleftptr($v) $a]
1162 if {$b != 0} break
1163 set a [lindex $vupptr($v) $a]
1165 if {$a == 0} break
1167 set a $b
1168 incr arcn
1169 lappend vrownum($v) $row
1170 lappend varcorder($v) $a
1171 lset varcix($v) $a $arcn
1172 lset varcrow($v) $a $row
1174 set vtokmod($v) [lindex $varctok($v) $p]
1175 set varcmod($v) $p
1176 set vrowmod($v) $row
1177 if {[info exists currentid]} {
1178 set selectedline [rowofcommit $currentid]
1182 # Test whether view $v contains commit $id
1183 proc commitinview {id v} {
1184 global varcid
1186 return [info exists varcid($v,$id)]
1189 # Return the row number for commit $id in the current view
1190 proc rowofcommit {id} {
1191 global varcid varccommits varcrow curview cached_commitrow
1192 global varctok vtokmod
1194 set v $curview
1195 if {![info exists varcid($v,$id)]} {
1196 puts "oops rowofcommit no arc for [shortids $id]"
1197 return {}
1199 set a $varcid($v,$id)
1200 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1201 update_arcrows $v
1203 if {[info exists cached_commitrow($id)]} {
1204 return $cached_commitrow($id)
1206 set i [lsearch -exact $varccommits($v,$a) $id]
1207 if {$i < 0} {
1208 puts "oops didn't find commit [shortids $id] in arc $a"
1209 return {}
1211 incr i [lindex $varcrow($v) $a]
1212 set cached_commitrow($id) $i
1213 return $i
1216 # Returns 1 if a is on an earlier row than b, otherwise 0
1217 proc comes_before {a b} {
1218 global varcid varctok curview
1220 set v $curview
1221 if {$a eq $b || ![info exists varcid($v,$a)] || \
1222 ![info exists varcid($v,$b)]} {
1223 return 0
1225 if {$varcid($v,$a) != $varcid($v,$b)} {
1226 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1227 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1229 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1232 proc bsearch {l elt} {
1233 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1234 return 0
1236 set lo 0
1237 set hi [llength $l]
1238 while {$hi - $lo > 1} {
1239 set mid [expr {int(($lo + $hi) / 2)}]
1240 set t [lindex $l $mid]
1241 if {$elt < $t} {
1242 set hi $mid
1243 } elseif {$elt > $t} {
1244 set lo $mid
1245 } else {
1246 return $mid
1249 return $lo
1252 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1253 proc make_disporder {start end} {
1254 global vrownum curview commitidx displayorder parentlist
1255 global varccommits varcorder parents vrowmod varcrow
1256 global d_valid_start d_valid_end
1258 if {$end > $vrowmod($curview)} {
1259 update_arcrows $curview
1261 set ai [bsearch $vrownum($curview) $start]
1262 set start [lindex $vrownum($curview) $ai]
1263 set narc [llength $vrownum($curview)]
1264 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1265 set a [lindex $varcorder($curview) $ai]
1266 set l [llength $displayorder]
1267 set al [llength $varccommits($curview,$a)]
1268 if {$l < $r + $al} {
1269 if {$l < $r} {
1270 set pad [ntimes [expr {$r - $l}] {}]
1271 set displayorder [concat $displayorder $pad]
1272 set parentlist [concat $parentlist $pad]
1273 } elseif {$l > $r} {
1274 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1275 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1277 foreach id $varccommits($curview,$a) {
1278 lappend displayorder $id
1279 lappend parentlist $parents($curview,$id)
1281 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1282 set i $r
1283 foreach id $varccommits($curview,$a) {
1284 lset displayorder $i $id
1285 lset parentlist $i $parents($curview,$id)
1286 incr i
1289 incr r $al
1293 proc commitonrow {row} {
1294 global displayorder
1296 set id [lindex $displayorder $row]
1297 if {$id eq {}} {
1298 make_disporder $row [expr {$row + 1}]
1299 set id [lindex $displayorder $row]
1301 return $id
1304 proc closevarcs {v} {
1305 global varctok varccommits varcid parents children
1306 global cmitlisted commitidx vtokmod
1308 set missing_parents 0
1309 set scripts {}
1310 set narcs [llength $varctok($v)]
1311 for {set a 1} {$a < $narcs} {incr a} {
1312 set id [lindex $varccommits($v,$a) end]
1313 foreach p $parents($v,$id) {
1314 if {[info exists varcid($v,$p)]} continue
1315 # add p as a new commit
1316 incr missing_parents
1317 set cmitlisted($v,$p) 0
1318 set parents($v,$p) {}
1319 if {[llength $children($v,$p)] == 1 &&
1320 [llength $parents($v,$id)] == 1} {
1321 set b $a
1322 } else {
1323 set b [newvarc $v $p]
1325 set varcid($v,$p) $b
1326 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1327 modify_arc $v $b
1329 lappend varccommits($v,$b) $p
1330 incr commitidx($v)
1331 set scripts [check_interest $p $scripts]
1334 if {$missing_parents > 0} {
1335 foreach s $scripts {
1336 eval $s
1341 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1342 # Assumes we already have an arc for $rwid.
1343 proc rewrite_commit {v id rwid} {
1344 global children parents varcid varctok vtokmod varccommits
1346 foreach ch $children($v,$id) {
1347 # make $rwid be $ch's parent in place of $id
1348 set i [lsearch -exact $parents($v,$ch) $id]
1349 if {$i < 0} {
1350 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1352 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1353 # add $ch to $rwid's children and sort the list if necessary
1354 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1355 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1356 $children($v,$rwid)]
1358 # fix the graph after joining $id to $rwid
1359 set a $varcid($v,$ch)
1360 fix_reversal $rwid $a $v
1361 # parentlist is wrong for the last element of arc $a
1362 # even if displayorder is right, hence the 3rd arg here
1363 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1367 # Mechanism for registering a command to be executed when we come
1368 # across a particular commit. To handle the case when only the
1369 # prefix of the commit is known, the commitinterest array is now
1370 # indexed by the first 4 characters of the ID. Each element is a
1371 # list of id, cmd pairs.
1372 proc interestedin {id cmd} {
1373 global commitinterest
1375 lappend commitinterest([string range $id 0 3]) $id $cmd
1378 proc check_interest {id scripts} {
1379 global commitinterest
1381 set prefix [string range $id 0 3]
1382 if {[info exists commitinterest($prefix)]} {
1383 set newlist {}
1384 foreach {i script} $commitinterest($prefix) {
1385 if {[string match "$i*" $id]} {
1386 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1387 } else {
1388 lappend newlist $i $script
1391 if {$newlist ne {}} {
1392 set commitinterest($prefix) $newlist
1393 } else {
1394 unset commitinterest($prefix)
1397 return $scripts
1400 proc getcommitlines {fd inst view updating} {
1401 global cmitlisted leftover
1402 global commitidx commitdata vdatemode
1403 global parents children curview hlview
1404 global idpending ordertok
1405 global varccommits varcid varctok vtokmod vfilelimit vshortids
1407 set stuff [read $fd 500000]
1408 # git log doesn't terminate the last commit with a null...
1409 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1410 set stuff "\0"
1412 if {$stuff == {}} {
1413 if {![eof $fd]} {
1414 return 1
1416 global commfd viewcomplete viewactive viewname
1417 global viewinstances
1418 unset commfd($inst)
1419 set i [lsearch -exact $viewinstances($view) $inst]
1420 if {$i >= 0} {
1421 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1423 # set it blocking so we wait for the process to terminate
1424 fconfigure $fd -blocking 1
1425 if {[catch {close $fd} err]} {
1426 set fv {}
1427 if {$view != $curview} {
1428 set fv " for the \"$viewname($view)\" view"
1430 if {[string range $err 0 4] == "usage"} {
1431 set err "Gitk: error reading commits$fv:\
1432 bad arguments to git log."
1433 if {$viewname($view) eq "Command line"} {
1434 append err \
1435 " (Note: arguments to gitk are passed to git log\
1436 to allow selection of commits to be displayed.)"
1438 } else {
1439 set err "Error reading commits$fv: $err"
1441 error_popup $err
1443 if {[incr viewactive($view) -1] <= 0} {
1444 set viewcomplete($view) 1
1445 # Check if we have seen any ids listed as parents that haven't
1446 # appeared in the list
1447 closevarcs $view
1448 notbusy $view
1450 if {$view == $curview} {
1451 run chewcommits
1453 return 0
1455 set start 0
1456 set gotsome 0
1457 set scripts {}
1458 while 1 {
1459 set i [string first "\0" $stuff $start]
1460 if {$i < 0} {
1461 append leftover($inst) [string range $stuff $start end]
1462 break
1464 if {$start == 0} {
1465 set cmit $leftover($inst)
1466 append cmit [string range $stuff 0 [expr {$i - 1}]]
1467 set leftover($inst) {}
1468 } else {
1469 set cmit [string range $stuff $start [expr {$i - 1}]]
1471 set start [expr {$i + 1}]
1472 set j [string first "\n" $cmit]
1473 set ok 0
1474 set listed 1
1475 if {$j >= 0 && [string match "commit *" $cmit]} {
1476 set ids [string range $cmit 7 [expr {$j - 1}]]
1477 if {[string match {[-^<>]*} $ids]} {
1478 switch -- [string index $ids 0] {
1479 "-" {set listed 0}
1480 "^" {set listed 2}
1481 "<" {set listed 3}
1482 ">" {set listed 4}
1484 set ids [string range $ids 1 end]
1486 set ok 1
1487 foreach id $ids {
1488 if {[string length $id] != 40} {
1489 set ok 0
1490 break
1494 if {!$ok} {
1495 set shortcmit $cmit
1496 if {[string length $shortcmit] > 80} {
1497 set shortcmit "[string range $shortcmit 0 80]..."
1499 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1500 exit 1
1502 set id [lindex $ids 0]
1503 set vid $view,$id
1505 lappend vshortids($view,[string range $id 0 3]) $id
1507 if {!$listed && $updating && ![info exists varcid($vid)] &&
1508 $vfilelimit($view) ne {}} {
1509 # git log doesn't rewrite parents for unlisted commits
1510 # when doing path limiting, so work around that here
1511 # by working out the rewritten parent with git rev-list
1512 # and if we already know about it, using the rewritten
1513 # parent as a substitute parent for $id's children.
1514 if {![catch {
1515 set rwid [exec git rev-list --first-parent --max-count=1 \
1516 $id -- $vfilelimit($view)]
1517 }]} {
1518 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1519 # use $rwid in place of $id
1520 rewrite_commit $view $id $rwid
1521 continue
1526 set a 0
1527 if {[info exists varcid($vid)]} {
1528 if {$cmitlisted($vid) || !$listed} continue
1529 set a $varcid($vid)
1531 if {$listed} {
1532 set olds [lrange $ids 1 end]
1533 } else {
1534 set olds {}
1536 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1537 set cmitlisted($vid) $listed
1538 set parents($vid) $olds
1539 if {![info exists children($vid)]} {
1540 set children($vid) {}
1541 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1542 set k [lindex $children($vid) 0]
1543 if {[llength $parents($view,$k)] == 1 &&
1544 (!$vdatemode($view) ||
1545 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1546 set a $varcid($view,$k)
1549 if {$a == 0} {
1550 # new arc
1551 set a [newvarc $view $id]
1553 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1554 modify_arc $view $a
1556 if {![info exists varcid($vid)]} {
1557 set varcid($vid) $a
1558 lappend varccommits($view,$a) $id
1559 incr commitidx($view)
1562 set i 0
1563 foreach p $olds {
1564 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1565 set vp $view,$p
1566 if {[llength [lappend children($vp) $id]] > 1 &&
1567 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1568 set children($vp) [lsort -command [list vtokcmp $view] \
1569 $children($vp)]
1570 catch {unset ordertok}
1572 if {[info exists varcid($view,$p)]} {
1573 fix_reversal $p $a $view
1576 incr i
1579 set scripts [check_interest $id $scripts]
1580 set gotsome 1
1582 if {$gotsome} {
1583 global numcommits hlview
1585 if {$view == $curview} {
1586 set numcommits $commitidx($view)
1587 run chewcommits
1589 if {[info exists hlview] && $view == $hlview} {
1590 # we never actually get here...
1591 run vhighlightmore
1593 foreach s $scripts {
1594 eval $s
1597 return 2
1600 proc chewcommits {} {
1601 global curview hlview viewcomplete
1602 global pending_select
1604 layoutmore
1605 if {$viewcomplete($curview)} {
1606 global commitidx varctok
1607 global numcommits startmsecs
1609 if {[info exists pending_select]} {
1610 update
1611 reset_pending_select {}
1613 if {[commitinview $pending_select $curview]} {
1614 selectline [rowofcommit $pending_select] 1
1615 } else {
1616 set row [first_real_row]
1617 selectline $row 1
1620 if {$commitidx($curview) > 0} {
1621 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1622 #puts "overall $ms ms for $numcommits commits"
1623 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1624 } else {
1625 show_status [mc "No commits selected"]
1627 notbusy layout
1629 return 0
1632 proc do_readcommit {id} {
1633 global tclencoding
1635 # Invoke git-log to handle automatic encoding conversion
1636 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1637 # Read the results using i18n.logoutputencoding
1638 fconfigure $fd -translation lf -eofchar {}
1639 if {$tclencoding != {}} {
1640 fconfigure $fd -encoding $tclencoding
1642 set contents [read $fd]
1643 close $fd
1644 # Remove the heading line
1645 regsub {^commit [0-9a-f]+\n} $contents {} contents
1647 return $contents
1650 proc readcommit {id} {
1651 if {[catch {set contents [do_readcommit $id]}]} return
1652 parsecommit $id $contents 1
1655 proc parsecommit {id contents listed} {
1656 global commitinfo
1658 set inhdr 1
1659 set comment {}
1660 set headline {}
1661 set auname {}
1662 set audate {}
1663 set comname {}
1664 set comdate {}
1665 set hdrend [string first "\n\n" $contents]
1666 if {$hdrend < 0} {
1667 # should never happen...
1668 set hdrend [string length $contents]
1670 set header [string range $contents 0 [expr {$hdrend - 1}]]
1671 set comment [string range $contents [expr {$hdrend + 2}] end]
1672 foreach line [split $header "\n"] {
1673 set line [split $line " "]
1674 set tag [lindex $line 0]
1675 if {$tag == "author"} {
1676 set audate [lrange $line end-1 end]
1677 set auname [join [lrange $line 1 end-2] " "]
1678 } elseif {$tag == "committer"} {
1679 set comdate [lrange $line end-1 end]
1680 set comname [join [lrange $line 1 end-2] " "]
1683 set headline {}
1684 # take the first non-blank line of the comment as the headline
1685 set headline [string trimleft $comment]
1686 set i [string first "\n" $headline]
1687 if {$i >= 0} {
1688 set headline [string range $headline 0 $i]
1690 set headline [string trimright $headline]
1691 set i [string first "\r" $headline]
1692 if {$i >= 0} {
1693 set headline [string trimright [string range $headline 0 $i]]
1695 if {!$listed} {
1696 # git log indents the comment by 4 spaces;
1697 # if we got this via git cat-file, add the indentation
1698 set newcomment {}
1699 foreach line [split $comment "\n"] {
1700 append newcomment " "
1701 append newcomment $line
1702 append newcomment "\n"
1704 set comment $newcomment
1706 set hasnote [string first "\nNotes:\n" $contents]
1707 set commitinfo($id) [list $headline $auname $audate \
1708 $comname $comdate $comment $hasnote]
1711 proc getcommit {id} {
1712 global commitdata commitinfo
1714 if {[info exists commitdata($id)]} {
1715 parsecommit $id $commitdata($id) 1
1716 } else {
1717 readcommit $id
1718 if {![info exists commitinfo($id)]} {
1719 set commitinfo($id) [list [mc "No commit information available"]]
1722 return 1
1725 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1726 # and are present in the current view.
1727 # This is fairly slow...
1728 proc longid {prefix} {
1729 global varcid curview vshortids
1731 set ids {}
1732 if {[string length $prefix] >= 4} {
1733 set vshortid $curview,[string range $prefix 0 3]
1734 if {[info exists vshortids($vshortid)]} {
1735 foreach id $vshortids($vshortid) {
1736 if {[string match "$prefix*" $id]} {
1737 if {[lsearch -exact $ids $id] < 0} {
1738 lappend ids $id
1739 if {[llength $ids] >= 2} break
1744 } else {
1745 foreach match [array names varcid "$curview,$prefix*"] {
1746 lappend ids [lindex [split $match ","] 1]
1747 if {[llength $ids] >= 2} break
1750 return $ids
1753 proc readrefs {} {
1754 global tagids idtags headids idheads tagobjid
1755 global otherrefids idotherrefs mainhead mainheadid
1756 global selecthead selectheadid
1757 global hideremotes
1759 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1760 catch {unset $v}
1762 set refd [open [list | git show-ref -d] r]
1763 while {[gets $refd line] >= 0} {
1764 if {[string index $line 40] ne " "} continue
1765 set id [string range $line 0 39]
1766 set ref [string range $line 41 end]
1767 if {![string match "refs/*" $ref]} continue
1768 set name [string range $ref 5 end]
1769 if {[string match "remotes/*" $name]} {
1770 if {![string match "*/HEAD" $name] && !$hideremotes} {
1771 set headids($name) $id
1772 lappend idheads($id) $name
1774 } elseif {[string match "heads/*" $name]} {
1775 set name [string range $name 6 end]
1776 set headids($name) $id
1777 lappend idheads($id) $name
1778 } elseif {[string match "tags/*" $name]} {
1779 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1780 # which is what we want since the former is the commit ID
1781 set name [string range $name 5 end]
1782 if {[string match "*^{}" $name]} {
1783 set name [string range $name 0 end-3]
1784 } else {
1785 set tagobjid($name) $id
1787 set tagids($name) $id
1788 lappend idtags($id) $name
1789 } else {
1790 set otherrefids($name) $id
1791 lappend idotherrefs($id) $name
1794 catch {close $refd}
1795 set mainhead {}
1796 set mainheadid {}
1797 catch {
1798 set mainheadid [exec git rev-parse HEAD]
1799 set thehead [exec git symbolic-ref HEAD]
1800 if {[string match "refs/heads/*" $thehead]} {
1801 set mainhead [string range $thehead 11 end]
1804 set selectheadid {}
1805 if {$selecthead ne {}} {
1806 catch {
1807 set selectheadid [exec git rev-parse --verify $selecthead]
1812 # skip over fake commits
1813 proc first_real_row {} {
1814 global nullid nullid2 numcommits
1816 for {set row 0} {$row < $numcommits} {incr row} {
1817 set id [commitonrow $row]
1818 if {$id ne $nullid && $id ne $nullid2} {
1819 break
1822 return $row
1825 # update things for a head moved to a child of its previous location
1826 proc movehead {id name} {
1827 global headids idheads
1829 removehead $headids($name) $name
1830 set headids($name) $id
1831 lappend idheads($id) $name
1834 # update things when a head has been removed
1835 proc removehead {id name} {
1836 global headids idheads
1838 if {$idheads($id) eq $name} {
1839 unset idheads($id)
1840 } else {
1841 set i [lsearch -exact $idheads($id) $name]
1842 if {$i >= 0} {
1843 set idheads($id) [lreplace $idheads($id) $i $i]
1846 unset headids($name)
1849 proc ttk_toplevel {w args} {
1850 global use_ttk
1851 eval [linsert $args 0 ::toplevel $w]
1852 if {$use_ttk} {
1853 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1855 return $w
1858 proc make_transient {window origin} {
1859 global have_tk85
1861 # In MacOS Tk 8.4 transient appears to work by setting
1862 # overrideredirect, which is utterly useless, since the
1863 # windows get no border, and are not even kept above
1864 # the parent.
1865 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1867 wm transient $window $origin
1869 # Windows fails to place transient windows normally, so
1870 # schedule a callback to center them on the parent.
1871 if {[tk windowingsystem] eq {win32}} {
1872 after idle [list tk::PlaceWindow $window widget $origin]
1876 proc show_error {w top msg {mc mc}} {
1877 global NS
1878 if {![info exists NS]} {set NS ""}
1879 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1880 message $w.m -text $msg -justify center -aspect 400
1881 pack $w.m -side top -fill x -padx 20 -pady 20
1882 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1883 pack $w.ok -side bottom -fill x
1884 bind $top <Visibility> "grab $top; focus $top"
1885 bind $top <Key-Return> "destroy $top"
1886 bind $top <Key-space> "destroy $top"
1887 bind $top <Key-Escape> "destroy $top"
1888 tkwait window $top
1891 proc error_popup {msg {owner .}} {
1892 if {[tk windowingsystem] eq "win32"} {
1893 tk_messageBox -icon error -type ok -title [wm title .] \
1894 -parent $owner -message $msg
1895 } else {
1896 set w .error
1897 ttk_toplevel $w
1898 make_transient $w $owner
1899 show_error $w $w $msg
1903 proc confirm_popup {msg {owner .}} {
1904 global confirm_ok NS
1905 set confirm_ok 0
1906 set w .confirm
1907 ttk_toplevel $w
1908 make_transient $w $owner
1909 message $w.m -text $msg -justify center -aspect 400
1910 pack $w.m -side top -fill x -padx 20 -pady 20
1911 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1912 pack $w.ok -side left -fill x
1913 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1914 pack $w.cancel -side right -fill x
1915 bind $w <Visibility> "grab $w; focus $w"
1916 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1917 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1918 bind $w <Key-Escape> "destroy $w"
1919 tk::PlaceWindow $w widget $owner
1920 tkwait window $w
1921 return $confirm_ok
1924 proc setoptions {} {
1925 if {[tk windowingsystem] ne "win32"} {
1926 option add *Panedwindow.showHandle 1 startupFile
1927 option add *Panedwindow.sashRelief raised startupFile
1928 if {[tk windowingsystem] ne "aqua"} {
1929 option add *Menu.font uifont startupFile
1931 } else {
1932 option add *Menu.TearOff 0 startupFile
1934 option add *Button.font uifont startupFile
1935 option add *Checkbutton.font uifont startupFile
1936 option add *Radiobutton.font uifont startupFile
1937 option add *Menubutton.font uifont startupFile
1938 option add *Label.font uifont startupFile
1939 option add *Message.font uifont startupFile
1940 option add *Entry.font textfont startupFile
1941 option add *Text.font textfont startupFile
1942 option add *Labelframe.font uifont startupFile
1943 option add *Spinbox.font textfont startupFile
1944 option add *Listbox.font mainfont startupFile
1947 # Make a menu and submenus.
1948 # m is the window name for the menu, items is the list of menu items to add.
1949 # Each item is a list {mc label type description options...}
1950 # mc is ignored; it's so we can put mc there to alert xgettext
1951 # label is the string that appears in the menu
1952 # type is cascade, command or radiobutton (should add checkbutton)
1953 # description depends on type; it's the sublist for cascade, the
1954 # command to invoke for command, or {variable value} for radiobutton
1955 proc makemenu {m items} {
1956 menu $m
1957 if {[tk windowingsystem] eq {aqua}} {
1958 set Meta1 Cmd
1959 } else {
1960 set Meta1 Ctrl
1962 foreach i $items {
1963 set name [mc [lindex $i 1]]
1964 set type [lindex $i 2]
1965 set thing [lindex $i 3]
1966 set params [list $type]
1967 if {$name ne {}} {
1968 set u [string first "&" [string map {&& x} $name]]
1969 lappend params -label [string map {&& & & {}} $name]
1970 if {$u >= 0} {
1971 lappend params -underline $u
1974 switch -- $type {
1975 "cascade" {
1976 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1977 lappend params -menu $m.$submenu
1979 "command" {
1980 lappend params -command $thing
1982 "radiobutton" {
1983 lappend params -variable [lindex $thing 0] \
1984 -value [lindex $thing 1]
1987 set tail [lrange $i 4 end]
1988 regsub -all {\yMeta1\y} $tail $Meta1 tail
1989 eval $m add $params $tail
1990 if {$type eq "cascade"} {
1991 makemenu $m.$submenu $thing
1996 # translate string and remove ampersands
1997 proc mca {str} {
1998 return [string map {&& & & {}} [mc $str]]
2001 proc makedroplist {w varname args} {
2002 global use_ttk
2003 if {$use_ttk} {
2004 set width 0
2005 foreach label $args {
2006 set cx [string length $label]
2007 if {$cx > $width} {set width $cx}
2009 set gm [ttk::combobox $w -width $width -state readonly\
2010 -textvariable $varname -values $args]
2011 } else {
2012 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2014 return $gm
2017 proc makewindow {} {
2018 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2019 global tabstop
2020 global findtype findtypemenu findloc findstring fstring geometry
2021 global entries sha1entry sha1string sha1but
2022 global diffcontextstring diffcontext
2023 global ignorespace
2024 global maincursor textcursor curtextcursor
2025 global rowctxmenu fakerowmenu mergemax wrapcomment
2026 global highlight_files gdttype
2027 global searchstring sstring
2028 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2029 global headctxmenu progresscanv progressitem progresscoords statusw
2030 global fprogitem fprogcoord lastprogupdate progupdatepending
2031 global rprogitem rprogcoord rownumsel numcommits
2032 global have_tk85 use_ttk NS
2033 global git_version
2034 global worddiff
2036 # The "mc" arguments here are purely so that xgettext
2037 # sees the following string as needing to be translated
2038 set file {
2039 mc "File" cascade {
2040 {mc "Update" command updatecommits -accelerator F5}
2041 {mc "Reload" command reloadcommits -accelerator Shift-F5}
2042 {mc "Reread references" command rereadrefs}
2043 {mc "List references" command showrefs -accelerator F2}
2044 {xx "" separator}
2045 {mc "Start git gui" command {exec git gui &}}
2046 {xx "" separator}
2047 {mc "Quit" command doquit -accelerator Meta1-Q}
2049 set edit {
2050 mc "Edit" cascade {
2051 {mc "Preferences" command doprefs}
2053 set view {
2054 mc "View" cascade {
2055 {mc "New view..." command {newview 0} -accelerator Shift-F4}
2056 {mc "Edit view..." command editview -state disabled -accelerator F4}
2057 {mc "Delete view" command delview -state disabled}
2058 {xx "" separator}
2059 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2061 if {[tk windowingsystem] ne "aqua"} {
2062 set help {
2063 mc "Help" cascade {
2064 {mc "About gitk" command about}
2065 {mc "Key bindings" command keys}
2067 set bar [list $file $edit $view $help]
2068 } else {
2069 proc ::tk::mac::ShowPreferences {} {doprefs}
2070 proc ::tk::mac::Quit {} {doquit}
2071 lset file end [lreplace [lindex $file end] end-1 end]
2072 set apple {
2073 xx "Apple" cascade {
2074 {mc "About gitk" command about}
2075 {xx "" separator}
2077 set help {
2078 mc "Help" cascade {
2079 {mc "Key bindings" command keys}
2081 set bar [list $apple $file $view $help]
2083 makemenu .bar $bar
2084 . configure -menu .bar
2086 if {$use_ttk} {
2087 # cover the non-themed toplevel with a themed frame.
2088 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2091 # the gui has upper and lower half, parts of a paned window.
2092 ${NS}::panedwindow .ctop -orient vertical
2094 # possibly use assumed geometry
2095 if {![info exists geometry(pwsash0)]} {
2096 set geometry(topheight) [expr {15 * $linespc}]
2097 set geometry(topwidth) [expr {80 * $charspc}]
2098 set geometry(botheight) [expr {15 * $linespc}]
2099 set geometry(botwidth) [expr {50 * $charspc}]
2100 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2101 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2104 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2105 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2106 ${NS}::frame .tf.histframe
2107 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2108 if {!$use_ttk} {
2109 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2112 # create three canvases
2113 set cscroll .tf.histframe.csb
2114 set canv .tf.histframe.pwclist.canv
2115 canvas $canv \
2116 -selectbackground $selectbgcolor \
2117 -background $bgcolor -bd 0 \
2118 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2119 .tf.histframe.pwclist add $canv
2120 set canv2 .tf.histframe.pwclist.canv2
2121 canvas $canv2 \
2122 -selectbackground $selectbgcolor \
2123 -background $bgcolor -bd 0 -yscrollincr $linespc
2124 .tf.histframe.pwclist add $canv2
2125 set canv3 .tf.histframe.pwclist.canv3
2126 canvas $canv3 \
2127 -selectbackground $selectbgcolor \
2128 -background $bgcolor -bd 0 -yscrollincr $linespc
2129 .tf.histframe.pwclist add $canv3
2130 if {$use_ttk} {
2131 bind .tf.histframe.pwclist <Map> {
2132 bind %W <Map> {}
2133 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2134 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2136 } else {
2137 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2138 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2141 # a scroll bar to rule them
2142 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2143 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2144 pack $cscroll -side right -fill y
2145 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2146 lappend bglist $canv $canv2 $canv3
2147 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2149 # we have two button bars at bottom of top frame. Bar 1
2150 ${NS}::frame .tf.bar
2151 ${NS}::frame .tf.lbar -height 15
2153 set sha1entry .tf.bar.sha1
2154 set entries $sha1entry
2155 set sha1but .tf.bar.sha1label
2156 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2157 -command gotocommit -width 8
2158 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2159 pack .tf.bar.sha1label -side left
2160 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2161 trace add variable sha1string write sha1change
2162 pack $sha1entry -side left -pady 2
2164 set bm_left_data {
2165 #define left_width 16
2166 #define left_height 16
2167 static unsigned char left_bits[] = {
2168 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2169 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2170 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2172 set bm_right_data {
2173 #define right_width 16
2174 #define right_height 16
2175 static unsigned char right_bits[] = {
2176 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2177 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2178 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2180 image create bitmap bm-left -data $bm_left_data
2181 image create bitmap bm-left-gray -data $bm_left_data -foreground "#999"
2182 image create bitmap bm-right -data $bm_right_data
2183 image create bitmap bm-right-gray -data $bm_right_data -foreground "#999"
2185 ${NS}::button .tf.bar.leftbut -image [list bm-left disabled bm-left-gray] \
2186 -command goback -state disabled -width 26
2187 pack .tf.bar.leftbut -side left -fill y
2188 ${NS}::button .tf.bar.rightbut -image [list bm-right disabled bm-right-gray] \
2189 -command goforw -state disabled -width 26
2190 pack .tf.bar.rightbut -side left -fill y
2192 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2193 set rownumsel {}
2194 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2195 -relief sunken -anchor e
2196 ${NS}::label .tf.bar.rowlabel2 -text "/"
2197 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2198 -relief sunken -anchor e
2199 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2200 -side left
2201 if {!$use_ttk} {
2202 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2204 global selectedline
2205 trace add variable selectedline write selectedline_change
2207 # Status label and progress bar
2208 set statusw .tf.bar.status
2209 ${NS}::label $statusw -width 15 -relief sunken
2210 pack $statusw -side left -padx 5
2211 if {$use_ttk} {
2212 set progresscanv [ttk::progressbar .tf.bar.progress]
2213 } else {
2214 set h [expr {[font metrics uifont -linespace] + 2}]
2215 set progresscanv .tf.bar.progress
2216 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2217 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2218 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2219 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2221 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2222 set progresscoords {0 0}
2223 set fprogcoord 0
2224 set rprogcoord 0
2225 bind $progresscanv <Configure> adjustprogress
2226 set lastprogupdate [clock clicks -milliseconds]
2227 set progupdatepending 0
2229 # build up the bottom bar of upper window
2230 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2231 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2232 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2233 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2234 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2235 -side left -fill y
2236 set gdttype [mc "containing:"]
2237 set gm [makedroplist .tf.lbar.gdttype gdttype \
2238 [mc "containing:"] \
2239 [mc "touching paths:"] \
2240 [mc "adding/removing string:"]]
2241 trace add variable gdttype write gdttype_change
2242 pack .tf.lbar.gdttype -side left -fill y
2244 set findstring {}
2245 set fstring .tf.lbar.findstring
2246 lappend entries $fstring
2247 ${NS}::entry $fstring -width 30 -textvariable findstring
2248 trace add variable findstring write find_change
2249 set findtype [mc "Exact"]
2250 set findtypemenu [makedroplist .tf.lbar.findtype \
2251 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2252 trace add variable findtype write findcom_change
2253 set findloc [mc "All fields"]
2254 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2255 [mc "Comments"] [mc "Author"] [mc "Committer"]
2256 trace add variable findloc write find_change
2257 pack .tf.lbar.findloc -side right
2258 pack .tf.lbar.findtype -side right
2259 pack $fstring -side left -expand 1 -fill x
2261 # Finish putting the upper half of the viewer together
2262 pack .tf.lbar -in .tf -side bottom -fill x
2263 pack .tf.bar -in .tf -side bottom -fill x
2264 pack .tf.histframe -fill both -side top -expand 1
2265 .ctop add .tf
2266 if {!$use_ttk} {
2267 .ctop paneconfigure .tf -height $geometry(topheight)
2268 .ctop paneconfigure .tf -width $geometry(topwidth)
2271 # now build up the bottom
2272 ${NS}::panedwindow .pwbottom -orient horizontal
2274 # lower left, a text box over search bar, scroll bar to the right
2275 # if we know window height, then that will set the lower text height, otherwise
2276 # we set lower text height which will drive window height
2277 if {[info exists geometry(main)]} {
2278 ${NS}::frame .bleft -width $geometry(botwidth)
2279 } else {
2280 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2282 ${NS}::frame .bleft.top
2283 ${NS}::frame .bleft.mid
2284 ${NS}::frame .bleft.bottom
2286 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2287 pack .bleft.top.search -side left -padx 5
2288 set sstring .bleft.top.sstring
2289 set searchstring ""
2290 ${NS}::entry $sstring -width 20 -textvariable searchstring
2291 lappend entries $sstring
2292 trace add variable searchstring write incrsearch
2293 pack $sstring -side left -expand 1 -fill x
2294 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2295 -command changediffdisp -variable diffelide -value {0 0}
2296 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2297 -command changediffdisp -variable diffelide -value {0 1}
2298 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2299 -command changediffdisp -variable diffelide -value {1 0}
2300 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2301 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2302 spinbox .bleft.mid.diffcontext -width 5 \
2303 -from 0 -increment 1 -to 10000000 \
2304 -validate all -validatecommand "diffcontextvalidate %P" \
2305 -textvariable diffcontextstring
2306 .bleft.mid.diffcontext set $diffcontext
2307 trace add variable diffcontextstring write diffcontextchange
2308 lappend entries .bleft.mid.diffcontext
2309 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2310 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2311 -command changeignorespace -variable ignorespace
2312 pack .bleft.mid.ignspace -side left -padx 5
2314 set worddiff [mc "Line diff"]
2315 if {[package vcompare $git_version "1.7.2"] >= 0} {
2316 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2317 [mc "Markup words"] [mc "Color words"]
2318 trace add variable worddiff write changeworddiff
2319 pack .bleft.mid.worddiff -side left -padx 5
2322 set ctext .bleft.bottom.ctext
2323 text $ctext -background $bgcolor -foreground $fgcolor \
2324 -state disabled -font textfont \
2325 -yscrollcommand scrolltext -wrap none \
2326 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2327 if {$have_tk85} {
2328 $ctext conf -tabstyle wordprocessor
2330 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2331 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2332 pack .bleft.top -side top -fill x
2333 pack .bleft.mid -side top -fill x
2334 grid $ctext .bleft.bottom.sb -sticky nsew
2335 grid .bleft.bottom.sbhorizontal -sticky ew
2336 grid columnconfigure .bleft.bottom 0 -weight 1
2337 grid rowconfigure .bleft.bottom 0 -weight 1
2338 grid rowconfigure .bleft.bottom 1 -weight 0
2339 pack .bleft.bottom -side top -fill both -expand 1
2340 lappend bglist $ctext
2341 lappend fglist $ctext
2343 $ctext tag conf comment -wrap $wrapcomment
2344 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2345 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2346 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2347 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2348 $ctext tag conf m0 -fore red
2349 $ctext tag conf m1 -fore blue
2350 $ctext tag conf m2 -fore green
2351 $ctext tag conf m3 -fore purple
2352 $ctext tag conf m4 -fore brown
2353 $ctext tag conf m5 -fore "#009090"
2354 $ctext tag conf m6 -fore magenta
2355 $ctext tag conf m7 -fore "#808000"
2356 $ctext tag conf m8 -fore "#009000"
2357 $ctext tag conf m9 -fore "#ff0080"
2358 $ctext tag conf m10 -fore cyan
2359 $ctext tag conf m11 -fore "#b07070"
2360 $ctext tag conf m12 -fore "#70b0f0"
2361 $ctext tag conf m13 -fore "#70f0b0"
2362 $ctext tag conf m14 -fore "#f0b070"
2363 $ctext tag conf m15 -fore "#ff70b0"
2364 $ctext tag conf mmax -fore darkgrey
2365 set mergemax 16
2366 $ctext tag conf mresult -font textfontbold
2367 $ctext tag conf msep -font textfontbold
2368 $ctext tag conf found -back yellow
2369 $ctext tag conf currentsearchhit -back orange
2371 .pwbottom add .bleft
2372 if {!$use_ttk} {
2373 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2376 # lower right
2377 ${NS}::frame .bright
2378 ${NS}::frame .bright.mode
2379 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2380 -command reselectline -variable cmitmode -value "patch"
2381 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2382 -command reselectline -variable cmitmode -value "tree"
2383 grid .bright.mode.patch .bright.mode.tree -sticky ew
2384 pack .bright.mode -side top -fill x
2385 set cflist .bright.cfiles
2386 set indent [font measure mainfont "nn"]
2387 text $cflist \
2388 -selectbackground $selectbgcolor \
2389 -background $bgcolor -foreground $fgcolor \
2390 -font mainfont \
2391 -tabs [list $indent [expr {2 * $indent}]] \
2392 -yscrollcommand ".bright.sb set" \
2393 -cursor [. cget -cursor] \
2394 -spacing1 1 -spacing3 1
2395 lappend bglist $cflist
2396 lappend fglist $cflist
2397 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2398 pack .bright.sb -side right -fill y
2399 pack $cflist -side left -fill both -expand 1
2400 $cflist tag configure highlight \
2401 -background [$cflist cget -selectbackground]
2402 $cflist tag configure bold -font mainfontbold
2404 .pwbottom add .bright
2405 .ctop add .pwbottom
2407 # restore window width & height if known
2408 if {[info exists geometry(main)]} {
2409 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2410 if {$w > [winfo screenwidth .]} {
2411 set w [winfo screenwidth .]
2413 if {$h > [winfo screenheight .]} {
2414 set h [winfo screenheight .]
2416 wm geometry . "${w}x$h"
2420 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2421 wm state . $geometry(state)
2424 if {[tk windowingsystem] eq {aqua}} {
2425 set M1B M1
2426 set ::BM "3"
2427 } else {
2428 set M1B Control
2429 set ::BM "2"
2432 if {$use_ttk} {
2433 bind .ctop <Map> {
2434 bind %W <Map> {}
2435 %W sashpos 0 $::geometry(topheight)
2437 bind .pwbottom <Map> {
2438 bind %W <Map> {}
2439 %W sashpos 0 $::geometry(botwidth)
2443 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2444 pack .ctop -fill both -expand 1
2445 bindall <1> {selcanvline %W %x %y}
2446 #bindall <B1-Motion> {selcanvline %W %x %y}
2447 if {[tk windowingsystem] == "win32"} {
2448 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2449 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2450 } else {
2451 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2452 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2453 if {[tk windowingsystem] eq "aqua"} {
2454 bindall <MouseWheel> {
2455 set delta [expr {- (%D)}]
2456 allcanvs yview scroll $delta units
2458 bindall <Shift-MouseWheel> {
2459 set delta [expr {- (%D)}]
2460 $canv xview scroll $delta units
2464 bindall <$::BM> "canvscan mark %W %x %y"
2465 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2466 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2467 bind . <$M1B-Key-w> doquit
2468 bindkey <Home> selfirstline
2469 bindkey <End> sellastline
2470 bind . <Key-Up> "selnextline -1"
2471 bind . <Key-Down> "selnextline 1"
2472 bind . <Shift-Key-Up> "dofind -1 0"
2473 bind . <Shift-Key-Down> "dofind 1 0"
2474 bindkey <Key-Right> "goforw"
2475 bindkey <Key-Left> "goback"
2476 bind . <Key-Prior> "selnextpage -1"
2477 bind . <Key-Next> "selnextpage 1"
2478 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2479 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2480 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2481 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2482 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2483 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2484 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2485 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2486 bindkey <Key-space> "$ctext yview scroll 1 pages"
2487 bindkey p "selnextline -1"
2488 bindkey n "selnextline 1"
2489 bindkey z "goback"
2490 bindkey x "goforw"
2491 bindkey k "selnextline -1"
2492 bindkey j "selnextline 1"
2493 bindkey h "goback"
2494 bindkey l "goforw"
2495 bindkey b prevfile
2496 bindkey d "$ctext yview scroll 18 units"
2497 bindkey u "$ctext yview scroll -18 units"
2498 bindkey / {focus $fstring}
2499 bindkey <Key-KP_Divide> {focus $fstring}
2500 bindkey <Key-Return> {dofind 1 1}
2501 bindkey ? {dofind -1 1}
2502 bindkey f nextfile
2503 bind . <F5> updatecommits
2504 bind . <Shift-F5> reloadcommits
2505 bind . <F2> showrefs
2506 bind . <Shift-F4> {newview 0}
2507 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2508 bind . <F4> edit_or_newview
2509 bind . <$M1B-q> doquit
2510 bind . <$M1B-f> {dofind 1 1}
2511 bind . <$M1B-g> {dofind 1 0}
2512 bind . <$M1B-r> dosearchback
2513 bind . <$M1B-s> dosearch
2514 bind . <$M1B-equal> {incrfont 1}
2515 bind . <$M1B-plus> {incrfont 1}
2516 bind . <$M1B-KP_Add> {incrfont 1}
2517 bind . <$M1B-minus> {incrfont -1}
2518 bind . <$M1B-KP_Subtract> {incrfont -1}
2519 wm protocol . WM_DELETE_WINDOW doquit
2520 bind . <Destroy> {stop_backends}
2521 bind . <Button-1> "click %W"
2522 bind $fstring <Key-Return> {dofind 1 1}
2523 bind $sha1entry <Key-Return> {gotocommit; break}
2524 bind $sha1entry <<PasteSelection>> clearsha1
2525 bind $cflist <1> {sel_flist %W %x %y; break}
2526 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2527 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2528 global ctxbut
2529 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2530 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2531 bind $ctext <Button-1> {focus %W}
2532 bind $ctext <<Selection>> rehighlight_search_results
2534 set maincursor [. cget -cursor]
2535 set textcursor [$ctext cget -cursor]
2536 set curtextcursor $textcursor
2538 set rowctxmenu .rowctxmenu
2539 makemenu $rowctxmenu {
2540 {mc "Diff this -> selected" command {diffvssel 0}}
2541 {mc "Diff selected -> this" command {diffvssel 1}}
2542 {mc "Make patch" command mkpatch}
2543 {mc "Create tag" command mktag}
2544 {mc "Write commit to file" command writecommit}
2545 {mc "Create new branch" command mkbranch}
2546 {mc "Cherry-pick this commit" command cherrypick}
2547 {mc "Reset HEAD branch to here" command resethead}
2548 {mc "Mark this commit" command markhere}
2549 {mc "Return to mark" command gotomark}
2550 {mc "Find descendant of this and mark" command find_common_desc}
2551 {mc "Compare with marked commit" command compare_commits}
2552 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2553 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2555 $rowctxmenu configure -tearoff 0
2557 set fakerowmenu .fakerowmenu
2558 makemenu $fakerowmenu {
2559 {mc "Diff this -> selected" command {diffvssel 0}}
2560 {mc "Diff selected -> this" command {diffvssel 1}}
2561 {mc "Make patch" command mkpatch}
2562 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2563 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2565 $fakerowmenu configure -tearoff 0
2567 set headctxmenu .headctxmenu
2568 makemenu $headctxmenu {
2569 {mc "Check out this branch" command cobranch}
2570 {mc "Remove this branch" command rmbranch}
2572 $headctxmenu configure -tearoff 0
2574 global flist_menu
2575 set flist_menu .flistctxmenu
2576 makemenu $flist_menu {
2577 {mc "Highlight this too" command {flist_hl 0}}
2578 {mc "Highlight this only" command {flist_hl 1}}
2579 {mc "External diff" command {external_diff}}
2580 {mc "Blame parent commit" command {external_blame 1}}
2582 $flist_menu configure -tearoff 0
2584 global diff_menu
2585 set diff_menu .diffctxmenu
2586 makemenu $diff_menu {
2587 {mc "Show origin of this line" command show_line_source}
2588 {mc "Run git gui blame on this line" command {external_blame_diff}}
2590 $diff_menu configure -tearoff 0
2593 # Windows sends all mouse wheel events to the current focused window, not
2594 # the one where the mouse hovers, so bind those events here and redirect
2595 # to the correct window
2596 proc windows_mousewheel_redirector {W X Y D} {
2597 global canv canv2 canv3
2598 set w [winfo containing -displayof $W $X $Y]
2599 if {$w ne ""} {
2600 set u [expr {$D < 0 ? 5 : -5}]
2601 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2602 allcanvs yview scroll $u units
2603 } else {
2604 catch {
2605 $w yview scroll $u units
2611 # Update row number label when selectedline changes
2612 proc selectedline_change {n1 n2 op} {
2613 global selectedline rownumsel
2615 if {$selectedline eq {}} {
2616 set rownumsel {}
2617 } else {
2618 set rownumsel [expr {$selectedline + 1}]
2622 # mouse-2 makes all windows scan vertically, but only the one
2623 # the cursor is in scans horizontally
2624 proc canvscan {op w x y} {
2625 global canv canv2 canv3
2626 foreach c [list $canv $canv2 $canv3] {
2627 if {$c == $w} {
2628 $c scan $op $x $y
2629 } else {
2630 $c scan $op 0 $y
2635 proc scrollcanv {cscroll f0 f1} {
2636 $cscroll set $f0 $f1
2637 drawvisible
2638 flushhighlights
2641 # when we make a key binding for the toplevel, make sure
2642 # it doesn't get triggered when that key is pressed in the
2643 # find string entry widget.
2644 proc bindkey {ev script} {
2645 global entries
2646 bind . $ev $script
2647 set escript [bind Entry $ev]
2648 if {$escript == {}} {
2649 set escript [bind Entry <Key>]
2651 foreach e $entries {
2652 bind $e $ev "$escript; break"
2656 # set the focus back to the toplevel for any click outside
2657 # the entry widgets
2658 proc click {w} {
2659 global ctext entries
2660 foreach e [concat $entries $ctext] {
2661 if {$w == $e} return
2663 focus .
2666 # Adjust the progress bar for a change in requested extent or canvas size
2667 proc adjustprogress {} {
2668 global progresscanv progressitem progresscoords
2669 global fprogitem fprogcoord lastprogupdate progupdatepending
2670 global rprogitem rprogcoord use_ttk
2672 if {$use_ttk} {
2673 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2674 return
2677 set w [expr {[winfo width $progresscanv] - 4}]
2678 set x0 [expr {$w * [lindex $progresscoords 0]}]
2679 set x1 [expr {$w * [lindex $progresscoords 1]}]
2680 set h [winfo height $progresscanv]
2681 $progresscanv coords $progressitem $x0 0 $x1 $h
2682 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2683 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2684 set now [clock clicks -milliseconds]
2685 if {$now >= $lastprogupdate + 100} {
2686 set progupdatepending 0
2687 update
2688 } elseif {!$progupdatepending} {
2689 set progupdatepending 1
2690 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2694 proc doprogupdate {} {
2695 global lastprogupdate progupdatepending
2697 if {$progupdatepending} {
2698 set progupdatepending 0
2699 set lastprogupdate [clock clicks -milliseconds]
2700 update
2704 proc savestuff {w} {
2705 global canv canv2 canv3 mainfont textfont uifont tabstop
2706 global stuffsaved findmergefiles maxgraphpct
2707 global maxwidth showneartags showlocalchanges
2708 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2709 global cmitmode wrapcomment datetimeformat limitdiffs
2710 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2711 global autoselect autosellen extdifftool perfile_attrs markbgcolor use_ttk
2712 global hideremotes want_ttk
2714 if {$stuffsaved} return
2715 if {![winfo viewable .]} return
2716 catch {
2717 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2718 set f [open "~/.gitk-new" w]
2719 if {$::tcl_platform(platform) eq {windows}} {
2720 file attributes "~/.gitk-new" -hidden true
2722 puts $f [list set mainfont $mainfont]
2723 puts $f [list set textfont $textfont]
2724 puts $f [list set uifont $uifont]
2725 puts $f [list set tabstop $tabstop]
2726 puts $f [list set findmergefiles $findmergefiles]
2727 puts $f [list set maxgraphpct $maxgraphpct]
2728 puts $f [list set maxwidth $maxwidth]
2729 puts $f [list set cmitmode $cmitmode]
2730 puts $f [list set wrapcomment $wrapcomment]
2731 puts $f [list set autoselect $autoselect]
2732 puts $f [list set autosellen $autosellen]
2733 puts $f [list set showneartags $showneartags]
2734 puts $f [list set hideremotes $hideremotes]
2735 puts $f [list set showlocalchanges $showlocalchanges]
2736 puts $f [list set datetimeformat $datetimeformat]
2737 puts $f [list set limitdiffs $limitdiffs]
2738 puts $f [list set uicolor $uicolor]
2739 puts $f [list set want_ttk $want_ttk]
2740 puts $f [list set bgcolor $bgcolor]
2741 puts $f [list set fgcolor $fgcolor]
2742 puts $f [list set colors $colors]
2743 puts $f [list set diffcolors $diffcolors]
2744 puts $f [list set markbgcolor $markbgcolor]
2745 puts $f [list set diffcontext $diffcontext]
2746 puts $f [list set selectbgcolor $selectbgcolor]
2747 puts $f [list set extdifftool $extdifftool]
2748 puts $f [list set perfile_attrs $perfile_attrs]
2750 puts $f "set geometry(main) [wm geometry .]"
2751 puts $f "set geometry(state) [wm state .]"
2752 puts $f "set geometry(topwidth) [winfo width .tf]"
2753 puts $f "set geometry(topheight) [winfo height .tf]"
2754 if {$use_ttk} {
2755 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2756 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2757 } else {
2758 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2759 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2761 puts $f "set geometry(botwidth) [winfo width .bleft]"
2762 puts $f "set geometry(botheight) [winfo height .bleft]"
2764 puts -nonewline $f "set permviews {"
2765 for {set v 0} {$v < $nextviewnum} {incr v} {
2766 if {$viewperm($v)} {
2767 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2770 puts $f "}"
2771 close $f
2772 file rename -force "~/.gitk-new" "~/.gitk"
2774 set stuffsaved 1
2777 proc resizeclistpanes {win w} {
2778 global oldwidth use_ttk
2779 if {[info exists oldwidth($win)]} {
2780 if {$use_ttk} {
2781 set s0 [$win sashpos 0]
2782 set s1 [$win sashpos 1]
2783 } else {
2784 set s0 [$win sash coord 0]
2785 set s1 [$win sash coord 1]
2787 if {$w < 60} {
2788 set sash0 [expr {int($w/2 - 2)}]
2789 set sash1 [expr {int($w*5/6 - 2)}]
2790 } else {
2791 set factor [expr {1.0 * $w / $oldwidth($win)}]
2792 set sash0 [expr {int($factor * [lindex $s0 0])}]
2793 set sash1 [expr {int($factor * [lindex $s1 0])}]
2794 if {$sash0 < 30} {
2795 set sash0 30
2797 if {$sash1 < $sash0 + 20} {
2798 set sash1 [expr {$sash0 + 20}]
2800 if {$sash1 > $w - 10} {
2801 set sash1 [expr {$w - 10}]
2802 if {$sash0 > $sash1 - 20} {
2803 set sash0 [expr {$sash1 - 20}]
2807 if {$use_ttk} {
2808 $win sashpos 0 $sash0
2809 $win sashpos 1 $sash1
2810 } else {
2811 $win sash place 0 $sash0 [lindex $s0 1]
2812 $win sash place 1 $sash1 [lindex $s1 1]
2815 set oldwidth($win) $w
2818 proc resizecdetpanes {win w} {
2819 global oldwidth use_ttk
2820 if {[info exists oldwidth($win)]} {
2821 if {$use_ttk} {
2822 set s0 [$win sashpos 0]
2823 } else {
2824 set s0 [$win sash coord 0]
2826 if {$w < 60} {
2827 set sash0 [expr {int($w*3/4 - 2)}]
2828 } else {
2829 set factor [expr {1.0 * $w / $oldwidth($win)}]
2830 set sash0 [expr {int($factor * [lindex $s0 0])}]
2831 if {$sash0 < 45} {
2832 set sash0 45
2834 if {$sash0 > $w - 15} {
2835 set sash0 [expr {$w - 15}]
2838 if {$use_ttk} {
2839 $win sashpos 0 $sash0
2840 } else {
2841 $win sash place 0 $sash0 [lindex $s0 1]
2844 set oldwidth($win) $w
2847 proc allcanvs args {
2848 global canv canv2 canv3
2849 eval $canv $args
2850 eval $canv2 $args
2851 eval $canv3 $args
2854 proc bindall {event action} {
2855 global canv canv2 canv3
2856 bind $canv $event $action
2857 bind $canv2 $event $action
2858 bind $canv3 $event $action
2861 proc about {} {
2862 global uifont NS
2863 set w .about
2864 if {[winfo exists $w]} {
2865 raise $w
2866 return
2868 ttk_toplevel $w
2869 wm title $w [mc "About gitk"]
2870 make_transient $w .
2871 message $w.m -text [mc "
2872 Gitk - a commit viewer for git
2874 Copyright \u00a9 2005-2011 Paul Mackerras
2876 Use and redistribute under the terms of the GNU General Public License"] \
2877 -justify center -aspect 400 -border 2 -bg white -relief groove
2878 pack $w.m -side top -fill x -padx 2 -pady 2
2879 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2880 pack $w.ok -side bottom
2881 bind $w <Visibility> "focus $w.ok"
2882 bind $w <Key-Escape> "destroy $w"
2883 bind $w <Key-Return> "destroy $w"
2884 tk::PlaceWindow $w widget .
2887 proc keys {} {
2888 global NS
2889 set w .keys
2890 if {[winfo exists $w]} {
2891 raise $w
2892 return
2894 if {[tk windowingsystem] eq {aqua}} {
2895 set M1T Cmd
2896 } else {
2897 set M1T Ctrl
2899 ttk_toplevel $w
2900 wm title $w [mc "Gitk key bindings"]
2901 make_transient $w .
2902 message $w.m -text "
2903 [mc "Gitk key bindings:"]
2905 [mc "<%s-Q> Quit" $M1T]
2906 [mc "<%s-W> Close window" $M1T]
2907 [mc "<Home> Move to first commit"]
2908 [mc "<End> Move to last commit"]
2909 [mc "<Up>, p, k Move up one commit"]
2910 [mc "<Down>, n, j Move down one commit"]
2911 [mc "<Left>, z, h Go back in history list"]
2912 [mc "<Right>, x, l Go forward in history list"]
2913 [mc "<PageUp> Move up one page in commit list"]
2914 [mc "<PageDown> Move down one page in commit list"]
2915 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2916 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2917 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2918 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2919 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2920 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2921 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2922 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2923 [mc "<Delete>, b Scroll diff view up one page"]
2924 [mc "<Backspace> Scroll diff view up one page"]
2925 [mc "<Space> Scroll diff view down one page"]
2926 [mc "u Scroll diff view up 18 lines"]
2927 [mc "d Scroll diff view down 18 lines"]
2928 [mc "<%s-F> Find" $M1T]
2929 [mc "<%s-G> Move to next find hit" $M1T]
2930 [mc "<Return> Move to next find hit"]
2931 [mc "/ Focus the search box"]
2932 [mc "? Move to previous find hit"]
2933 [mc "f Scroll diff view to next file"]
2934 [mc "<%s-S> Search for next hit in diff view" $M1T]
2935 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2936 [mc "<%s-KP+> Increase font size" $M1T]
2937 [mc "<%s-plus> Increase font size" $M1T]
2938 [mc "<%s-KP-> Decrease font size" $M1T]
2939 [mc "<%s-minus> Decrease font size" $M1T]
2940 [mc "<F5> Update"]
2942 -justify left -bg white -border 2 -relief groove
2943 pack $w.m -side top -fill both -padx 2 -pady 2
2944 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2945 bind $w <Key-Escape> [list destroy $w]
2946 pack $w.ok -side bottom
2947 bind $w <Visibility> "focus $w.ok"
2948 bind $w <Key-Escape> "destroy $w"
2949 bind $w <Key-Return> "destroy $w"
2952 # Procedures for manipulating the file list window at the
2953 # bottom right of the overall window.
2955 proc treeview {w l openlevs} {
2956 global treecontents treediropen treeheight treeparent treeindex
2958 set ix 0
2959 set treeindex() 0
2960 set lev 0
2961 set prefix {}
2962 set prefixend -1
2963 set prefendstack {}
2964 set htstack {}
2965 set ht 0
2966 set treecontents() {}
2967 $w conf -state normal
2968 foreach f $l {
2969 while {[string range $f 0 $prefixend] ne $prefix} {
2970 if {$lev <= $openlevs} {
2971 $w mark set e:$treeindex($prefix) "end -1c"
2972 $w mark gravity e:$treeindex($prefix) left
2974 set treeheight($prefix) $ht
2975 incr ht [lindex $htstack end]
2976 set htstack [lreplace $htstack end end]
2977 set prefixend [lindex $prefendstack end]
2978 set prefendstack [lreplace $prefendstack end end]
2979 set prefix [string range $prefix 0 $prefixend]
2980 incr lev -1
2982 set tail [string range $f [expr {$prefixend+1}] end]
2983 while {[set slash [string first "/" $tail]] >= 0} {
2984 lappend htstack $ht
2985 set ht 0
2986 lappend prefendstack $prefixend
2987 incr prefixend [expr {$slash + 1}]
2988 set d [string range $tail 0 $slash]
2989 lappend treecontents($prefix) $d
2990 set oldprefix $prefix
2991 append prefix $d
2992 set treecontents($prefix) {}
2993 set treeindex($prefix) [incr ix]
2994 set treeparent($prefix) $oldprefix
2995 set tail [string range $tail [expr {$slash+1}] end]
2996 if {$lev <= $openlevs} {
2997 set ht 1
2998 set treediropen($prefix) [expr {$lev < $openlevs}]
2999 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3000 $w mark set d:$ix "end -1c"
3001 $w mark gravity d:$ix left
3002 set str "\n"
3003 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3004 $w insert end $str
3005 $w image create end -align center -image $bm -padx 1 \
3006 -name a:$ix
3007 $w insert end $d [highlight_tag $prefix]
3008 $w mark set s:$ix "end -1c"
3009 $w mark gravity s:$ix left
3011 incr lev
3013 if {$tail ne {}} {
3014 if {$lev <= $openlevs} {
3015 incr ht
3016 set str "\n"
3017 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3018 $w insert end $str
3019 $w insert end $tail [highlight_tag $f]
3021 lappend treecontents($prefix) $tail
3024 while {$htstack ne {}} {
3025 set treeheight($prefix) $ht
3026 incr ht [lindex $htstack end]
3027 set htstack [lreplace $htstack end end]
3028 set prefixend [lindex $prefendstack end]
3029 set prefendstack [lreplace $prefendstack end end]
3030 set prefix [string range $prefix 0 $prefixend]
3032 $w conf -state disabled
3035 proc linetoelt {l} {
3036 global treeheight treecontents
3038 set y 2
3039 set prefix {}
3040 while {1} {
3041 foreach e $treecontents($prefix) {
3042 if {$y == $l} {
3043 return "$prefix$e"
3045 set n 1
3046 if {[string index $e end] eq "/"} {
3047 set n $treeheight($prefix$e)
3048 if {$y + $n > $l} {
3049 append prefix $e
3050 incr y
3051 break
3054 incr y $n
3059 proc highlight_tree {y prefix} {
3060 global treeheight treecontents cflist
3062 foreach e $treecontents($prefix) {
3063 set path $prefix$e
3064 if {[highlight_tag $path] ne {}} {
3065 $cflist tag add bold $y.0 "$y.0 lineend"
3067 incr y
3068 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3069 set y [highlight_tree $y $path]
3072 return $y
3075 proc treeclosedir {w dir} {
3076 global treediropen treeheight treeparent treeindex
3078 set ix $treeindex($dir)
3079 $w conf -state normal
3080 $w delete s:$ix e:$ix
3081 set treediropen($dir) 0
3082 $w image configure a:$ix -image tri-rt
3083 $w conf -state disabled
3084 set n [expr {1 - $treeheight($dir)}]
3085 while {$dir ne {}} {
3086 incr treeheight($dir) $n
3087 set dir $treeparent($dir)
3091 proc treeopendir {w dir} {
3092 global treediropen treeheight treeparent treecontents treeindex
3094 set ix $treeindex($dir)
3095 $w conf -state normal
3096 $w image configure a:$ix -image tri-dn
3097 $w mark set e:$ix s:$ix
3098 $w mark gravity e:$ix right
3099 set lev 0
3100 set str "\n"
3101 set n [llength $treecontents($dir)]
3102 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3103 incr lev
3104 append str "\t"
3105 incr treeheight($x) $n
3107 foreach e $treecontents($dir) {
3108 set de $dir$e
3109 if {[string index $e end] eq "/"} {
3110 set iy $treeindex($de)
3111 $w mark set d:$iy e:$ix
3112 $w mark gravity d:$iy left
3113 $w insert e:$ix $str
3114 set treediropen($de) 0
3115 $w image create e:$ix -align center -image tri-rt -padx 1 \
3116 -name a:$iy
3117 $w insert e:$ix $e [highlight_tag $de]
3118 $w mark set s:$iy e:$ix
3119 $w mark gravity s:$iy left
3120 set treeheight($de) 1
3121 } else {
3122 $w insert e:$ix $str
3123 $w insert e:$ix $e [highlight_tag $de]
3126 $w mark gravity e:$ix right
3127 $w conf -state disabled
3128 set treediropen($dir) 1
3129 set top [lindex [split [$w index @0,0] .] 0]
3130 set ht [$w cget -height]
3131 set l [lindex [split [$w index s:$ix] .] 0]
3132 if {$l < $top} {
3133 $w yview $l.0
3134 } elseif {$l + $n + 1 > $top + $ht} {
3135 set top [expr {$l + $n + 2 - $ht}]
3136 if {$l < $top} {
3137 set top $l
3139 $w yview $top.0
3143 proc treeclick {w x y} {
3144 global treediropen cmitmode ctext cflist cflist_top
3146 if {$cmitmode ne "tree"} return
3147 if {![info exists cflist_top]} return
3148 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3149 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3150 $cflist tag add highlight $l.0 "$l.0 lineend"
3151 set cflist_top $l
3152 if {$l == 1} {
3153 $ctext yview 1.0
3154 return
3156 set e [linetoelt $l]
3157 if {[string index $e end] ne "/"} {
3158 showfile $e
3159 } elseif {$treediropen($e)} {
3160 treeclosedir $w $e
3161 } else {
3162 treeopendir $w $e
3166 proc setfilelist {id} {
3167 global treefilelist cflist jump_to_here
3169 treeview $cflist $treefilelist($id) 0
3170 if {$jump_to_here ne {}} {
3171 set f [lindex $jump_to_here 0]
3172 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3173 showfile $f
3178 image create bitmap tri-rt -background black -foreground blue -data {
3179 #define tri-rt_width 13
3180 #define tri-rt_height 13
3181 static unsigned char tri-rt_bits[] = {
3182 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3183 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3184 0x00, 0x00};
3185 } -maskdata {
3186 #define tri-rt-mask_width 13
3187 #define tri-rt-mask_height 13
3188 static unsigned char tri-rt-mask_bits[] = {
3189 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3190 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3191 0x08, 0x00};
3193 image create bitmap tri-dn -background black -foreground blue -data {
3194 #define tri-dn_width 13
3195 #define tri-dn_height 13
3196 static unsigned char tri-dn_bits[] = {
3197 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3198 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3199 0x00, 0x00};
3200 } -maskdata {
3201 #define tri-dn-mask_width 13
3202 #define tri-dn-mask_height 13
3203 static unsigned char tri-dn-mask_bits[] = {
3204 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3205 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3206 0x00, 0x00};
3209 image create bitmap reficon-T -background black -foreground yellow -data {
3210 #define tagicon_width 13
3211 #define tagicon_height 9
3212 static unsigned char tagicon_bits[] = {
3213 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3214 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3215 } -maskdata {
3216 #define tagicon-mask_width 13
3217 #define tagicon-mask_height 9
3218 static unsigned char tagicon-mask_bits[] = {
3219 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3220 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3222 set rectdata {
3223 #define headicon_width 13
3224 #define headicon_height 9
3225 static unsigned char headicon_bits[] = {
3226 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3227 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3229 set rectmask {
3230 #define headicon-mask_width 13
3231 #define headicon-mask_height 9
3232 static unsigned char headicon-mask_bits[] = {
3233 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3234 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3236 image create bitmap reficon-H -background black -foreground green \
3237 -data $rectdata -maskdata $rectmask
3238 image create bitmap reficon-o -background black -foreground "#ddddff" \
3239 -data $rectdata -maskdata $rectmask
3241 proc init_flist {first} {
3242 global cflist cflist_top difffilestart
3244 $cflist conf -state normal
3245 $cflist delete 0.0 end
3246 if {$first ne {}} {
3247 $cflist insert end $first
3248 set cflist_top 1
3249 $cflist tag add highlight 1.0 "1.0 lineend"
3250 } else {
3251 catch {unset cflist_top}
3253 $cflist conf -state disabled
3254 set difffilestart {}
3257 proc highlight_tag {f} {
3258 global highlight_paths
3260 foreach p $highlight_paths {
3261 if {[string match $p $f]} {
3262 return "bold"
3265 return {}
3268 proc highlight_filelist {} {
3269 global cmitmode cflist
3271 $cflist conf -state normal
3272 if {$cmitmode ne "tree"} {
3273 set end [lindex [split [$cflist index end] .] 0]
3274 for {set l 2} {$l < $end} {incr l} {
3275 set line [$cflist get $l.0 "$l.0 lineend"]
3276 if {[highlight_tag $line] ne {}} {
3277 $cflist tag add bold $l.0 "$l.0 lineend"
3280 } else {
3281 highlight_tree 2 {}
3283 $cflist conf -state disabled
3286 proc unhighlight_filelist {} {
3287 global cflist
3289 $cflist conf -state normal
3290 $cflist tag remove bold 1.0 end
3291 $cflist conf -state disabled
3294 proc add_flist {fl} {
3295 global cflist
3297 $cflist conf -state normal
3298 foreach f $fl {
3299 $cflist insert end "\n"
3300 $cflist insert end $f [highlight_tag $f]
3302 $cflist conf -state disabled
3305 proc sel_flist {w x y} {
3306 global ctext difffilestart cflist cflist_top cmitmode
3308 if {$cmitmode eq "tree"} return
3309 if {![info exists cflist_top]} return
3310 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3311 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3312 $cflist tag add highlight $l.0 "$l.0 lineend"
3313 set cflist_top $l
3314 if {$l == 1} {
3315 $ctext yview 1.0
3316 } else {
3317 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3319 suppress_highlighting_file_for_current_scrollpos
3322 proc pop_flist_menu {w X Y x y} {
3323 global ctext cflist cmitmode flist_menu flist_menu_file
3324 global treediffs diffids
3326 stopfinding
3327 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3328 if {$l <= 1} return
3329 if {$cmitmode eq "tree"} {
3330 set e [linetoelt $l]
3331 if {[string index $e end] eq "/"} return
3332 } else {
3333 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3335 set flist_menu_file $e
3336 set xdiffstate "normal"
3337 if {$cmitmode eq "tree"} {
3338 set xdiffstate "disabled"
3340 # Disable "External diff" item in tree mode
3341 $flist_menu entryconf 2 -state $xdiffstate
3342 tk_popup $flist_menu $X $Y
3345 proc find_ctext_fileinfo {line} {
3346 global ctext_file_names ctext_file_lines
3348 set ok [bsearch $ctext_file_lines $line]
3349 set tline [lindex $ctext_file_lines $ok]
3351 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3352 return {}
3353 } else {
3354 return [list [lindex $ctext_file_names $ok] $tline]
3358 proc pop_diff_menu {w X Y x y} {
3359 global ctext diff_menu flist_menu_file
3360 global diff_menu_txtpos diff_menu_line
3361 global diff_menu_filebase
3363 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3364 set diff_menu_line [lindex $diff_menu_txtpos 0]
3365 # don't pop up the menu on hunk-separator or file-separator lines
3366 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3367 return
3369 stopfinding
3370 set f [find_ctext_fileinfo $diff_menu_line]
3371 if {$f eq {}} return
3372 set flist_menu_file [lindex $f 0]
3373 set diff_menu_filebase [lindex $f 1]
3374 tk_popup $diff_menu $X $Y
3377 proc flist_hl {only} {
3378 global flist_menu_file findstring gdttype
3380 set x [shellquote $flist_menu_file]
3381 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3382 set findstring $x
3383 } else {
3384 append findstring " " $x
3386 set gdttype [mc "touching paths:"]
3389 proc gitknewtmpdir {} {
3390 global diffnum gitktmpdir gitdir
3392 if {![info exists gitktmpdir]} {
3393 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3394 if {[catch {file mkdir $gitktmpdir} err]} {
3395 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3396 unset gitktmpdir
3397 return {}
3399 set diffnum 0
3401 incr diffnum
3402 set diffdir [file join $gitktmpdir $diffnum]
3403 if {[catch {file mkdir $diffdir} err]} {
3404 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3405 return {}
3407 return $diffdir
3410 proc save_file_from_commit {filename output what} {
3411 global nullfile
3413 if {[catch {exec git show $filename -- > $output} err]} {
3414 if {[string match "fatal: bad revision *" $err]} {
3415 return $nullfile
3417 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3418 return {}
3420 return $output
3423 proc external_diff_get_one_file {diffid filename diffdir} {
3424 global nullid nullid2 nullfile
3425 global worktree
3427 if {$diffid == $nullid} {
3428 set difffile [file join $worktree $filename]
3429 if {[file exists $difffile]} {
3430 return $difffile
3432 return $nullfile
3434 if {$diffid == $nullid2} {
3435 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3436 return [save_file_from_commit :$filename $difffile index]
3438 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3439 return [save_file_from_commit $diffid:$filename $difffile \
3440 "revision $diffid"]
3443 proc external_diff {} {
3444 global nullid nullid2
3445 global flist_menu_file
3446 global diffids
3447 global extdifftool
3449 if {[llength $diffids] == 1} {
3450 # no reference commit given
3451 set diffidto [lindex $diffids 0]
3452 if {$diffidto eq $nullid} {
3453 # diffing working copy with index
3454 set diffidfrom $nullid2
3455 } elseif {$diffidto eq $nullid2} {
3456 # diffing index with HEAD
3457 set diffidfrom "HEAD"
3458 } else {
3459 # use first parent commit
3460 global parentlist selectedline
3461 set diffidfrom [lindex $parentlist $selectedline 0]
3463 } else {
3464 set diffidfrom [lindex $diffids 0]
3465 set diffidto [lindex $diffids 1]
3468 # make sure that several diffs wont collide
3469 set diffdir [gitknewtmpdir]
3470 if {$diffdir eq {}} return
3472 # gather files to diff
3473 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3474 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3476 if {$difffromfile ne {} && $difftofile ne {}} {
3477 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3478 if {[catch {set fl [open |$cmd r]} err]} {
3479 file delete -force $diffdir
3480 error_popup "$extdifftool: [mc "command failed:"] $err"
3481 } else {
3482 fconfigure $fl -blocking 0
3483 filerun $fl [list delete_at_eof $fl $diffdir]
3488 proc find_hunk_blamespec {base line} {
3489 global ctext
3491 # Find and parse the hunk header
3492 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3493 if {$s_lix eq {}} return
3495 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3496 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3497 s_line old_specs osz osz1 new_line nsz]} {
3498 return
3501 # base lines for the parents
3502 set base_lines [list $new_line]
3503 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3504 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3505 old_spec old_line osz]} {
3506 return
3508 lappend base_lines $old_line
3511 # Now scan the lines to determine offset within the hunk
3512 set max_parent [expr {[llength $base_lines]-2}]
3513 set dline 0
3514 set s_lno [lindex [split $s_lix "."] 0]
3516 # Determine if the line is removed
3517 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3518 if {[string match {[-+ ]*} $chunk]} {
3519 set removed_idx [string first "-" $chunk]
3520 # Choose a parent index
3521 if {$removed_idx >= 0} {
3522 set parent $removed_idx
3523 } else {
3524 set unchanged_idx [string first " " $chunk]
3525 if {$unchanged_idx >= 0} {
3526 set parent $unchanged_idx
3527 } else {
3528 # blame the current commit
3529 set parent -1
3532 # then count other lines that belong to it
3533 for {set i $line} {[incr i -1] > $s_lno} {} {
3534 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3535 # Determine if the line is removed
3536 set removed_idx [string first "-" $chunk]
3537 if {$parent >= 0} {
3538 set code [string index $chunk $parent]
3539 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3540 incr dline
3542 } else {
3543 if {$removed_idx < 0} {
3544 incr dline
3548 incr parent
3549 } else {
3550 set parent 0
3553 incr dline [lindex $base_lines $parent]
3554 return [list $parent $dline]
3557 proc external_blame_diff {} {
3558 global currentid cmitmode
3559 global diff_menu_txtpos diff_menu_line
3560 global diff_menu_filebase flist_menu_file
3562 if {$cmitmode eq "tree"} {
3563 set parent_idx 0
3564 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3565 } else {
3566 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3567 if {$hinfo ne {}} {
3568 set parent_idx [lindex $hinfo 0]
3569 set line [lindex $hinfo 1]
3570 } else {
3571 set parent_idx 0
3572 set line 0
3576 external_blame $parent_idx $line
3579 # Find the SHA1 ID of the blob for file $fname in the index
3580 # at stage 0 or 2
3581 proc index_sha1 {fname} {
3582 set f [open [list | git ls-files -s $fname] r]
3583 while {[gets $f line] >= 0} {
3584 set info [lindex [split $line "\t"] 0]
3585 set stage [lindex $info 2]
3586 if {$stage eq "0" || $stage eq "2"} {
3587 close $f
3588 return [lindex $info 1]
3591 close $f
3592 return {}
3595 # Turn an absolute path into one relative to the current directory
3596 proc make_relative {f} {
3597 if {[file pathtype $f] eq "relative"} {
3598 return $f
3600 set elts [file split $f]
3601 set here [file split [pwd]]
3602 set ei 0
3603 set hi 0
3604 set res {}
3605 foreach d $here {
3606 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3607 lappend res ".."
3608 } else {
3609 incr ei
3611 incr hi
3613 set elts [concat $res [lrange $elts $ei end]]
3614 return [eval file join $elts]
3617 proc external_blame {parent_idx {line {}}} {
3618 global flist_menu_file cdup
3619 global nullid nullid2
3620 global parentlist selectedline currentid
3622 if {$parent_idx > 0} {
3623 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3624 } else {
3625 set base_commit $currentid
3628 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3629 error_popup [mc "No such commit"]
3630 return
3633 set cmdline [list git gui blame]
3634 if {$line ne {} && $line > 1} {
3635 lappend cmdline "--line=$line"
3637 set f [file join $cdup $flist_menu_file]
3638 # Unfortunately it seems git gui blame doesn't like
3639 # being given an absolute path...
3640 set f [make_relative $f]
3641 lappend cmdline $base_commit $f
3642 if {[catch {eval exec $cmdline &} err]} {
3643 error_popup "[mc "git gui blame: command failed:"] $err"
3647 proc show_line_source {} {
3648 global cmitmode currentid parents curview blamestuff blameinst
3649 global diff_menu_line diff_menu_filebase flist_menu_file
3650 global nullid nullid2 gitdir cdup
3652 set from_index {}
3653 if {$cmitmode eq "tree"} {
3654 set id $currentid
3655 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3656 } else {
3657 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3658 if {$h eq {}} return
3659 set pi [lindex $h 0]
3660 if {$pi == 0} {
3661 mark_ctext_line $diff_menu_line
3662 return
3664 incr pi -1
3665 if {$currentid eq $nullid} {
3666 if {$pi > 0} {
3667 # must be a merge in progress...
3668 if {[catch {
3669 # get the last line from .git/MERGE_HEAD
3670 set f [open [file join $gitdir MERGE_HEAD] r]
3671 set id [lindex [split [read $f] "\n"] end-1]
3672 close $f
3673 } err]} {
3674 error_popup [mc "Couldn't read merge head: %s" $err]
3675 return
3677 } elseif {$parents($curview,$currentid) eq $nullid2} {
3678 # need to do the blame from the index
3679 if {[catch {
3680 set from_index [index_sha1 $flist_menu_file]
3681 } err]} {
3682 error_popup [mc "Error reading index: %s" $err]
3683 return
3685 } else {
3686 set id $parents($curview,$currentid)
3688 } else {
3689 set id [lindex $parents($curview,$currentid) $pi]
3691 set line [lindex $h 1]
3693 set blameargs {}
3694 if {$from_index ne {}} {
3695 lappend blameargs | git cat-file blob $from_index
3697 lappend blameargs | git blame -p -L$line,+1
3698 if {$from_index ne {}} {
3699 lappend blameargs --contents -
3700 } else {
3701 lappend blameargs $id
3703 lappend blameargs -- [file join $cdup $flist_menu_file]
3704 if {[catch {
3705 set f [open $blameargs r]
3706 } err]} {
3707 error_popup [mc "Couldn't start git blame: %s" $err]
3708 return
3710 nowbusy blaming [mc "Searching"]
3711 fconfigure $f -blocking 0
3712 set i [reg_instance $f]
3713 set blamestuff($i) {}
3714 set blameinst $i
3715 filerun $f [list read_line_source $f $i]
3718 proc stopblaming {} {
3719 global blameinst
3721 if {[info exists blameinst]} {
3722 stop_instance $blameinst
3723 unset blameinst
3724 notbusy blaming
3728 proc read_line_source {fd inst} {
3729 global blamestuff curview commfd blameinst nullid nullid2
3731 while {[gets $fd line] >= 0} {
3732 lappend blamestuff($inst) $line
3734 if {![eof $fd]} {
3735 return 1
3737 unset commfd($inst)
3738 unset blameinst
3739 notbusy blaming
3740 fconfigure $fd -blocking 1
3741 if {[catch {close $fd} err]} {
3742 error_popup [mc "Error running git blame: %s" $err]
3743 return 0
3746 set fname {}
3747 set line [split [lindex $blamestuff($inst) 0] " "]
3748 set id [lindex $line 0]
3749 set lnum [lindex $line 1]
3750 if {[string length $id] == 40 && [string is xdigit $id] &&
3751 [string is digit -strict $lnum]} {
3752 # look for "filename" line
3753 foreach l $blamestuff($inst) {
3754 if {[string match "filename *" $l]} {
3755 set fname [string range $l 9 end]
3756 break
3760 if {$fname ne {}} {
3761 # all looks good, select it
3762 if {$id eq $nullid} {
3763 # blame uses all-zeroes to mean not committed,
3764 # which would mean a change in the index
3765 set id $nullid2
3767 if {[commitinview $id $curview]} {
3768 selectline [rowofcommit $id] 1 [list $fname $lnum]
3769 } else {
3770 error_popup [mc "That line comes from commit %s, \
3771 which is not in this view" [shortids $id]]
3773 } else {
3774 puts "oops couldn't parse git blame output"
3776 return 0
3779 # delete $dir when we see eof on $f (presumably because the child has exited)
3780 proc delete_at_eof {f dir} {
3781 while {[gets $f line] >= 0} {}
3782 if {[eof $f]} {
3783 if {[catch {close $f} err]} {
3784 error_popup "[mc "External diff viewer failed:"] $err"
3786 file delete -force $dir
3787 return 0
3789 return 1
3792 # Functions for adding and removing shell-type quoting
3794 proc shellquote {str} {
3795 if {![string match "*\['\"\\ \t]*" $str]} {
3796 return $str
3798 if {![string match "*\['\"\\]*" $str]} {
3799 return "\"$str\""
3801 if {![string match "*'*" $str]} {
3802 return "'$str'"
3804 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3807 proc shellarglist {l} {
3808 set str {}
3809 foreach a $l {
3810 if {$str ne {}} {
3811 append str " "
3813 append str [shellquote $a]
3815 return $str
3818 proc shelldequote {str} {
3819 set ret {}
3820 set used -1
3821 while {1} {
3822 incr used
3823 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3824 append ret [string range $str $used end]
3825 set used [string length $str]
3826 break
3828 set first [lindex $first 0]
3829 set ch [string index $str $first]
3830 if {$first > $used} {
3831 append ret [string range $str $used [expr {$first - 1}]]
3832 set used $first
3834 if {$ch eq " " || $ch eq "\t"} break
3835 incr used
3836 if {$ch eq "'"} {
3837 set first [string first "'" $str $used]
3838 if {$first < 0} {
3839 error "unmatched single-quote"
3841 append ret [string range $str $used [expr {$first - 1}]]
3842 set used $first
3843 continue
3845 if {$ch eq "\\"} {
3846 if {$used >= [string length $str]} {
3847 error "trailing backslash"
3849 append ret [string index $str $used]
3850 continue
3852 # here ch == "\""
3853 while {1} {
3854 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3855 error "unmatched double-quote"
3857 set first [lindex $first 0]
3858 set ch [string index $str $first]
3859 if {$first > $used} {
3860 append ret [string range $str $used [expr {$first - 1}]]
3861 set used $first
3863 if {$ch eq "\""} break
3864 incr used
3865 append ret [string index $str $used]
3866 incr used
3869 return [list $used $ret]
3872 proc shellsplit {str} {
3873 set l {}
3874 while {1} {
3875 set str [string trimleft $str]
3876 if {$str eq {}} break
3877 set dq [shelldequote $str]
3878 set n [lindex $dq 0]
3879 set word [lindex $dq 1]
3880 set str [string range $str $n end]
3881 lappend l $word
3883 return $l
3886 # Code to implement multiple views
3888 proc newview {ishighlight} {
3889 global nextviewnum newviewname newishighlight
3890 global revtreeargs viewargscmd newviewopts curview
3892 set newishighlight $ishighlight
3893 set top .gitkview
3894 if {[winfo exists $top]} {
3895 raise $top
3896 return
3898 decode_view_opts $nextviewnum $revtreeargs
3899 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3900 set newviewopts($nextviewnum,perm) 0
3901 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3902 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3905 set known_view_options {
3906 {perm b . {} {mc "Remember this view"}}
3907 {reflabel l + {} {mc "References (space separated list):"}}
3908 {refs t15 .. {} {mc "Branches & tags:"}}
3909 {allrefs b *. "--all" {mc "All refs"}}
3910 {branches b . "--branches" {mc "All (local) branches"}}
3911 {tags b . "--tags" {mc "All tags"}}
3912 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3913 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3914 {author t15 .. "--author=*" {mc "Author:"}}
3915 {committer t15 . "--committer=*" {mc "Committer:"}}
3916 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3917 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3918 {changes_l l + {} {mc "Changes to Files:"}}
3919 {pickaxe_s r0 . {} {mc "Fixed String"}}
3920 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3921 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3922 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3923 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3924 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3925 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3926 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3927 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3928 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3929 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3930 {lright b . "--left-right" {mc "Mark branch sides"}}
3931 {first b . "--first-parent" {mc "Limit to first parent"}}
3932 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3933 {args t50 *. {} {mc "Additional arguments to git log:"}}
3934 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3935 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3938 # Convert $newviewopts($n, ...) into args for git log.
3939 proc encode_view_opts {n} {
3940 global known_view_options newviewopts
3942 set rargs [list]
3943 foreach opt $known_view_options {
3944 set patterns [lindex $opt 3]
3945 if {$patterns eq {}} continue
3946 set pattern [lindex $patterns 0]
3948 if {[lindex $opt 1] eq "b"} {
3949 set val $newviewopts($n,[lindex $opt 0])
3950 if {$val} {
3951 lappend rargs $pattern
3953 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3954 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3955 set val $newviewopts($n,$button_id)
3956 if {$val eq $value} {
3957 lappend rargs $pattern
3959 } else {
3960 set val $newviewopts($n,[lindex $opt 0])
3961 set val [string trim $val]
3962 if {$val ne {}} {
3963 set pfix [string range $pattern 0 end-1]
3964 lappend rargs $pfix$val
3968 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3969 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3972 # Fill $newviewopts($n, ...) based on args for git log.
3973 proc decode_view_opts {n view_args} {
3974 global known_view_options newviewopts
3976 foreach opt $known_view_options {
3977 set id [lindex $opt 0]
3978 if {[lindex $opt 1] eq "b"} {
3979 # Checkboxes
3980 set val 0
3981 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3982 # Radiobuttons
3983 regexp {^(.*_)} $id uselessvar id
3984 set val 0
3985 } else {
3986 # Text fields
3987 set val {}
3989 set newviewopts($n,$id) $val
3991 set oargs [list]
3992 set refargs [list]
3993 foreach arg $view_args {
3994 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3995 && ![info exists found(limit)]} {
3996 set newviewopts($n,limit) $cnt
3997 set found(limit) 1
3998 continue
4000 catch { unset val }
4001 foreach opt $known_view_options {
4002 set id [lindex $opt 0]
4003 if {[info exists found($id)]} continue
4004 foreach pattern [lindex $opt 3] {
4005 if {![string match $pattern $arg]} continue
4006 if {[lindex $opt 1] eq "b"} {
4007 # Check buttons
4008 set val 1
4009 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4010 # Radio buttons
4011 regexp {^(.*_)} $id uselessvar id
4012 set val $num
4013 } else {
4014 # Text input fields
4015 set size [string length $pattern]
4016 set val [string range $arg [expr {$size-1}] end]
4018 set newviewopts($n,$id) $val
4019 set found($id) 1
4020 break
4022 if {[info exists val]} break
4024 if {[info exists val]} continue
4025 if {[regexp {^-} $arg]} {
4026 lappend oargs $arg
4027 } else {
4028 lappend refargs $arg
4031 set newviewopts($n,refs) [shellarglist $refargs]
4032 set newviewopts($n,args) [shellarglist $oargs]
4035 proc edit_or_newview {} {
4036 global curview
4038 if {$curview > 0} {
4039 editview
4040 } else {
4041 newview 0
4045 proc editview {} {
4046 global curview
4047 global viewname viewperm newviewname newviewopts
4048 global viewargs viewargscmd
4050 set top .gitkvedit-$curview
4051 if {[winfo exists $top]} {
4052 raise $top
4053 return
4055 decode_view_opts $curview $viewargs($curview)
4056 set newviewname($curview) $viewname($curview)
4057 set newviewopts($curview,perm) $viewperm($curview)
4058 set newviewopts($curview,cmd) $viewargscmd($curview)
4059 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4062 proc vieweditor {top n title} {
4063 global newviewname newviewopts viewfiles bgcolor
4064 global known_view_options NS
4066 ttk_toplevel $top
4067 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4068 make_transient $top .
4070 # View name
4071 ${NS}::frame $top.nfr
4072 ${NS}::label $top.nl -text [mc "View Name"]
4073 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4074 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4075 pack $top.nl -in $top.nfr -side left -padx {0 5}
4076 pack $top.name -in $top.nfr -side left -padx {0 25}
4078 # View options
4079 set cframe $top.nfr
4080 set cexpand 0
4081 set cnt 0
4082 foreach opt $known_view_options {
4083 set id [lindex $opt 0]
4084 set type [lindex $opt 1]
4085 set flags [lindex $opt 2]
4086 set title [eval [lindex $opt 4]]
4087 set lxpad 0
4089 if {$flags eq "+" || $flags eq "*"} {
4090 set cframe $top.fr$cnt
4091 incr cnt
4092 ${NS}::frame $cframe
4093 pack $cframe -in $top -fill x -pady 3 -padx 3
4094 set cexpand [expr {$flags eq "*"}]
4095 } elseif {$flags eq ".." || $flags eq "*."} {
4096 set cframe $top.fr$cnt
4097 incr cnt
4098 ${NS}::frame $cframe
4099 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4100 set cexpand [expr {$flags eq "*."}]
4101 } else {
4102 set lxpad 5
4105 if {$type eq "l"} {
4106 ${NS}::label $cframe.l_$id -text $title
4107 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4108 } elseif {$type eq "b"} {
4109 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4110 pack $cframe.c_$id -in $cframe -side left \
4111 -padx [list $lxpad 0] -expand $cexpand -anchor w
4112 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4113 regexp {^(.*_)} $id uselessvar button_id
4114 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4115 pack $cframe.c_$id -in $cframe -side left \
4116 -padx [list $lxpad 0] -expand $cexpand -anchor w
4117 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4118 ${NS}::label $cframe.l_$id -text $title
4119 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4120 -textvariable newviewopts($n,$id)
4121 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4122 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4123 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4124 ${NS}::label $cframe.l_$id -text $title
4125 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4126 -textvariable newviewopts($n,$id)
4127 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4128 pack $cframe.e_$id -in $cframe -side top -fill x
4129 } elseif {$type eq "path"} {
4130 ${NS}::label $top.l -text $title
4131 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4132 text $top.t -width 40 -height 5 -background $bgcolor
4133 if {[info exists viewfiles($n)]} {
4134 foreach f $viewfiles($n) {
4135 $top.t insert end $f
4136 $top.t insert end "\n"
4138 $top.t delete {end - 1c} end
4139 $top.t mark set insert 0.0
4141 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4145 ${NS}::frame $top.buts
4146 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4147 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4148 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4149 bind $top <Control-Return> [list newviewok $top $n]
4150 bind $top <F5> [list newviewok $top $n 1]
4151 bind $top <Escape> [list destroy $top]
4152 grid $top.buts.ok $top.buts.apply $top.buts.can
4153 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4154 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4155 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4156 pack $top.buts -in $top -side top -fill x
4157 focus $top.t
4160 proc doviewmenu {m first cmd op argv} {
4161 set nmenu [$m index end]
4162 for {set i $first} {$i <= $nmenu} {incr i} {
4163 if {[$m entrycget $i -command] eq $cmd} {
4164 eval $m $op $i $argv
4165 break
4170 proc allviewmenus {n op args} {
4171 # global viewhlmenu
4173 doviewmenu .bar.view 5 [list showview $n] $op $args
4174 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4177 proc newviewok {top n {apply 0}} {
4178 global nextviewnum newviewperm newviewname newishighlight
4179 global viewname viewfiles viewperm selectedview curview
4180 global viewargs viewargscmd newviewopts viewhlmenu
4182 if {[catch {
4183 set newargs [encode_view_opts $n]
4184 } err]} {
4185 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4186 return
4188 set files {}
4189 foreach f [split [$top.t get 0.0 end] "\n"] {
4190 set ft [string trim $f]
4191 if {$ft ne {}} {
4192 lappend files $ft
4195 if {![info exists viewfiles($n)]} {
4196 # creating a new view
4197 incr nextviewnum
4198 set viewname($n) $newviewname($n)
4199 set viewperm($n) $newviewopts($n,perm)
4200 set viewfiles($n) $files
4201 set viewargs($n) $newargs
4202 set viewargscmd($n) $newviewopts($n,cmd)
4203 addviewmenu $n
4204 if {!$newishighlight} {
4205 run showview $n
4206 } else {
4207 run addvhighlight $n
4209 } else {
4210 # editing an existing view
4211 set viewperm($n) $newviewopts($n,perm)
4212 if {$newviewname($n) ne $viewname($n)} {
4213 set viewname($n) $newviewname($n)
4214 doviewmenu .bar.view 5 [list showview $n] \
4215 entryconf [list -label $viewname($n)]
4216 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4217 # entryconf [list -label $viewname($n) -value $viewname($n)]
4219 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4220 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4221 set viewfiles($n) $files
4222 set viewargs($n) $newargs
4223 set viewargscmd($n) $newviewopts($n,cmd)
4224 if {$curview == $n} {
4225 run reloadcommits
4229 if {$apply} return
4230 catch {destroy $top}
4233 proc delview {} {
4234 global curview viewperm hlview selectedhlview
4236 if {$curview == 0} return
4237 if {[info exists hlview] && $hlview == $curview} {
4238 set selectedhlview [mc "None"]
4239 unset hlview
4241 allviewmenus $curview delete
4242 set viewperm($curview) 0
4243 showview 0
4246 proc addviewmenu {n} {
4247 global viewname viewhlmenu
4249 .bar.view add radiobutton -label $viewname($n) \
4250 -command [list showview $n] -variable selectedview -value $n
4251 #$viewhlmenu add radiobutton -label $viewname($n) \
4252 # -command [list addvhighlight $n] -variable selectedhlview
4255 proc showview {n} {
4256 global curview cached_commitrow ordertok
4257 global displayorder parentlist rowidlist rowisopt rowfinal
4258 global colormap rowtextx nextcolor canvxmax
4259 global numcommits viewcomplete
4260 global selectedline currentid canv canvy0
4261 global treediffs
4262 global pending_select mainheadid
4263 global commitidx
4264 global selectedview
4265 global hlview selectedhlview commitinterest
4267 if {$n == $curview} return
4268 set selid {}
4269 set ymax [lindex [$canv cget -scrollregion] 3]
4270 set span [$canv yview]
4271 set ytop [expr {[lindex $span 0] * $ymax}]
4272 set ybot [expr {[lindex $span 1] * $ymax}]
4273 set yscreen [expr {($ybot - $ytop) / 2}]
4274 if {$selectedline ne {}} {
4275 set selid $currentid
4276 set y [yc $selectedline]
4277 if {$ytop < $y && $y < $ybot} {
4278 set yscreen [expr {$y - $ytop}]
4280 } elseif {[info exists pending_select]} {
4281 set selid $pending_select
4282 unset pending_select
4284 unselectline
4285 normalline
4286 catch {unset treediffs}
4287 clear_display
4288 if {[info exists hlview] && $hlview == $n} {
4289 unset hlview
4290 set selectedhlview [mc "None"]
4292 catch {unset commitinterest}
4293 catch {unset cached_commitrow}
4294 catch {unset ordertok}
4296 set curview $n
4297 set selectedview $n
4298 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4299 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4301 run refill_reflist
4302 if {![info exists viewcomplete($n)]} {
4303 getcommits $selid
4304 return
4307 set displayorder {}
4308 set parentlist {}
4309 set rowidlist {}
4310 set rowisopt {}
4311 set rowfinal {}
4312 set numcommits $commitidx($n)
4314 catch {unset colormap}
4315 catch {unset rowtextx}
4316 set nextcolor 0
4317 set canvxmax [$canv cget -width]
4318 set curview $n
4319 set row 0
4320 setcanvscroll
4321 set yf 0
4322 set row {}
4323 if {$selid ne {} && [commitinview $selid $n]} {
4324 set row [rowofcommit $selid]
4325 # try to get the selected row in the same position on the screen
4326 set ymax [lindex [$canv cget -scrollregion] 3]
4327 set ytop [expr {[yc $row] - $yscreen}]
4328 if {$ytop < 0} {
4329 set ytop 0
4331 set yf [expr {$ytop * 1.0 / $ymax}]
4333 allcanvs yview moveto $yf
4334 drawvisible
4335 if {$row ne {}} {
4336 selectline $row 0
4337 } elseif {!$viewcomplete($n)} {
4338 reset_pending_select $selid
4339 } else {
4340 reset_pending_select {}
4342 if {[commitinview $pending_select $curview]} {
4343 selectline [rowofcommit $pending_select] 1
4344 } else {
4345 set row [first_real_row]
4346 if {$row < $numcommits} {
4347 selectline $row 0
4351 if {!$viewcomplete($n)} {
4352 if {$numcommits == 0} {
4353 show_status [mc "Reading commits..."]
4355 } elseif {$numcommits == 0} {
4356 show_status [mc "No commits selected"]
4360 # Stuff relating to the highlighting facility
4362 proc ishighlighted {id} {
4363 global vhighlights fhighlights nhighlights rhighlights
4365 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4366 return $nhighlights($id)
4368 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4369 return $vhighlights($id)
4371 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4372 return $fhighlights($id)
4374 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4375 return $rhighlights($id)
4377 return 0
4380 proc bolden {id font} {
4381 global canv linehtag currentid boldids need_redisplay markedid
4383 # need_redisplay = 1 means the display is stale and about to be redrawn
4384 if {$need_redisplay} return
4385 lappend boldids $id
4386 $canv itemconf $linehtag($id) -font $font
4387 if {[info exists currentid] && $id eq $currentid} {
4388 $canv delete secsel
4389 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4390 -outline {{}} -tags secsel \
4391 -fill [$canv cget -selectbackground]]
4392 $canv lower $t
4394 if {[info exists markedid] && $id eq $markedid} {
4395 make_idmark $id
4399 proc bolden_name {id font} {
4400 global canv2 linentag currentid boldnameids need_redisplay
4402 if {$need_redisplay} return
4403 lappend boldnameids $id
4404 $canv2 itemconf $linentag($id) -font $font
4405 if {[info exists currentid] && $id eq $currentid} {
4406 $canv2 delete secsel
4407 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4408 -outline {{}} -tags secsel \
4409 -fill [$canv2 cget -selectbackground]]
4410 $canv2 lower $t
4414 proc unbolden {} {
4415 global boldids
4417 set stillbold {}
4418 foreach id $boldids {
4419 if {![ishighlighted $id]} {
4420 bolden $id mainfont
4421 } else {
4422 lappend stillbold $id
4425 set boldids $stillbold
4428 proc addvhighlight {n} {
4429 global hlview viewcomplete curview vhl_done commitidx
4431 if {[info exists hlview]} {
4432 delvhighlight
4434 set hlview $n
4435 if {$n != $curview && ![info exists viewcomplete($n)]} {
4436 start_rev_list $n
4438 set vhl_done $commitidx($hlview)
4439 if {$vhl_done > 0} {
4440 drawvisible
4444 proc delvhighlight {} {
4445 global hlview vhighlights
4447 if {![info exists hlview]} return
4448 unset hlview
4449 catch {unset vhighlights}
4450 unbolden
4453 proc vhighlightmore {} {
4454 global hlview vhl_done commitidx vhighlights curview
4456 set max $commitidx($hlview)
4457 set vr [visiblerows]
4458 set r0 [lindex $vr 0]
4459 set r1 [lindex $vr 1]
4460 for {set i $vhl_done} {$i < $max} {incr i} {
4461 set id [commitonrow $i $hlview]
4462 if {[commitinview $id $curview]} {
4463 set row [rowofcommit $id]
4464 if {$r0 <= $row && $row <= $r1} {
4465 if {![highlighted $row]} {
4466 bolden $id mainfontbold
4468 set vhighlights($id) 1
4472 set vhl_done $max
4473 return 0
4476 proc askvhighlight {row id} {
4477 global hlview vhighlights iddrawn
4479 if {[commitinview $id $hlview]} {
4480 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4481 bolden $id mainfontbold
4483 set vhighlights($id) 1
4484 } else {
4485 set vhighlights($id) 0
4489 proc hfiles_change {} {
4490 global highlight_files filehighlight fhighlights fh_serial
4491 global highlight_paths
4493 if {[info exists filehighlight]} {
4494 # delete previous highlights
4495 catch {close $filehighlight}
4496 unset filehighlight
4497 catch {unset fhighlights}
4498 unbolden
4499 unhighlight_filelist
4501 set highlight_paths {}
4502 after cancel do_file_hl $fh_serial
4503 incr fh_serial
4504 if {$highlight_files ne {}} {
4505 after 300 do_file_hl $fh_serial
4509 proc gdttype_change {name ix op} {
4510 global gdttype highlight_files findstring findpattern
4512 stopfinding
4513 if {$findstring ne {}} {
4514 if {$gdttype eq [mc "containing:"]} {
4515 if {$highlight_files ne {}} {
4516 set highlight_files {}
4517 hfiles_change
4519 findcom_change
4520 } else {
4521 if {$findpattern ne {}} {
4522 set findpattern {}
4523 findcom_change
4525 set highlight_files $findstring
4526 hfiles_change
4528 drawvisible
4530 # enable/disable findtype/findloc menus too
4533 proc find_change {name ix op} {
4534 global gdttype findstring highlight_files
4536 stopfinding
4537 if {$gdttype eq [mc "containing:"]} {
4538 findcom_change
4539 } else {
4540 if {$highlight_files ne $findstring} {
4541 set highlight_files $findstring
4542 hfiles_change
4545 drawvisible
4548 proc findcom_change args {
4549 global nhighlights boldnameids
4550 global findpattern findtype findstring gdttype
4552 stopfinding
4553 # delete previous highlights, if any
4554 foreach id $boldnameids {
4555 bolden_name $id mainfont
4557 set boldnameids {}
4558 catch {unset nhighlights}
4559 unbolden
4560 unmarkmatches
4561 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4562 set findpattern {}
4563 } elseif {$findtype eq [mc "Regexp"]} {
4564 set findpattern $findstring
4565 } else {
4566 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4567 $findstring]
4568 set findpattern "*$e*"
4572 proc makepatterns {l} {
4573 set ret {}
4574 foreach e $l {
4575 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4576 if {[string index $ee end] eq "/"} {
4577 lappend ret "$ee*"
4578 } else {
4579 lappend ret $ee
4580 lappend ret "$ee/*"
4583 return $ret
4586 proc do_file_hl {serial} {
4587 global highlight_files filehighlight highlight_paths gdttype fhl_list
4588 global cdup findtype
4590 if {$gdttype eq [mc "touching paths:"]} {
4591 # If "exact" match then convert backslashes to forward slashes.
4592 # Most useful to support Windows-flavoured file paths.
4593 if {$findtype eq [mc "Exact"]} {
4594 set highlight_files [string map {"\\" "/"} $highlight_files]
4596 if {[catch {set paths [shellsplit $highlight_files]}]} return
4597 set highlight_paths [makepatterns $paths]
4598 highlight_filelist
4599 set relative_paths {}
4600 foreach path $paths {
4601 lappend relative_paths [file join $cdup $path]
4603 set gdtargs [concat -- $relative_paths]
4604 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4605 set gdtargs [list "-S$highlight_files"]
4606 } else {
4607 # must be "containing:", i.e. we're searching commit info
4608 return
4610 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4611 set filehighlight [open $cmd r+]
4612 fconfigure $filehighlight -blocking 0
4613 filerun $filehighlight readfhighlight
4614 set fhl_list {}
4615 drawvisible
4616 flushhighlights
4619 proc flushhighlights {} {
4620 global filehighlight fhl_list
4622 if {[info exists filehighlight]} {
4623 lappend fhl_list {}
4624 puts $filehighlight ""
4625 flush $filehighlight
4629 proc askfilehighlight {row id} {
4630 global filehighlight fhighlights fhl_list
4632 lappend fhl_list $id
4633 set fhighlights($id) -1
4634 puts $filehighlight $id
4637 proc readfhighlight {} {
4638 global filehighlight fhighlights curview iddrawn
4639 global fhl_list find_dirn
4641 if {![info exists filehighlight]} {
4642 return 0
4644 set nr 0
4645 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4646 set line [string trim $line]
4647 set i [lsearch -exact $fhl_list $line]
4648 if {$i < 0} continue
4649 for {set j 0} {$j < $i} {incr j} {
4650 set id [lindex $fhl_list $j]
4651 set fhighlights($id) 0
4653 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4654 if {$line eq {}} continue
4655 if {![commitinview $line $curview]} continue
4656 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4657 bolden $line mainfontbold
4659 set fhighlights($line) 1
4661 if {[eof $filehighlight]} {
4662 # strange...
4663 puts "oops, git diff-tree died"
4664 catch {close $filehighlight}
4665 unset filehighlight
4666 return 0
4668 if {[info exists find_dirn]} {
4669 run findmore
4671 return 1
4674 proc doesmatch {f} {
4675 global findtype findpattern
4677 if {$findtype eq [mc "Regexp"]} {
4678 return [regexp $findpattern $f]
4679 } elseif {$findtype eq [mc "IgnCase"]} {
4680 return [string match -nocase $findpattern $f]
4681 } else {
4682 return [string match $findpattern $f]
4686 proc askfindhighlight {row id} {
4687 global nhighlights commitinfo iddrawn
4688 global findloc
4689 global markingmatches
4691 if {![info exists commitinfo($id)]} {
4692 getcommit $id
4694 set info $commitinfo($id)
4695 set isbold 0
4696 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4697 foreach f $info ty $fldtypes {
4698 if {$ty eq ""} continue
4699 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4700 [doesmatch $f]} {
4701 if {$ty eq [mc "Author"]} {
4702 set isbold 2
4703 break
4705 set isbold 1
4708 if {$isbold && [info exists iddrawn($id)]} {
4709 if {![ishighlighted $id]} {
4710 bolden $id mainfontbold
4711 if {$isbold > 1} {
4712 bolden_name $id mainfontbold
4715 if {$markingmatches} {
4716 markrowmatches $row $id
4719 set nhighlights($id) $isbold
4722 proc markrowmatches {row id} {
4723 global canv canv2 linehtag linentag commitinfo findloc
4725 set headline [lindex $commitinfo($id) 0]
4726 set author [lindex $commitinfo($id) 1]
4727 $canv delete match$row
4728 $canv2 delete match$row
4729 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4730 set m [findmatches $headline]
4731 if {$m ne {}} {
4732 markmatches $canv $row $headline $linehtag($id) $m \
4733 [$canv itemcget $linehtag($id) -font] $row
4736 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4737 set m [findmatches $author]
4738 if {$m ne {}} {
4739 markmatches $canv2 $row $author $linentag($id) $m \
4740 [$canv2 itemcget $linentag($id) -font] $row
4745 proc vrel_change {name ix op} {
4746 global highlight_related
4748 rhighlight_none
4749 if {$highlight_related ne [mc "None"]} {
4750 run drawvisible
4754 # prepare for testing whether commits are descendents or ancestors of a
4755 proc rhighlight_sel {a} {
4756 global descendent desc_todo ancestor anc_todo
4757 global highlight_related
4759 catch {unset descendent}
4760 set desc_todo [list $a]
4761 catch {unset ancestor}
4762 set anc_todo [list $a]
4763 if {$highlight_related ne [mc "None"]} {
4764 rhighlight_none
4765 run drawvisible
4769 proc rhighlight_none {} {
4770 global rhighlights
4772 catch {unset rhighlights}
4773 unbolden
4776 proc is_descendent {a} {
4777 global curview children descendent desc_todo
4779 set v $curview
4780 set la [rowofcommit $a]
4781 set todo $desc_todo
4782 set leftover {}
4783 set done 0
4784 for {set i 0} {$i < [llength $todo]} {incr i} {
4785 set do [lindex $todo $i]
4786 if {[rowofcommit $do] < $la} {
4787 lappend leftover $do
4788 continue
4790 foreach nk $children($v,$do) {
4791 if {![info exists descendent($nk)]} {
4792 set descendent($nk) 1
4793 lappend todo $nk
4794 if {$nk eq $a} {
4795 set done 1
4799 if {$done} {
4800 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4801 return
4804 set descendent($a) 0
4805 set desc_todo $leftover
4808 proc is_ancestor {a} {
4809 global curview parents ancestor anc_todo
4811 set v $curview
4812 set la [rowofcommit $a]
4813 set todo $anc_todo
4814 set leftover {}
4815 set done 0
4816 for {set i 0} {$i < [llength $todo]} {incr i} {
4817 set do [lindex $todo $i]
4818 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4819 lappend leftover $do
4820 continue
4822 foreach np $parents($v,$do) {
4823 if {![info exists ancestor($np)]} {
4824 set ancestor($np) 1
4825 lappend todo $np
4826 if {$np eq $a} {
4827 set done 1
4831 if {$done} {
4832 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4833 return
4836 set ancestor($a) 0
4837 set anc_todo $leftover
4840 proc askrelhighlight {row id} {
4841 global descendent highlight_related iddrawn rhighlights
4842 global selectedline ancestor
4844 if {$selectedline eq {}} return
4845 set isbold 0
4846 if {$highlight_related eq [mc "Descendant"] ||
4847 $highlight_related eq [mc "Not descendant"]} {
4848 if {![info exists descendent($id)]} {
4849 is_descendent $id
4851 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4852 set isbold 1
4854 } elseif {$highlight_related eq [mc "Ancestor"] ||
4855 $highlight_related eq [mc "Not ancestor"]} {
4856 if {![info exists ancestor($id)]} {
4857 is_ancestor $id
4859 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4860 set isbold 1
4863 if {[info exists iddrawn($id)]} {
4864 if {$isbold && ![ishighlighted $id]} {
4865 bolden $id mainfontbold
4868 set rhighlights($id) $isbold
4871 # Graph layout functions
4873 proc shortids {ids} {
4874 set res {}
4875 foreach id $ids {
4876 if {[llength $id] > 1} {
4877 lappend res [shortids $id]
4878 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4879 lappend res [string range $id 0 7]
4880 } else {
4881 lappend res $id
4884 return $res
4887 proc ntimes {n o} {
4888 set ret {}
4889 set o [list $o]
4890 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4891 if {($n & $mask) != 0} {
4892 set ret [concat $ret $o]
4894 set o [concat $o $o]
4896 return $ret
4899 proc ordertoken {id} {
4900 global ordertok curview varcid varcstart varctok curview parents children
4901 global nullid nullid2
4903 if {[info exists ordertok($id)]} {
4904 return $ordertok($id)
4906 set origid $id
4907 set todo {}
4908 while {1} {
4909 if {[info exists varcid($curview,$id)]} {
4910 set a $varcid($curview,$id)
4911 set p [lindex $varcstart($curview) $a]
4912 } else {
4913 set p [lindex $children($curview,$id) 0]
4915 if {[info exists ordertok($p)]} {
4916 set tok $ordertok($p)
4917 break
4919 set id [first_real_child $curview,$p]
4920 if {$id eq {}} {
4921 # it's a root
4922 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4923 break
4925 if {[llength $parents($curview,$id)] == 1} {
4926 lappend todo [list $p {}]
4927 } else {
4928 set j [lsearch -exact $parents($curview,$id) $p]
4929 if {$j < 0} {
4930 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4932 lappend todo [list $p [strrep $j]]
4935 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4936 set p [lindex $todo $i 0]
4937 append tok [lindex $todo $i 1]
4938 set ordertok($p) $tok
4940 set ordertok($origid) $tok
4941 return $tok
4944 # Work out where id should go in idlist so that order-token
4945 # values increase from left to right
4946 proc idcol {idlist id {i 0}} {
4947 set t [ordertoken $id]
4948 if {$i < 0} {
4949 set i 0
4951 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4952 if {$i > [llength $idlist]} {
4953 set i [llength $idlist]
4955 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4956 incr i
4957 } else {
4958 if {$t > [ordertoken [lindex $idlist $i]]} {
4959 while {[incr i] < [llength $idlist] &&
4960 $t >= [ordertoken [lindex $idlist $i]]} {}
4963 return $i
4966 proc initlayout {} {
4967 global rowidlist rowisopt rowfinal displayorder parentlist
4968 global numcommits canvxmax canv
4969 global nextcolor
4970 global colormap rowtextx
4972 set numcommits 0
4973 set displayorder {}
4974 set parentlist {}
4975 set nextcolor 0
4976 set rowidlist {}
4977 set rowisopt {}
4978 set rowfinal {}
4979 set canvxmax [$canv cget -width]
4980 catch {unset colormap}
4981 catch {unset rowtextx}
4982 setcanvscroll
4985 proc setcanvscroll {} {
4986 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4987 global lastscrollset lastscrollrows
4989 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4990 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4991 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4992 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4993 set lastscrollset [clock clicks -milliseconds]
4994 set lastscrollrows $numcommits
4997 proc visiblerows {} {
4998 global canv numcommits linespc
5000 set ymax [lindex [$canv cget -scrollregion] 3]
5001 if {$ymax eq {} || $ymax == 0} return
5002 set f [$canv yview]
5003 set y0 [expr {int([lindex $f 0] * $ymax)}]
5004 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5005 if {$r0 < 0} {
5006 set r0 0
5008 set y1 [expr {int([lindex $f 1] * $ymax)}]
5009 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5010 if {$r1 >= $numcommits} {
5011 set r1 [expr {$numcommits - 1}]
5013 return [list $r0 $r1]
5016 proc layoutmore {} {
5017 global commitidx viewcomplete curview
5018 global numcommits pending_select curview
5019 global lastscrollset lastscrollrows
5021 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5022 [clock clicks -milliseconds] - $lastscrollset > 500} {
5023 setcanvscroll
5025 if {[info exists pending_select] &&
5026 [commitinview $pending_select $curview]} {
5027 update
5028 selectline [rowofcommit $pending_select] 1
5030 drawvisible
5033 # With path limiting, we mightn't get the actual HEAD commit,
5034 # so ask git rev-list what is the first ancestor of HEAD that
5035 # touches a file in the path limit.
5036 proc get_viewmainhead {view} {
5037 global viewmainheadid vfilelimit viewinstances mainheadid
5039 catch {
5040 set rfd [open [concat | git rev-list -1 $mainheadid \
5041 -- $vfilelimit($view)] r]
5042 set j [reg_instance $rfd]
5043 lappend viewinstances($view) $j
5044 fconfigure $rfd -blocking 0
5045 filerun $rfd [list getviewhead $rfd $j $view]
5046 set viewmainheadid($curview) {}
5050 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5051 proc getviewhead {fd inst view} {
5052 global viewmainheadid commfd curview viewinstances showlocalchanges
5054 set id {}
5055 if {[gets $fd line] < 0} {
5056 if {![eof $fd]} {
5057 return 1
5059 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5060 set id $line
5062 set viewmainheadid($view) $id
5063 close $fd
5064 unset commfd($inst)
5065 set i [lsearch -exact $viewinstances($view) $inst]
5066 if {$i >= 0} {
5067 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5069 if {$showlocalchanges && $id ne {} && $view == $curview} {
5070 doshowlocalchanges
5072 return 0
5075 proc doshowlocalchanges {} {
5076 global curview viewmainheadid
5078 if {$viewmainheadid($curview) eq {}} return
5079 if {[commitinview $viewmainheadid($curview) $curview]} {
5080 dodiffindex
5081 } else {
5082 interestedin $viewmainheadid($curview) dodiffindex
5086 proc dohidelocalchanges {} {
5087 global nullid nullid2 lserial curview
5089 if {[commitinview $nullid $curview]} {
5090 removefakerow $nullid
5092 if {[commitinview $nullid2 $curview]} {
5093 removefakerow $nullid2
5095 incr lserial
5098 # spawn off a process to do git diff-index --cached HEAD
5099 proc dodiffindex {} {
5100 global lserial showlocalchanges vfilelimit curview
5101 global hasworktree
5103 if {!$showlocalchanges || !$hasworktree} return
5104 incr lserial
5105 set cmd "|git diff-index --cached HEAD"
5106 if {$vfilelimit($curview) ne {}} {
5107 set cmd [concat $cmd -- $vfilelimit($curview)]
5109 set fd [open $cmd r]
5110 fconfigure $fd -blocking 0
5111 set i [reg_instance $fd]
5112 filerun $fd [list readdiffindex $fd $lserial $i]
5115 proc readdiffindex {fd serial inst} {
5116 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5117 global vfilelimit
5119 set isdiff 1
5120 if {[gets $fd line] < 0} {
5121 if {![eof $fd]} {
5122 return 1
5124 set isdiff 0
5126 # we only need to see one line and we don't really care what it says...
5127 stop_instance $inst
5129 if {$serial != $lserial} {
5130 return 0
5133 # now see if there are any local changes not checked in to the index
5134 set cmd "|git diff-files"
5135 if {$vfilelimit($curview) ne {}} {
5136 set cmd [concat $cmd -- $vfilelimit($curview)]
5138 set fd [open $cmd r]
5139 fconfigure $fd -blocking 0
5140 set i [reg_instance $fd]
5141 filerun $fd [list readdifffiles $fd $serial $i]
5143 if {$isdiff && ![commitinview $nullid2 $curview]} {
5144 # add the line for the changes in the index to the graph
5145 set hl [mc "Local changes checked in to index but not committed"]
5146 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5147 set commitdata($nullid2) "\n $hl\n"
5148 if {[commitinview $nullid $curview]} {
5149 removefakerow $nullid
5151 insertfakerow $nullid2 $viewmainheadid($curview)
5152 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5153 if {[commitinview $nullid $curview]} {
5154 removefakerow $nullid
5156 removefakerow $nullid2
5158 return 0
5161 proc readdifffiles {fd serial inst} {
5162 global viewmainheadid nullid nullid2 curview
5163 global commitinfo commitdata lserial
5165 set isdiff 1
5166 if {[gets $fd line] < 0} {
5167 if {![eof $fd]} {
5168 return 1
5170 set isdiff 0
5172 # we only need to see one line and we don't really care what it says...
5173 stop_instance $inst
5175 if {$serial != $lserial} {
5176 return 0
5179 if {$isdiff && ![commitinview $nullid $curview]} {
5180 # add the line for the local diff to the graph
5181 set hl [mc "Local uncommitted changes, not checked in to index"]
5182 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5183 set commitdata($nullid) "\n $hl\n"
5184 if {[commitinview $nullid2 $curview]} {
5185 set p $nullid2
5186 } else {
5187 set p $viewmainheadid($curview)
5189 insertfakerow $nullid $p
5190 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5191 removefakerow $nullid
5193 return 0
5196 proc nextuse {id row} {
5197 global curview children
5199 if {[info exists children($curview,$id)]} {
5200 foreach kid $children($curview,$id) {
5201 if {![commitinview $kid $curview]} {
5202 return -1
5204 if {[rowofcommit $kid] > $row} {
5205 return [rowofcommit $kid]
5209 if {[commitinview $id $curview]} {
5210 return [rowofcommit $id]
5212 return -1
5215 proc prevuse {id row} {
5216 global curview children
5218 set ret -1
5219 if {[info exists children($curview,$id)]} {
5220 foreach kid $children($curview,$id) {
5221 if {![commitinview $kid $curview]} break
5222 if {[rowofcommit $kid] < $row} {
5223 set ret [rowofcommit $kid]
5227 return $ret
5230 proc make_idlist {row} {
5231 global displayorder parentlist uparrowlen downarrowlen mingaplen
5232 global commitidx curview children
5234 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5235 if {$r < 0} {
5236 set r 0
5238 set ra [expr {$row - $downarrowlen}]
5239 if {$ra < 0} {
5240 set ra 0
5242 set rb [expr {$row + $uparrowlen}]
5243 if {$rb > $commitidx($curview)} {
5244 set rb $commitidx($curview)
5246 make_disporder $r [expr {$rb + 1}]
5247 set ids {}
5248 for {} {$r < $ra} {incr r} {
5249 set nextid [lindex $displayorder [expr {$r + 1}]]
5250 foreach p [lindex $parentlist $r] {
5251 if {$p eq $nextid} continue
5252 set rn [nextuse $p $r]
5253 if {$rn >= $row &&
5254 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5255 lappend ids [list [ordertoken $p] $p]
5259 for {} {$r < $row} {incr r} {
5260 set nextid [lindex $displayorder [expr {$r + 1}]]
5261 foreach p [lindex $parentlist $r] {
5262 if {$p eq $nextid} continue
5263 set rn [nextuse $p $r]
5264 if {$rn < 0 || $rn >= $row} {
5265 lappend ids [list [ordertoken $p] $p]
5269 set id [lindex $displayorder $row]
5270 lappend ids [list [ordertoken $id] $id]
5271 while {$r < $rb} {
5272 foreach p [lindex $parentlist $r] {
5273 set firstkid [lindex $children($curview,$p) 0]
5274 if {[rowofcommit $firstkid] < $row} {
5275 lappend ids [list [ordertoken $p] $p]
5278 incr r
5279 set id [lindex $displayorder $r]
5280 if {$id ne {}} {
5281 set firstkid [lindex $children($curview,$id) 0]
5282 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5283 lappend ids [list [ordertoken $id] $id]
5287 set idlist {}
5288 foreach idx [lsort -unique $ids] {
5289 lappend idlist [lindex $idx 1]
5291 return $idlist
5294 proc rowsequal {a b} {
5295 while {[set i [lsearch -exact $a {}]] >= 0} {
5296 set a [lreplace $a $i $i]
5298 while {[set i [lsearch -exact $b {}]] >= 0} {
5299 set b [lreplace $b $i $i]
5301 return [expr {$a eq $b}]
5304 proc makeupline {id row rend col} {
5305 global rowidlist uparrowlen downarrowlen mingaplen
5307 for {set r $rend} {1} {set r $rstart} {
5308 set rstart [prevuse $id $r]
5309 if {$rstart < 0} return
5310 if {$rstart < $row} break
5312 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5313 set rstart [expr {$rend - $uparrowlen - 1}]
5315 for {set r $rstart} {[incr r] <= $row} {} {
5316 set idlist [lindex $rowidlist $r]
5317 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5318 set col [idcol $idlist $id $col]
5319 lset rowidlist $r [linsert $idlist $col $id]
5320 changedrow $r
5325 proc layoutrows {row endrow} {
5326 global rowidlist rowisopt rowfinal displayorder
5327 global uparrowlen downarrowlen maxwidth mingaplen
5328 global children parentlist
5329 global commitidx viewcomplete curview
5331 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5332 set idlist {}
5333 if {$row > 0} {
5334 set rm1 [expr {$row - 1}]
5335 foreach id [lindex $rowidlist $rm1] {
5336 if {$id ne {}} {
5337 lappend idlist $id
5340 set final [lindex $rowfinal $rm1]
5342 for {} {$row < $endrow} {incr row} {
5343 set rm1 [expr {$row - 1}]
5344 if {$rm1 < 0 || $idlist eq {}} {
5345 set idlist [make_idlist $row]
5346 set final 1
5347 } else {
5348 set id [lindex $displayorder $rm1]
5349 set col [lsearch -exact $idlist $id]
5350 set idlist [lreplace $idlist $col $col]
5351 foreach p [lindex $parentlist $rm1] {
5352 if {[lsearch -exact $idlist $p] < 0} {
5353 set col [idcol $idlist $p $col]
5354 set idlist [linsert $idlist $col $p]
5355 # if not the first child, we have to insert a line going up
5356 if {$id ne [lindex $children($curview,$p) 0]} {
5357 makeupline $p $rm1 $row $col
5361 set id [lindex $displayorder $row]
5362 if {$row > $downarrowlen} {
5363 set termrow [expr {$row - $downarrowlen - 1}]
5364 foreach p [lindex $parentlist $termrow] {
5365 set i [lsearch -exact $idlist $p]
5366 if {$i < 0} continue
5367 set nr [nextuse $p $termrow]
5368 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5369 set idlist [lreplace $idlist $i $i]
5373 set col [lsearch -exact $idlist $id]
5374 if {$col < 0} {
5375 set col [idcol $idlist $id]
5376 set idlist [linsert $idlist $col $id]
5377 if {$children($curview,$id) ne {}} {
5378 makeupline $id $rm1 $row $col
5381 set r [expr {$row + $uparrowlen - 1}]
5382 if {$r < $commitidx($curview)} {
5383 set x $col
5384 foreach p [lindex $parentlist $r] {
5385 if {[lsearch -exact $idlist $p] >= 0} continue
5386 set fk [lindex $children($curview,$p) 0]
5387 if {[rowofcommit $fk] < $row} {
5388 set x [idcol $idlist $p $x]
5389 set idlist [linsert $idlist $x $p]
5392 if {[incr r] < $commitidx($curview)} {
5393 set p [lindex $displayorder $r]
5394 if {[lsearch -exact $idlist $p] < 0} {
5395 set fk [lindex $children($curview,$p) 0]
5396 if {$fk ne {} && [rowofcommit $fk] < $row} {
5397 set x [idcol $idlist $p $x]
5398 set idlist [linsert $idlist $x $p]
5404 if {$final && !$viewcomplete($curview) &&
5405 $row + $uparrowlen + $mingaplen + $downarrowlen
5406 >= $commitidx($curview)} {
5407 set final 0
5409 set l [llength $rowidlist]
5410 if {$row == $l} {
5411 lappend rowidlist $idlist
5412 lappend rowisopt 0
5413 lappend rowfinal $final
5414 } elseif {$row < $l} {
5415 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5416 lset rowidlist $row $idlist
5417 changedrow $row
5419 lset rowfinal $row $final
5420 } else {
5421 set pad [ntimes [expr {$row - $l}] {}]
5422 set rowidlist [concat $rowidlist $pad]
5423 lappend rowidlist $idlist
5424 set rowfinal [concat $rowfinal $pad]
5425 lappend rowfinal $final
5426 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5429 return $row
5432 proc changedrow {row} {
5433 global displayorder iddrawn rowisopt need_redisplay
5435 set l [llength $rowisopt]
5436 if {$row < $l} {
5437 lset rowisopt $row 0
5438 if {$row + 1 < $l} {
5439 lset rowisopt [expr {$row + 1}] 0
5440 if {$row + 2 < $l} {
5441 lset rowisopt [expr {$row + 2}] 0
5445 set id [lindex $displayorder $row]
5446 if {[info exists iddrawn($id)]} {
5447 set need_redisplay 1
5451 proc insert_pad {row col npad} {
5452 global rowidlist
5454 set pad [ntimes $npad {}]
5455 set idlist [lindex $rowidlist $row]
5456 set bef [lrange $idlist 0 [expr {$col - 1}]]
5457 set aft [lrange $idlist $col end]
5458 set i [lsearch -exact $aft {}]
5459 if {$i > 0} {
5460 set aft [lreplace $aft $i $i]
5462 lset rowidlist $row [concat $bef $pad $aft]
5463 changedrow $row
5466 proc optimize_rows {row col endrow} {
5467 global rowidlist rowisopt displayorder curview children
5469 if {$row < 1} {
5470 set row 1
5472 for {} {$row < $endrow} {incr row; set col 0} {
5473 if {[lindex $rowisopt $row]} continue
5474 set haspad 0
5475 set y0 [expr {$row - 1}]
5476 set ym [expr {$row - 2}]
5477 set idlist [lindex $rowidlist $row]
5478 set previdlist [lindex $rowidlist $y0]
5479 if {$idlist eq {} || $previdlist eq {}} continue
5480 if {$ym >= 0} {
5481 set pprevidlist [lindex $rowidlist $ym]
5482 if {$pprevidlist eq {}} continue
5483 } else {
5484 set pprevidlist {}
5486 set x0 -1
5487 set xm -1
5488 for {} {$col < [llength $idlist]} {incr col} {
5489 set id [lindex $idlist $col]
5490 if {[lindex $previdlist $col] eq $id} continue
5491 if {$id eq {}} {
5492 set haspad 1
5493 continue
5495 set x0 [lsearch -exact $previdlist $id]
5496 if {$x0 < 0} continue
5497 set z [expr {$x0 - $col}]
5498 set isarrow 0
5499 set z0 {}
5500 if {$ym >= 0} {
5501 set xm [lsearch -exact $pprevidlist $id]
5502 if {$xm >= 0} {
5503 set z0 [expr {$xm - $x0}]
5506 if {$z0 eq {}} {
5507 # if row y0 is the first child of $id then it's not an arrow
5508 if {[lindex $children($curview,$id) 0] ne
5509 [lindex $displayorder $y0]} {
5510 set isarrow 1
5513 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5514 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5515 set isarrow 1
5517 # Looking at lines from this row to the previous row,
5518 # make them go straight up if they end in an arrow on
5519 # the previous row; otherwise make them go straight up
5520 # or at 45 degrees.
5521 if {$z < -1 || ($z < 0 && $isarrow)} {
5522 # Line currently goes left too much;
5523 # insert pads in the previous row, then optimize it
5524 set npad [expr {-1 - $z + $isarrow}]
5525 insert_pad $y0 $x0 $npad
5526 if {$y0 > 0} {
5527 optimize_rows $y0 $x0 $row
5529 set previdlist [lindex $rowidlist $y0]
5530 set x0 [lsearch -exact $previdlist $id]
5531 set z [expr {$x0 - $col}]
5532 if {$z0 ne {}} {
5533 set pprevidlist [lindex $rowidlist $ym]
5534 set xm [lsearch -exact $pprevidlist $id]
5535 set z0 [expr {$xm - $x0}]
5537 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5538 # Line currently goes right too much;
5539 # insert pads in this line
5540 set npad [expr {$z - 1 + $isarrow}]
5541 insert_pad $row $col $npad
5542 set idlist [lindex $rowidlist $row]
5543 incr col $npad
5544 set z [expr {$x0 - $col}]
5545 set haspad 1
5547 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5548 # this line links to its first child on row $row-2
5549 set id [lindex $displayorder $ym]
5550 set xc [lsearch -exact $pprevidlist $id]
5551 if {$xc >= 0} {
5552 set z0 [expr {$xc - $x0}]
5555 # avoid lines jigging left then immediately right
5556 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5557 insert_pad $y0 $x0 1
5558 incr x0
5559 optimize_rows $y0 $x0 $row
5560 set previdlist [lindex $rowidlist $y0]
5563 if {!$haspad} {
5564 # Find the first column that doesn't have a line going right
5565 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5566 set id [lindex $idlist $col]
5567 if {$id eq {}} break
5568 set x0 [lsearch -exact $previdlist $id]
5569 if {$x0 < 0} {
5570 # check if this is the link to the first child
5571 set kid [lindex $displayorder $y0]
5572 if {[lindex $children($curview,$id) 0] eq $kid} {
5573 # it is, work out offset to child
5574 set x0 [lsearch -exact $previdlist $kid]
5577 if {$x0 <= $col} break
5579 # Insert a pad at that column as long as it has a line and
5580 # isn't the last column
5581 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5582 set idlist [linsert $idlist $col {}]
5583 lset rowidlist $row $idlist
5584 changedrow $row
5590 proc xc {row col} {
5591 global canvx0 linespc
5592 return [expr {$canvx0 + $col * $linespc}]
5595 proc yc {row} {
5596 global canvy0 linespc
5597 return [expr {$canvy0 + $row * $linespc}]
5600 proc linewidth {id} {
5601 global thickerline lthickness
5603 set wid $lthickness
5604 if {[info exists thickerline] && $id eq $thickerline} {
5605 set wid [expr {2 * $lthickness}]
5607 return $wid
5610 proc rowranges {id} {
5611 global curview children uparrowlen downarrowlen
5612 global rowidlist
5614 set kids $children($curview,$id)
5615 if {$kids eq {}} {
5616 return {}
5618 set ret {}
5619 lappend kids $id
5620 foreach child $kids {
5621 if {![commitinview $child $curview]} break
5622 set row [rowofcommit $child]
5623 if {![info exists prev]} {
5624 lappend ret [expr {$row + 1}]
5625 } else {
5626 if {$row <= $prevrow} {
5627 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5629 # see if the line extends the whole way from prevrow to row
5630 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5631 [lsearch -exact [lindex $rowidlist \
5632 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5633 # it doesn't, see where it ends
5634 set r [expr {$prevrow + $downarrowlen}]
5635 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5636 while {[incr r -1] > $prevrow &&
5637 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5638 } else {
5639 while {[incr r] <= $row &&
5640 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5641 incr r -1
5643 lappend ret $r
5644 # see where it starts up again
5645 set r [expr {$row - $uparrowlen}]
5646 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5647 while {[incr r] < $row &&
5648 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5649 } else {
5650 while {[incr r -1] >= $prevrow &&
5651 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5652 incr r
5654 lappend ret $r
5657 if {$child eq $id} {
5658 lappend ret $row
5660 set prev $child
5661 set prevrow $row
5663 return $ret
5666 proc drawlineseg {id row endrow arrowlow} {
5667 global rowidlist displayorder iddrawn linesegs
5668 global canv colormap linespc curview maxlinelen parentlist
5670 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5671 set le [expr {$row + 1}]
5672 set arrowhigh 1
5673 while {1} {
5674 set c [lsearch -exact [lindex $rowidlist $le] $id]
5675 if {$c < 0} {
5676 incr le -1
5677 break
5679 lappend cols $c
5680 set x [lindex $displayorder $le]
5681 if {$x eq $id} {
5682 set arrowhigh 0
5683 break
5685 if {[info exists iddrawn($x)] || $le == $endrow} {
5686 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5687 if {$c >= 0} {
5688 lappend cols $c
5689 set arrowhigh 0
5691 break
5693 incr le
5695 if {$le <= $row} {
5696 return $row
5699 set lines {}
5700 set i 0
5701 set joinhigh 0
5702 if {[info exists linesegs($id)]} {
5703 set lines $linesegs($id)
5704 foreach li $lines {
5705 set r0 [lindex $li 0]
5706 if {$r0 > $row} {
5707 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5708 set joinhigh 1
5710 break
5712 incr i
5715 set joinlow 0
5716 if {$i > 0} {
5717 set li [lindex $lines [expr {$i-1}]]
5718 set r1 [lindex $li 1]
5719 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5720 set joinlow 1
5724 set x [lindex $cols [expr {$le - $row}]]
5725 set xp [lindex $cols [expr {$le - 1 - $row}]]
5726 set dir [expr {$xp - $x}]
5727 if {$joinhigh} {
5728 set ith [lindex $lines $i 2]
5729 set coords [$canv coords $ith]
5730 set ah [$canv itemcget $ith -arrow]
5731 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5732 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5733 if {$x2 ne {} && $x - $x2 == $dir} {
5734 set coords [lrange $coords 0 end-2]
5736 } else {
5737 set coords [list [xc $le $x] [yc $le]]
5739 if {$joinlow} {
5740 set itl [lindex $lines [expr {$i-1}] 2]
5741 set al [$canv itemcget $itl -arrow]
5742 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5743 } elseif {$arrowlow} {
5744 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5745 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5746 set arrowlow 0
5749 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5750 for {set y $le} {[incr y -1] > $row} {} {
5751 set x $xp
5752 set xp [lindex $cols [expr {$y - 1 - $row}]]
5753 set ndir [expr {$xp - $x}]
5754 if {$dir != $ndir || $xp < 0} {
5755 lappend coords [xc $y $x] [yc $y]
5757 set dir $ndir
5759 if {!$joinlow} {
5760 if {$xp < 0} {
5761 # join parent line to first child
5762 set ch [lindex $displayorder $row]
5763 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5764 if {$xc < 0} {
5765 puts "oops: drawlineseg: child $ch not on row $row"
5766 } elseif {$xc != $x} {
5767 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5768 set d [expr {int(0.5 * $linespc)}]
5769 set x1 [xc $row $x]
5770 if {$xc < $x} {
5771 set x2 [expr {$x1 - $d}]
5772 } else {
5773 set x2 [expr {$x1 + $d}]
5775 set y2 [yc $row]
5776 set y1 [expr {$y2 + $d}]
5777 lappend coords $x1 $y1 $x2 $y2
5778 } elseif {$xc < $x - 1} {
5779 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5780 } elseif {$xc > $x + 1} {
5781 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5783 set x $xc
5785 lappend coords [xc $row $x] [yc $row]
5786 } else {
5787 set xn [xc $row $xp]
5788 set yn [yc $row]
5789 lappend coords $xn $yn
5791 if {!$joinhigh} {
5792 assigncolor $id
5793 set t [$canv create line $coords -width [linewidth $id] \
5794 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5795 $canv lower $t
5796 bindline $t $id
5797 set lines [linsert $lines $i [list $row $le $t]]
5798 } else {
5799 $canv coords $ith $coords
5800 if {$arrow ne $ah} {
5801 $canv itemconf $ith -arrow $arrow
5803 lset lines $i 0 $row
5805 } else {
5806 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5807 set ndir [expr {$xo - $xp}]
5808 set clow [$canv coords $itl]
5809 if {$dir == $ndir} {
5810 set clow [lrange $clow 2 end]
5812 set coords [concat $coords $clow]
5813 if {!$joinhigh} {
5814 lset lines [expr {$i-1}] 1 $le
5815 } else {
5816 # coalesce two pieces
5817 $canv delete $ith
5818 set b [lindex $lines [expr {$i-1}] 0]
5819 set e [lindex $lines $i 1]
5820 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5822 $canv coords $itl $coords
5823 if {$arrow ne $al} {
5824 $canv itemconf $itl -arrow $arrow
5828 set linesegs($id) $lines
5829 return $le
5832 proc drawparentlinks {id row} {
5833 global rowidlist canv colormap curview parentlist
5834 global idpos linespc
5836 set rowids [lindex $rowidlist $row]
5837 set col [lsearch -exact $rowids $id]
5838 if {$col < 0} return
5839 set olds [lindex $parentlist $row]
5840 set row2 [expr {$row + 1}]
5841 set x [xc $row $col]
5842 set y [yc $row]
5843 set y2 [yc $row2]
5844 set d [expr {int(0.5 * $linespc)}]
5845 set ymid [expr {$y + $d}]
5846 set ids [lindex $rowidlist $row2]
5847 # rmx = right-most X coord used
5848 set rmx 0
5849 foreach p $olds {
5850 set i [lsearch -exact $ids $p]
5851 if {$i < 0} {
5852 puts "oops, parent $p of $id not in list"
5853 continue
5855 set x2 [xc $row2 $i]
5856 if {$x2 > $rmx} {
5857 set rmx $x2
5859 set j [lsearch -exact $rowids $p]
5860 if {$j < 0} {
5861 # drawlineseg will do this one for us
5862 continue
5864 assigncolor $p
5865 # should handle duplicated parents here...
5866 set coords [list $x $y]
5867 if {$i != $col} {
5868 # if attaching to a vertical segment, draw a smaller
5869 # slant for visual distinctness
5870 if {$i == $j} {
5871 if {$i < $col} {
5872 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5873 } else {
5874 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5876 } elseif {$i < $col && $i < $j} {
5877 # segment slants towards us already
5878 lappend coords [xc $row $j] $y
5879 } else {
5880 if {$i < $col - 1} {
5881 lappend coords [expr {$x2 + $linespc}] $y
5882 } elseif {$i > $col + 1} {
5883 lappend coords [expr {$x2 - $linespc}] $y
5885 lappend coords $x2 $y2
5887 } else {
5888 lappend coords $x2 $y2
5890 set t [$canv create line $coords -width [linewidth $p] \
5891 -fill $colormap($p) -tags lines.$p]
5892 $canv lower $t
5893 bindline $t $p
5895 if {$rmx > [lindex $idpos($id) 1]} {
5896 lset idpos($id) 1 $rmx
5897 redrawtags $id
5901 proc drawlines {id} {
5902 global canv
5904 $canv itemconf lines.$id -width [linewidth $id]
5907 proc drawcmittext {id row col} {
5908 global linespc canv canv2 canv3 fgcolor curview
5909 global cmitlisted commitinfo rowidlist parentlist
5910 global rowtextx idpos idtags idheads idotherrefs
5911 global linehtag linentag linedtag selectedline
5912 global canvxmax boldids boldnameids fgcolor markedid
5913 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5915 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5916 set listed $cmitlisted($curview,$id)
5917 if {$id eq $nullid} {
5918 set ofill red
5919 } elseif {$id eq $nullid2} {
5920 set ofill green
5921 } elseif {$id eq $mainheadid} {
5922 set ofill yellow
5923 } else {
5924 set ofill [lindex $circlecolors $listed]
5926 set x [xc $row $col]
5927 set y [yc $row]
5928 set orad [expr {$linespc / 3}]
5929 if {$listed <= 2} {
5930 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5931 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5932 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5933 } elseif {$listed == 3} {
5934 # triangle pointing left for left-side commits
5935 set t [$canv create polygon \
5936 [expr {$x - $orad}] $y \
5937 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5938 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5939 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5940 } else {
5941 # triangle pointing right for right-side commits
5942 set t [$canv create polygon \
5943 [expr {$x + $orad - 1}] $y \
5944 [expr {$x - $orad}] [expr {$y - $orad}] \
5945 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5946 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5948 set circleitem($row) $t
5949 $canv raise $t
5950 $canv bind $t <1> {selcanvline {} %x %y}
5951 set rmx [llength [lindex $rowidlist $row]]
5952 set olds [lindex $parentlist $row]
5953 if {$olds ne {}} {
5954 set nextids [lindex $rowidlist [expr {$row + 1}]]
5955 foreach p $olds {
5956 set i [lsearch -exact $nextids $p]
5957 if {$i > $rmx} {
5958 set rmx $i
5962 set xt [xc $row $rmx]
5963 set rowtextx($row) $xt
5964 set idpos($id) [list $x $xt $y]
5965 if {[info exists idtags($id)] || [info exists idheads($id)]
5966 || [info exists idotherrefs($id)]} {
5967 set xt [drawtags $id $x $xt $y]
5969 if {[lindex $commitinfo($id) 6] > 0} {
5970 set xt [drawnotesign $xt $y]
5972 set headline [lindex $commitinfo($id) 0]
5973 set name [lindex $commitinfo($id) 1]
5974 set date [lindex $commitinfo($id) 2]
5975 set date [formatdate $date]
5976 set font mainfont
5977 set nfont mainfont
5978 set isbold [ishighlighted $id]
5979 if {$isbold > 0} {
5980 lappend boldids $id
5981 set font mainfontbold
5982 if {$isbold > 1} {
5983 lappend boldnameids $id
5984 set nfont mainfontbold
5987 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5988 -text $headline -font $font -tags text]
5989 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5990 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5991 -text $name -font $nfont -tags text]
5992 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5993 -text $date -font mainfont -tags text]
5994 if {$selectedline == $row} {
5995 make_secsel $id
5997 if {[info exists markedid] && $markedid eq $id} {
5998 make_idmark $id
6000 set xr [expr {$xt + [font measure $font $headline]}]
6001 if {$xr > $canvxmax} {
6002 set canvxmax $xr
6003 setcanvscroll
6007 proc drawcmitrow {row} {
6008 global displayorder rowidlist nrows_drawn
6009 global iddrawn markingmatches
6010 global commitinfo numcommits
6011 global filehighlight fhighlights findpattern nhighlights
6012 global hlview vhighlights
6013 global highlight_related rhighlights
6015 if {$row >= $numcommits} return
6017 set id [lindex $displayorder $row]
6018 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6019 askvhighlight $row $id
6021 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6022 askfilehighlight $row $id
6024 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6025 askfindhighlight $row $id
6027 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6028 askrelhighlight $row $id
6030 if {![info exists iddrawn($id)]} {
6031 set col [lsearch -exact [lindex $rowidlist $row] $id]
6032 if {$col < 0} {
6033 puts "oops, row $row id $id not in list"
6034 return
6036 if {![info exists commitinfo($id)]} {
6037 getcommit $id
6039 assigncolor $id
6040 drawcmittext $id $row $col
6041 set iddrawn($id) 1
6042 incr nrows_drawn
6044 if {$markingmatches} {
6045 markrowmatches $row $id
6049 proc drawcommits {row {endrow {}}} {
6050 global numcommits iddrawn displayorder curview need_redisplay
6051 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6053 if {$row < 0} {
6054 set row 0
6056 if {$endrow eq {}} {
6057 set endrow $row
6059 if {$endrow >= $numcommits} {
6060 set endrow [expr {$numcommits - 1}]
6063 set rl1 [expr {$row - $downarrowlen - 3}]
6064 if {$rl1 < 0} {
6065 set rl1 0
6067 set ro1 [expr {$row - 3}]
6068 if {$ro1 < 0} {
6069 set ro1 0
6071 set r2 [expr {$endrow + $uparrowlen + 3}]
6072 if {$r2 > $numcommits} {
6073 set r2 $numcommits
6075 for {set r $rl1} {$r < $r2} {incr r} {
6076 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6077 if {$rl1 < $r} {
6078 layoutrows $rl1 $r
6080 set rl1 [expr {$r + 1}]
6083 if {$rl1 < $r} {
6084 layoutrows $rl1 $r
6086 optimize_rows $ro1 0 $r2
6087 if {$need_redisplay || $nrows_drawn > 2000} {
6088 clear_display
6091 # make the lines join to already-drawn rows either side
6092 set r [expr {$row - 1}]
6093 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6094 set r $row
6096 set er [expr {$endrow + 1}]
6097 if {$er >= $numcommits ||
6098 ![info exists iddrawn([lindex $displayorder $er])]} {
6099 set er $endrow
6101 for {} {$r <= $er} {incr r} {
6102 set id [lindex $displayorder $r]
6103 set wasdrawn [info exists iddrawn($id)]
6104 drawcmitrow $r
6105 if {$r == $er} break
6106 set nextid [lindex $displayorder [expr {$r + 1}]]
6107 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6108 drawparentlinks $id $r
6110 set rowids [lindex $rowidlist $r]
6111 foreach lid $rowids {
6112 if {$lid eq {}} continue
6113 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6114 if {$lid eq $id} {
6115 # see if this is the first child of any of its parents
6116 foreach p [lindex $parentlist $r] {
6117 if {[lsearch -exact $rowids $p] < 0} {
6118 # make this line extend up to the child
6119 set lineend($p) [drawlineseg $p $r $er 0]
6122 } else {
6123 set lineend($lid) [drawlineseg $lid $r $er 1]
6129 proc undolayout {row} {
6130 global uparrowlen mingaplen downarrowlen
6131 global rowidlist rowisopt rowfinal need_redisplay
6133 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6134 if {$r < 0} {
6135 set r 0
6137 if {[llength $rowidlist] > $r} {
6138 incr r -1
6139 set rowidlist [lrange $rowidlist 0 $r]
6140 set rowfinal [lrange $rowfinal 0 $r]
6141 set rowisopt [lrange $rowisopt 0 $r]
6142 set need_redisplay 1
6143 run drawvisible
6147 proc drawvisible {} {
6148 global canv linespc curview vrowmod selectedline targetrow targetid
6149 global need_redisplay cscroll numcommits
6151 set fs [$canv yview]
6152 set ymax [lindex [$canv cget -scrollregion] 3]
6153 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6154 set f0 [lindex $fs 0]
6155 set f1 [lindex $fs 1]
6156 set y0 [expr {int($f0 * $ymax)}]
6157 set y1 [expr {int($f1 * $ymax)}]
6159 if {[info exists targetid]} {
6160 if {[commitinview $targetid $curview]} {
6161 set r [rowofcommit $targetid]
6162 if {$r != $targetrow} {
6163 # Fix up the scrollregion and change the scrolling position
6164 # now that our target row has moved.
6165 set diff [expr {($r - $targetrow) * $linespc}]
6166 set targetrow $r
6167 setcanvscroll
6168 set ymax [lindex [$canv cget -scrollregion] 3]
6169 incr y0 $diff
6170 incr y1 $diff
6171 set f0 [expr {$y0 / $ymax}]
6172 set f1 [expr {$y1 / $ymax}]
6173 allcanvs yview moveto $f0
6174 $cscroll set $f0 $f1
6175 set need_redisplay 1
6177 } else {
6178 unset targetid
6182 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6183 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6184 if {$endrow >= $vrowmod($curview)} {
6185 update_arcrows $curview
6187 if {$selectedline ne {} &&
6188 $row <= $selectedline && $selectedline <= $endrow} {
6189 set targetrow $selectedline
6190 } elseif {[info exists targetid]} {
6191 set targetrow [expr {int(($row + $endrow) / 2)}]
6193 if {[info exists targetrow]} {
6194 if {$targetrow >= $numcommits} {
6195 set targetrow [expr {$numcommits - 1}]
6197 set targetid [commitonrow $targetrow]
6199 drawcommits $row $endrow
6202 proc clear_display {} {
6203 global iddrawn linesegs need_redisplay nrows_drawn
6204 global vhighlights fhighlights nhighlights rhighlights
6205 global linehtag linentag linedtag boldids boldnameids
6207 allcanvs delete all
6208 catch {unset iddrawn}
6209 catch {unset linesegs}
6210 catch {unset linehtag}
6211 catch {unset linentag}
6212 catch {unset linedtag}
6213 set boldids {}
6214 set boldnameids {}
6215 catch {unset vhighlights}
6216 catch {unset fhighlights}
6217 catch {unset nhighlights}
6218 catch {unset rhighlights}
6219 set need_redisplay 0
6220 set nrows_drawn 0
6223 proc findcrossings {id} {
6224 global rowidlist parentlist numcommits displayorder
6226 set cross {}
6227 set ccross {}
6228 foreach {s e} [rowranges $id] {
6229 if {$e >= $numcommits} {
6230 set e [expr {$numcommits - 1}]
6232 if {$e <= $s} continue
6233 for {set row $e} {[incr row -1] >= $s} {} {
6234 set x [lsearch -exact [lindex $rowidlist $row] $id]
6235 if {$x < 0} break
6236 set olds [lindex $parentlist $row]
6237 set kid [lindex $displayorder $row]
6238 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6239 if {$kidx < 0} continue
6240 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6241 foreach p $olds {
6242 set px [lsearch -exact $nextrow $p]
6243 if {$px < 0} continue
6244 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6245 if {[lsearch -exact $ccross $p] >= 0} continue
6246 if {$x == $px + ($kidx < $px? -1: 1)} {
6247 lappend ccross $p
6248 } elseif {[lsearch -exact $cross $p] < 0} {
6249 lappend cross $p
6255 return [concat $ccross {{}} $cross]
6258 proc assigncolor {id} {
6259 global colormap colors nextcolor
6260 global parents children children curview
6262 if {[info exists colormap($id)]} return
6263 set ncolors [llength $colors]
6264 if {[info exists children($curview,$id)]} {
6265 set kids $children($curview,$id)
6266 } else {
6267 set kids {}
6269 if {[llength $kids] == 1} {
6270 set child [lindex $kids 0]
6271 if {[info exists colormap($child)]
6272 && [llength $parents($curview,$child)] == 1} {
6273 set colormap($id) $colormap($child)
6274 return
6277 set badcolors {}
6278 set origbad {}
6279 foreach x [findcrossings $id] {
6280 if {$x eq {}} {
6281 # delimiter between corner crossings and other crossings
6282 if {[llength $badcolors] >= $ncolors - 1} break
6283 set origbad $badcolors
6285 if {[info exists colormap($x)]
6286 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6287 lappend badcolors $colormap($x)
6290 if {[llength $badcolors] >= $ncolors} {
6291 set badcolors $origbad
6293 set origbad $badcolors
6294 if {[llength $badcolors] < $ncolors - 1} {
6295 foreach child $kids {
6296 if {[info exists colormap($child)]
6297 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6298 lappend badcolors $colormap($child)
6300 foreach p $parents($curview,$child) {
6301 if {[info exists colormap($p)]
6302 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6303 lappend badcolors $colormap($p)
6307 if {[llength $badcolors] >= $ncolors} {
6308 set badcolors $origbad
6311 for {set i 0} {$i <= $ncolors} {incr i} {
6312 set c [lindex $colors $nextcolor]
6313 if {[incr nextcolor] >= $ncolors} {
6314 set nextcolor 0
6316 if {[lsearch -exact $badcolors $c]} break
6318 set colormap($id) $c
6321 proc bindline {t id} {
6322 global canv
6324 $canv bind $t <Enter> "lineenter %x %y $id"
6325 $canv bind $t <Motion> "linemotion %x %y $id"
6326 $canv bind $t <Leave> "lineleave $id"
6327 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6330 proc drawtags {id x xt y1} {
6331 global idtags idheads idotherrefs mainhead
6332 global linespc lthickness
6333 global canv rowtextx curview fgcolor bgcolor ctxbut
6335 set marks {}
6336 set ntags 0
6337 set nheads 0
6338 if {[info exists idtags($id)]} {
6339 set marks $idtags($id)
6340 set ntags [llength $marks]
6342 if {[info exists idheads($id)]} {
6343 set marks [concat $marks $idheads($id)]
6344 set nheads [llength $idheads($id)]
6346 if {[info exists idotherrefs($id)]} {
6347 set marks [concat $marks $idotherrefs($id)]
6349 if {$marks eq {}} {
6350 return $xt
6353 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6354 set yt [expr {$y1 - 0.5 * $linespc}]
6355 set yb [expr {$yt + $linespc - 1}]
6356 set xvals {}
6357 set wvals {}
6358 set i -1
6359 foreach tag $marks {
6360 incr i
6361 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6362 set wid [font measure mainfontbold $tag]
6363 } else {
6364 set wid [font measure mainfont $tag]
6366 lappend xvals $xt
6367 lappend wvals $wid
6368 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6370 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6371 -width $lthickness -fill black -tags tag.$id]
6372 $canv lower $t
6373 foreach tag $marks x $xvals wid $wvals {
6374 set tag_quoted [string map {% %%} $tag]
6375 set xl [expr {$x + $delta}]
6376 set xr [expr {$x + $delta + $wid + $lthickness}]
6377 set font mainfont
6378 if {[incr ntags -1] >= 0} {
6379 # draw a tag
6380 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6381 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6382 -width 1 -outline black -fill yellow -tags tag.$id]
6383 $canv bind $t <1> [list showtag $tag_quoted 1]
6384 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6385 } else {
6386 # draw a head or other ref
6387 if {[incr nheads -1] >= 0} {
6388 set col green
6389 if {$tag eq $mainhead} {
6390 set font mainfontbold
6392 } else {
6393 set col "#ddddff"
6395 set xl [expr {$xl - $delta/2}]
6396 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6397 -width 1 -outline black -fill $col -tags tag.$id
6398 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6399 set rwid [font measure mainfont $remoteprefix]
6400 set xi [expr {$x + 1}]
6401 set yti [expr {$yt + 1}]
6402 set xri [expr {$x + $rwid}]
6403 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6404 -width 0 -fill "#ffddaa" -tags tag.$id
6407 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6408 -font $font -tags [list tag.$id text]]
6409 if {$ntags >= 0} {
6410 $canv bind $t <1> [list showtag $tag_quoted 1]
6411 } elseif {$nheads >= 0} {
6412 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6415 return $xt
6418 proc drawnotesign {xt y} {
6419 global linespc canv fgcolor
6421 set orad [expr {$linespc / 3}]
6422 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6423 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6424 -fill yellow -outline $fgcolor -width 1 -tags circle]
6425 set xt [expr {$xt + $orad * 3}]
6426 return $xt
6429 proc xcoord {i level ln} {
6430 global canvx0 xspc1 xspc2
6432 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6433 if {$i > 0 && $i == $level} {
6434 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6435 } elseif {$i > $level} {
6436 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6438 return $x
6441 proc show_status {msg} {
6442 global canv fgcolor
6444 clear_display
6445 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6446 -tags text -fill $fgcolor
6449 # Don't change the text pane cursor if it is currently the hand cursor,
6450 # showing that we are over a sha1 ID link.
6451 proc settextcursor {c} {
6452 global ctext curtextcursor
6454 if {[$ctext cget -cursor] == $curtextcursor} {
6455 $ctext config -cursor $c
6457 set curtextcursor $c
6460 proc nowbusy {what {name {}}} {
6461 global isbusy busyname statusw
6463 if {[array names isbusy] eq {}} {
6464 . config -cursor watch
6465 settextcursor watch
6467 set isbusy($what) 1
6468 set busyname($what) $name
6469 if {$name ne {}} {
6470 $statusw conf -text $name
6474 proc notbusy {what} {
6475 global isbusy maincursor textcursor busyname statusw
6477 catch {
6478 unset isbusy($what)
6479 if {$busyname($what) ne {} &&
6480 [$statusw cget -text] eq $busyname($what)} {
6481 $statusw conf -text {}
6484 if {[array names isbusy] eq {}} {
6485 . config -cursor $maincursor
6486 settextcursor $textcursor
6490 proc findmatches {f} {
6491 global findtype findstring
6492 if {$findtype == [mc "Regexp"]} {
6493 set matches [regexp -indices -all -inline $findstring $f]
6494 } else {
6495 set fs $findstring
6496 if {$findtype == [mc "IgnCase"]} {
6497 set f [string tolower $f]
6498 set fs [string tolower $fs]
6500 set matches {}
6501 set i 0
6502 set l [string length $fs]
6503 while {[set j [string first $fs $f $i]] >= 0} {
6504 lappend matches [list $j [expr {$j+$l-1}]]
6505 set i [expr {$j + $l}]
6508 return $matches
6511 proc dofind {{dirn 1} {wrap 1}} {
6512 global findstring findstartline findcurline selectedline numcommits
6513 global gdttype filehighlight fh_serial find_dirn findallowwrap
6515 if {[info exists find_dirn]} {
6516 if {$find_dirn == $dirn} return
6517 stopfinding
6519 focus .
6520 if {$findstring eq {} || $numcommits == 0} return
6521 if {$selectedline eq {}} {
6522 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6523 } else {
6524 set findstartline $selectedline
6526 set findcurline $findstartline
6527 nowbusy finding [mc "Searching"]
6528 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6529 after cancel do_file_hl $fh_serial
6530 do_file_hl $fh_serial
6532 set find_dirn $dirn
6533 set findallowwrap $wrap
6534 run findmore
6537 proc stopfinding {} {
6538 global find_dirn findcurline fprogcoord
6540 if {[info exists find_dirn]} {
6541 unset find_dirn
6542 unset findcurline
6543 notbusy finding
6544 set fprogcoord 0
6545 adjustprogress
6547 stopblaming
6550 proc findmore {} {
6551 global commitdata commitinfo numcommits findpattern findloc
6552 global findstartline findcurline findallowwrap
6553 global find_dirn gdttype fhighlights fprogcoord
6554 global curview varcorder vrownum varccommits vrowmod
6556 if {![info exists find_dirn]} {
6557 return 0
6559 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6560 set l $findcurline
6561 set moretodo 0
6562 if {$find_dirn > 0} {
6563 incr l
6564 if {$l >= $numcommits} {
6565 set l 0
6567 if {$l <= $findstartline} {
6568 set lim [expr {$findstartline + 1}]
6569 } else {
6570 set lim $numcommits
6571 set moretodo $findallowwrap
6573 } else {
6574 if {$l == 0} {
6575 set l $numcommits
6577 incr l -1
6578 if {$l >= $findstartline} {
6579 set lim [expr {$findstartline - 1}]
6580 } else {
6581 set lim -1
6582 set moretodo $findallowwrap
6585 set n [expr {($lim - $l) * $find_dirn}]
6586 if {$n > 500} {
6587 set n 500
6588 set moretodo 1
6590 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6591 update_arcrows $curview
6593 set found 0
6594 set domore 1
6595 set ai [bsearch $vrownum($curview) $l]
6596 set a [lindex $varcorder($curview) $ai]
6597 set arow [lindex $vrownum($curview) $ai]
6598 set ids [lindex $varccommits($curview,$a)]
6599 set arowend [expr {$arow + [llength $ids]}]
6600 if {$gdttype eq [mc "containing:"]} {
6601 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6602 if {$l < $arow || $l >= $arowend} {
6603 incr ai $find_dirn
6604 set a [lindex $varcorder($curview) $ai]
6605 set arow [lindex $vrownum($curview) $ai]
6606 set ids [lindex $varccommits($curview,$a)]
6607 set arowend [expr {$arow + [llength $ids]}]
6609 set id [lindex $ids [expr {$l - $arow}]]
6610 # shouldn't happen unless git log doesn't give all the commits...
6611 if {![info exists commitdata($id)] ||
6612 ![doesmatch $commitdata($id)]} {
6613 continue
6615 if {![info exists commitinfo($id)]} {
6616 getcommit $id
6618 set info $commitinfo($id)
6619 foreach f $info ty $fldtypes {
6620 if {$ty eq ""} continue
6621 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6622 [doesmatch $f]} {
6623 set found 1
6624 break
6627 if {$found} break
6629 } else {
6630 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6631 if {$l < $arow || $l >= $arowend} {
6632 incr ai $find_dirn
6633 set a [lindex $varcorder($curview) $ai]
6634 set arow [lindex $vrownum($curview) $ai]
6635 set ids [lindex $varccommits($curview,$a)]
6636 set arowend [expr {$arow + [llength $ids]}]
6638 set id [lindex $ids [expr {$l - $arow}]]
6639 if {![info exists fhighlights($id)]} {
6640 # this sets fhighlights($id) to -1
6641 askfilehighlight $l $id
6643 if {$fhighlights($id) > 0} {
6644 set found $domore
6645 break
6647 if {$fhighlights($id) < 0} {
6648 if {$domore} {
6649 set domore 0
6650 set findcurline [expr {$l - $find_dirn}]
6655 if {$found || ($domore && !$moretodo)} {
6656 unset findcurline
6657 unset find_dirn
6658 notbusy finding
6659 set fprogcoord 0
6660 adjustprogress
6661 if {$found} {
6662 findselectline $l
6663 } else {
6664 bell
6666 return 0
6668 if {!$domore} {
6669 flushhighlights
6670 } else {
6671 set findcurline [expr {$l - $find_dirn}]
6673 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6674 if {$n < 0} {
6675 incr n $numcommits
6677 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6678 adjustprogress
6679 return $domore
6682 proc findselectline {l} {
6683 global findloc commentend ctext findcurline markingmatches gdttype
6685 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6686 set findcurline $l
6687 selectline $l 1
6688 if {$markingmatches &&
6689 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6690 # highlight the matches in the comments
6691 set f [$ctext get 1.0 $commentend]
6692 set matches [findmatches $f]
6693 foreach match $matches {
6694 set start [lindex $match 0]
6695 set end [expr {[lindex $match 1] + 1}]
6696 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6699 drawvisible
6702 # mark the bits of a headline or author that match a find string
6703 proc markmatches {canv l str tag matches font row} {
6704 global selectedline
6706 set bbox [$canv bbox $tag]
6707 set x0 [lindex $bbox 0]
6708 set y0 [lindex $bbox 1]
6709 set y1 [lindex $bbox 3]
6710 foreach match $matches {
6711 set start [lindex $match 0]
6712 set end [lindex $match 1]
6713 if {$start > $end} continue
6714 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6715 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6716 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6717 [expr {$x0+$xlen+2}] $y1 \
6718 -outline {} -tags [list match$l matches] -fill yellow]
6719 $canv lower $t
6720 if {$row == $selectedline} {
6721 $canv raise $t secsel
6726 proc unmarkmatches {} {
6727 global markingmatches
6729 allcanvs delete matches
6730 set markingmatches 0
6731 stopfinding
6734 proc selcanvline {w x y} {
6735 global canv canvy0 ctext linespc
6736 global rowtextx
6737 set ymax [lindex [$canv cget -scrollregion] 3]
6738 if {$ymax == {}} return
6739 set yfrac [lindex [$canv yview] 0]
6740 set y [expr {$y + $yfrac * $ymax}]
6741 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6742 if {$l < 0} {
6743 set l 0
6745 if {$w eq $canv} {
6746 set xmax [lindex [$canv cget -scrollregion] 2]
6747 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6748 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6750 unmarkmatches
6751 selectline $l 1
6754 proc commit_descriptor {p} {
6755 global commitinfo
6756 if {![info exists commitinfo($p)]} {
6757 getcommit $p
6759 set l "..."
6760 if {[llength $commitinfo($p)] > 1} {
6761 set l [lindex $commitinfo($p) 0]
6763 return "$p ($l)\n"
6766 # append some text to the ctext widget, and make any SHA1 ID
6767 # that we know about be a clickable link.
6768 proc appendwithlinks {text tags} {
6769 global ctext linknum curview
6771 set start [$ctext index "end - 1c"]
6772 $ctext insert end $text $tags
6773 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6774 foreach l $links {
6775 set s [lindex $l 0]
6776 set e [lindex $l 1]
6777 set linkid [string range $text $s $e]
6778 incr e
6779 $ctext tag delete link$linknum
6780 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6781 setlink $linkid link$linknum
6782 incr linknum
6786 proc setlink {id lk} {
6787 global curview ctext pendinglinks
6789 if {[string range $id 0 1] eq "-g"} {
6790 set id [string range $id 2 end]
6793 set known 0
6794 if {[string length $id] < 40} {
6795 set matches [longid $id]
6796 if {[llength $matches] > 0} {
6797 if {[llength $matches] > 1} return
6798 set known 1
6799 set id [lindex $matches 0]
6801 } else {
6802 set known [commitinview $id $curview]
6804 if {$known} {
6805 $ctext tag conf $lk -foreground blue -underline 1
6806 $ctext tag bind $lk <1> [list selbyid $id]
6807 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6808 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6809 } else {
6810 lappend pendinglinks($id) $lk
6811 interestedin $id {makelink %P}
6815 proc appendshortlink {id {pre {}} {post {}}} {
6816 global ctext linknum
6818 $ctext insert end $pre
6819 $ctext tag delete link$linknum
6820 $ctext insert end [string range $id 0 7] link$linknum
6821 $ctext insert end $post
6822 setlink $id link$linknum
6823 incr linknum
6826 proc makelink {id} {
6827 global pendinglinks
6829 if {![info exists pendinglinks($id)]} return
6830 foreach lk $pendinglinks($id) {
6831 setlink $id $lk
6833 unset pendinglinks($id)
6836 proc linkcursor {w inc} {
6837 global linkentercount curtextcursor
6839 if {[incr linkentercount $inc] > 0} {
6840 $w configure -cursor hand2
6841 } else {
6842 $w configure -cursor $curtextcursor
6843 if {$linkentercount < 0} {
6844 set linkentercount 0
6849 proc viewnextline {dir} {
6850 global canv linespc
6852 $canv delete hover
6853 set ymax [lindex [$canv cget -scrollregion] 3]
6854 set wnow [$canv yview]
6855 set wtop [expr {[lindex $wnow 0] * $ymax}]
6856 set newtop [expr {$wtop + $dir * $linespc}]
6857 if {$newtop < 0} {
6858 set newtop 0
6859 } elseif {$newtop > $ymax} {
6860 set newtop $ymax
6862 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6865 # add a list of tag or branch names at position pos
6866 # returns the number of names inserted
6867 proc appendrefs {pos ids var} {
6868 global ctext linknum curview $var maxrefs
6870 if {[catch {$ctext index $pos}]} {
6871 return 0
6873 $ctext conf -state normal
6874 $ctext delete $pos "$pos lineend"
6875 set tags {}
6876 foreach id $ids {
6877 foreach tag [set $var\($id\)] {
6878 lappend tags [list $tag $id]
6881 if {[llength $tags] > $maxrefs} {
6882 $ctext insert $pos "[mc "many"] ([llength $tags])"
6883 } else {
6884 set tags [lsort -index 0 -decreasing $tags]
6885 set sep {}
6886 foreach ti $tags {
6887 set id [lindex $ti 1]
6888 set lk link$linknum
6889 incr linknum
6890 $ctext tag delete $lk
6891 $ctext insert $pos $sep
6892 $ctext insert $pos [lindex $ti 0] $lk
6893 setlink $id $lk
6894 set sep ", "
6897 $ctext conf -state disabled
6898 return [llength $tags]
6901 # called when we have finished computing the nearby tags
6902 proc dispneartags {delay} {
6903 global selectedline currentid showneartags tagphase
6905 if {$selectedline eq {} || !$showneartags} return
6906 after cancel dispnexttag
6907 if {$delay} {
6908 after 200 dispnexttag
6909 set tagphase -1
6910 } else {
6911 after idle dispnexttag
6912 set tagphase 0
6916 proc dispnexttag {} {
6917 global selectedline currentid showneartags tagphase ctext
6919 if {$selectedline eq {} || !$showneartags} return
6920 switch -- $tagphase {
6922 set dtags [desctags $currentid]
6923 if {$dtags ne {}} {
6924 appendrefs precedes $dtags idtags
6928 set atags [anctags $currentid]
6929 if {$atags ne {}} {
6930 appendrefs follows $atags idtags
6934 set dheads [descheads $currentid]
6935 if {$dheads ne {}} {
6936 if {[appendrefs branch $dheads idheads] > 1
6937 && [$ctext get "branch -3c"] eq "h"} {
6938 # turn "Branch" into "Branches"
6939 $ctext conf -state normal
6940 $ctext insert "branch -2c" "es"
6941 $ctext conf -state disabled
6946 if {[incr tagphase] <= 2} {
6947 after idle dispnexttag
6951 proc make_secsel {id} {
6952 global linehtag linentag linedtag canv canv2 canv3
6954 if {![info exists linehtag($id)]} return
6955 $canv delete secsel
6956 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6957 -tags secsel -fill [$canv cget -selectbackground]]
6958 $canv lower $t
6959 $canv2 delete secsel
6960 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6961 -tags secsel -fill [$canv2 cget -selectbackground]]
6962 $canv2 lower $t
6963 $canv3 delete secsel
6964 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6965 -tags secsel -fill [$canv3 cget -selectbackground]]
6966 $canv3 lower $t
6969 proc make_idmark {id} {
6970 global linehtag canv fgcolor
6972 if {![info exists linehtag($id)]} return
6973 $canv delete markid
6974 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6975 -tags markid -outline $fgcolor]
6976 $canv raise $t
6979 proc selectline {l isnew {desired_loc {}}} {
6980 global canv ctext commitinfo selectedline
6981 global canvy0 linespc parents children curview
6982 global currentid sha1entry
6983 global commentend idtags linknum
6984 global mergemax numcommits pending_select
6985 global cmitmode showneartags allcommits
6986 global targetrow targetid lastscrollrows
6987 global autoselect autosellen jump_to_here
6989 catch {unset pending_select}
6990 $canv delete hover
6991 normalline
6992 unsel_reflist
6993 stopfinding
6994 if {$l < 0 || $l >= $numcommits} return
6995 set id [commitonrow $l]
6996 set targetid $id
6997 set targetrow $l
6998 set selectedline $l
6999 set currentid $id
7000 if {$lastscrollrows < $numcommits} {
7001 setcanvscroll
7004 set y [expr {$canvy0 + $l * $linespc}]
7005 set ymax [lindex [$canv cget -scrollregion] 3]
7006 set ytop [expr {$y - $linespc - 1}]
7007 set ybot [expr {$y + $linespc + 1}]
7008 set wnow [$canv yview]
7009 set wtop [expr {[lindex $wnow 0] * $ymax}]
7010 set wbot [expr {[lindex $wnow 1] * $ymax}]
7011 set wh [expr {$wbot - $wtop}]
7012 set newtop $wtop
7013 if {$ytop < $wtop} {
7014 if {$ybot < $wtop} {
7015 set newtop [expr {$y - $wh / 2.0}]
7016 } else {
7017 set newtop $ytop
7018 if {$newtop > $wtop - $linespc} {
7019 set newtop [expr {$wtop - $linespc}]
7022 } elseif {$ybot > $wbot} {
7023 if {$ytop > $wbot} {
7024 set newtop [expr {$y - $wh / 2.0}]
7025 } else {
7026 set newtop [expr {$ybot - $wh}]
7027 if {$newtop < $wtop + $linespc} {
7028 set newtop [expr {$wtop + $linespc}]
7032 if {$newtop != $wtop} {
7033 if {$newtop < 0} {
7034 set newtop 0
7036 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7037 drawvisible
7040 make_secsel $id
7042 if {$isnew} {
7043 addtohistory [list selbyid $id 0] savecmitpos
7046 $sha1entry delete 0 end
7047 $sha1entry insert 0 $id
7048 if {$autoselect} {
7049 $sha1entry selection range 0 $autosellen
7051 rhighlight_sel $id
7053 $ctext conf -state normal
7054 clear_ctext
7055 set linknum 0
7056 if {![info exists commitinfo($id)]} {
7057 getcommit $id
7059 set info $commitinfo($id)
7060 set date [formatdate [lindex $info 2]]
7061 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7062 set date [formatdate [lindex $info 4]]
7063 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7064 if {[info exists idtags($id)]} {
7065 $ctext insert end [mc "Tags:"]
7066 foreach tag $idtags($id) {
7067 $ctext insert end " $tag"
7069 $ctext insert end "\n"
7072 set headers {}
7073 set olds $parents($curview,$id)
7074 if {[llength $olds] > 1} {
7075 set np 0
7076 foreach p $olds {
7077 if {$np >= $mergemax} {
7078 set tag mmax
7079 } else {
7080 set tag m$np
7082 $ctext insert end "[mc "Parent"]: " $tag
7083 appendwithlinks [commit_descriptor $p] {}
7084 incr np
7086 } else {
7087 foreach p $olds {
7088 append headers "[mc "Parent"]: [commit_descriptor $p]"
7092 foreach c $children($curview,$id) {
7093 append headers "[mc "Child"]: [commit_descriptor $c]"
7096 # make anything that looks like a SHA1 ID be a clickable link
7097 appendwithlinks $headers {}
7098 if {$showneartags} {
7099 if {![info exists allcommits]} {
7100 getallcommits
7102 $ctext insert end "[mc "Branch"]: "
7103 $ctext mark set branch "end -1c"
7104 $ctext mark gravity branch left
7105 $ctext insert end "\n[mc "Follows"]: "
7106 $ctext mark set follows "end -1c"
7107 $ctext mark gravity follows left
7108 $ctext insert end "\n[mc "Precedes"]: "
7109 $ctext mark set precedes "end -1c"
7110 $ctext mark gravity precedes left
7111 $ctext insert end "\n"
7112 dispneartags 1
7114 $ctext insert end "\n"
7115 set comment [lindex $info 5]
7116 if {[string first "\r" $comment] >= 0} {
7117 set comment [string map {"\r" "\n "} $comment]
7119 appendwithlinks $comment {comment}
7121 $ctext tag remove found 1.0 end
7122 $ctext conf -state disabled
7123 set commentend [$ctext index "end - 1c"]
7125 set jump_to_here $desired_loc
7126 init_flist [mc "Comments"]
7127 if {$cmitmode eq "tree"} {
7128 gettree $id
7129 } elseif {[llength $olds] <= 1} {
7130 startdiff $id
7131 } else {
7132 mergediff $id
7136 proc selfirstline {} {
7137 unmarkmatches
7138 selectline 0 1
7141 proc sellastline {} {
7142 global numcommits
7143 unmarkmatches
7144 set l [expr {$numcommits - 1}]
7145 selectline $l 1
7148 proc selnextline {dir} {
7149 global selectedline
7150 focus .
7151 if {$selectedline eq {}} return
7152 set l [expr {$selectedline + $dir}]
7153 unmarkmatches
7154 selectline $l 1
7157 proc selnextpage {dir} {
7158 global canv linespc selectedline numcommits
7160 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7161 if {$lpp < 1} {
7162 set lpp 1
7164 allcanvs yview scroll [expr {$dir * $lpp}] units
7165 drawvisible
7166 if {$selectedline eq {}} return
7167 set l [expr {$selectedline + $dir * $lpp}]
7168 if {$l < 0} {
7169 set l 0
7170 } elseif {$l >= $numcommits} {
7171 set l [expr $numcommits - 1]
7173 unmarkmatches
7174 selectline $l 1
7177 proc unselectline {} {
7178 global selectedline currentid
7180 set selectedline {}
7181 catch {unset currentid}
7182 allcanvs delete secsel
7183 rhighlight_none
7186 proc reselectline {} {
7187 global selectedline
7189 if {$selectedline ne {}} {
7190 selectline $selectedline 0
7194 proc addtohistory {cmd {saveproc {}}} {
7195 global history historyindex curview
7197 unset_posvars
7198 save_position
7199 set elt [list $curview $cmd $saveproc {}]
7200 if {$historyindex > 0
7201 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7202 return
7205 if {$historyindex < [llength $history]} {
7206 set history [lreplace $history $historyindex end $elt]
7207 } else {
7208 lappend history $elt
7210 incr historyindex
7211 if {$historyindex > 1} {
7212 .tf.bar.leftbut conf -state normal
7213 } else {
7214 .tf.bar.leftbut conf -state disabled
7216 .tf.bar.rightbut conf -state disabled
7219 # save the scrolling position of the diff display pane
7220 proc save_position {} {
7221 global historyindex history
7223 if {$historyindex < 1} return
7224 set hi [expr {$historyindex - 1}]
7225 set fn [lindex $history $hi 2]
7226 if {$fn ne {}} {
7227 lset history $hi 3 [eval $fn]
7231 proc unset_posvars {} {
7232 global last_posvars
7234 if {[info exists last_posvars]} {
7235 foreach {var val} $last_posvars {
7236 global $var
7237 catch {unset $var}
7239 unset last_posvars
7243 proc godo {elt} {
7244 global curview last_posvars
7246 set view [lindex $elt 0]
7247 set cmd [lindex $elt 1]
7248 set pv [lindex $elt 3]
7249 if {$curview != $view} {
7250 showview $view
7252 unset_posvars
7253 foreach {var val} $pv {
7254 global $var
7255 set $var $val
7257 set last_posvars $pv
7258 eval $cmd
7261 proc goback {} {
7262 global history historyindex
7263 focus .
7265 if {$historyindex > 1} {
7266 save_position
7267 incr historyindex -1
7268 godo [lindex $history [expr {$historyindex - 1}]]
7269 .tf.bar.rightbut conf -state normal
7271 if {$historyindex <= 1} {
7272 .tf.bar.leftbut conf -state disabled
7276 proc goforw {} {
7277 global history historyindex
7278 focus .
7280 if {$historyindex < [llength $history]} {
7281 save_position
7282 set cmd [lindex $history $historyindex]
7283 incr historyindex
7284 godo $cmd
7285 .tf.bar.leftbut conf -state normal
7287 if {$historyindex >= [llength $history]} {
7288 .tf.bar.rightbut conf -state disabled
7292 proc gettree {id} {
7293 global treefilelist treeidlist diffids diffmergeid treepending
7294 global nullid nullid2
7296 set diffids $id
7297 catch {unset diffmergeid}
7298 if {![info exists treefilelist($id)]} {
7299 if {![info exists treepending]} {
7300 if {$id eq $nullid} {
7301 set cmd [list | git ls-files]
7302 } elseif {$id eq $nullid2} {
7303 set cmd [list | git ls-files --stage -t]
7304 } else {
7305 set cmd [list | git ls-tree -r $id]
7307 if {[catch {set gtf [open $cmd r]}]} {
7308 return
7310 set treepending $id
7311 set treefilelist($id) {}
7312 set treeidlist($id) {}
7313 fconfigure $gtf -blocking 0 -encoding binary
7314 filerun $gtf [list gettreeline $gtf $id]
7316 } else {
7317 setfilelist $id
7321 proc gettreeline {gtf id} {
7322 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7324 set nl 0
7325 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7326 if {$diffids eq $nullid} {
7327 set fname $line
7328 } else {
7329 set i [string first "\t" $line]
7330 if {$i < 0} continue
7331 set fname [string range $line [expr {$i+1}] end]
7332 set line [string range $line 0 [expr {$i-1}]]
7333 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7334 set sha1 [lindex $line 2]
7335 lappend treeidlist($id) $sha1
7337 if {[string index $fname 0] eq "\""} {
7338 set fname [lindex $fname 0]
7340 set fname [encoding convertfrom $fname]
7341 lappend treefilelist($id) $fname
7343 if {![eof $gtf]} {
7344 return [expr {$nl >= 1000? 2: 1}]
7346 close $gtf
7347 unset treepending
7348 if {$cmitmode ne "tree"} {
7349 if {![info exists diffmergeid]} {
7350 gettreediffs $diffids
7352 } elseif {$id ne $diffids} {
7353 gettree $diffids
7354 } else {
7355 setfilelist $id
7357 return 0
7360 proc showfile {f} {
7361 global treefilelist treeidlist diffids nullid nullid2
7362 global ctext_file_names ctext_file_lines
7363 global ctext commentend
7365 set i [lsearch -exact $treefilelist($diffids) $f]
7366 if {$i < 0} {
7367 puts "oops, $f not in list for id $diffids"
7368 return
7370 if {$diffids eq $nullid} {
7371 if {[catch {set bf [open $f r]} err]} {
7372 puts "oops, can't read $f: $err"
7373 return
7375 } else {
7376 set blob [lindex $treeidlist($diffids) $i]
7377 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7378 puts "oops, error reading blob $blob: $err"
7379 return
7382 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7383 filerun $bf [list getblobline $bf $diffids]
7384 $ctext config -state normal
7385 clear_ctext $commentend
7386 lappend ctext_file_names $f
7387 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7388 $ctext insert end "\n"
7389 $ctext insert end "$f\n" filesep
7390 $ctext config -state disabled
7391 $ctext yview $commentend
7392 settabs 0
7395 proc getblobline {bf id} {
7396 global diffids cmitmode ctext
7398 if {$id ne $diffids || $cmitmode ne "tree"} {
7399 catch {close $bf}
7400 return 0
7402 $ctext config -state normal
7403 set nl 0
7404 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7405 $ctext insert end "$line\n"
7407 if {[eof $bf]} {
7408 global jump_to_here ctext_file_names commentend
7410 # delete last newline
7411 $ctext delete "end - 2c" "end - 1c"
7412 close $bf
7413 if {$jump_to_here ne {} &&
7414 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7415 set lnum [expr {[lindex $jump_to_here 1] +
7416 [lindex [split $commentend .] 0]}]
7417 mark_ctext_line $lnum
7419 $ctext config -state disabled
7420 return 0
7422 $ctext config -state disabled
7423 return [expr {$nl >= 1000? 2: 1}]
7426 proc mark_ctext_line {lnum} {
7427 global ctext markbgcolor
7429 $ctext tag delete omark
7430 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7431 $ctext tag conf omark -background $markbgcolor
7432 $ctext see $lnum.0
7435 proc mergediff {id} {
7436 global diffmergeid
7437 global diffids treediffs
7438 global parents curview
7440 set diffmergeid $id
7441 set diffids $id
7442 set treediffs($id) {}
7443 set np [llength $parents($curview,$id)]
7444 settabs $np
7445 getblobdiffs $id
7448 proc startdiff {ids} {
7449 global treediffs diffids treepending diffmergeid nullid nullid2
7451 settabs 1
7452 set diffids $ids
7453 catch {unset diffmergeid}
7454 if {![info exists treediffs($ids)] ||
7455 [lsearch -exact $ids $nullid] >= 0 ||
7456 [lsearch -exact $ids $nullid2] >= 0} {
7457 if {![info exists treepending]} {
7458 gettreediffs $ids
7460 } else {
7461 addtocflist $ids
7465 # If the filename (name) is under any of the passed filter paths
7466 # then return true to include the file in the listing.
7467 proc path_filter {filter name} {
7468 set worktree [gitworktree]
7469 foreach p $filter {
7470 set fq_p [file normalize $p]
7471 set fq_n [file normalize [file join $worktree $name]]
7472 if {[string match [file normalize $fq_p]* $fq_n]} {
7473 return 1
7476 return 0
7479 proc addtocflist {ids} {
7480 global treediffs
7482 add_flist $treediffs($ids)
7483 getblobdiffs $ids
7486 proc diffcmd {ids flags} {
7487 global log_showroot nullid nullid2
7489 set i [lsearch -exact $ids $nullid]
7490 set j [lsearch -exact $ids $nullid2]
7491 if {$i >= 0} {
7492 if {[llength $ids] > 1 && $j < 0} {
7493 # comparing working directory with some specific revision
7494 set cmd [concat | git diff-index $flags]
7495 if {$i == 0} {
7496 lappend cmd -R [lindex $ids 1]
7497 } else {
7498 lappend cmd [lindex $ids 0]
7500 } else {
7501 # comparing working directory with index
7502 set cmd [concat | git diff-files $flags]
7503 if {$j == 1} {
7504 lappend cmd -R
7507 } elseif {$j >= 0} {
7508 set cmd [concat | git diff-index --cached $flags]
7509 if {[llength $ids] > 1} {
7510 # comparing index with specific revision
7511 if {$j == 0} {
7512 lappend cmd -R [lindex $ids 1]
7513 } else {
7514 lappend cmd [lindex $ids 0]
7516 } else {
7517 # comparing index with HEAD
7518 lappend cmd HEAD
7520 } else {
7521 if {$log_showroot} {
7522 lappend flags --root
7524 set cmd [concat | git diff-tree -r $flags $ids]
7526 return $cmd
7529 proc gettreediffs {ids} {
7530 global treediff treepending
7532 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7534 set treepending $ids
7535 set treediff {}
7536 fconfigure $gdtf -blocking 0 -encoding binary
7537 filerun $gdtf [list gettreediffline $gdtf $ids]
7540 proc gettreediffline {gdtf ids} {
7541 global treediff treediffs treepending diffids diffmergeid
7542 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7544 set nr 0
7545 set sublist {}
7546 set max 1000
7547 if {$perfile_attrs} {
7548 # cache_gitattr is slow, and even slower on win32 where we
7549 # have to invoke it for only about 30 paths at a time
7550 set max 500
7551 if {[tk windowingsystem] == "win32"} {
7552 set max 120
7555 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7556 set i [string first "\t" $line]
7557 if {$i >= 0} {
7558 set file [string range $line [expr {$i+1}] end]
7559 if {[string index $file 0] eq "\""} {
7560 set file [lindex $file 0]
7562 set file [encoding convertfrom $file]
7563 if {$file ne [lindex $treediff end]} {
7564 lappend treediff $file
7565 lappend sublist $file
7569 if {$perfile_attrs} {
7570 cache_gitattr encoding $sublist
7572 if {![eof $gdtf]} {
7573 return [expr {$nr >= $max? 2: 1}]
7575 close $gdtf
7576 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7577 set flist {}
7578 foreach f $treediff {
7579 if {[path_filter $vfilelimit($curview) $f]} {
7580 lappend flist $f
7583 set treediffs($ids) $flist
7584 } else {
7585 set treediffs($ids) $treediff
7587 unset treepending
7588 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7589 gettree $diffids
7590 } elseif {$ids != $diffids} {
7591 if {![info exists diffmergeid]} {
7592 gettreediffs $diffids
7594 } else {
7595 addtocflist $ids
7597 return 0
7600 # empty string or positive integer
7601 proc diffcontextvalidate {v} {
7602 return [regexp {^(|[1-9][0-9]*)$} $v]
7605 proc diffcontextchange {n1 n2 op} {
7606 global diffcontextstring diffcontext
7608 if {[string is integer -strict $diffcontextstring]} {
7609 if {$diffcontextstring >= 0} {
7610 set diffcontext $diffcontextstring
7611 reselectline
7616 proc changeignorespace {} {
7617 reselectline
7620 proc changeworddiff {name ix op} {
7621 reselectline
7624 proc getblobdiffs {ids} {
7625 global blobdifffd diffids env
7626 global diffinhdr treediffs
7627 global diffcontext
7628 global ignorespace
7629 global worddiff
7630 global limitdiffs vfilelimit curview
7631 global diffencoding targetline diffnparents
7632 global git_version currdiffsubmod
7634 set textconv {}
7635 if {[package vcompare $git_version "1.6.1"] >= 0} {
7636 set textconv "--textconv"
7638 set submodule {}
7639 if {[package vcompare $git_version "1.6.6"] >= 0} {
7640 set submodule "--submodule"
7642 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7643 if {$ignorespace} {
7644 append cmd " -w"
7646 if {$worddiff ne [mc "Line diff"]} {
7647 append cmd " --word-diff=porcelain"
7649 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7650 set cmd [concat $cmd -- $vfilelimit($curview)]
7652 if {[catch {set bdf [open $cmd r]} err]} {
7653 error_popup [mc "Error getting diffs: %s" $err]
7654 return
7656 set targetline {}
7657 set diffnparents 0
7658 set diffinhdr 0
7659 set diffencoding [get_path_encoding {}]
7660 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7661 set blobdifffd($ids) $bdf
7662 set currdiffsubmod ""
7663 filerun $bdf [list getblobdiffline $bdf $diffids]
7666 proc savecmitpos {} {
7667 global ctext cmitmode
7669 if {$cmitmode eq "tree"} {
7670 return {}
7672 return [list target_scrollpos [$ctext index @0,0]]
7675 proc savectextpos {} {
7676 global ctext
7678 return [list target_scrollpos [$ctext index @0,0]]
7681 proc maybe_scroll_ctext {ateof} {
7682 global ctext target_scrollpos
7684 if {![info exists target_scrollpos]} return
7685 if {!$ateof} {
7686 set nlines [expr {[winfo height $ctext]
7687 / [font metrics textfont -linespace]}]
7688 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7690 $ctext yview $target_scrollpos
7691 unset target_scrollpos
7694 proc setinlist {var i val} {
7695 global $var
7697 while {[llength [set $var]] < $i} {
7698 lappend $var {}
7700 if {[llength [set $var]] == $i} {
7701 lappend $var $val
7702 } else {
7703 lset $var $i $val
7707 proc makediffhdr {fname ids} {
7708 global ctext curdiffstart treediffs diffencoding
7709 global ctext_file_names jump_to_here targetline diffline
7711 set fname [encoding convertfrom $fname]
7712 set diffencoding [get_path_encoding $fname]
7713 set i [lsearch -exact $treediffs($ids) $fname]
7714 if {$i >= 0} {
7715 setinlist difffilestart $i $curdiffstart
7717 lset ctext_file_names end $fname
7718 set l [expr {(78 - [string length $fname]) / 2}]
7719 set pad [string range "----------------------------------------" 1 $l]
7720 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7721 set targetline {}
7722 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7723 set targetline [lindex $jump_to_here 1]
7725 set diffline 0
7728 proc getblobdiffline {bdf ids} {
7729 global diffids blobdifffd ctext curdiffstart
7730 global diffnexthead diffnextnote difffilestart
7731 global ctext_file_names ctext_file_lines
7732 global diffinhdr treediffs mergemax diffnparents
7733 global diffencoding jump_to_here targetline diffline currdiffsubmod
7734 global worddiff
7736 set nr 0
7737 $ctext conf -state normal
7738 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7739 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7740 catch {close $bdf}
7741 return 0
7743 if {![string compare -length 5 "diff " $line]} {
7744 if {![regexp {^diff (--cc|--git) } $line m type]} {
7745 set line [encoding convertfrom $line]
7746 $ctext insert end "$line\n" hunksep
7747 continue
7749 # start of a new file
7750 set diffinhdr 1
7751 $ctext insert end "\n"
7752 set curdiffstart [$ctext index "end - 1c"]
7753 lappend ctext_file_names ""
7754 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7755 $ctext insert end "\n" filesep
7757 if {$type eq "--cc"} {
7758 # start of a new file in a merge diff
7759 set fname [string range $line 10 end]
7760 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7761 lappend treediffs($ids) $fname
7762 add_flist [list $fname]
7765 } else {
7766 set line [string range $line 11 end]
7767 # If the name hasn't changed the length will be odd,
7768 # the middle char will be a space, and the two bits either
7769 # side will be a/name and b/name, or "a/name" and "b/name".
7770 # If the name has changed we'll get "rename from" and
7771 # "rename to" or "copy from" and "copy to" lines following
7772 # this, and we'll use them to get the filenames.
7773 # This complexity is necessary because spaces in the
7774 # filename(s) don't get escaped.
7775 set l [string length $line]
7776 set i [expr {$l / 2}]
7777 if {!(($l & 1) && [string index $line $i] eq " " &&
7778 [string range $line 2 [expr {$i - 1}]] eq \
7779 [string range $line [expr {$i + 3}] end])} {
7780 continue
7782 # unescape if quoted and chop off the a/ from the front
7783 if {[string index $line 0] eq "\""} {
7784 set fname [string range [lindex $line 0] 2 end]
7785 } else {
7786 set fname [string range $line 2 [expr {$i - 1}]]
7789 makediffhdr $fname $ids
7791 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7792 set fname [encoding convertfrom [string range $line 16 end]]
7793 $ctext insert end "\n"
7794 set curdiffstart [$ctext index "end - 1c"]
7795 lappend ctext_file_names $fname
7796 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7797 $ctext insert end "$line\n" filesep
7798 set i [lsearch -exact $treediffs($ids) $fname]
7799 if {$i >= 0} {
7800 setinlist difffilestart $i $curdiffstart
7803 } elseif {![string compare -length 2 "@@" $line]} {
7804 regexp {^@@+} $line ats
7805 set line [encoding convertfrom $diffencoding $line]
7806 $ctext insert end "$line\n" hunksep
7807 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7808 set diffline $nl
7810 set diffnparents [expr {[string length $ats] - 1}]
7811 set diffinhdr 0
7813 } elseif {![string compare -length 10 "Submodule " $line]} {
7814 # start of a new submodule
7815 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
7816 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
7817 } else {
7818 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
7820 if {$currdiffsubmod != $fname} {
7821 $ctext insert end "\n"; # Add newline after commit message
7823 set curdiffstart [$ctext index "end - 1c"]
7824 lappend ctext_file_names ""
7825 if {$currdiffsubmod != $fname} {
7826 lappend ctext_file_lines $fname
7827 makediffhdr $fname $ids
7828 set currdiffsubmod $fname
7829 $ctext insert end "\n$line\n" filesep
7830 } else {
7831 $ctext insert end "$line\n" filesep
7833 } elseif {![string compare -length 3 " >" $line]} {
7834 set $currdiffsubmod ""
7835 set line [encoding convertfrom $diffencoding $line]
7836 $ctext insert end "$line\n" dresult
7837 } elseif {![string compare -length 3 " <" $line]} {
7838 set $currdiffsubmod ""
7839 set line [encoding convertfrom $diffencoding $line]
7840 $ctext insert end "$line\n" d0
7841 } elseif {$diffinhdr} {
7842 if {![string compare -length 12 "rename from " $line]} {
7843 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7844 if {[string index $fname 0] eq "\""} {
7845 set fname [lindex $fname 0]
7847 set fname [encoding convertfrom $fname]
7848 set i [lsearch -exact $treediffs($ids) $fname]
7849 if {$i >= 0} {
7850 setinlist difffilestart $i $curdiffstart
7852 } elseif {![string compare -length 10 $line "rename to "] ||
7853 ![string compare -length 8 $line "copy to "]} {
7854 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7855 if {[string index $fname 0] eq "\""} {
7856 set fname [lindex $fname 0]
7858 makediffhdr $fname $ids
7859 } elseif {[string compare -length 3 $line "---"] == 0} {
7860 # do nothing
7861 continue
7862 } elseif {[string compare -length 3 $line "+++"] == 0} {
7863 set diffinhdr 0
7864 continue
7866 $ctext insert end "$line\n" filesep
7868 } else {
7869 set line [string map {\x1A ^Z} \
7870 [encoding convertfrom $diffencoding $line]]
7871 # parse the prefix - one ' ', '-' or '+' for each parent
7872 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7873 set tag [expr {$diffnparents > 1? "m": "d"}]
7874 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
7875 set words_pre_markup ""
7876 set words_post_markup ""
7877 if {[string trim $prefix " -+"] eq {}} {
7878 # prefix only has " ", "-" and "+" in it: normal diff line
7879 set num [string first "-" $prefix]
7880 if {$dowords} {
7881 set line [string range $line 1 end]
7883 if {$num >= 0} {
7884 # removed line, first parent with line is $num
7885 if {$num >= $mergemax} {
7886 set num "max"
7888 if {$dowords && $worddiff eq [mc "Markup words"]} {
7889 $ctext insert end "\[-$line-\]" $tag$num
7890 } else {
7891 $ctext insert end "$line" $tag$num
7893 if {!$dowords} {
7894 $ctext insert end "\n" $tag$num
7896 } else {
7897 set tags {}
7898 if {[string first "+" $prefix] >= 0} {
7899 # added line
7900 lappend tags ${tag}result
7901 if {$diffnparents > 1} {
7902 set num [string first " " $prefix]
7903 if {$num >= 0} {
7904 if {$num >= $mergemax} {
7905 set num "max"
7907 lappend tags m$num
7910 set words_pre_markup "{+"
7911 set words_post_markup "+}"
7913 if {$targetline ne {}} {
7914 if {$diffline == $targetline} {
7915 set seehere [$ctext index "end - 1 chars"]
7916 set targetline {}
7917 } else {
7918 incr diffline
7921 if {$dowords && $worddiff eq [mc "Markup words"]} {
7922 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
7923 } else {
7924 $ctext insert end "$line" $tags
7926 if {!$dowords} {
7927 $ctext insert end "\n" $tags
7930 } elseif {$dowords && $prefix eq "~"} {
7931 $ctext insert end "\n" {}
7932 } else {
7933 # "\ No newline at end of file",
7934 # or something else we don't recognize
7935 $ctext insert end "$line\n" hunksep
7939 if {[info exists seehere]} {
7940 mark_ctext_line [lindex [split $seehere .] 0]
7942 maybe_scroll_ctext [eof $bdf]
7943 $ctext conf -state disabled
7944 if {[eof $bdf]} {
7945 catch {close $bdf}
7946 return 0
7948 return [expr {$nr >= 1000? 2: 1}]
7951 proc changediffdisp {} {
7952 global ctext diffelide
7954 $ctext tag conf d0 -elide [lindex $diffelide 0]
7955 $ctext tag conf dresult -elide [lindex $diffelide 1]
7958 proc highlightfile {cline} {
7959 global cflist cflist_top
7961 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7962 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7963 $cflist see $cline.0
7964 set cflist_top $cline
7967 proc highlightfile_for_scrollpos {topidx} {
7968 global difffilestart
7970 if {![info exists difffilestart]} return
7972 set top [lindex [split $topidx .] 0]
7973 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
7974 highlightfile 0
7975 } else {
7976 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
7980 proc prevfile {} {
7981 global difffilestart ctext cmitmode
7983 if {$cmitmode eq "tree"} return
7984 set prev 0.0
7985 set here [$ctext index @0,0]
7986 foreach loc $difffilestart {
7987 if {[$ctext compare $loc >= $here]} {
7988 $ctext yview $prev
7989 return
7991 set prev $loc
7993 $ctext yview $prev
7996 proc nextfile {} {
7997 global difffilestart ctext cmitmode
7999 if {$cmitmode eq "tree"} return
8000 set here [$ctext index @0,0]
8001 foreach loc $difffilestart {
8002 if {[$ctext compare $loc > $here]} {
8003 $ctext yview $loc
8004 return
8009 proc clear_ctext {{first 1.0}} {
8010 global ctext smarktop smarkbot
8011 global ctext_file_names ctext_file_lines
8012 global pendinglinks
8014 set l [lindex [split $first .] 0]
8015 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8016 set smarktop $l
8018 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8019 set smarkbot $l
8021 $ctext delete $first end
8022 if {$first eq "1.0"} {
8023 catch {unset pendinglinks}
8025 set ctext_file_names {}
8026 set ctext_file_lines {}
8029 proc settabs {{firstab {}}} {
8030 global firsttabstop tabstop ctext have_tk85
8032 if {$firstab ne {} && $have_tk85} {
8033 set firsttabstop $firstab
8035 set w [font measure textfont "0"]
8036 if {$firsttabstop != 0} {
8037 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8038 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8039 } elseif {$have_tk85 || $tabstop != 8} {
8040 $ctext conf -tabs [expr {$tabstop * $w}]
8041 } else {
8042 $ctext conf -tabs {}
8046 proc incrsearch {name ix op} {
8047 global ctext searchstring searchdirn
8049 if {[catch {$ctext index anchor}]} {
8050 # no anchor set, use start of selection, or of visible area
8051 set sel [$ctext tag ranges sel]
8052 if {$sel ne {}} {
8053 $ctext mark set anchor [lindex $sel 0]
8054 } elseif {$searchdirn eq "-forwards"} {
8055 $ctext mark set anchor @0,0
8056 } else {
8057 $ctext mark set anchor @0,[winfo height $ctext]
8060 if {$searchstring ne {}} {
8061 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8062 if {$here ne {}} {
8063 $ctext see $here
8064 set mend "$here + $mlen c"
8065 $ctext tag remove sel 1.0 end
8066 $ctext tag add sel $here $mend
8067 suppress_highlighting_file_for_current_scrollpos
8068 highlightfile_for_scrollpos $here
8071 rehighlight_search_results
8074 proc dosearch {} {
8075 global sstring ctext searchstring searchdirn
8077 focus $sstring
8078 $sstring icursor end
8079 set searchdirn -forwards
8080 if {$searchstring ne {}} {
8081 set sel [$ctext tag ranges sel]
8082 if {$sel ne {}} {
8083 set start "[lindex $sel 0] + 1c"
8084 } elseif {[catch {set start [$ctext index anchor]}]} {
8085 set start "@0,0"
8087 set match [$ctext search -count mlen -- $searchstring $start]
8088 $ctext tag remove sel 1.0 end
8089 if {$match eq {}} {
8090 bell
8091 return
8093 $ctext see $match
8094 suppress_highlighting_file_for_current_scrollpos
8095 highlightfile_for_scrollpos $match
8096 set mend "$match + $mlen c"
8097 $ctext tag add sel $match $mend
8098 $ctext mark unset anchor
8099 rehighlight_search_results
8103 proc dosearchback {} {
8104 global sstring ctext searchstring searchdirn
8106 focus $sstring
8107 $sstring icursor end
8108 set searchdirn -backwards
8109 if {$searchstring ne {}} {
8110 set sel [$ctext tag ranges sel]
8111 if {$sel ne {}} {
8112 set start [lindex $sel 0]
8113 } elseif {[catch {set start [$ctext index anchor]}]} {
8114 set start @0,[winfo height $ctext]
8116 set match [$ctext search -backwards -count ml -- $searchstring $start]
8117 $ctext tag remove sel 1.0 end
8118 if {$match eq {}} {
8119 bell
8120 return
8122 $ctext see $match
8123 suppress_highlighting_file_for_current_scrollpos
8124 highlightfile_for_scrollpos $match
8125 set mend "$match + $ml c"
8126 $ctext tag add sel $match $mend
8127 $ctext mark unset anchor
8128 rehighlight_search_results
8132 proc rehighlight_search_results {} {
8133 global ctext searchstring
8135 $ctext tag remove found 1.0 end
8136 $ctext tag remove currentsearchhit 1.0 end
8138 if {$searchstring ne {}} {
8139 searchmarkvisible 1
8143 proc searchmark {first last} {
8144 global ctext searchstring
8146 set sel [$ctext tag ranges sel]
8148 set mend $first.0
8149 while {1} {
8150 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8151 if {$match eq {}} break
8152 set mend "$match + $mlen c"
8153 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8154 $ctext tag add currentsearchhit $match $mend
8155 } else {
8156 $ctext tag add found $match $mend
8161 proc searchmarkvisible {doall} {
8162 global ctext smarktop smarkbot
8164 set topline [lindex [split [$ctext index @0,0] .] 0]
8165 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8166 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8167 # no overlap with previous
8168 searchmark $topline $botline
8169 set smarktop $topline
8170 set smarkbot $botline
8171 } else {
8172 if {$topline < $smarktop} {
8173 searchmark $topline [expr {$smarktop-1}]
8174 set smarktop $topline
8176 if {$botline > $smarkbot} {
8177 searchmark [expr {$smarkbot+1}] $botline
8178 set smarkbot $botline
8183 proc suppress_highlighting_file_for_current_scrollpos {} {
8184 global ctext suppress_highlighting_file_for_this_scrollpos
8186 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8189 proc scrolltext {f0 f1} {
8190 global searchstring cmitmode ctext
8191 global suppress_highlighting_file_for_this_scrollpos
8193 if {$cmitmode ne "tree"} {
8194 set topidx [$ctext index @0,0]
8195 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8196 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8197 highlightfile_for_scrollpos $topidx
8201 catch {unset suppress_highlighting_file_for_this_scrollpos}
8203 .bleft.bottom.sb set $f0 $f1
8204 if {$searchstring ne {}} {
8205 searchmarkvisible 0
8209 proc setcoords {} {
8210 global linespc charspc canvx0 canvy0
8211 global xspc1 xspc2 lthickness
8213 set linespc [font metrics mainfont -linespace]
8214 set charspc [font measure mainfont "m"]
8215 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8216 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8217 set lthickness [expr {int($linespc / 9) + 1}]
8218 set xspc1(0) $linespc
8219 set xspc2 $linespc
8222 proc redisplay {} {
8223 global canv
8224 global selectedline
8226 set ymax [lindex [$canv cget -scrollregion] 3]
8227 if {$ymax eq {} || $ymax == 0} return
8228 set span [$canv yview]
8229 clear_display
8230 setcanvscroll
8231 allcanvs yview moveto [lindex $span 0]
8232 drawvisible
8233 if {$selectedline ne {}} {
8234 selectline $selectedline 0
8235 allcanvs yview moveto [lindex $span 0]
8239 proc parsefont {f n} {
8240 global fontattr
8242 set fontattr($f,family) [lindex $n 0]
8243 set s [lindex $n 1]
8244 if {$s eq {} || $s == 0} {
8245 set s 10
8246 } elseif {$s < 0} {
8247 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8249 set fontattr($f,size) $s
8250 set fontattr($f,weight) normal
8251 set fontattr($f,slant) roman
8252 foreach style [lrange $n 2 end] {
8253 switch -- $style {
8254 "normal" -
8255 "bold" {set fontattr($f,weight) $style}
8256 "roman" -
8257 "italic" {set fontattr($f,slant) $style}
8262 proc fontflags {f {isbold 0}} {
8263 global fontattr
8265 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8266 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8267 -slant $fontattr($f,slant)]
8270 proc fontname {f} {
8271 global fontattr
8273 set n [list $fontattr($f,family) $fontattr($f,size)]
8274 if {$fontattr($f,weight) eq "bold"} {
8275 lappend n "bold"
8277 if {$fontattr($f,slant) eq "italic"} {
8278 lappend n "italic"
8280 return $n
8283 proc incrfont {inc} {
8284 global mainfont textfont ctext canv cflist showrefstop
8285 global stopped entries fontattr
8287 unmarkmatches
8288 set s $fontattr(mainfont,size)
8289 incr s $inc
8290 if {$s < 1} {
8291 set s 1
8293 set fontattr(mainfont,size) $s
8294 font config mainfont -size $s
8295 font config mainfontbold -size $s
8296 set mainfont [fontname mainfont]
8297 set s $fontattr(textfont,size)
8298 incr s $inc
8299 if {$s < 1} {
8300 set s 1
8302 set fontattr(textfont,size) $s
8303 font config textfont -size $s
8304 font config textfontbold -size $s
8305 set textfont [fontname textfont]
8306 setcoords
8307 settabs
8308 redisplay
8311 proc clearsha1 {} {
8312 global sha1entry sha1string
8313 if {[string length $sha1string] == 40} {
8314 $sha1entry delete 0 end
8318 proc sha1change {n1 n2 op} {
8319 global sha1string currentid sha1but
8320 if {$sha1string == {}
8321 || ([info exists currentid] && $sha1string == $currentid)} {
8322 set state disabled
8323 } else {
8324 set state normal
8326 if {[$sha1but cget -state] == $state} return
8327 if {$state == "normal"} {
8328 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8329 } else {
8330 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8334 proc gotocommit {} {
8335 global sha1string tagids headids curview varcid
8337 if {$sha1string == {}
8338 || ([info exists currentid] && $sha1string == $currentid)} return
8339 if {[info exists tagids($sha1string)]} {
8340 set id $tagids($sha1string)
8341 } elseif {[info exists headids($sha1string)]} {
8342 set id $headids($sha1string)
8343 } else {
8344 set id [string tolower $sha1string]
8345 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8346 set matches [longid $id]
8347 if {$matches ne {}} {
8348 if {[llength $matches] > 1} {
8349 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8350 return
8352 set id [lindex $matches 0]
8354 } else {
8355 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8356 error_popup [mc "Revision %s is not known" $sha1string]
8357 return
8361 if {[commitinview $id $curview]} {
8362 selectline [rowofcommit $id] 1
8363 return
8365 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8366 set msg [mc "SHA1 id %s is not known" $sha1string]
8367 } else {
8368 set msg [mc "Revision %s is not in the current view" $sha1string]
8370 error_popup $msg
8373 proc lineenter {x y id} {
8374 global hoverx hovery hoverid hovertimer
8375 global commitinfo canv
8377 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8378 set hoverx $x
8379 set hovery $y
8380 set hoverid $id
8381 if {[info exists hovertimer]} {
8382 after cancel $hovertimer
8384 set hovertimer [after 500 linehover]
8385 $canv delete hover
8388 proc linemotion {x y id} {
8389 global hoverx hovery hoverid hovertimer
8391 if {[info exists hoverid] && $id == $hoverid} {
8392 set hoverx $x
8393 set hovery $y
8394 if {[info exists hovertimer]} {
8395 after cancel $hovertimer
8397 set hovertimer [after 500 linehover]
8401 proc lineleave {id} {
8402 global hoverid hovertimer canv
8404 if {[info exists hoverid] && $id == $hoverid} {
8405 $canv delete hover
8406 if {[info exists hovertimer]} {
8407 after cancel $hovertimer
8408 unset hovertimer
8410 unset hoverid
8414 proc linehover {} {
8415 global hoverx hovery hoverid hovertimer
8416 global canv linespc lthickness
8417 global commitinfo
8419 set text [lindex $commitinfo($hoverid) 0]
8420 set ymax [lindex [$canv cget -scrollregion] 3]
8421 if {$ymax == {}} return
8422 set yfrac [lindex [$canv yview] 0]
8423 set x [expr {$hoverx + 2 * $linespc}]
8424 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8425 set x0 [expr {$x - 2 * $lthickness}]
8426 set y0 [expr {$y - 2 * $lthickness}]
8427 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8428 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8429 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8430 -fill \#ffff80 -outline black -width 1 -tags hover]
8431 $canv raise $t
8432 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8433 -font mainfont]
8434 $canv raise $t
8437 proc clickisonarrow {id y} {
8438 global lthickness
8440 set ranges [rowranges $id]
8441 set thresh [expr {2 * $lthickness + 6}]
8442 set n [expr {[llength $ranges] - 1}]
8443 for {set i 1} {$i < $n} {incr i} {
8444 set row [lindex $ranges $i]
8445 if {abs([yc $row] - $y) < $thresh} {
8446 return $i
8449 return {}
8452 proc arrowjump {id n y} {
8453 global canv
8455 # 1 <-> 2, 3 <-> 4, etc...
8456 set n [expr {(($n - 1) ^ 1) + 1}]
8457 set row [lindex [rowranges $id] $n]
8458 set yt [yc $row]
8459 set ymax [lindex [$canv cget -scrollregion] 3]
8460 if {$ymax eq {} || $ymax <= 0} return
8461 set view [$canv yview]
8462 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8463 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8464 if {$yfrac < 0} {
8465 set yfrac 0
8467 allcanvs yview moveto $yfrac
8470 proc lineclick {x y id isnew} {
8471 global ctext commitinfo children canv thickerline curview
8473 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8474 unmarkmatches
8475 unselectline
8476 normalline
8477 $canv delete hover
8478 # draw this line thicker than normal
8479 set thickerline $id
8480 drawlines $id
8481 if {$isnew} {
8482 set ymax [lindex [$canv cget -scrollregion] 3]
8483 if {$ymax eq {}} return
8484 set yfrac [lindex [$canv yview] 0]
8485 set y [expr {$y + $yfrac * $ymax}]
8487 set dirn [clickisonarrow $id $y]
8488 if {$dirn ne {}} {
8489 arrowjump $id $dirn $y
8490 return
8493 if {$isnew} {
8494 addtohistory [list lineclick $x $y $id 0] savectextpos
8496 # fill the details pane with info about this line
8497 $ctext conf -state normal
8498 clear_ctext
8499 settabs 0
8500 $ctext insert end "[mc "Parent"]:\t"
8501 $ctext insert end $id link0
8502 setlink $id link0
8503 set info $commitinfo($id)
8504 $ctext insert end "\n\t[lindex $info 0]\n"
8505 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8506 set date [formatdate [lindex $info 2]]
8507 $ctext insert end "\t[mc "Date"]:\t$date\n"
8508 set kids $children($curview,$id)
8509 if {$kids ne {}} {
8510 $ctext insert end "\n[mc "Children"]:"
8511 set i 0
8512 foreach child $kids {
8513 incr i
8514 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8515 set info $commitinfo($child)
8516 $ctext insert end "\n\t"
8517 $ctext insert end $child link$i
8518 setlink $child link$i
8519 $ctext insert end "\n\t[lindex $info 0]"
8520 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8521 set date [formatdate [lindex $info 2]]
8522 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8525 maybe_scroll_ctext 1
8526 $ctext conf -state disabled
8527 init_flist {}
8530 proc normalline {} {
8531 global thickerline
8532 if {[info exists thickerline]} {
8533 set id $thickerline
8534 unset thickerline
8535 drawlines $id
8539 proc selbyid {id {isnew 1}} {
8540 global curview
8541 if {[commitinview $id $curview]} {
8542 selectline [rowofcommit $id] $isnew
8546 proc mstime {} {
8547 global startmstime
8548 if {![info exists startmstime]} {
8549 set startmstime [clock clicks -milliseconds]
8551 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8554 proc rowmenu {x y id} {
8555 global rowctxmenu selectedline rowmenuid curview
8556 global nullid nullid2 fakerowmenu mainhead markedid
8558 stopfinding
8559 set rowmenuid $id
8560 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8561 set state disabled
8562 } else {
8563 set state normal
8565 if {[info exists markedid] && $markedid ne $id} {
8566 set mstate normal
8567 } else {
8568 set mstate disabled
8570 if {$id ne $nullid && $id ne $nullid2} {
8571 set menu $rowctxmenu
8572 if {$mainhead ne {}} {
8573 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8574 } else {
8575 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8577 $menu entryconfigure 9 -state $mstate
8578 $menu entryconfigure 10 -state $mstate
8579 $menu entryconfigure 11 -state $mstate
8580 } else {
8581 set menu $fakerowmenu
8583 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8584 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8585 $menu entryconfigure [mca "Make patch"] -state $state
8586 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8587 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8588 tk_popup $menu $x $y
8591 proc markhere {} {
8592 global rowmenuid markedid canv
8594 set markedid $rowmenuid
8595 make_idmark $markedid
8598 proc gotomark {} {
8599 global markedid
8601 if {[info exists markedid]} {
8602 selbyid $markedid
8606 proc replace_by_kids {l r} {
8607 global curview children
8609 set id [commitonrow $r]
8610 set l [lreplace $l 0 0]
8611 foreach kid $children($curview,$id) {
8612 lappend l [rowofcommit $kid]
8614 return [lsort -integer -decreasing -unique $l]
8617 proc find_common_desc {} {
8618 global markedid rowmenuid curview children
8620 if {![info exists markedid]} return
8621 if {![commitinview $markedid $curview] ||
8622 ![commitinview $rowmenuid $curview]} return
8623 #set t1 [clock clicks -milliseconds]
8624 set l1 [list [rowofcommit $markedid]]
8625 set l2 [list [rowofcommit $rowmenuid]]
8626 while 1 {
8627 set r1 [lindex $l1 0]
8628 set r2 [lindex $l2 0]
8629 if {$r1 eq {} || $r2 eq {}} break
8630 if {$r1 == $r2} {
8631 selectline $r1 1
8632 break
8634 if {$r1 > $r2} {
8635 set l1 [replace_by_kids $l1 $r1]
8636 } else {
8637 set l2 [replace_by_kids $l2 $r2]
8640 #set t2 [clock clicks -milliseconds]
8641 #puts "took [expr {$t2-$t1}]ms"
8644 proc compare_commits {} {
8645 global markedid rowmenuid curview children
8647 if {![info exists markedid]} return
8648 if {![commitinview $markedid $curview]} return
8649 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8650 do_cmp_commits $markedid $rowmenuid
8653 proc getpatchid {id} {
8654 global patchids
8656 if {![info exists patchids($id)]} {
8657 set cmd [diffcmd [list $id] {-p --root}]
8658 # trim off the initial "|"
8659 set cmd [lrange $cmd 1 end]
8660 if {[catch {
8661 set x [eval exec $cmd | git patch-id]
8662 set patchids($id) [lindex $x 0]
8663 }]} {
8664 set patchids($id) "error"
8667 return $patchids($id)
8670 proc do_cmp_commits {a b} {
8671 global ctext curview parents children patchids commitinfo
8673 $ctext conf -state normal
8674 clear_ctext
8675 init_flist {}
8676 for {set i 0} {$i < 100} {incr i} {
8677 set skipa 0
8678 set skipb 0
8679 if {[llength $parents($curview,$a)] > 1} {
8680 appendshortlink $a [mc "Skipping merge commit "] "\n"
8681 set skipa 1
8682 } else {
8683 set patcha [getpatchid $a]
8685 if {[llength $parents($curview,$b)] > 1} {
8686 appendshortlink $b [mc "Skipping merge commit "] "\n"
8687 set skipb 1
8688 } else {
8689 set patchb [getpatchid $b]
8691 if {!$skipa && !$skipb} {
8692 set heada [lindex $commitinfo($a) 0]
8693 set headb [lindex $commitinfo($b) 0]
8694 if {$patcha eq "error"} {
8695 appendshortlink $a [mc "Error getting patch ID for "] \
8696 [mc " - stopping\n"]
8697 break
8699 if {$patchb eq "error"} {
8700 appendshortlink $b [mc "Error getting patch ID for "] \
8701 [mc " - stopping\n"]
8702 break
8704 if {$patcha eq $patchb} {
8705 if {$heada eq $headb} {
8706 appendshortlink $a [mc "Commit "]
8707 appendshortlink $b " == " " $heada\n"
8708 } else {
8709 appendshortlink $a [mc "Commit "] " $heada\n"
8710 appendshortlink $b [mc " is the same patch as\n "] \
8711 " $headb\n"
8713 set skipa 1
8714 set skipb 1
8715 } else {
8716 $ctext insert end "\n"
8717 appendshortlink $a [mc "Commit "] " $heada\n"
8718 appendshortlink $b [mc " differs from\n "] \
8719 " $headb\n"
8720 $ctext insert end [mc "Diff of commits:\n\n"]
8721 $ctext conf -state disabled
8722 update
8723 diffcommits $a $b
8724 return
8727 if {$skipa} {
8728 set kids [real_children $curview,$a]
8729 if {[llength $kids] != 1} {
8730 $ctext insert end "\n"
8731 appendshortlink $a [mc "Commit "] \
8732 [mc " has %s children - stopping\n" [llength $kids]]
8733 break
8735 set a [lindex $kids 0]
8737 if {$skipb} {
8738 set kids [real_children $curview,$b]
8739 if {[llength $kids] != 1} {
8740 appendshortlink $b [mc "Commit "] \
8741 [mc " has %s children - stopping\n" [llength $kids]]
8742 break
8744 set b [lindex $kids 0]
8747 $ctext conf -state disabled
8750 proc diffcommits {a b} {
8751 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
8753 set tmpdir [gitknewtmpdir]
8754 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8755 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8756 if {[catch {
8757 exec git diff-tree -p --pretty $a >$fna
8758 exec git diff-tree -p --pretty $b >$fnb
8759 } err]} {
8760 error_popup [mc "Error writing commit to file: %s" $err]
8761 return
8763 if {[catch {
8764 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8765 } err]} {
8766 error_popup [mc "Error diffing commits: %s" $err]
8767 return
8769 set diffids [list commits $a $b]
8770 set blobdifffd($diffids) $fd
8771 set diffinhdr 0
8772 set currdiffsubmod ""
8773 filerun $fd [list getblobdiffline $fd $diffids]
8776 proc diffvssel {dirn} {
8777 global rowmenuid selectedline
8779 if {$selectedline eq {}} return
8780 if {$dirn} {
8781 set oldid [commitonrow $selectedline]
8782 set newid $rowmenuid
8783 } else {
8784 set oldid $rowmenuid
8785 set newid [commitonrow $selectedline]
8787 addtohistory [list doseldiff $oldid $newid] savectextpos
8788 doseldiff $oldid $newid
8791 proc diffvsmark {dirn} {
8792 global rowmenuid markedid
8794 if {![info exists markedid]} return
8795 if {$dirn} {
8796 set oldid $markedid
8797 set newid $rowmenuid
8798 } else {
8799 set oldid $rowmenuid
8800 set newid $markedid
8802 addtohistory [list doseldiff $oldid $newid] savectextpos
8803 doseldiff $oldid $newid
8806 proc doseldiff {oldid newid} {
8807 global ctext
8808 global commitinfo
8810 $ctext conf -state normal
8811 clear_ctext
8812 init_flist [mc "Top"]
8813 $ctext insert end "[mc "From"] "
8814 $ctext insert end $oldid link0
8815 setlink $oldid link0
8816 $ctext insert end "\n "
8817 $ctext insert end [lindex $commitinfo($oldid) 0]
8818 $ctext insert end "\n\n[mc "To"] "
8819 $ctext insert end $newid link1
8820 setlink $newid link1
8821 $ctext insert end "\n "
8822 $ctext insert end [lindex $commitinfo($newid) 0]
8823 $ctext insert end "\n"
8824 $ctext conf -state disabled
8825 $ctext tag remove found 1.0 end
8826 startdiff [list $oldid $newid]
8829 proc mkpatch {} {
8830 global rowmenuid currentid commitinfo patchtop patchnum NS
8832 if {![info exists currentid]} return
8833 set oldid $currentid
8834 set oldhead [lindex $commitinfo($oldid) 0]
8835 set newid $rowmenuid
8836 set newhead [lindex $commitinfo($newid) 0]
8837 set top .patch
8838 set patchtop $top
8839 catch {destroy $top}
8840 ttk_toplevel $top
8841 make_transient $top .
8842 ${NS}::label $top.title -text [mc "Generate patch"]
8843 grid $top.title - -pady 10
8844 ${NS}::label $top.from -text [mc "From:"]
8845 ${NS}::entry $top.fromsha1 -width 40
8846 $top.fromsha1 insert 0 $oldid
8847 $top.fromsha1 conf -state readonly
8848 grid $top.from $top.fromsha1 -sticky w
8849 ${NS}::entry $top.fromhead -width 60
8850 $top.fromhead insert 0 $oldhead
8851 $top.fromhead conf -state readonly
8852 grid x $top.fromhead -sticky w
8853 ${NS}::label $top.to -text [mc "To:"]
8854 ${NS}::entry $top.tosha1 -width 40
8855 $top.tosha1 insert 0 $newid
8856 $top.tosha1 conf -state readonly
8857 grid $top.to $top.tosha1 -sticky w
8858 ${NS}::entry $top.tohead -width 60
8859 $top.tohead insert 0 $newhead
8860 $top.tohead conf -state readonly
8861 grid x $top.tohead -sticky w
8862 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8863 grid $top.rev x -pady 10 -padx 5
8864 ${NS}::label $top.flab -text [mc "Output file:"]
8865 ${NS}::entry $top.fname -width 60
8866 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8867 incr patchnum
8868 grid $top.flab $top.fname -sticky w
8869 ${NS}::frame $top.buts
8870 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8871 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8872 bind $top <Key-Return> mkpatchgo
8873 bind $top <Key-Escape> mkpatchcan
8874 grid $top.buts.gen $top.buts.can
8875 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8876 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8877 grid $top.buts - -pady 10 -sticky ew
8878 focus $top.fname
8881 proc mkpatchrev {} {
8882 global patchtop
8884 set oldid [$patchtop.fromsha1 get]
8885 set oldhead [$patchtop.fromhead get]
8886 set newid [$patchtop.tosha1 get]
8887 set newhead [$patchtop.tohead get]
8888 foreach e [list fromsha1 fromhead tosha1 tohead] \
8889 v [list $newid $newhead $oldid $oldhead] {
8890 $patchtop.$e conf -state normal
8891 $patchtop.$e delete 0 end
8892 $patchtop.$e insert 0 $v
8893 $patchtop.$e conf -state readonly
8897 proc mkpatchgo {} {
8898 global patchtop nullid nullid2
8900 set oldid [$patchtop.fromsha1 get]
8901 set newid [$patchtop.tosha1 get]
8902 set fname [$patchtop.fname get]
8903 set cmd [diffcmd [list $oldid $newid] -p]
8904 # trim off the initial "|"
8905 set cmd [lrange $cmd 1 end]
8906 lappend cmd >$fname &
8907 if {[catch {eval exec $cmd} err]} {
8908 error_popup "[mc "Error creating patch:"] $err" $patchtop
8910 catch {destroy $patchtop}
8911 unset patchtop
8914 proc mkpatchcan {} {
8915 global patchtop
8917 catch {destroy $patchtop}
8918 unset patchtop
8921 proc mktag {} {
8922 global rowmenuid mktagtop commitinfo NS
8924 set top .maketag
8925 set mktagtop $top
8926 catch {destroy $top}
8927 ttk_toplevel $top
8928 make_transient $top .
8929 ${NS}::label $top.title -text [mc "Create tag"]
8930 grid $top.title - -pady 10
8931 ${NS}::label $top.id -text [mc "ID:"]
8932 ${NS}::entry $top.sha1 -width 40
8933 $top.sha1 insert 0 $rowmenuid
8934 $top.sha1 conf -state readonly
8935 grid $top.id $top.sha1 -sticky w
8936 ${NS}::entry $top.head -width 60
8937 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8938 $top.head conf -state readonly
8939 grid x $top.head -sticky w
8940 ${NS}::label $top.tlab -text [mc "Tag name:"]
8941 ${NS}::entry $top.tag -width 60
8942 grid $top.tlab $top.tag -sticky w
8943 ${NS}::label $top.op -text [mc "Tag message is optional"]
8944 grid $top.op -columnspan 2 -sticky we
8945 ${NS}::label $top.mlab -text [mc "Tag message:"]
8946 ${NS}::entry $top.msg -width 60
8947 grid $top.mlab $top.msg -sticky w
8948 ${NS}::frame $top.buts
8949 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8950 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8951 bind $top <Key-Return> mktaggo
8952 bind $top <Key-Escape> mktagcan
8953 grid $top.buts.gen $top.buts.can
8954 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8955 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8956 grid $top.buts - -pady 10 -sticky ew
8957 focus $top.tag
8960 proc domktag {} {
8961 global mktagtop env tagids idtags
8963 set id [$mktagtop.sha1 get]
8964 set tag [$mktagtop.tag get]
8965 set msg [$mktagtop.msg get]
8966 if {$tag == {}} {
8967 error_popup [mc "No tag name specified"] $mktagtop
8968 return 0
8970 if {[info exists tagids($tag)]} {
8971 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8972 return 0
8974 if {[catch {
8975 if {$msg != {}} {
8976 exec git tag -a -m $msg $tag $id
8977 } else {
8978 exec git tag $tag $id
8980 } err]} {
8981 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8982 return 0
8985 set tagids($tag) $id
8986 lappend idtags($id) $tag
8987 redrawtags $id
8988 addedtag $id
8989 dispneartags 0
8990 run refill_reflist
8991 return 1
8994 proc redrawtags {id} {
8995 global canv linehtag idpos currentid curview cmitlisted markedid
8996 global canvxmax iddrawn circleitem mainheadid circlecolors
8998 if {![commitinview $id $curview]} return
8999 if {![info exists iddrawn($id)]} return
9000 set row [rowofcommit $id]
9001 if {$id eq $mainheadid} {
9002 set ofill yellow
9003 } else {
9004 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9006 $canv itemconf $circleitem($row) -fill $ofill
9007 $canv delete tag.$id
9008 set xt [eval drawtags $id $idpos($id)]
9009 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9010 set text [$canv itemcget $linehtag($id) -text]
9011 set font [$canv itemcget $linehtag($id) -font]
9012 set xr [expr {$xt + [font measure $font $text]}]
9013 if {$xr > $canvxmax} {
9014 set canvxmax $xr
9015 setcanvscroll
9017 if {[info exists currentid] && $currentid == $id} {
9018 make_secsel $id
9020 if {[info exists markedid] && $markedid eq $id} {
9021 make_idmark $id
9025 proc mktagcan {} {
9026 global mktagtop
9028 catch {destroy $mktagtop}
9029 unset mktagtop
9032 proc mktaggo {} {
9033 if {![domktag]} return
9034 mktagcan
9037 proc writecommit {} {
9038 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9040 set top .writecommit
9041 set wrcomtop $top
9042 catch {destroy $top}
9043 ttk_toplevel $top
9044 make_transient $top .
9045 ${NS}::label $top.title -text [mc "Write commit to file"]
9046 grid $top.title - -pady 10
9047 ${NS}::label $top.id -text [mc "ID:"]
9048 ${NS}::entry $top.sha1 -width 40
9049 $top.sha1 insert 0 $rowmenuid
9050 $top.sha1 conf -state readonly
9051 grid $top.id $top.sha1 -sticky w
9052 ${NS}::entry $top.head -width 60
9053 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9054 $top.head conf -state readonly
9055 grid x $top.head -sticky w
9056 ${NS}::label $top.clab -text [mc "Command:"]
9057 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9058 grid $top.clab $top.cmd -sticky w -pady 10
9059 ${NS}::label $top.flab -text [mc "Output file:"]
9060 ${NS}::entry $top.fname -width 60
9061 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9062 grid $top.flab $top.fname -sticky w
9063 ${NS}::frame $top.buts
9064 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9065 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9066 bind $top <Key-Return> wrcomgo
9067 bind $top <Key-Escape> wrcomcan
9068 grid $top.buts.gen $top.buts.can
9069 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9070 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9071 grid $top.buts - -pady 10 -sticky ew
9072 focus $top.fname
9075 proc wrcomgo {} {
9076 global wrcomtop
9078 set id [$wrcomtop.sha1 get]
9079 set cmd "echo $id | [$wrcomtop.cmd get]"
9080 set fname [$wrcomtop.fname get]
9081 if {[catch {exec sh -c $cmd >$fname &} err]} {
9082 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9084 catch {destroy $wrcomtop}
9085 unset wrcomtop
9088 proc wrcomcan {} {
9089 global wrcomtop
9091 catch {destroy $wrcomtop}
9092 unset wrcomtop
9095 proc mkbranch {} {
9096 global rowmenuid mkbrtop NS
9098 set top .makebranch
9099 catch {destroy $top}
9100 ttk_toplevel $top
9101 make_transient $top .
9102 ${NS}::label $top.title -text [mc "Create new branch"]
9103 grid $top.title - -pady 10
9104 ${NS}::label $top.id -text [mc "ID:"]
9105 ${NS}::entry $top.sha1 -width 40
9106 $top.sha1 insert 0 $rowmenuid
9107 $top.sha1 conf -state readonly
9108 grid $top.id $top.sha1 -sticky w
9109 ${NS}::label $top.nlab -text [mc "Name:"]
9110 ${NS}::entry $top.name -width 40
9111 grid $top.nlab $top.name -sticky w
9112 ${NS}::frame $top.buts
9113 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9114 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9115 bind $top <Key-Return> [list mkbrgo $top]
9116 bind $top <Key-Escape> "catch {destroy $top}"
9117 grid $top.buts.go $top.buts.can
9118 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9119 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9120 grid $top.buts - -pady 10 -sticky ew
9121 focus $top.name
9124 proc mkbrgo {top} {
9125 global headids idheads
9127 set name [$top.name get]
9128 set id [$top.sha1 get]
9129 set cmdargs {}
9130 set old_id {}
9131 if {$name eq {}} {
9132 error_popup [mc "Please specify a name for the new branch"] $top
9133 return
9135 if {[info exists headids($name)]} {
9136 if {![confirm_popup [mc \
9137 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9138 return
9140 set old_id $headids($name)
9141 lappend cmdargs -f
9143 catch {destroy $top}
9144 lappend cmdargs $name $id
9145 nowbusy newbranch
9146 update
9147 if {[catch {
9148 eval exec git branch $cmdargs
9149 } err]} {
9150 notbusy newbranch
9151 error_popup $err
9152 } else {
9153 notbusy newbranch
9154 if {$old_id ne {}} {
9155 movehead $id $name
9156 movedhead $id $name
9157 redrawtags $old_id
9158 redrawtags $id
9159 } else {
9160 set headids($name) $id
9161 lappend idheads($id) $name
9162 addedhead $id $name
9163 redrawtags $id
9165 dispneartags 0
9166 run refill_reflist
9170 proc exec_citool {tool_args {baseid {}}} {
9171 global commitinfo env
9173 set save_env [array get env GIT_AUTHOR_*]
9175 if {$baseid ne {}} {
9176 if {![info exists commitinfo($baseid)]} {
9177 getcommit $baseid
9179 set author [lindex $commitinfo($baseid) 1]
9180 set date [lindex $commitinfo($baseid) 2]
9181 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9182 $author author name email]
9183 && $date ne {}} {
9184 set env(GIT_AUTHOR_NAME) $name
9185 set env(GIT_AUTHOR_EMAIL) $email
9186 set env(GIT_AUTHOR_DATE) $date
9190 eval exec git citool $tool_args &
9192 array unset env GIT_AUTHOR_*
9193 array set env $save_env
9196 proc cherrypick {} {
9197 global rowmenuid curview
9198 global mainhead mainheadid
9199 global gitdir
9201 set oldhead [exec git rev-parse HEAD]
9202 set dheads [descheads $rowmenuid]
9203 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9204 set ok [confirm_popup [mc "Commit %s is already\
9205 included in branch %s -- really re-apply it?" \
9206 [string range $rowmenuid 0 7] $mainhead]]
9207 if {!$ok} return
9209 nowbusy cherrypick [mc "Cherry-picking"]
9210 update
9211 # Unfortunately git-cherry-pick writes stuff to stderr even when
9212 # no error occurs, and exec takes that as an indication of error...
9213 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9214 notbusy cherrypick
9215 if {[regexp -line \
9216 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9217 $err msg fname]} {
9218 error_popup [mc "Cherry-pick failed because of local changes\
9219 to file '%s'.\nPlease commit, reset or stash\
9220 your changes and try again." $fname]
9221 } elseif {[regexp -line \
9222 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9223 $err]} {
9224 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9225 conflict.\nDo you wish to run git citool to\
9226 resolve it?"]]} {
9227 # Force citool to read MERGE_MSG
9228 file delete [file join $gitdir "GITGUI_MSG"]
9229 exec_citool {} $rowmenuid
9231 } else {
9232 error_popup $err
9234 run updatecommits
9235 return
9237 set newhead [exec git rev-parse HEAD]
9238 if {$newhead eq $oldhead} {
9239 notbusy cherrypick
9240 error_popup [mc "No changes committed"]
9241 return
9243 addnewchild $newhead $oldhead
9244 if {[commitinview $oldhead $curview]} {
9245 # XXX this isn't right if we have a path limit...
9246 insertrow $newhead $oldhead $curview
9247 if {$mainhead ne {}} {
9248 movehead $newhead $mainhead
9249 movedhead $newhead $mainhead
9251 set mainheadid $newhead
9252 redrawtags $oldhead
9253 redrawtags $newhead
9254 selbyid $newhead
9256 notbusy cherrypick
9259 proc resethead {} {
9260 global mainhead rowmenuid confirm_ok resettype NS
9262 set confirm_ok 0
9263 set w ".confirmreset"
9264 ttk_toplevel $w
9265 make_transient $w .
9266 wm title $w [mc "Confirm reset"]
9267 ${NS}::label $w.m -text \
9268 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9269 pack $w.m -side top -fill x -padx 20 -pady 20
9270 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9271 set resettype mixed
9272 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9273 -text [mc "Soft: Leave working tree and index untouched"]
9274 grid $w.f.soft -sticky w
9275 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9276 -text [mc "Mixed: Leave working tree untouched, reset index"]
9277 grid $w.f.mixed -sticky w
9278 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9279 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9280 grid $w.f.hard -sticky w
9281 pack $w.f -side top -fill x -padx 4
9282 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9283 pack $w.ok -side left -fill x -padx 20 -pady 20
9284 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9285 bind $w <Key-Escape> [list destroy $w]
9286 pack $w.cancel -side right -fill x -padx 20 -pady 20
9287 bind $w <Visibility> "grab $w; focus $w"
9288 tkwait window $w
9289 if {!$confirm_ok} return
9290 if {[catch {set fd [open \
9291 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9292 error_popup $err
9293 } else {
9294 dohidelocalchanges
9295 filerun $fd [list readresetstat $fd]
9296 nowbusy reset [mc "Resetting"]
9297 selbyid $rowmenuid
9301 proc readresetstat {fd} {
9302 global mainhead mainheadid showlocalchanges rprogcoord
9304 if {[gets $fd line] >= 0} {
9305 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9306 set rprogcoord [expr {1.0 * $m / $n}]
9307 adjustprogress
9309 return 1
9311 set rprogcoord 0
9312 adjustprogress
9313 notbusy reset
9314 if {[catch {close $fd} err]} {
9315 error_popup $err
9317 set oldhead $mainheadid
9318 set newhead [exec git rev-parse HEAD]
9319 if {$newhead ne $oldhead} {
9320 movehead $newhead $mainhead
9321 movedhead $newhead $mainhead
9322 set mainheadid $newhead
9323 redrawtags $oldhead
9324 redrawtags $newhead
9326 if {$showlocalchanges} {
9327 doshowlocalchanges
9329 return 0
9332 # context menu for a head
9333 proc headmenu {x y id head} {
9334 global headmenuid headmenuhead headctxmenu mainhead
9336 stopfinding
9337 set headmenuid $id
9338 set headmenuhead $head
9339 set state normal
9340 if {[string match "remotes/*" $head]} {
9341 set state disabled
9343 if {$head eq $mainhead} {
9344 set state disabled
9346 $headctxmenu entryconfigure 0 -state $state
9347 $headctxmenu entryconfigure 1 -state $state
9348 tk_popup $headctxmenu $x $y
9351 proc cobranch {} {
9352 global headmenuid headmenuhead headids
9353 global showlocalchanges
9355 # check the tree is clean first??
9356 nowbusy checkout [mc "Checking out"]
9357 update
9358 dohidelocalchanges
9359 if {[catch {
9360 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9361 } err]} {
9362 notbusy checkout
9363 error_popup $err
9364 if {$showlocalchanges} {
9365 dodiffindex
9367 } else {
9368 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9372 proc readcheckoutstat {fd newhead newheadid} {
9373 global mainhead mainheadid headids showlocalchanges progresscoords
9374 global viewmainheadid curview
9376 if {[gets $fd line] >= 0} {
9377 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9378 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9379 adjustprogress
9381 return 1
9383 set progresscoords {0 0}
9384 adjustprogress
9385 notbusy checkout
9386 if {[catch {close $fd} err]} {
9387 error_popup $err
9389 set oldmainid $mainheadid
9390 set mainhead $newhead
9391 set mainheadid $newheadid
9392 set viewmainheadid($curview) $newheadid
9393 redrawtags $oldmainid
9394 redrawtags $newheadid
9395 selbyid $newheadid
9396 if {$showlocalchanges} {
9397 dodiffindex
9401 proc rmbranch {} {
9402 global headmenuid headmenuhead mainhead
9403 global idheads
9405 set head $headmenuhead
9406 set id $headmenuid
9407 # this check shouldn't be needed any more...
9408 if {$head eq $mainhead} {
9409 error_popup [mc "Cannot delete the currently checked-out branch"]
9410 return
9412 set dheads [descheads $id]
9413 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9414 # the stuff on this branch isn't on any other branch
9415 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9416 branch.\nReally delete branch %s?" $head $head]]} return
9418 nowbusy rmbranch
9419 update
9420 if {[catch {exec git branch -D $head} err]} {
9421 notbusy rmbranch
9422 error_popup $err
9423 return
9425 removehead $id $head
9426 removedhead $id $head
9427 redrawtags $id
9428 notbusy rmbranch
9429 dispneartags 0
9430 run refill_reflist
9433 # Display a list of tags and heads
9434 proc showrefs {} {
9435 global showrefstop bgcolor fgcolor selectbgcolor NS
9436 global bglist fglist reflistfilter reflist maincursor
9438 set top .showrefs
9439 set showrefstop $top
9440 if {[winfo exists $top]} {
9441 raise $top
9442 refill_reflist
9443 return
9445 ttk_toplevel $top
9446 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9447 make_transient $top .
9448 text $top.list -background $bgcolor -foreground $fgcolor \
9449 -selectbackground $selectbgcolor -font mainfont \
9450 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9451 -width 30 -height 20 -cursor $maincursor \
9452 -spacing1 1 -spacing3 1 -state disabled
9453 $top.list tag configure highlight -background $selectbgcolor
9454 lappend bglist $top.list
9455 lappend fglist $top.list
9456 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9457 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9458 grid $top.list $top.ysb -sticky nsew
9459 grid $top.xsb x -sticky ew
9460 ${NS}::frame $top.f
9461 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9462 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9463 set reflistfilter "*"
9464 trace add variable reflistfilter write reflistfilter_change
9465 pack $top.f.e -side right -fill x -expand 1
9466 pack $top.f.l -side left
9467 grid $top.f - -sticky ew -pady 2
9468 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9469 bind $top <Key-Escape> [list destroy $top]
9470 grid $top.close -
9471 grid columnconfigure $top 0 -weight 1
9472 grid rowconfigure $top 0 -weight 1
9473 bind $top.list <1> {break}
9474 bind $top.list <B1-Motion> {break}
9475 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9476 set reflist {}
9477 refill_reflist
9480 proc sel_reflist {w x y} {
9481 global showrefstop reflist headids tagids otherrefids
9483 if {![winfo exists $showrefstop]} return
9484 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9485 set ref [lindex $reflist [expr {$l-1}]]
9486 set n [lindex $ref 0]
9487 switch -- [lindex $ref 1] {
9488 "H" {selbyid $headids($n)}
9489 "T" {selbyid $tagids($n)}
9490 "o" {selbyid $otherrefids($n)}
9492 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9495 proc unsel_reflist {} {
9496 global showrefstop
9498 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9499 $showrefstop.list tag remove highlight 0.0 end
9502 proc reflistfilter_change {n1 n2 op} {
9503 global reflistfilter
9505 after cancel refill_reflist
9506 after 200 refill_reflist
9509 proc refill_reflist {} {
9510 global reflist reflistfilter showrefstop headids tagids otherrefids
9511 global curview
9513 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9514 set refs {}
9515 foreach n [array names headids] {
9516 if {[string match $reflistfilter $n]} {
9517 if {[commitinview $headids($n) $curview]} {
9518 lappend refs [list $n H]
9519 } else {
9520 interestedin $headids($n) {run refill_reflist}
9524 foreach n [array names tagids] {
9525 if {[string match $reflistfilter $n]} {
9526 if {[commitinview $tagids($n) $curview]} {
9527 lappend refs [list $n T]
9528 } else {
9529 interestedin $tagids($n) {run refill_reflist}
9533 foreach n [array names otherrefids] {
9534 if {[string match $reflistfilter $n]} {
9535 if {[commitinview $otherrefids($n) $curview]} {
9536 lappend refs [list $n o]
9537 } else {
9538 interestedin $otherrefids($n) {run refill_reflist}
9542 set refs [lsort -index 0 $refs]
9543 if {$refs eq $reflist} return
9545 # Update the contents of $showrefstop.list according to the
9546 # differences between $reflist (old) and $refs (new)
9547 $showrefstop.list conf -state normal
9548 $showrefstop.list insert end "\n"
9549 set i 0
9550 set j 0
9551 while {$i < [llength $reflist] || $j < [llength $refs]} {
9552 if {$i < [llength $reflist]} {
9553 if {$j < [llength $refs]} {
9554 set cmp [string compare [lindex $reflist $i 0] \
9555 [lindex $refs $j 0]]
9556 if {$cmp == 0} {
9557 set cmp [string compare [lindex $reflist $i 1] \
9558 [lindex $refs $j 1]]
9560 } else {
9561 set cmp -1
9563 } else {
9564 set cmp 1
9566 switch -- $cmp {
9567 -1 {
9568 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9569 incr i
9572 incr i
9573 incr j
9576 set l [expr {$j + 1}]
9577 $showrefstop.list image create $l.0 -align baseline \
9578 -image reficon-[lindex $refs $j 1] -padx 2
9579 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9580 incr j
9584 set reflist $refs
9585 # delete last newline
9586 $showrefstop.list delete end-2c end-1c
9587 $showrefstop.list conf -state disabled
9590 # Stuff for finding nearby tags
9591 proc getallcommits {} {
9592 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9593 global idheads idtags idotherrefs allparents tagobjid
9594 global gitdir
9596 if {![info exists allcommits]} {
9597 set nextarc 0
9598 set allcommits 0
9599 set seeds {}
9600 set allcwait 0
9601 set cachedarcs 0
9602 set allccache [file join $gitdir "gitk.cache"]
9603 if {![catch {
9604 set f [open $allccache r]
9605 set allcwait 1
9606 getcache $f
9607 }]} return
9610 if {$allcwait} {
9611 return
9613 set cmd [list | git rev-list --parents]
9614 set allcupdate [expr {$seeds ne {}}]
9615 if {!$allcupdate} {
9616 set ids "--all"
9617 } else {
9618 set refs [concat [array names idheads] [array names idtags] \
9619 [array names idotherrefs]]
9620 set ids {}
9621 set tagobjs {}
9622 foreach name [array names tagobjid] {
9623 lappend tagobjs $tagobjid($name)
9625 foreach id [lsort -unique $refs] {
9626 if {![info exists allparents($id)] &&
9627 [lsearch -exact $tagobjs $id] < 0} {
9628 lappend ids $id
9631 if {$ids ne {}} {
9632 foreach id $seeds {
9633 lappend ids "^$id"
9637 if {$ids ne {}} {
9638 set fd [open [concat $cmd $ids] r]
9639 fconfigure $fd -blocking 0
9640 incr allcommits
9641 nowbusy allcommits
9642 filerun $fd [list getallclines $fd]
9643 } else {
9644 dispneartags 0
9648 # Since most commits have 1 parent and 1 child, we group strings of
9649 # such commits into "arcs" joining branch/merge points (BMPs), which
9650 # are commits that either don't have 1 parent or don't have 1 child.
9652 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9653 # arcout(id) - outgoing arcs for BMP
9654 # arcids(a) - list of IDs on arc including end but not start
9655 # arcstart(a) - BMP ID at start of arc
9656 # arcend(a) - BMP ID at end of arc
9657 # growing(a) - arc a is still growing
9658 # arctags(a) - IDs out of arcids (excluding end) that have tags
9659 # archeads(a) - IDs out of arcids (excluding end) that have heads
9660 # The start of an arc is at the descendent end, so "incoming" means
9661 # coming from descendents, and "outgoing" means going towards ancestors.
9663 proc getallclines {fd} {
9664 global allparents allchildren idtags idheads nextarc
9665 global arcnos arcids arctags arcout arcend arcstart archeads growing
9666 global seeds allcommits cachedarcs allcupdate
9668 set nid 0
9669 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9670 set id [lindex $line 0]
9671 if {[info exists allparents($id)]} {
9672 # seen it already
9673 continue
9675 set cachedarcs 0
9676 set olds [lrange $line 1 end]
9677 set allparents($id) $olds
9678 if {![info exists allchildren($id)]} {
9679 set allchildren($id) {}
9680 set arcnos($id) {}
9681 lappend seeds $id
9682 } else {
9683 set a $arcnos($id)
9684 if {[llength $olds] == 1 && [llength $a] == 1} {
9685 lappend arcids($a) $id
9686 if {[info exists idtags($id)]} {
9687 lappend arctags($a) $id
9689 if {[info exists idheads($id)]} {
9690 lappend archeads($a) $id
9692 if {[info exists allparents($olds)]} {
9693 # seen parent already
9694 if {![info exists arcout($olds)]} {
9695 splitarc $olds
9697 lappend arcids($a) $olds
9698 set arcend($a) $olds
9699 unset growing($a)
9701 lappend allchildren($olds) $id
9702 lappend arcnos($olds) $a
9703 continue
9706 foreach a $arcnos($id) {
9707 lappend arcids($a) $id
9708 set arcend($a) $id
9709 unset growing($a)
9712 set ao {}
9713 foreach p $olds {
9714 lappend allchildren($p) $id
9715 set a [incr nextarc]
9716 set arcstart($a) $id
9717 set archeads($a) {}
9718 set arctags($a) {}
9719 set archeads($a) {}
9720 set arcids($a) {}
9721 lappend ao $a
9722 set growing($a) 1
9723 if {[info exists allparents($p)]} {
9724 # seen it already, may need to make a new branch
9725 if {![info exists arcout($p)]} {
9726 splitarc $p
9728 lappend arcids($a) $p
9729 set arcend($a) $p
9730 unset growing($a)
9732 lappend arcnos($p) $a
9734 set arcout($id) $ao
9736 if {$nid > 0} {
9737 global cached_dheads cached_dtags cached_atags
9738 catch {unset cached_dheads}
9739 catch {unset cached_dtags}
9740 catch {unset cached_atags}
9742 if {![eof $fd]} {
9743 return [expr {$nid >= 1000? 2: 1}]
9745 set cacheok 1
9746 if {[catch {
9747 fconfigure $fd -blocking 1
9748 close $fd
9749 } err]} {
9750 # got an error reading the list of commits
9751 # if we were updating, try rereading the whole thing again
9752 if {$allcupdate} {
9753 incr allcommits -1
9754 dropcache $err
9755 return
9757 error_popup "[mc "Error reading commit topology information;\
9758 branch and preceding/following tag information\
9759 will be incomplete."]\n($err)"
9760 set cacheok 0
9762 if {[incr allcommits -1] == 0} {
9763 notbusy allcommits
9764 if {$cacheok} {
9765 run savecache
9768 dispneartags 0
9769 return 0
9772 proc recalcarc {a} {
9773 global arctags archeads arcids idtags idheads
9775 set at {}
9776 set ah {}
9777 foreach id [lrange $arcids($a) 0 end-1] {
9778 if {[info exists idtags($id)]} {
9779 lappend at $id
9781 if {[info exists idheads($id)]} {
9782 lappend ah $id
9785 set arctags($a) $at
9786 set archeads($a) $ah
9789 proc splitarc {p} {
9790 global arcnos arcids nextarc arctags archeads idtags idheads
9791 global arcstart arcend arcout allparents growing
9793 set a $arcnos($p)
9794 if {[llength $a] != 1} {
9795 puts "oops splitarc called but [llength $a] arcs already"
9796 return
9798 set a [lindex $a 0]
9799 set i [lsearch -exact $arcids($a) $p]
9800 if {$i < 0} {
9801 puts "oops splitarc $p not in arc $a"
9802 return
9804 set na [incr nextarc]
9805 if {[info exists arcend($a)]} {
9806 set arcend($na) $arcend($a)
9807 } else {
9808 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9809 set j [lsearch -exact $arcnos($l) $a]
9810 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9812 set tail [lrange $arcids($a) [expr {$i+1}] end]
9813 set arcids($a) [lrange $arcids($a) 0 $i]
9814 set arcend($a) $p
9815 set arcstart($na) $p
9816 set arcout($p) $na
9817 set arcids($na) $tail
9818 if {[info exists growing($a)]} {
9819 set growing($na) 1
9820 unset growing($a)
9823 foreach id $tail {
9824 if {[llength $arcnos($id)] == 1} {
9825 set arcnos($id) $na
9826 } else {
9827 set j [lsearch -exact $arcnos($id) $a]
9828 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9832 # reconstruct tags and heads lists
9833 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9834 recalcarc $a
9835 recalcarc $na
9836 } else {
9837 set arctags($na) {}
9838 set archeads($na) {}
9842 # Update things for a new commit added that is a child of one
9843 # existing commit. Used when cherry-picking.
9844 proc addnewchild {id p} {
9845 global allparents allchildren idtags nextarc
9846 global arcnos arcids arctags arcout arcend arcstart archeads growing
9847 global seeds allcommits
9849 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9850 set allparents($id) [list $p]
9851 set allchildren($id) {}
9852 set arcnos($id) {}
9853 lappend seeds $id
9854 lappend allchildren($p) $id
9855 set a [incr nextarc]
9856 set arcstart($a) $id
9857 set archeads($a) {}
9858 set arctags($a) {}
9859 set arcids($a) [list $p]
9860 set arcend($a) $p
9861 if {![info exists arcout($p)]} {
9862 splitarc $p
9864 lappend arcnos($p) $a
9865 set arcout($id) [list $a]
9868 # This implements a cache for the topology information.
9869 # The cache saves, for each arc, the start and end of the arc,
9870 # the ids on the arc, and the outgoing arcs from the end.
9871 proc readcache {f} {
9872 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9873 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9874 global allcwait
9876 set a $nextarc
9877 set lim $cachedarcs
9878 if {$lim - $a > 500} {
9879 set lim [expr {$a + 500}]
9881 if {[catch {
9882 if {$a == $lim} {
9883 # finish reading the cache and setting up arctags, etc.
9884 set line [gets $f]
9885 if {$line ne "1"} {error "bad final version"}
9886 close $f
9887 foreach id [array names idtags] {
9888 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9889 [llength $allparents($id)] == 1} {
9890 set a [lindex $arcnos($id) 0]
9891 if {$arctags($a) eq {}} {
9892 recalcarc $a
9896 foreach id [array names idheads] {
9897 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9898 [llength $allparents($id)] == 1} {
9899 set a [lindex $arcnos($id) 0]
9900 if {$archeads($a) eq {}} {
9901 recalcarc $a
9905 foreach id [lsort -unique $possible_seeds] {
9906 if {$arcnos($id) eq {}} {
9907 lappend seeds $id
9910 set allcwait 0
9911 } else {
9912 while {[incr a] <= $lim} {
9913 set line [gets $f]
9914 if {[llength $line] != 3} {error "bad line"}
9915 set s [lindex $line 0]
9916 set arcstart($a) $s
9917 lappend arcout($s) $a
9918 if {![info exists arcnos($s)]} {
9919 lappend possible_seeds $s
9920 set arcnos($s) {}
9922 set e [lindex $line 1]
9923 if {$e eq {}} {
9924 set growing($a) 1
9925 } else {
9926 set arcend($a) $e
9927 if {![info exists arcout($e)]} {
9928 set arcout($e) {}
9931 set arcids($a) [lindex $line 2]
9932 foreach id $arcids($a) {
9933 lappend allparents($s) $id
9934 set s $id
9935 lappend arcnos($id) $a
9937 if {![info exists allparents($s)]} {
9938 set allparents($s) {}
9940 set arctags($a) {}
9941 set archeads($a) {}
9943 set nextarc [expr {$a - 1}]
9945 } err]} {
9946 dropcache $err
9947 return 0
9949 if {!$allcwait} {
9950 getallcommits
9952 return $allcwait
9955 proc getcache {f} {
9956 global nextarc cachedarcs possible_seeds
9958 if {[catch {
9959 set line [gets $f]
9960 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9961 # make sure it's an integer
9962 set cachedarcs [expr {int([lindex $line 1])}]
9963 if {$cachedarcs < 0} {error "bad number of arcs"}
9964 set nextarc 0
9965 set possible_seeds {}
9966 run readcache $f
9967 } err]} {
9968 dropcache $err
9970 return 0
9973 proc dropcache {err} {
9974 global allcwait nextarc cachedarcs seeds
9976 #puts "dropping cache ($err)"
9977 foreach v {arcnos arcout arcids arcstart arcend growing \
9978 arctags archeads allparents allchildren} {
9979 global $v
9980 catch {unset $v}
9982 set allcwait 0
9983 set nextarc 0
9984 set cachedarcs 0
9985 set seeds {}
9986 getallcommits
9989 proc writecache {f} {
9990 global cachearc cachedarcs allccache
9991 global arcstart arcend arcnos arcids arcout
9993 set a $cachearc
9994 set lim $cachedarcs
9995 if {$lim - $a > 1000} {
9996 set lim [expr {$a + 1000}]
9998 if {[catch {
9999 while {[incr a] <= $lim} {
10000 if {[info exists arcend($a)]} {
10001 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10002 } else {
10003 puts $f [list $arcstart($a) {} $arcids($a)]
10006 } err]} {
10007 catch {close $f}
10008 catch {file delete $allccache}
10009 #puts "writing cache failed ($err)"
10010 return 0
10012 set cachearc [expr {$a - 1}]
10013 if {$a > $cachedarcs} {
10014 puts $f "1"
10015 close $f
10016 return 0
10018 return 1
10021 proc savecache {} {
10022 global nextarc cachedarcs cachearc allccache
10024 if {$nextarc == $cachedarcs} return
10025 set cachearc 0
10026 set cachedarcs $nextarc
10027 catch {
10028 set f [open $allccache w]
10029 puts $f [list 1 $cachedarcs]
10030 run writecache $f
10034 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10035 # or 0 if neither is true.
10036 proc anc_or_desc {a b} {
10037 global arcout arcstart arcend arcnos cached_isanc
10039 if {$arcnos($a) eq $arcnos($b)} {
10040 # Both are on the same arc(s); either both are the same BMP,
10041 # or if one is not a BMP, the other is also not a BMP or is
10042 # the BMP at end of the arc (and it only has 1 incoming arc).
10043 # Or both can be BMPs with no incoming arcs.
10044 if {$a eq $b || $arcnos($a) eq {}} {
10045 return 0
10047 # assert {[llength $arcnos($a)] == 1}
10048 set arc [lindex $arcnos($a) 0]
10049 set i [lsearch -exact $arcids($arc) $a]
10050 set j [lsearch -exact $arcids($arc) $b]
10051 if {$i < 0 || $i > $j} {
10052 return 1
10053 } else {
10054 return -1
10058 if {![info exists arcout($a)]} {
10059 set arc [lindex $arcnos($a) 0]
10060 if {[info exists arcend($arc)]} {
10061 set aend $arcend($arc)
10062 } else {
10063 set aend {}
10065 set a $arcstart($arc)
10066 } else {
10067 set aend $a
10069 if {![info exists arcout($b)]} {
10070 set arc [lindex $arcnos($b) 0]
10071 if {[info exists arcend($arc)]} {
10072 set bend $arcend($arc)
10073 } else {
10074 set bend {}
10076 set b $arcstart($arc)
10077 } else {
10078 set bend $b
10080 if {$a eq $bend} {
10081 return 1
10083 if {$b eq $aend} {
10084 return -1
10086 if {[info exists cached_isanc($a,$bend)]} {
10087 if {$cached_isanc($a,$bend)} {
10088 return 1
10091 if {[info exists cached_isanc($b,$aend)]} {
10092 if {$cached_isanc($b,$aend)} {
10093 return -1
10095 if {[info exists cached_isanc($a,$bend)]} {
10096 return 0
10100 set todo [list $a $b]
10101 set anc($a) a
10102 set anc($b) b
10103 for {set i 0} {$i < [llength $todo]} {incr i} {
10104 set x [lindex $todo $i]
10105 if {$anc($x) eq {}} {
10106 continue
10108 foreach arc $arcnos($x) {
10109 set xd $arcstart($arc)
10110 if {$xd eq $bend} {
10111 set cached_isanc($a,$bend) 1
10112 set cached_isanc($b,$aend) 0
10113 return 1
10114 } elseif {$xd eq $aend} {
10115 set cached_isanc($b,$aend) 1
10116 set cached_isanc($a,$bend) 0
10117 return -1
10119 if {![info exists anc($xd)]} {
10120 set anc($xd) $anc($x)
10121 lappend todo $xd
10122 } elseif {$anc($xd) ne $anc($x)} {
10123 set anc($xd) {}
10127 set cached_isanc($a,$bend) 0
10128 set cached_isanc($b,$aend) 0
10129 return 0
10132 # This identifies whether $desc has an ancestor that is
10133 # a growing tip of the graph and which is not an ancestor of $anc
10134 # and returns 0 if so and 1 if not.
10135 # If we subsequently discover a tag on such a growing tip, and that
10136 # turns out to be a descendent of $anc (which it could, since we
10137 # don't necessarily see children before parents), then $desc
10138 # isn't a good choice to display as a descendent tag of
10139 # $anc (since it is the descendent of another tag which is
10140 # a descendent of $anc). Similarly, $anc isn't a good choice to
10141 # display as a ancestor tag of $desc.
10143 proc is_certain {desc anc} {
10144 global arcnos arcout arcstart arcend growing problems
10146 set certain {}
10147 if {[llength $arcnos($anc)] == 1} {
10148 # tags on the same arc are certain
10149 if {$arcnos($desc) eq $arcnos($anc)} {
10150 return 1
10152 if {![info exists arcout($anc)]} {
10153 # if $anc is partway along an arc, use the start of the arc instead
10154 set a [lindex $arcnos($anc) 0]
10155 set anc $arcstart($a)
10158 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10159 set x $desc
10160 } else {
10161 set a [lindex $arcnos($desc) 0]
10162 set x $arcend($a)
10164 if {$x == $anc} {
10165 return 1
10167 set anclist [list $x]
10168 set dl($x) 1
10169 set nnh 1
10170 set ngrowanc 0
10171 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10172 set x [lindex $anclist $i]
10173 if {$dl($x)} {
10174 incr nnh -1
10176 set done($x) 1
10177 foreach a $arcout($x) {
10178 if {[info exists growing($a)]} {
10179 if {![info exists growanc($x)] && $dl($x)} {
10180 set growanc($x) 1
10181 incr ngrowanc
10183 } else {
10184 set y $arcend($a)
10185 if {[info exists dl($y)]} {
10186 if {$dl($y)} {
10187 if {!$dl($x)} {
10188 set dl($y) 0
10189 if {![info exists done($y)]} {
10190 incr nnh -1
10192 if {[info exists growanc($x)]} {
10193 incr ngrowanc -1
10195 set xl [list $y]
10196 for {set k 0} {$k < [llength $xl]} {incr k} {
10197 set z [lindex $xl $k]
10198 foreach c $arcout($z) {
10199 if {[info exists arcend($c)]} {
10200 set v $arcend($c)
10201 if {[info exists dl($v)] && $dl($v)} {
10202 set dl($v) 0
10203 if {![info exists done($v)]} {
10204 incr nnh -1
10206 if {[info exists growanc($v)]} {
10207 incr ngrowanc -1
10209 lappend xl $v
10216 } elseif {$y eq $anc || !$dl($x)} {
10217 set dl($y) 0
10218 lappend anclist $y
10219 } else {
10220 set dl($y) 1
10221 lappend anclist $y
10222 incr nnh
10227 foreach x [array names growanc] {
10228 if {$dl($x)} {
10229 return 0
10231 return 0
10233 return 1
10236 proc validate_arctags {a} {
10237 global arctags idtags
10239 set i -1
10240 set na $arctags($a)
10241 foreach id $arctags($a) {
10242 incr i
10243 if {![info exists idtags($id)]} {
10244 set na [lreplace $na $i $i]
10245 incr i -1
10248 set arctags($a) $na
10251 proc validate_archeads {a} {
10252 global archeads idheads
10254 set i -1
10255 set na $archeads($a)
10256 foreach id $archeads($a) {
10257 incr i
10258 if {![info exists idheads($id)]} {
10259 set na [lreplace $na $i $i]
10260 incr i -1
10263 set archeads($a) $na
10266 # Return the list of IDs that have tags that are descendents of id,
10267 # ignoring IDs that are descendents of IDs already reported.
10268 proc desctags {id} {
10269 global arcnos arcstart arcids arctags idtags allparents
10270 global growing cached_dtags
10272 if {![info exists allparents($id)]} {
10273 return {}
10275 set t1 [clock clicks -milliseconds]
10276 set argid $id
10277 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10278 # part-way along an arc; check that arc first
10279 set a [lindex $arcnos($id) 0]
10280 if {$arctags($a) ne {}} {
10281 validate_arctags $a
10282 set i [lsearch -exact $arcids($a) $id]
10283 set tid {}
10284 foreach t $arctags($a) {
10285 set j [lsearch -exact $arcids($a) $t]
10286 if {$j >= $i} break
10287 set tid $t
10289 if {$tid ne {}} {
10290 return $tid
10293 set id $arcstart($a)
10294 if {[info exists idtags($id)]} {
10295 return $id
10298 if {[info exists cached_dtags($id)]} {
10299 return $cached_dtags($id)
10302 set origid $id
10303 set todo [list $id]
10304 set queued($id) 1
10305 set nc 1
10306 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10307 set id [lindex $todo $i]
10308 set done($id) 1
10309 set ta [info exists hastaggedancestor($id)]
10310 if {!$ta} {
10311 incr nc -1
10313 # ignore tags on starting node
10314 if {!$ta && $i > 0} {
10315 if {[info exists idtags($id)]} {
10316 set tagloc($id) $id
10317 set ta 1
10318 } elseif {[info exists cached_dtags($id)]} {
10319 set tagloc($id) $cached_dtags($id)
10320 set ta 1
10323 foreach a $arcnos($id) {
10324 set d $arcstart($a)
10325 if {!$ta && $arctags($a) ne {}} {
10326 validate_arctags $a
10327 if {$arctags($a) ne {}} {
10328 lappend tagloc($id) [lindex $arctags($a) end]
10331 if {$ta || $arctags($a) ne {}} {
10332 set tomark [list $d]
10333 for {set j 0} {$j < [llength $tomark]} {incr j} {
10334 set dd [lindex $tomark $j]
10335 if {![info exists hastaggedancestor($dd)]} {
10336 if {[info exists done($dd)]} {
10337 foreach b $arcnos($dd) {
10338 lappend tomark $arcstart($b)
10340 if {[info exists tagloc($dd)]} {
10341 unset tagloc($dd)
10343 } elseif {[info exists queued($dd)]} {
10344 incr nc -1
10346 set hastaggedancestor($dd) 1
10350 if {![info exists queued($d)]} {
10351 lappend todo $d
10352 set queued($d) 1
10353 if {![info exists hastaggedancestor($d)]} {
10354 incr nc
10359 set tags {}
10360 foreach id [array names tagloc] {
10361 if {![info exists hastaggedancestor($id)]} {
10362 foreach t $tagloc($id) {
10363 if {[lsearch -exact $tags $t] < 0} {
10364 lappend tags $t
10369 set t2 [clock clicks -milliseconds]
10370 set loopix $i
10372 # remove tags that are descendents of other tags
10373 for {set i 0} {$i < [llength $tags]} {incr i} {
10374 set a [lindex $tags $i]
10375 for {set j 0} {$j < $i} {incr j} {
10376 set b [lindex $tags $j]
10377 set r [anc_or_desc $a $b]
10378 if {$r == 1} {
10379 set tags [lreplace $tags $j $j]
10380 incr j -1
10381 incr i -1
10382 } elseif {$r == -1} {
10383 set tags [lreplace $tags $i $i]
10384 incr i -1
10385 break
10390 if {[array names growing] ne {}} {
10391 # graph isn't finished, need to check if any tag could get
10392 # eclipsed by another tag coming later. Simply ignore any
10393 # tags that could later get eclipsed.
10394 set ctags {}
10395 foreach t $tags {
10396 if {[is_certain $t $origid]} {
10397 lappend ctags $t
10400 if {$tags eq $ctags} {
10401 set cached_dtags($origid) $tags
10402 } else {
10403 set tags $ctags
10405 } else {
10406 set cached_dtags($origid) $tags
10408 set t3 [clock clicks -milliseconds]
10409 if {0 && $t3 - $t1 >= 100} {
10410 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10411 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10413 return $tags
10416 proc anctags {id} {
10417 global arcnos arcids arcout arcend arctags idtags allparents
10418 global growing cached_atags
10420 if {![info exists allparents($id)]} {
10421 return {}
10423 set t1 [clock clicks -milliseconds]
10424 set argid $id
10425 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10426 # part-way along an arc; check that arc first
10427 set a [lindex $arcnos($id) 0]
10428 if {$arctags($a) ne {}} {
10429 validate_arctags $a
10430 set i [lsearch -exact $arcids($a) $id]
10431 foreach t $arctags($a) {
10432 set j [lsearch -exact $arcids($a) $t]
10433 if {$j > $i} {
10434 return $t
10438 if {![info exists arcend($a)]} {
10439 return {}
10441 set id $arcend($a)
10442 if {[info exists idtags($id)]} {
10443 return $id
10446 if {[info exists cached_atags($id)]} {
10447 return $cached_atags($id)
10450 set origid $id
10451 set todo [list $id]
10452 set queued($id) 1
10453 set taglist {}
10454 set nc 1
10455 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10456 set id [lindex $todo $i]
10457 set done($id) 1
10458 set td [info exists hastaggeddescendent($id)]
10459 if {!$td} {
10460 incr nc -1
10462 # ignore tags on starting node
10463 if {!$td && $i > 0} {
10464 if {[info exists idtags($id)]} {
10465 set tagloc($id) $id
10466 set td 1
10467 } elseif {[info exists cached_atags($id)]} {
10468 set tagloc($id) $cached_atags($id)
10469 set td 1
10472 foreach a $arcout($id) {
10473 if {!$td && $arctags($a) ne {}} {
10474 validate_arctags $a
10475 if {$arctags($a) ne {}} {
10476 lappend tagloc($id) [lindex $arctags($a) 0]
10479 if {![info exists arcend($a)]} continue
10480 set d $arcend($a)
10481 if {$td || $arctags($a) ne {}} {
10482 set tomark [list $d]
10483 for {set j 0} {$j < [llength $tomark]} {incr j} {
10484 set dd [lindex $tomark $j]
10485 if {![info exists hastaggeddescendent($dd)]} {
10486 if {[info exists done($dd)]} {
10487 foreach b $arcout($dd) {
10488 if {[info exists arcend($b)]} {
10489 lappend tomark $arcend($b)
10492 if {[info exists tagloc($dd)]} {
10493 unset tagloc($dd)
10495 } elseif {[info exists queued($dd)]} {
10496 incr nc -1
10498 set hastaggeddescendent($dd) 1
10502 if {![info exists queued($d)]} {
10503 lappend todo $d
10504 set queued($d) 1
10505 if {![info exists hastaggeddescendent($d)]} {
10506 incr nc
10511 set t2 [clock clicks -milliseconds]
10512 set loopix $i
10513 set tags {}
10514 foreach id [array names tagloc] {
10515 if {![info exists hastaggeddescendent($id)]} {
10516 foreach t $tagloc($id) {
10517 if {[lsearch -exact $tags $t] < 0} {
10518 lappend tags $t
10524 # remove tags that are ancestors of other tags
10525 for {set i 0} {$i < [llength $tags]} {incr i} {
10526 set a [lindex $tags $i]
10527 for {set j 0} {$j < $i} {incr j} {
10528 set b [lindex $tags $j]
10529 set r [anc_or_desc $a $b]
10530 if {$r == -1} {
10531 set tags [lreplace $tags $j $j]
10532 incr j -1
10533 incr i -1
10534 } elseif {$r == 1} {
10535 set tags [lreplace $tags $i $i]
10536 incr i -1
10537 break
10542 if {[array names growing] ne {}} {
10543 # graph isn't finished, need to check if any tag could get
10544 # eclipsed by another tag coming later. Simply ignore any
10545 # tags that could later get eclipsed.
10546 set ctags {}
10547 foreach t $tags {
10548 if {[is_certain $origid $t]} {
10549 lappend ctags $t
10552 if {$tags eq $ctags} {
10553 set cached_atags($origid) $tags
10554 } else {
10555 set tags $ctags
10557 } else {
10558 set cached_atags($origid) $tags
10560 set t3 [clock clicks -milliseconds]
10561 if {0 && $t3 - $t1 >= 100} {
10562 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10563 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10565 return $tags
10568 # Return the list of IDs that have heads that are descendents of id,
10569 # including id itself if it has a head.
10570 proc descheads {id} {
10571 global arcnos arcstart arcids archeads idheads cached_dheads
10572 global allparents
10574 if {![info exists allparents($id)]} {
10575 return {}
10577 set aret {}
10578 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10579 # part-way along an arc; check it first
10580 set a [lindex $arcnos($id) 0]
10581 if {$archeads($a) ne {}} {
10582 validate_archeads $a
10583 set i [lsearch -exact $arcids($a) $id]
10584 foreach t $archeads($a) {
10585 set j [lsearch -exact $arcids($a) $t]
10586 if {$j > $i} break
10587 lappend aret $t
10590 set id $arcstart($a)
10592 set origid $id
10593 set todo [list $id]
10594 set seen($id) 1
10595 set ret {}
10596 for {set i 0} {$i < [llength $todo]} {incr i} {
10597 set id [lindex $todo $i]
10598 if {[info exists cached_dheads($id)]} {
10599 set ret [concat $ret $cached_dheads($id)]
10600 } else {
10601 if {[info exists idheads($id)]} {
10602 lappend ret $id
10604 foreach a $arcnos($id) {
10605 if {$archeads($a) ne {}} {
10606 validate_archeads $a
10607 if {$archeads($a) ne {}} {
10608 set ret [concat $ret $archeads($a)]
10611 set d $arcstart($a)
10612 if {![info exists seen($d)]} {
10613 lappend todo $d
10614 set seen($d) 1
10619 set ret [lsort -unique $ret]
10620 set cached_dheads($origid) $ret
10621 return [concat $ret $aret]
10624 proc addedtag {id} {
10625 global arcnos arcout cached_dtags cached_atags
10627 if {![info exists arcnos($id)]} return
10628 if {![info exists arcout($id)]} {
10629 recalcarc [lindex $arcnos($id) 0]
10631 catch {unset cached_dtags}
10632 catch {unset cached_atags}
10635 proc addedhead {hid head} {
10636 global arcnos arcout cached_dheads
10638 if {![info exists arcnos($hid)]} return
10639 if {![info exists arcout($hid)]} {
10640 recalcarc [lindex $arcnos($hid) 0]
10642 catch {unset cached_dheads}
10645 proc removedhead {hid head} {
10646 global cached_dheads
10648 catch {unset cached_dheads}
10651 proc movedhead {hid head} {
10652 global arcnos arcout cached_dheads
10654 if {![info exists arcnos($hid)]} return
10655 if {![info exists arcout($hid)]} {
10656 recalcarc [lindex $arcnos($hid) 0]
10658 catch {unset cached_dheads}
10661 proc changedrefs {} {
10662 global cached_dheads cached_dtags cached_atags cached_tagcontent
10663 global arctags archeads arcnos arcout idheads idtags
10665 foreach id [concat [array names idheads] [array names idtags]] {
10666 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10667 set a [lindex $arcnos($id) 0]
10668 if {![info exists donearc($a)]} {
10669 recalcarc $a
10670 set donearc($a) 1
10674 catch {unset cached_tagcontent}
10675 catch {unset cached_dtags}
10676 catch {unset cached_atags}
10677 catch {unset cached_dheads}
10680 proc rereadrefs {} {
10681 global idtags idheads idotherrefs mainheadid
10683 set refids [concat [array names idtags] \
10684 [array names idheads] [array names idotherrefs]]
10685 foreach id $refids {
10686 if {![info exists ref($id)]} {
10687 set ref($id) [listrefs $id]
10690 set oldmainhead $mainheadid
10691 readrefs
10692 changedrefs
10693 set refids [lsort -unique [concat $refids [array names idtags] \
10694 [array names idheads] [array names idotherrefs]]]
10695 foreach id $refids {
10696 set v [listrefs $id]
10697 if {![info exists ref($id)] || $ref($id) != $v} {
10698 redrawtags $id
10701 if {$oldmainhead ne $mainheadid} {
10702 redrawtags $oldmainhead
10703 redrawtags $mainheadid
10705 run refill_reflist
10708 proc listrefs {id} {
10709 global idtags idheads idotherrefs
10711 set x {}
10712 if {[info exists idtags($id)]} {
10713 set x $idtags($id)
10715 set y {}
10716 if {[info exists idheads($id)]} {
10717 set y $idheads($id)
10719 set z {}
10720 if {[info exists idotherrefs($id)]} {
10721 set z $idotherrefs($id)
10723 return [list $x $y $z]
10726 proc showtag {tag isnew} {
10727 global ctext cached_tagcontent tagids linknum tagobjid
10729 if {$isnew} {
10730 addtohistory [list showtag $tag 0] savectextpos
10732 $ctext conf -state normal
10733 clear_ctext
10734 settabs 0
10735 set linknum 0
10736 if {![info exists cached_tagcontent($tag)]} {
10737 catch {
10738 set cached_tagcontent($tag) [exec git cat-file tag $tag]
10741 if {[info exists cached_tagcontent($tag)]} {
10742 set text $cached_tagcontent($tag)
10743 } else {
10744 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10746 appendwithlinks $text {}
10747 maybe_scroll_ctext 1
10748 $ctext conf -state disabled
10749 init_flist {}
10752 proc doquit {} {
10753 global stopped
10754 global gitktmpdir
10756 set stopped 100
10757 savestuff .
10758 destroy .
10760 if {[info exists gitktmpdir]} {
10761 catch {file delete -force $gitktmpdir}
10765 proc mkfontdisp {font top which} {
10766 global fontattr fontpref $font NS use_ttk
10768 set fontpref($font) [set $font]
10769 ${NS}::button $top.${font}but -text $which \
10770 -command [list choosefont $font $which]
10771 ${NS}::label $top.$font -relief flat -font $font \
10772 -text $fontattr($font,family) -justify left
10773 grid x $top.${font}but $top.$font -sticky w
10776 proc choosefont {font which} {
10777 global fontparam fontlist fonttop fontattr
10778 global prefstop NS
10780 set fontparam(which) $which
10781 set fontparam(font) $font
10782 set fontparam(family) [font actual $font -family]
10783 set fontparam(size) $fontattr($font,size)
10784 set fontparam(weight) $fontattr($font,weight)
10785 set fontparam(slant) $fontattr($font,slant)
10786 set top .gitkfont
10787 set fonttop $top
10788 if {![winfo exists $top]} {
10789 font create sample
10790 eval font config sample [font actual $font]
10791 ttk_toplevel $top
10792 make_transient $top $prefstop
10793 wm title $top [mc "Gitk font chooser"]
10794 ${NS}::label $top.l -textvariable fontparam(which)
10795 pack $top.l -side top
10796 set fontlist [lsort [font families]]
10797 ${NS}::frame $top.f
10798 listbox $top.f.fam -listvariable fontlist \
10799 -yscrollcommand [list $top.f.sb set]
10800 bind $top.f.fam <<ListboxSelect>> selfontfam
10801 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10802 pack $top.f.sb -side right -fill y
10803 pack $top.f.fam -side left -fill both -expand 1
10804 pack $top.f -side top -fill both -expand 1
10805 ${NS}::frame $top.g
10806 spinbox $top.g.size -from 4 -to 40 -width 4 \
10807 -textvariable fontparam(size) \
10808 -validatecommand {string is integer -strict %s}
10809 checkbutton $top.g.bold -padx 5 \
10810 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10811 -variable fontparam(weight) -onvalue bold -offvalue normal
10812 checkbutton $top.g.ital -padx 5 \
10813 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10814 -variable fontparam(slant) -onvalue italic -offvalue roman
10815 pack $top.g.size $top.g.bold $top.g.ital -side left
10816 pack $top.g -side top
10817 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10818 -background white
10819 $top.c create text 100 25 -anchor center -text $which -font sample \
10820 -fill black -tags text
10821 bind $top.c <Configure> [list centertext $top.c]
10822 pack $top.c -side top -fill x
10823 ${NS}::frame $top.buts
10824 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10825 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10826 bind $top <Key-Return> fontok
10827 bind $top <Key-Escape> fontcan
10828 grid $top.buts.ok $top.buts.can
10829 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10830 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10831 pack $top.buts -side bottom -fill x
10832 trace add variable fontparam write chg_fontparam
10833 } else {
10834 raise $top
10835 $top.c itemconf text -text $which
10837 set i [lsearch -exact $fontlist $fontparam(family)]
10838 if {$i >= 0} {
10839 $top.f.fam selection set $i
10840 $top.f.fam see $i
10844 proc centertext {w} {
10845 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10848 proc fontok {} {
10849 global fontparam fontpref prefstop
10851 set f $fontparam(font)
10852 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10853 if {$fontparam(weight) eq "bold"} {
10854 lappend fontpref($f) "bold"
10856 if {$fontparam(slant) eq "italic"} {
10857 lappend fontpref($f) "italic"
10859 set w $prefstop.notebook.fonts.$f
10860 $w conf -text $fontparam(family) -font $fontpref($f)
10862 fontcan
10865 proc fontcan {} {
10866 global fonttop fontparam
10868 if {[info exists fonttop]} {
10869 catch {destroy $fonttop}
10870 catch {font delete sample}
10871 unset fonttop
10872 unset fontparam
10876 if {[package vsatisfies [package provide Tk] 8.6]} {
10877 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10878 # function to make use of it.
10879 proc choosefont {font which} {
10880 tk fontchooser configure -title $which -font $font \
10881 -command [list on_choosefont $font $which]
10882 tk fontchooser show
10884 proc on_choosefont {font which newfont} {
10885 global fontparam
10886 puts stderr "$font $newfont"
10887 array set f [font actual $newfont]
10888 set fontparam(which) $which
10889 set fontparam(font) $font
10890 set fontparam(family) $f(-family)
10891 set fontparam(size) $f(-size)
10892 set fontparam(weight) $f(-weight)
10893 set fontparam(slant) $f(-slant)
10894 fontok
10898 proc selfontfam {} {
10899 global fonttop fontparam
10901 set i [$fonttop.f.fam curselection]
10902 if {$i ne {}} {
10903 set fontparam(family) [$fonttop.f.fam get $i]
10907 proc chg_fontparam {v sub op} {
10908 global fontparam
10910 font config sample -$sub $fontparam($sub)
10913 # Create a property sheet tab page
10914 proc create_prefs_page {w} {
10915 global NS
10916 set parent [join [lrange [split $w .] 0 end-1] .]
10917 if {[winfo class $parent] eq "TNotebook"} {
10918 ${NS}::frame $w
10919 } else {
10920 ${NS}::labelframe $w
10924 proc prefspage_general {notebook} {
10925 global NS maxwidth maxgraphpct showneartags showlocalchanges
10926 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
10927 global hideremotes want_ttk have_ttk
10929 set page [create_prefs_page $notebook.general]
10931 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
10932 grid $page.ldisp - -sticky w -pady 10
10933 ${NS}::label $page.spacer -text " "
10934 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
10935 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10936 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
10937 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
10938 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10939 grid x $page.maxpctl $page.maxpct -sticky w
10940 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
10941 -variable showlocalchanges
10942 grid x $page.showlocal -sticky w
10943 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
10944 -variable autoselect
10945 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
10946 grid x $page.autoselect $page.autosellen -sticky w
10947 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
10948 -variable hideremotes
10949 grid x $page.hideremotes -sticky w
10951 ${NS}::label $page.ddisp -text [mc "Diff display options"]
10952 grid $page.ddisp - -sticky w -pady 10
10953 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
10954 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10955 grid x $page.tabstopl $page.tabstop -sticky w
10956 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags"] \
10957 -variable showneartags
10958 grid x $page.ntag -sticky w
10959 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
10960 -variable limitdiffs
10961 grid x $page.ldiff -sticky w
10962 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
10963 -variable perfile_attrs
10964 grid x $page.lattr -sticky w
10966 ${NS}::entry $page.extdifft -textvariable extdifftool
10967 ${NS}::frame $page.extdifff
10968 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
10969 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10970 pack $page.extdifff.l $page.extdifff.b -side left
10971 pack configure $page.extdifff.l -padx 10
10972 grid x $page.extdifff $page.extdifft -sticky ew
10974 ${NS}::label $page.lgen -text [mc "General options"]
10975 grid $page.lgen - -sticky w -pady 10
10976 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
10977 -text [mc "Use themed widgets"]
10978 if {$have_ttk} {
10979 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
10980 } else {
10981 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
10983 grid x $page.want_ttk $page.ttk_note -sticky w
10984 return $page
10987 proc prefspage_colors {notebook} {
10988 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10990 set page [create_prefs_page $notebook.colors]
10992 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
10993 grid $page.cdisp - -sticky w -pady 10
10994 label $page.ui -padx 40 -relief sunk -background $uicolor
10995 ${NS}::button $page.uibut -text [mc "Interface"] \
10996 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
10997 grid x $page.uibut $page.ui -sticky w
10998 label $page.bg -padx 40 -relief sunk -background $bgcolor
10999 ${NS}::button $page.bgbut -text [mc "Background"] \
11000 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11001 grid x $page.bgbut $page.bg -sticky w
11002 label $page.fg -padx 40 -relief sunk -background $fgcolor
11003 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11004 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11005 grid x $page.fgbut $page.fg -sticky w
11006 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11007 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11008 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11009 [list $ctext tag conf d0 -foreground]]
11010 grid x $page.diffoldbut $page.diffold -sticky w
11011 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11012 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11013 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11014 [list $ctext tag conf dresult -foreground]]
11015 grid x $page.diffnewbut $page.diffnew -sticky w
11016 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11017 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11018 -command [list choosecolor diffcolors 2 $page.hunksep \
11019 [mc "diff hunk header"] \
11020 [list $ctext tag conf hunksep -foreground]]
11021 grid x $page.hunksepbut $page.hunksep -sticky w
11022 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11023 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11024 -command [list choosecolor markbgcolor {} $page.markbgsep \
11025 [mc "marked line background"] \
11026 [list $ctext tag conf omark -background]]
11027 grid x $page.markbgbut $page.markbgsep -sticky w
11028 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11029 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11030 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11031 grid x $page.selbgbut $page.selbgsep -sticky w
11032 return $page
11035 proc prefspage_fonts {notebook} {
11036 global NS
11037 set page [create_prefs_page $notebook.fonts]
11038 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11039 grid $page.cfont - -sticky w -pady 10
11040 mkfontdisp mainfont $page [mc "Main font"]
11041 mkfontdisp textfont $page [mc "Diff display font"]
11042 mkfontdisp uifont $page [mc "User interface font"]
11043 return $page
11046 proc doprefs {} {
11047 global maxwidth maxgraphpct use_ttk NS
11048 global oldprefs prefstop showneartags showlocalchanges
11049 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11050 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11051 global hideremotes want_ttk have_ttk
11053 set top .gitkprefs
11054 set prefstop $top
11055 if {[winfo exists $top]} {
11056 raise $top
11057 return
11059 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11060 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11061 set oldprefs($v) [set $v]
11063 ttk_toplevel $top
11064 wm title $top [mc "Gitk preferences"]
11065 make_transient $top .
11067 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11068 set notebook [ttk::notebook $top.notebook]
11069 } else {
11070 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11073 lappend pages [prefspage_general $notebook] [mc "General"]
11074 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11075 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11076 set col 0
11077 foreach {page title} $pages {
11078 if {$use_notebook} {
11079 $notebook add $page -text $title
11080 } else {
11081 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11082 -text $title -command [list raise $page]]
11083 $page configure -text $title
11084 grid $btn -row 0 -column [incr col] -sticky w
11085 grid $page -row 1 -column 0 -sticky news -columnspan 100
11089 if {!$use_notebook} {
11090 grid columnconfigure $notebook 0 -weight 1
11091 grid rowconfigure $notebook 1 -weight 1
11092 raise [lindex $pages 0]
11095 grid $notebook -sticky news -padx 2 -pady 2
11096 grid rowconfigure $top 0 -weight 1
11097 grid columnconfigure $top 0 -weight 1
11099 ${NS}::frame $top.buts
11100 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11101 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11102 bind $top <Key-Return> prefsok
11103 bind $top <Key-Escape> prefscan
11104 grid $top.buts.ok $top.buts.can
11105 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11106 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11107 grid $top.buts - - -pady 10 -sticky ew
11108 grid columnconfigure $top 2 -weight 1
11109 bind $top <Visibility> [list focus $top.buts.ok]
11112 proc choose_extdiff {} {
11113 global extdifftool
11115 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11116 if {$prog ne {}} {
11117 set extdifftool $prog
11121 proc choosecolor {v vi w x cmd} {
11122 global $v
11124 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11125 -title [mc "Gitk: choose color for %s" $x]]
11126 if {$c eq {}} return
11127 $w conf -background $c
11128 lset $v $vi $c
11129 eval $cmd $c
11132 proc setselbg {c} {
11133 global bglist cflist
11134 foreach w $bglist {
11135 $w configure -selectbackground $c
11137 $cflist tag configure highlight \
11138 -background [$cflist cget -selectbackground]
11139 allcanvs itemconf secsel -fill $c
11142 # This sets the background color and the color scheme for the whole UI.
11143 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11144 # if we don't specify one ourselves, which makes the checkbuttons and
11145 # radiobuttons look bad. This chooses white for selectColor if the
11146 # background color is light, or black if it is dark.
11147 proc setui {c} {
11148 if {[tk windowingsystem] eq "win32"} { return }
11149 set bg [winfo rgb . $c]
11150 set selc black
11151 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11152 set selc white
11154 tk_setPalette background $c selectColor $selc
11157 proc setbg {c} {
11158 global bglist
11160 foreach w $bglist {
11161 $w conf -background $c
11165 proc setfg {c} {
11166 global fglist canv
11168 foreach w $fglist {
11169 $w conf -foreground $c
11171 allcanvs itemconf text -fill $c
11172 $canv itemconf circle -outline $c
11173 $canv itemconf markid -outline $c
11176 proc prefscan {} {
11177 global oldprefs prefstop
11179 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11180 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11181 global $v
11182 set $v $oldprefs($v)
11184 catch {destroy $prefstop}
11185 unset prefstop
11186 fontcan
11189 proc prefsok {} {
11190 global maxwidth maxgraphpct
11191 global oldprefs prefstop showneartags showlocalchanges
11192 global fontpref mainfont textfont uifont
11193 global limitdiffs treediffs perfile_attrs
11194 global hideremotes
11196 catch {destroy $prefstop}
11197 unset prefstop
11198 fontcan
11199 set fontchanged 0
11200 if {$mainfont ne $fontpref(mainfont)} {
11201 set mainfont $fontpref(mainfont)
11202 parsefont mainfont $mainfont
11203 eval font configure mainfont [fontflags mainfont]
11204 eval font configure mainfontbold [fontflags mainfont 1]
11205 setcoords
11206 set fontchanged 1
11208 if {$textfont ne $fontpref(textfont)} {
11209 set textfont $fontpref(textfont)
11210 parsefont textfont $textfont
11211 eval font configure textfont [fontflags textfont]
11212 eval font configure textfontbold [fontflags textfont 1]
11214 if {$uifont ne $fontpref(uifont)} {
11215 set uifont $fontpref(uifont)
11216 parsefont uifont $uifont
11217 eval font configure uifont [fontflags uifont]
11219 settabs
11220 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11221 if {$showlocalchanges} {
11222 doshowlocalchanges
11223 } else {
11224 dohidelocalchanges
11227 if {$limitdiffs != $oldprefs(limitdiffs) ||
11228 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11229 # treediffs elements are limited by path;
11230 # won't have encodings cached if perfile_attrs was just turned on
11231 catch {unset treediffs}
11233 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11234 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11235 redisplay
11236 } elseif {$showneartags != $oldprefs(showneartags) ||
11237 $limitdiffs != $oldprefs(limitdiffs)} {
11238 reselectline
11240 if {$hideremotes != $oldprefs(hideremotes)} {
11241 rereadrefs
11245 proc formatdate {d} {
11246 global datetimeformat
11247 if {$d ne {}} {
11248 set d [clock format [lindex $d 0] -format $datetimeformat]
11250 return $d
11253 # This list of encoding names and aliases is distilled from
11254 # http://www.iana.org/assignments/character-sets.
11255 # Not all of them are supported by Tcl.
11256 set encoding_aliases {
11257 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11258 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11259 { ISO-10646-UTF-1 csISO10646UTF1 }
11260 { ISO_646.basic:1983 ref csISO646basic1983 }
11261 { INVARIANT csINVARIANT }
11262 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11263 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11264 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11265 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11266 { NATS-DANO iso-ir-9-1 csNATSDANO }
11267 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11268 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11269 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11270 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11271 { ISO-2022-KR csISO2022KR }
11272 { EUC-KR csEUCKR }
11273 { ISO-2022-JP csISO2022JP }
11274 { ISO-2022-JP-2 csISO2022JP2 }
11275 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11276 csISO13JISC6220jp }
11277 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11278 { IT iso-ir-15 ISO646-IT csISO15Italian }
11279 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11280 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11281 { greek7-old iso-ir-18 csISO18Greek7Old }
11282 { latin-greek iso-ir-19 csISO19LatinGreek }
11283 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11284 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11285 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11286 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11287 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11288 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11289 { INIS iso-ir-49 csISO49INIS }
11290 { INIS-8 iso-ir-50 csISO50INIS8 }
11291 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11292 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11293 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11294 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11295 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11296 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11297 csISO60Norwegian1 }
11298 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11299 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11300 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11301 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11302 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11303 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11304 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11305 { greek7 iso-ir-88 csISO88Greek7 }
11306 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11307 { iso-ir-90 csISO90 }
11308 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11309 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11310 csISO92JISC62991984b }
11311 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11312 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11313 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11314 csISO95JIS62291984handadd }
11315 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11316 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11317 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11318 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11319 CP819 csISOLatin1 }
11320 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11321 { T.61-7bit iso-ir-102 csISO102T617bit }
11322 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11323 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11324 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11325 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11326 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11327 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11328 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11329 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11330 arabic csISOLatinArabic }
11331 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11332 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11333 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11334 greek greek8 csISOLatinGreek }
11335 { T.101-G2 iso-ir-128 csISO128T101G2 }
11336 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11337 csISOLatinHebrew }
11338 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11339 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11340 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11341 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11342 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11343 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11344 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11345 csISOLatinCyrillic }
11346 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11347 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11348 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11349 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11350 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11351 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11352 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11353 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11354 { ISO_10367-box iso-ir-155 csISO10367Box }
11355 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11356 { latin-lap lap iso-ir-158 csISO158Lap }
11357 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11358 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11359 { us-dk csUSDK }
11360 { dk-us csDKUS }
11361 { JIS_X0201 X0201 csHalfWidthKatakana }
11362 { KSC5636 ISO646-KR csKSC5636 }
11363 { ISO-10646-UCS-2 csUnicode }
11364 { ISO-10646-UCS-4 csUCS4 }
11365 { DEC-MCS dec csDECMCS }
11366 { hp-roman8 roman8 r8 csHPRoman8 }
11367 { macintosh mac csMacintosh }
11368 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11369 csIBM037 }
11370 { IBM038 EBCDIC-INT cp038 csIBM038 }
11371 { IBM273 CP273 csIBM273 }
11372 { IBM274 EBCDIC-BE CP274 csIBM274 }
11373 { IBM275 EBCDIC-BR cp275 csIBM275 }
11374 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11375 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11376 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11377 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11378 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11379 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11380 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11381 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11382 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11383 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11384 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11385 { IBM437 cp437 437 csPC8CodePage437 }
11386 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11387 { IBM775 cp775 csPC775Baltic }
11388 { IBM850 cp850 850 csPC850Multilingual }
11389 { IBM851 cp851 851 csIBM851 }
11390 { IBM852 cp852 852 csPCp852 }
11391 { IBM855 cp855 855 csIBM855 }
11392 { IBM857 cp857 857 csIBM857 }
11393 { IBM860 cp860 860 csIBM860 }
11394 { IBM861 cp861 861 cp-is csIBM861 }
11395 { IBM862 cp862 862 csPC862LatinHebrew }
11396 { IBM863 cp863 863 csIBM863 }
11397 { IBM864 cp864 csIBM864 }
11398 { IBM865 cp865 865 csIBM865 }
11399 { IBM866 cp866 866 csIBM866 }
11400 { IBM868 CP868 cp-ar csIBM868 }
11401 { IBM869 cp869 869 cp-gr csIBM869 }
11402 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11403 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11404 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11405 { IBM891 cp891 csIBM891 }
11406 { IBM903 cp903 csIBM903 }
11407 { IBM904 cp904 904 csIBBM904 }
11408 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11409 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11410 { IBM1026 CP1026 csIBM1026 }
11411 { EBCDIC-AT-DE csIBMEBCDICATDE }
11412 { EBCDIC-AT-DE-A csEBCDICATDEA }
11413 { EBCDIC-CA-FR csEBCDICCAFR }
11414 { EBCDIC-DK-NO csEBCDICDKNO }
11415 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11416 { EBCDIC-FI-SE csEBCDICFISE }
11417 { EBCDIC-FI-SE-A csEBCDICFISEA }
11418 { EBCDIC-FR csEBCDICFR }
11419 { EBCDIC-IT csEBCDICIT }
11420 { EBCDIC-PT csEBCDICPT }
11421 { EBCDIC-ES csEBCDICES }
11422 { EBCDIC-ES-A csEBCDICESA }
11423 { EBCDIC-ES-S csEBCDICESS }
11424 { EBCDIC-UK csEBCDICUK }
11425 { EBCDIC-US csEBCDICUS }
11426 { UNKNOWN-8BIT csUnknown8BiT }
11427 { MNEMONIC csMnemonic }
11428 { MNEM csMnem }
11429 { VISCII csVISCII }
11430 { VIQR csVIQR }
11431 { KOI8-R csKOI8R }
11432 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11433 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11434 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11435 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11436 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11437 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11438 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11439 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11440 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11441 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11442 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11443 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11444 { IBM1047 IBM-1047 }
11445 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11446 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11447 { UNICODE-1-1 csUnicode11 }
11448 { CESU-8 csCESU-8 }
11449 { BOCU-1 csBOCU-1 }
11450 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11451 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11452 l8 }
11453 { ISO-8859-15 ISO_8859-15 Latin-9 }
11454 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11455 { GBK CP936 MS936 windows-936 }
11456 { JIS_Encoding csJISEncoding }
11457 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11458 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11459 EUC-JP }
11460 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11461 { ISO-10646-UCS-Basic csUnicodeASCII }
11462 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11463 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11464 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11465 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11466 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11467 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11468 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11469 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11470 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11471 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11472 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11473 { Ventura-US csVenturaUS }
11474 { Ventura-International csVenturaInternational }
11475 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11476 { PC8-Turkish csPC8Turkish }
11477 { IBM-Symbols csIBMSymbols }
11478 { IBM-Thai csIBMThai }
11479 { HP-Legal csHPLegal }
11480 { HP-Pi-font csHPPiFont }
11481 { HP-Math8 csHPMath8 }
11482 { Adobe-Symbol-Encoding csHPPSMath }
11483 { HP-DeskTop csHPDesktop }
11484 { Ventura-Math csVenturaMath }
11485 { Microsoft-Publishing csMicrosoftPublishing }
11486 { Windows-31J csWindows31J }
11487 { GB2312 csGB2312 }
11488 { Big5 csBig5 }
11491 proc tcl_encoding {enc} {
11492 global encoding_aliases tcl_encoding_cache
11493 if {[info exists tcl_encoding_cache($enc)]} {
11494 return $tcl_encoding_cache($enc)
11496 set names [encoding names]
11497 set lcnames [string tolower $names]
11498 set enc [string tolower $enc]
11499 set i [lsearch -exact $lcnames $enc]
11500 if {$i < 0} {
11501 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11502 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11503 set i [lsearch -exact $lcnames $encx]
11506 if {$i < 0} {
11507 foreach l $encoding_aliases {
11508 set ll [string tolower $l]
11509 if {[lsearch -exact $ll $enc] < 0} continue
11510 # look through the aliases for one that tcl knows about
11511 foreach e $ll {
11512 set i [lsearch -exact $lcnames $e]
11513 if {$i < 0} {
11514 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11515 set i [lsearch -exact $lcnames $ex]
11518 if {$i >= 0} break
11520 break
11523 set tclenc {}
11524 if {$i >= 0} {
11525 set tclenc [lindex $names $i]
11527 set tcl_encoding_cache($enc) $tclenc
11528 return $tclenc
11531 proc gitattr {path attr default} {
11532 global path_attr_cache
11533 if {[info exists path_attr_cache($attr,$path)]} {
11534 set r $path_attr_cache($attr,$path)
11535 } else {
11536 set r "unspecified"
11537 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11538 regexp "(.*): $attr: (.*)" $line m f r
11540 set path_attr_cache($attr,$path) $r
11542 if {$r eq "unspecified"} {
11543 return $default
11545 return $r
11548 proc cache_gitattr {attr pathlist} {
11549 global path_attr_cache
11550 set newlist {}
11551 foreach path $pathlist {
11552 if {![info exists path_attr_cache($attr,$path)]} {
11553 lappend newlist $path
11556 set lim 1000
11557 if {[tk windowingsystem] == "win32"} {
11558 # windows has a 32k limit on the arguments to a command...
11559 set lim 30
11561 while {$newlist ne {}} {
11562 set head [lrange $newlist 0 [expr {$lim - 1}]]
11563 set newlist [lrange $newlist $lim end]
11564 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11565 foreach row [split $rlist "\n"] {
11566 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11567 if {[string index $path 0] eq "\""} {
11568 set path [encoding convertfrom [lindex $path 0]]
11570 set path_attr_cache($attr,$path) $value
11577 proc get_path_encoding {path} {
11578 global gui_encoding perfile_attrs
11579 set tcl_enc $gui_encoding
11580 if {$path ne {} && $perfile_attrs} {
11581 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11582 if {$enc2 ne {}} {
11583 set tcl_enc $enc2
11586 return $tcl_enc
11589 # First check that Tcl/Tk is recent enough
11590 if {[catch {package require Tk 8.4} err]} {
11591 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11592 Gitk requires at least Tcl/Tk 8.4." list
11593 exit 1
11596 # Unset GIT_TRACE var if set
11597 if { [info exists ::env(GIT_TRACE)] } {
11598 unset ::env(GIT_TRACE)
11601 # defaults...
11602 set wrcomcmd "git diff-tree --stdin -p --pretty"
11604 set gitencoding {}
11605 catch {
11606 set gitencoding [exec git config --get i18n.commitencoding]
11608 catch {
11609 set gitencoding [exec git config --get i18n.logoutputencoding]
11611 if {$gitencoding == ""} {
11612 set gitencoding "utf-8"
11614 set tclencoding [tcl_encoding $gitencoding]
11615 if {$tclencoding == {}} {
11616 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11619 set gui_encoding [encoding system]
11620 catch {
11621 set enc [exec git config --get gui.encoding]
11622 if {$enc ne {}} {
11623 set tclenc [tcl_encoding $enc]
11624 if {$tclenc ne {}} {
11625 set gui_encoding $tclenc
11626 } else {
11627 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11632 set log_showroot true
11633 catch {
11634 set log_showroot [exec git config --bool --get log.showroot]
11637 if {[tk windowingsystem] eq "aqua"} {
11638 set mainfont {{Lucida Grande} 9}
11639 set textfont {Monaco 9}
11640 set uifont {{Lucida Grande} 9 bold}
11641 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
11642 # fontconfig!
11643 set mainfont {sans 9}
11644 set textfont {monospace 9}
11645 set uifont {sans 9 bold}
11646 } else {
11647 set mainfont {Helvetica 9}
11648 set textfont {Courier 9}
11649 set uifont {Helvetica 9 bold}
11651 set tabstop 8
11652 set findmergefiles 0
11653 set maxgraphpct 50
11654 set maxwidth 16
11655 set revlistorder 0
11656 set fastdate 0
11657 set uparrowlen 5
11658 set downarrowlen 5
11659 set mingaplen 100
11660 set cmitmode "patch"
11661 set wrapcomment "none"
11662 set showneartags 1
11663 set hideremotes 0
11664 set maxrefs 20
11665 set maxlinelen 200
11666 set showlocalchanges 1
11667 set limitdiffs 1
11668 set datetimeformat "%Y-%m-%d %H:%M:%S"
11669 set autoselect 1
11670 set autosellen 40
11671 set perfile_attrs 0
11672 set want_ttk 1
11674 if {[tk windowingsystem] eq "aqua"} {
11675 set extdifftool "opendiff"
11676 } else {
11677 set extdifftool "meld"
11680 set colors {green red blue magenta darkgrey brown orange}
11681 if {[tk windowingsystem] eq "win32"} {
11682 set uicolor SystemButtonFace
11683 set bgcolor SystemWindow
11684 set fgcolor SystemButtonText
11685 set selectbgcolor SystemHighlight
11686 } else {
11687 set uicolor grey85
11688 set bgcolor white
11689 set fgcolor black
11690 set selectbgcolor gray85
11692 set diffcolors {red "#00a000" blue}
11693 set diffcontext 3
11694 set ignorespace 0
11695 set worddiff ""
11696 set markbgcolor "#e0e0ff"
11698 set circlecolors {white blue gray blue blue}
11700 # button for popping up context menus
11701 if {[tk windowingsystem] eq "aqua"} {
11702 set ctxbut <Button-2>
11703 } else {
11704 set ctxbut <Button-3>
11707 ## For msgcat loading, first locate the installation location.
11708 if { [info exists ::env(GITK_MSGSDIR)] } {
11709 ## Msgsdir was manually set in the environment.
11710 set gitk_msgsdir $::env(GITK_MSGSDIR)
11711 } else {
11712 ## Let's guess the prefix from argv0.
11713 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11714 set gitk_libdir [file join $gitk_prefix share gitk lib]
11715 set gitk_msgsdir [file join $gitk_libdir msgs]
11716 unset gitk_prefix
11719 ## Internationalization (i18n) through msgcat and gettext. See
11720 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11721 package require msgcat
11722 namespace import ::msgcat::mc
11723 ## And eventually load the actual message catalog
11724 ::msgcat::mcload $gitk_msgsdir
11726 catch {source ~/.gitk}
11728 parsefont mainfont $mainfont
11729 eval font create mainfont [fontflags mainfont]
11730 eval font create mainfontbold [fontflags mainfont 1]
11732 parsefont textfont $textfont
11733 eval font create textfont [fontflags textfont]
11734 eval font create textfontbold [fontflags textfont 1]
11736 parsefont uifont $uifont
11737 eval font create uifont [fontflags uifont]
11739 setui $uicolor
11741 setoptions
11743 # check that we can find a .git directory somewhere...
11744 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
11745 show_error {} . [mc "Cannot find a git repository here."]
11746 exit 1
11749 set selecthead {}
11750 set selectheadid {}
11752 set revtreeargs {}
11753 set cmdline_files {}
11754 set i 0
11755 set revtreeargscmd {}
11756 foreach arg $argv {
11757 switch -glob -- $arg {
11758 "" { }
11759 "--" {
11760 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11761 break
11763 "--select-commit=*" {
11764 set selecthead [string range $arg 16 end]
11766 "--argscmd=*" {
11767 set revtreeargscmd [string range $arg 10 end]
11769 default {
11770 lappend revtreeargs $arg
11773 incr i
11776 if {$selecthead eq "HEAD"} {
11777 set selecthead {}
11780 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11781 # no -- on command line, but some arguments (other than --argscmd)
11782 if {[catch {
11783 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11784 set cmdline_files [split $f "\n"]
11785 set n [llength $cmdline_files]
11786 set revtreeargs [lrange $revtreeargs 0 end-$n]
11787 # Unfortunately git rev-parse doesn't produce an error when
11788 # something is both a revision and a filename. To be consistent
11789 # with git log and git rev-list, check revtreeargs for filenames.
11790 foreach arg $revtreeargs {
11791 if {[file exists $arg]} {
11792 show_error {} . [mc "Ambiguous argument '%s': both revision\
11793 and filename" $arg]
11794 exit 1
11797 } err]} {
11798 # unfortunately we get both stdout and stderr in $err,
11799 # so look for "fatal:".
11800 set i [string first "fatal:" $err]
11801 if {$i > 0} {
11802 set err [string range $err [expr {$i + 6}] end]
11804 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11805 exit 1
11809 set nullid "0000000000000000000000000000000000000000"
11810 set nullid2 "0000000000000000000000000000000000000001"
11811 set nullfile "/dev/null"
11813 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11814 if {![info exists have_ttk]} {
11815 set have_ttk [llength [info commands ::ttk::style]]
11817 set use_ttk [expr {$have_ttk && $want_ttk}]
11818 set NS [expr {$use_ttk ? "ttk" : ""}]
11820 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
11822 set show_notes {}
11823 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
11824 set show_notes "--show-notes"
11827 set appname "gitk"
11829 set runq {}
11830 set history {}
11831 set historyindex 0
11832 set fh_serial 0
11833 set nhl_names {}
11834 set highlight_paths {}
11835 set findpattern {}
11836 set searchdirn -forwards
11837 set boldids {}
11838 set boldnameids {}
11839 set diffelide {0 0}
11840 set markingmatches 0
11841 set linkentercount 0
11842 set need_redisplay 0
11843 set nrows_drawn 0
11844 set firsttabstop 0
11846 set nextviewnum 1
11847 set curview 0
11848 set selectedview 0
11849 set selectedhlview [mc "None"]
11850 set highlight_related [mc "None"]
11851 set highlight_files {}
11852 set viewfiles(0) {}
11853 set viewperm(0) 0
11854 set viewargs(0) {}
11855 set viewargscmd(0) {}
11857 set selectedline {}
11858 set numcommits 0
11859 set loginstance 0
11860 set cmdlineok 0
11861 set stopped 0
11862 set stuffsaved 0
11863 set patchnum 0
11864 set lserial 0
11865 set hasworktree [hasworktree]
11866 set cdup {}
11867 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
11868 set cdup [exec git rev-parse --show-cdup]
11870 set worktree [exec git rev-parse --show-toplevel]
11871 setcoords
11872 makewindow
11873 catch {
11874 image create photo gitlogo -width 16 -height 16
11876 image create photo gitlogominus -width 4 -height 2
11877 gitlogominus put #C00000 -to 0 0 4 2
11878 gitlogo copy gitlogominus -to 1 5
11879 gitlogo copy gitlogominus -to 6 5
11880 gitlogo copy gitlogominus -to 11 5
11881 image delete gitlogominus
11883 image create photo gitlogoplus -width 4 -height 4
11884 gitlogoplus put #008000 -to 1 0 3 4
11885 gitlogoplus put #008000 -to 0 1 4 3
11886 gitlogo copy gitlogoplus -to 1 9
11887 gitlogo copy gitlogoplus -to 6 9
11888 gitlogo copy gitlogoplus -to 11 9
11889 image delete gitlogoplus
11891 image create photo gitlogo32 -width 32 -height 32
11892 gitlogo32 copy gitlogo -zoom 2 2
11894 wm iconphoto . -default gitlogo gitlogo32
11896 # wait for the window to become visible
11897 tkwait visibility .
11898 wm title . "$appname: [reponame]"
11899 update
11900 readrefs
11902 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11903 # create a view for the files/dirs specified on the command line
11904 set curview 1
11905 set selectedview 1
11906 set nextviewnum 2
11907 set viewname(1) [mc "Command line"]
11908 set viewfiles(1) $cmdline_files
11909 set viewargs(1) $revtreeargs
11910 set viewargscmd(1) $revtreeargscmd
11911 set viewperm(1) 0
11912 set vdatemode(1) 0
11913 addviewmenu 1
11914 .bar.view entryconf [mca "Edit view..."] -state normal
11915 .bar.view entryconf [mca "Delete view"] -state normal
11918 if {[info exists permviews]} {
11919 foreach v $permviews {
11920 set n $nextviewnum
11921 incr nextviewnum
11922 set viewname($n) [lindex $v 0]
11923 set viewfiles($n) [lindex $v 1]
11924 set viewargs($n) [lindex $v 2]
11925 set viewargscmd($n) [lindex $v 3]
11926 set viewperm($n) 1
11927 addviewmenu $n
11931 if {[tk windowingsystem] eq "win32"} {
11932 focus -force .
11935 getcommits {}
11937 # Local variables:
11938 # mode: tcl
11939 # indent-tabs-mode: t
11940 # tab-width: 8
11941 # End: