gitk: Tag display improvements
[git/mingw/j6t.git] / gitk
blob0bdb14638277aba619a997ca23fee5a6fd11187c
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 cleardropsel {w} {
2002 $w selection clear
2004 proc makedroplist {w varname args} {
2005 global use_ttk
2006 if {$use_ttk} {
2007 set width 0
2008 foreach label $args {
2009 set cx [string length $label]
2010 if {$cx > $width} {set width $cx}
2012 set gm [ttk::combobox $w -width $width -state readonly\
2013 -textvariable $varname -values $args \
2014 -exportselection false]
2015 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2016 } else {
2017 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2019 return $gm
2022 proc makewindow {} {
2023 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2024 global tabstop
2025 global findtype findtypemenu findloc findstring fstring geometry
2026 global entries sha1entry sha1string sha1but
2027 global diffcontextstring diffcontext
2028 global ignorespace
2029 global maincursor textcursor curtextcursor
2030 global rowctxmenu fakerowmenu mergemax wrapcomment
2031 global highlight_files gdttype
2032 global searchstring sstring
2033 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2034 global uifgcolor uifgdisabledcolor
2035 global filesepbgcolor filesepfgcolor
2036 global mergecolors foundbgcolor currentsearchhitbgcolor
2037 global headctxmenu progresscanv progressitem progresscoords statusw
2038 global fprogitem fprogcoord lastprogupdate progupdatepending
2039 global rprogitem rprogcoord rownumsel numcommits
2040 global have_tk85 use_ttk NS
2041 global git_version
2042 global worddiff
2044 # The "mc" arguments here are purely so that xgettext
2045 # sees the following string as needing to be translated
2046 set file {
2047 mc "File" cascade {
2048 {mc "Update" command updatecommits -accelerator F5}
2049 {mc "Reload" command reloadcommits -accelerator Shift-F5}
2050 {mc "Reread references" command rereadrefs}
2051 {mc "List references" command showrefs -accelerator F2}
2052 {xx "" separator}
2053 {mc "Start git gui" command {exec git gui &}}
2054 {xx "" separator}
2055 {mc "Quit" command doquit -accelerator Meta1-Q}
2057 set edit {
2058 mc "Edit" cascade {
2059 {mc "Preferences" command doprefs}
2061 set view {
2062 mc "View" cascade {
2063 {mc "New view..." command {newview 0} -accelerator Shift-F4}
2064 {mc "Edit view..." command editview -state disabled -accelerator F4}
2065 {mc "Delete view" command delview -state disabled}
2066 {xx "" separator}
2067 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2069 if {[tk windowingsystem] ne "aqua"} {
2070 set help {
2071 mc "Help" cascade {
2072 {mc "About gitk" command about}
2073 {mc "Key bindings" command keys}
2075 set bar [list $file $edit $view $help]
2076 } else {
2077 proc ::tk::mac::ShowPreferences {} {doprefs}
2078 proc ::tk::mac::Quit {} {doquit}
2079 lset file end [lreplace [lindex $file end] end-1 end]
2080 set apple {
2081 xx "Apple" cascade {
2082 {mc "About gitk" command about}
2083 {xx "" separator}
2085 set help {
2086 mc "Help" cascade {
2087 {mc "Key bindings" command keys}
2089 set bar [list $apple $file $view $help]
2091 makemenu .bar $bar
2092 . configure -menu .bar
2094 if {$use_ttk} {
2095 # cover the non-themed toplevel with a themed frame.
2096 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2099 # the gui has upper and lower half, parts of a paned window.
2100 ${NS}::panedwindow .ctop -orient vertical
2102 # possibly use assumed geometry
2103 if {![info exists geometry(pwsash0)]} {
2104 set geometry(topheight) [expr {15 * $linespc}]
2105 set geometry(topwidth) [expr {80 * $charspc}]
2106 set geometry(botheight) [expr {15 * $linespc}]
2107 set geometry(botwidth) [expr {50 * $charspc}]
2108 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2109 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2112 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2113 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2114 ${NS}::frame .tf.histframe
2115 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2116 if {!$use_ttk} {
2117 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2120 # create three canvases
2121 set cscroll .tf.histframe.csb
2122 set canv .tf.histframe.pwclist.canv
2123 canvas $canv \
2124 -selectbackground $selectbgcolor \
2125 -background $bgcolor -bd 0 \
2126 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2127 .tf.histframe.pwclist add $canv
2128 set canv2 .tf.histframe.pwclist.canv2
2129 canvas $canv2 \
2130 -selectbackground $selectbgcolor \
2131 -background $bgcolor -bd 0 -yscrollincr $linespc
2132 .tf.histframe.pwclist add $canv2
2133 set canv3 .tf.histframe.pwclist.canv3
2134 canvas $canv3 \
2135 -selectbackground $selectbgcolor \
2136 -background $bgcolor -bd 0 -yscrollincr $linespc
2137 .tf.histframe.pwclist add $canv3
2138 if {$use_ttk} {
2139 bind .tf.histframe.pwclist <Map> {
2140 bind %W <Map> {}
2141 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2142 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2144 } else {
2145 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2146 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2149 # a scroll bar to rule them
2150 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2151 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2152 pack $cscroll -side right -fill y
2153 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2154 lappend bglist $canv $canv2 $canv3
2155 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2157 # we have two button bars at bottom of top frame. Bar 1
2158 ${NS}::frame .tf.bar
2159 ${NS}::frame .tf.lbar -height 15
2161 set sha1entry .tf.bar.sha1
2162 set entries $sha1entry
2163 set sha1but .tf.bar.sha1label
2164 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2165 -command gotocommit -width 8
2166 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2167 pack .tf.bar.sha1label -side left
2168 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2169 trace add variable sha1string write sha1change
2170 pack $sha1entry -side left -pady 2
2172 set bm_left_data {
2173 #define left_width 16
2174 #define left_height 16
2175 static unsigned char left_bits[] = {
2176 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2177 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2178 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2180 set bm_right_data {
2181 #define right_width 16
2182 #define right_height 16
2183 static unsigned char right_bits[] = {
2184 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2185 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2186 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2188 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2189 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2190 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2191 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2193 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2194 if {$use_ttk} {
2195 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2196 } else {
2197 .tf.bar.leftbut configure -image bm-left
2199 pack .tf.bar.leftbut -side left -fill y
2200 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2201 if {$use_ttk} {
2202 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2203 } else {
2204 .tf.bar.rightbut configure -image bm-right
2206 pack .tf.bar.rightbut -side left -fill y
2208 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2209 set rownumsel {}
2210 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2211 -relief sunken -anchor e
2212 ${NS}::label .tf.bar.rowlabel2 -text "/"
2213 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2214 -relief sunken -anchor e
2215 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2216 -side left
2217 if {!$use_ttk} {
2218 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2220 global selectedline
2221 trace add variable selectedline write selectedline_change
2223 # Status label and progress bar
2224 set statusw .tf.bar.status
2225 ${NS}::label $statusw -width 15 -relief sunken
2226 pack $statusw -side left -padx 5
2227 if {$use_ttk} {
2228 set progresscanv [ttk::progressbar .tf.bar.progress]
2229 } else {
2230 set h [expr {[font metrics uifont -linespace] + 2}]
2231 set progresscanv .tf.bar.progress
2232 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2233 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2234 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2235 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2237 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2238 set progresscoords {0 0}
2239 set fprogcoord 0
2240 set rprogcoord 0
2241 bind $progresscanv <Configure> adjustprogress
2242 set lastprogupdate [clock clicks -milliseconds]
2243 set progupdatepending 0
2245 # build up the bottom bar of upper window
2246 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2247 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2248 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2249 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2250 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2251 -side left -fill y
2252 set gdttype [mc "containing:"]
2253 set gm [makedroplist .tf.lbar.gdttype gdttype \
2254 [mc "containing:"] \
2255 [mc "touching paths:"] \
2256 [mc "adding/removing string:"] \
2257 [mc "changing lines matching:"]]
2258 trace add variable gdttype write gdttype_change
2259 pack .tf.lbar.gdttype -side left -fill y
2261 set findstring {}
2262 set fstring .tf.lbar.findstring
2263 lappend entries $fstring
2264 ${NS}::entry $fstring -width 30 -textvariable findstring
2265 trace add variable findstring write find_change
2266 set findtype [mc "Exact"]
2267 set findtypemenu [makedroplist .tf.lbar.findtype \
2268 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2269 trace add variable findtype write findcom_change
2270 set findloc [mc "All fields"]
2271 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2272 [mc "Comments"] [mc "Author"] [mc "Committer"]
2273 trace add variable findloc write find_change
2274 pack .tf.lbar.findloc -side right
2275 pack .tf.lbar.findtype -side right
2276 pack $fstring -side left -expand 1 -fill x
2278 # Finish putting the upper half of the viewer together
2279 pack .tf.lbar -in .tf -side bottom -fill x
2280 pack .tf.bar -in .tf -side bottom -fill x
2281 pack .tf.histframe -fill both -side top -expand 1
2282 .ctop add .tf
2283 if {!$use_ttk} {
2284 .ctop paneconfigure .tf -height $geometry(topheight)
2285 .ctop paneconfigure .tf -width $geometry(topwidth)
2288 # now build up the bottom
2289 ${NS}::panedwindow .pwbottom -orient horizontal
2291 # lower left, a text box over search bar, scroll bar to the right
2292 # if we know window height, then that will set the lower text height, otherwise
2293 # we set lower text height which will drive window height
2294 if {[info exists geometry(main)]} {
2295 ${NS}::frame .bleft -width $geometry(botwidth)
2296 } else {
2297 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2299 ${NS}::frame .bleft.top
2300 ${NS}::frame .bleft.mid
2301 ${NS}::frame .bleft.bottom
2303 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2304 pack .bleft.top.search -side left -padx 5
2305 set sstring .bleft.top.sstring
2306 set searchstring ""
2307 ${NS}::entry $sstring -width 20 -textvariable searchstring
2308 lappend entries $sstring
2309 trace add variable searchstring write incrsearch
2310 pack $sstring -side left -expand 1 -fill x
2311 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2312 -command changediffdisp -variable diffelide -value {0 0}
2313 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2314 -command changediffdisp -variable diffelide -value {0 1}
2315 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2316 -command changediffdisp -variable diffelide -value {1 0}
2317 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2318 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2319 spinbox .bleft.mid.diffcontext -width 5 \
2320 -from 0 -increment 1 -to 10000000 \
2321 -validate all -validatecommand "diffcontextvalidate %P" \
2322 -textvariable diffcontextstring
2323 .bleft.mid.diffcontext set $diffcontext
2324 trace add variable diffcontextstring write diffcontextchange
2325 lappend entries .bleft.mid.diffcontext
2326 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2327 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2328 -command changeignorespace -variable ignorespace
2329 pack .bleft.mid.ignspace -side left -padx 5
2331 set worddiff [mc "Line diff"]
2332 if {[package vcompare $git_version "1.7.2"] >= 0} {
2333 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2334 [mc "Markup words"] [mc "Color words"]
2335 trace add variable worddiff write changeworddiff
2336 pack .bleft.mid.worddiff -side left -padx 5
2339 set ctext .bleft.bottom.ctext
2340 text $ctext -background $bgcolor -foreground $fgcolor \
2341 -state disabled -font textfont \
2342 -yscrollcommand scrolltext -wrap none \
2343 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2344 if {$have_tk85} {
2345 $ctext conf -tabstyle wordprocessor
2347 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2348 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2349 pack .bleft.top -side top -fill x
2350 pack .bleft.mid -side top -fill x
2351 grid $ctext .bleft.bottom.sb -sticky nsew
2352 grid .bleft.bottom.sbhorizontal -sticky ew
2353 grid columnconfigure .bleft.bottom 0 -weight 1
2354 grid rowconfigure .bleft.bottom 0 -weight 1
2355 grid rowconfigure .bleft.bottom 1 -weight 0
2356 pack .bleft.bottom -side top -fill both -expand 1
2357 lappend bglist $ctext
2358 lappend fglist $ctext
2360 $ctext tag conf comment -wrap $wrapcomment
2361 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2362 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2363 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2364 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2365 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2366 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2367 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2368 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2369 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2370 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2371 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2372 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2373 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2374 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2375 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2376 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2377 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2378 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2379 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2380 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2381 $ctext tag conf mmax -fore darkgrey
2382 set mergemax 16
2383 $ctext tag conf mresult -font textfontbold
2384 $ctext tag conf msep -font textfontbold
2385 $ctext tag conf found -back $foundbgcolor
2386 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2387 $ctext tag conf wwrap -wrap word
2388 $ctext tag conf bold -font textfontbold
2390 .pwbottom add .bleft
2391 if {!$use_ttk} {
2392 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2395 # lower right
2396 ${NS}::frame .bright
2397 ${NS}::frame .bright.mode
2398 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2399 -command reselectline -variable cmitmode -value "patch"
2400 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2401 -command reselectline -variable cmitmode -value "tree"
2402 grid .bright.mode.patch .bright.mode.tree -sticky ew
2403 pack .bright.mode -side top -fill x
2404 set cflist .bright.cfiles
2405 set indent [font measure mainfont "nn"]
2406 text $cflist \
2407 -selectbackground $selectbgcolor \
2408 -background $bgcolor -foreground $fgcolor \
2409 -font mainfont \
2410 -tabs [list $indent [expr {2 * $indent}]] \
2411 -yscrollcommand ".bright.sb set" \
2412 -cursor [. cget -cursor] \
2413 -spacing1 1 -spacing3 1
2414 lappend bglist $cflist
2415 lappend fglist $cflist
2416 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2417 pack .bright.sb -side right -fill y
2418 pack $cflist -side left -fill both -expand 1
2419 $cflist tag configure highlight \
2420 -background [$cflist cget -selectbackground]
2421 $cflist tag configure bold -font mainfontbold
2423 .pwbottom add .bright
2424 .ctop add .pwbottom
2426 # restore window width & height if known
2427 if {[info exists geometry(main)]} {
2428 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2429 if {$w > [winfo screenwidth .]} {
2430 set w [winfo screenwidth .]
2432 if {$h > [winfo screenheight .]} {
2433 set h [winfo screenheight .]
2435 wm geometry . "${w}x$h"
2439 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2440 wm state . $geometry(state)
2443 if {[tk windowingsystem] eq {aqua}} {
2444 set M1B M1
2445 set ::BM "3"
2446 } else {
2447 set M1B Control
2448 set ::BM "2"
2451 if {$use_ttk} {
2452 bind .ctop <Map> {
2453 bind %W <Map> {}
2454 %W sashpos 0 $::geometry(topheight)
2456 bind .pwbottom <Map> {
2457 bind %W <Map> {}
2458 %W sashpos 0 $::geometry(botwidth)
2462 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2463 pack .ctop -fill both -expand 1
2464 bindall <1> {selcanvline %W %x %y}
2465 #bindall <B1-Motion> {selcanvline %W %x %y}
2466 if {[tk windowingsystem] == "win32"} {
2467 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2468 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2469 } else {
2470 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2471 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2472 if {[tk windowingsystem] eq "aqua"} {
2473 bindall <MouseWheel> {
2474 set delta [expr {- (%D)}]
2475 allcanvs yview scroll $delta units
2477 bindall <Shift-MouseWheel> {
2478 set delta [expr {- (%D)}]
2479 $canv xview scroll $delta units
2483 bindall <$::BM> "canvscan mark %W %x %y"
2484 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2485 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2486 bind . <$M1B-Key-w> doquit
2487 bindkey <Home> selfirstline
2488 bindkey <End> sellastline
2489 bind . <Key-Up> "selnextline -1"
2490 bind . <Key-Down> "selnextline 1"
2491 bind . <Shift-Key-Up> "dofind -1 0"
2492 bind . <Shift-Key-Down> "dofind 1 0"
2493 bindkey <Key-Right> "goforw"
2494 bindkey <Key-Left> "goback"
2495 bind . <Key-Prior> "selnextpage -1"
2496 bind . <Key-Next> "selnextpage 1"
2497 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2498 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2499 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2500 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2501 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2502 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2503 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2504 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2505 bindkey <Key-space> "$ctext yview scroll 1 pages"
2506 bindkey p "selnextline -1"
2507 bindkey n "selnextline 1"
2508 bindkey z "goback"
2509 bindkey x "goforw"
2510 bindkey k "selnextline -1"
2511 bindkey j "selnextline 1"
2512 bindkey h "goback"
2513 bindkey l "goforw"
2514 bindkey b prevfile
2515 bindkey d "$ctext yview scroll 18 units"
2516 bindkey u "$ctext yview scroll -18 units"
2517 bindkey / {focus $fstring}
2518 bindkey <Key-KP_Divide> {focus $fstring}
2519 bindkey <Key-Return> {dofind 1 1}
2520 bindkey ? {dofind -1 1}
2521 bindkey f nextfile
2522 bind . <F5> updatecommits
2523 bindmodfunctionkey Shift 5 reloadcommits
2524 bind . <F2> showrefs
2525 bindmodfunctionkey Shift 4 {newview 0}
2526 bind . <F4> edit_or_newview
2527 bind . <$M1B-q> doquit
2528 bind . <$M1B-f> {dofind 1 1}
2529 bind . <$M1B-g> {dofind 1 0}
2530 bind . <$M1B-r> dosearchback
2531 bind . <$M1B-s> dosearch
2532 bind . <$M1B-equal> {incrfont 1}
2533 bind . <$M1B-plus> {incrfont 1}
2534 bind . <$M1B-KP_Add> {incrfont 1}
2535 bind . <$M1B-minus> {incrfont -1}
2536 bind . <$M1B-KP_Subtract> {incrfont -1}
2537 wm protocol . WM_DELETE_WINDOW doquit
2538 bind . <Destroy> {stop_backends}
2539 bind . <Button-1> "click %W"
2540 bind $fstring <Key-Return> {dofind 1 1}
2541 bind $sha1entry <Key-Return> {gotocommit; break}
2542 bind $sha1entry <<PasteSelection>> clearsha1
2543 bind $cflist <1> {sel_flist %W %x %y; break}
2544 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2545 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2546 global ctxbut
2547 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2548 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2549 bind $ctext <Button-1> {focus %W}
2550 bind $ctext <<Selection>> rehighlight_search_results
2552 set maincursor [. cget -cursor]
2553 set textcursor [$ctext cget -cursor]
2554 set curtextcursor $textcursor
2556 set rowctxmenu .rowctxmenu
2557 makemenu $rowctxmenu {
2558 {mc "Diff this -> selected" command {diffvssel 0}}
2559 {mc "Diff selected -> this" command {diffvssel 1}}
2560 {mc "Make patch" command mkpatch}
2561 {mc "Create tag" command mktag}
2562 {mc "Write commit to file" command writecommit}
2563 {mc "Create new branch" command mkbranch}
2564 {mc "Cherry-pick this commit" command cherrypick}
2565 {mc "Reset HEAD branch to here" command resethead}
2566 {mc "Mark this commit" command markhere}
2567 {mc "Return to mark" command gotomark}
2568 {mc "Find descendant of this and mark" command find_common_desc}
2569 {mc "Compare with marked commit" command compare_commits}
2570 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2571 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2572 {mc "Revert this commit" command revert}
2574 $rowctxmenu configure -tearoff 0
2576 set fakerowmenu .fakerowmenu
2577 makemenu $fakerowmenu {
2578 {mc "Diff this -> selected" command {diffvssel 0}}
2579 {mc "Diff selected -> this" command {diffvssel 1}}
2580 {mc "Make patch" command mkpatch}
2581 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2582 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2584 $fakerowmenu configure -tearoff 0
2586 set headctxmenu .headctxmenu
2587 makemenu $headctxmenu {
2588 {mc "Check out this branch" command cobranch}
2589 {mc "Remove this branch" command rmbranch}
2591 $headctxmenu configure -tearoff 0
2593 global flist_menu
2594 set flist_menu .flistctxmenu
2595 makemenu $flist_menu {
2596 {mc "Highlight this too" command {flist_hl 0}}
2597 {mc "Highlight this only" command {flist_hl 1}}
2598 {mc "External diff" command {external_diff}}
2599 {mc "Blame parent commit" command {external_blame 1}}
2601 $flist_menu configure -tearoff 0
2603 global diff_menu
2604 set diff_menu .diffctxmenu
2605 makemenu $diff_menu {
2606 {mc "Show origin of this line" command show_line_source}
2607 {mc "Run git gui blame on this line" command {external_blame_diff}}
2609 $diff_menu configure -tearoff 0
2612 # Windows sends all mouse wheel events to the current focused window, not
2613 # the one where the mouse hovers, so bind those events here and redirect
2614 # to the correct window
2615 proc windows_mousewheel_redirector {W X Y D} {
2616 global canv canv2 canv3
2617 set w [winfo containing -displayof $W $X $Y]
2618 if {$w ne ""} {
2619 set u [expr {$D < 0 ? 5 : -5}]
2620 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2621 allcanvs yview scroll $u units
2622 } else {
2623 catch {
2624 $w yview scroll $u units
2630 # Update row number label when selectedline changes
2631 proc selectedline_change {n1 n2 op} {
2632 global selectedline rownumsel
2634 if {$selectedline eq {}} {
2635 set rownumsel {}
2636 } else {
2637 set rownumsel [expr {$selectedline + 1}]
2641 # mouse-2 makes all windows scan vertically, but only the one
2642 # the cursor is in scans horizontally
2643 proc canvscan {op w x y} {
2644 global canv canv2 canv3
2645 foreach c [list $canv $canv2 $canv3] {
2646 if {$c == $w} {
2647 $c scan $op $x $y
2648 } else {
2649 $c scan $op 0 $y
2654 proc scrollcanv {cscroll f0 f1} {
2655 $cscroll set $f0 $f1
2656 drawvisible
2657 flushhighlights
2660 # when we make a key binding for the toplevel, make sure
2661 # it doesn't get triggered when that key is pressed in the
2662 # find string entry widget.
2663 proc bindkey {ev script} {
2664 global entries
2665 bind . $ev $script
2666 set escript [bind Entry $ev]
2667 if {$escript == {}} {
2668 set escript [bind Entry <Key>]
2670 foreach e $entries {
2671 bind $e $ev "$escript; break"
2675 proc bindmodfunctionkey {mod n script} {
2676 bind . <$mod-F$n> $script
2677 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2680 # set the focus back to the toplevel for any click outside
2681 # the entry widgets
2682 proc click {w} {
2683 global ctext entries
2684 foreach e [concat $entries $ctext] {
2685 if {$w == $e} return
2687 focus .
2690 # Adjust the progress bar for a change in requested extent or canvas size
2691 proc adjustprogress {} {
2692 global progresscanv progressitem progresscoords
2693 global fprogitem fprogcoord lastprogupdate progupdatepending
2694 global rprogitem rprogcoord use_ttk
2696 if {$use_ttk} {
2697 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2698 return
2701 set w [expr {[winfo width $progresscanv] - 4}]
2702 set x0 [expr {$w * [lindex $progresscoords 0]}]
2703 set x1 [expr {$w * [lindex $progresscoords 1]}]
2704 set h [winfo height $progresscanv]
2705 $progresscanv coords $progressitem $x0 0 $x1 $h
2706 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2707 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2708 set now [clock clicks -milliseconds]
2709 if {$now >= $lastprogupdate + 100} {
2710 set progupdatepending 0
2711 update
2712 } elseif {!$progupdatepending} {
2713 set progupdatepending 1
2714 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2718 proc doprogupdate {} {
2719 global lastprogupdate progupdatepending
2721 if {$progupdatepending} {
2722 set progupdatepending 0
2723 set lastprogupdate [clock clicks -milliseconds]
2724 update
2728 proc savestuff {w} {
2729 global canv canv2 canv3 mainfont textfont uifont tabstop
2730 global stuffsaved findmergefiles maxgraphpct
2731 global maxwidth showneartags showlocalchanges
2732 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2733 global cmitmode wrapcomment datetimeformat limitdiffs
2734 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2735 global uifgcolor uifgdisabledcolor
2736 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
2737 global tagbgcolor tagfgcolor tagoutlinecolor
2738 global reflinecolor filesepbgcolor filesepfgcolor
2739 global mergecolors foundbgcolor currentsearchhitbgcolor
2740 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor circlecolors
2741 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
2742 global linkfgcolor circleoutlinecolor
2743 global autoselect autosellen extdifftool perfile_attrs markbgcolor use_ttk
2744 global hideremotes want_ttk maxrefs
2746 if {$stuffsaved} return
2747 if {![winfo viewable .]} return
2748 catch {
2749 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2750 set f [open "~/.gitk-new" w]
2751 if {$::tcl_platform(platform) eq {windows}} {
2752 file attributes "~/.gitk-new" -hidden true
2754 puts $f [list set mainfont $mainfont]
2755 puts $f [list set textfont $textfont]
2756 puts $f [list set uifont $uifont]
2757 puts $f [list set tabstop $tabstop]
2758 puts $f [list set findmergefiles $findmergefiles]
2759 puts $f [list set maxgraphpct $maxgraphpct]
2760 puts $f [list set maxwidth $maxwidth]
2761 puts $f [list set cmitmode $cmitmode]
2762 puts $f [list set wrapcomment $wrapcomment]
2763 puts $f [list set autoselect $autoselect]
2764 puts $f [list set autosellen $autosellen]
2765 puts $f [list set showneartags $showneartags]
2766 puts $f [list set maxrefs $maxrefs]
2767 puts $f [list set hideremotes $hideremotes]
2768 puts $f [list set showlocalchanges $showlocalchanges]
2769 puts $f [list set datetimeformat $datetimeformat]
2770 puts $f [list set limitdiffs $limitdiffs]
2771 puts $f [list set uicolor $uicolor]
2772 puts $f [list set want_ttk $want_ttk]
2773 puts $f [list set bgcolor $bgcolor]
2774 puts $f [list set fgcolor $fgcolor]
2775 puts $f [list set uifgcolor $uifgcolor]
2776 puts $f [list set uifgdisabledcolor $uifgdisabledcolor]
2777 puts $f [list set colors $colors]
2778 puts $f [list set diffcolors $diffcolors]
2779 puts $f [list set mergecolors $mergecolors]
2780 puts $f [list set markbgcolor $markbgcolor]
2781 puts $f [list set diffcontext $diffcontext]
2782 puts $f [list set selectbgcolor $selectbgcolor]
2783 puts $f [list set foundbgcolor $foundbgcolor]
2784 puts $f [list set currentsearchhitbgcolor $currentsearchhitbgcolor]
2785 puts $f [list set extdifftool $extdifftool]
2786 puts $f [list set perfile_attrs $perfile_attrs]
2787 puts $f [list set headbgcolor $headbgcolor]
2788 puts $f [list set headfgcolor $headfgcolor]
2789 puts $f [list set headoutlinecolor $headoutlinecolor]
2790 puts $f [list set remotebgcolor $remotebgcolor]
2791 puts $f [list set tagbgcolor $tagbgcolor]
2792 puts $f [list set tagfgcolor $tagfgcolor]
2793 puts $f [list set tagoutlinecolor $tagoutlinecolor]
2794 puts $f [list set reflinecolor $reflinecolor]
2795 puts $f [list set filesepbgcolor $filesepbgcolor]
2796 puts $f [list set filesepfgcolor $filesepfgcolor]
2797 puts $f [list set linehoverbgcolor $linehoverbgcolor]
2798 puts $f [list set linehoverfgcolor $linehoverfgcolor]
2799 puts $f [list set linehoveroutlinecolor $linehoveroutlinecolor]
2800 puts $f [list set mainheadcirclecolor $mainheadcirclecolor]
2801 puts $f [list set workingfilescirclecolor $workingfilescirclecolor]
2802 puts $f [list set indexcirclecolor $indexcirclecolor]
2803 puts $f [list set circlecolors $circlecolors]
2804 puts $f [list set linkfgcolor $linkfgcolor]
2805 puts $f [list set circleoutlinecolor $circleoutlinecolor]
2807 puts $f "set geometry(main) [wm geometry .]"
2808 puts $f "set geometry(state) [wm state .]"
2809 puts $f "set geometry(topwidth) [winfo width .tf]"
2810 puts $f "set geometry(topheight) [winfo height .tf]"
2811 if {$use_ttk} {
2812 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2813 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2814 } else {
2815 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2816 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2818 puts $f "set geometry(botwidth) [winfo width .bleft]"
2819 puts $f "set geometry(botheight) [winfo height .bleft]"
2821 puts -nonewline $f "set permviews {"
2822 for {set v 0} {$v < $nextviewnum} {incr v} {
2823 if {$viewperm($v)} {
2824 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2827 puts $f "}"
2828 close $f
2829 file rename -force "~/.gitk-new" "~/.gitk"
2831 set stuffsaved 1
2834 proc resizeclistpanes {win w} {
2835 global oldwidth use_ttk
2836 if {[info exists oldwidth($win)]} {
2837 if {$use_ttk} {
2838 set s0 [$win sashpos 0]
2839 set s1 [$win sashpos 1]
2840 } else {
2841 set s0 [$win sash coord 0]
2842 set s1 [$win sash coord 1]
2844 if {$w < 60} {
2845 set sash0 [expr {int($w/2 - 2)}]
2846 set sash1 [expr {int($w*5/6 - 2)}]
2847 } else {
2848 set factor [expr {1.0 * $w / $oldwidth($win)}]
2849 set sash0 [expr {int($factor * [lindex $s0 0])}]
2850 set sash1 [expr {int($factor * [lindex $s1 0])}]
2851 if {$sash0 < 30} {
2852 set sash0 30
2854 if {$sash1 < $sash0 + 20} {
2855 set sash1 [expr {$sash0 + 20}]
2857 if {$sash1 > $w - 10} {
2858 set sash1 [expr {$w - 10}]
2859 if {$sash0 > $sash1 - 20} {
2860 set sash0 [expr {$sash1 - 20}]
2864 if {$use_ttk} {
2865 $win sashpos 0 $sash0
2866 $win sashpos 1 $sash1
2867 } else {
2868 $win sash place 0 $sash0 [lindex $s0 1]
2869 $win sash place 1 $sash1 [lindex $s1 1]
2872 set oldwidth($win) $w
2875 proc resizecdetpanes {win w} {
2876 global oldwidth use_ttk
2877 if {[info exists oldwidth($win)]} {
2878 if {$use_ttk} {
2879 set s0 [$win sashpos 0]
2880 } else {
2881 set s0 [$win sash coord 0]
2883 if {$w < 60} {
2884 set sash0 [expr {int($w*3/4 - 2)}]
2885 } else {
2886 set factor [expr {1.0 * $w / $oldwidth($win)}]
2887 set sash0 [expr {int($factor * [lindex $s0 0])}]
2888 if {$sash0 < 45} {
2889 set sash0 45
2891 if {$sash0 > $w - 15} {
2892 set sash0 [expr {$w - 15}]
2895 if {$use_ttk} {
2896 $win sashpos 0 $sash0
2897 } else {
2898 $win sash place 0 $sash0 [lindex $s0 1]
2901 set oldwidth($win) $w
2904 proc allcanvs args {
2905 global canv canv2 canv3
2906 eval $canv $args
2907 eval $canv2 $args
2908 eval $canv3 $args
2911 proc bindall {event action} {
2912 global canv canv2 canv3
2913 bind $canv $event $action
2914 bind $canv2 $event $action
2915 bind $canv3 $event $action
2918 proc about {} {
2919 global uifont NS
2920 set w .about
2921 if {[winfo exists $w]} {
2922 raise $w
2923 return
2925 ttk_toplevel $w
2926 wm title $w [mc "About gitk"]
2927 make_transient $w .
2928 message $w.m -text [mc "
2929 Gitk - a commit viewer for git
2931 Copyright \u00a9 2005-2011 Paul Mackerras
2933 Use and redistribute under the terms of the GNU General Public License"] \
2934 -justify center -aspect 400 -border 2 -bg white -relief groove
2935 pack $w.m -side top -fill x -padx 2 -pady 2
2936 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2937 pack $w.ok -side bottom
2938 bind $w <Visibility> "focus $w.ok"
2939 bind $w <Key-Escape> "destroy $w"
2940 bind $w <Key-Return> "destroy $w"
2941 tk::PlaceWindow $w widget .
2944 proc keys {} {
2945 global NS
2946 set w .keys
2947 if {[winfo exists $w]} {
2948 raise $w
2949 return
2951 if {[tk windowingsystem] eq {aqua}} {
2952 set M1T Cmd
2953 } else {
2954 set M1T Ctrl
2956 ttk_toplevel $w
2957 wm title $w [mc "Gitk key bindings"]
2958 make_transient $w .
2959 message $w.m -text "
2960 [mc "Gitk key bindings:"]
2962 [mc "<%s-Q> Quit" $M1T]
2963 [mc "<%s-W> Close window" $M1T]
2964 [mc "<Home> Move to first commit"]
2965 [mc "<End> Move to last commit"]
2966 [mc "<Up>, p, k Move up one commit"]
2967 [mc "<Down>, n, j Move down one commit"]
2968 [mc "<Left>, z, h Go back in history list"]
2969 [mc "<Right>, x, l Go forward in history list"]
2970 [mc "<PageUp> Move up one page in commit list"]
2971 [mc "<PageDown> Move down one page in commit list"]
2972 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2973 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2974 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2975 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2976 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2977 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2978 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2979 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2980 [mc "<Delete>, b Scroll diff view up one page"]
2981 [mc "<Backspace> Scroll diff view up one page"]
2982 [mc "<Space> Scroll diff view down one page"]
2983 [mc "u Scroll diff view up 18 lines"]
2984 [mc "d Scroll diff view down 18 lines"]
2985 [mc "<%s-F> Find" $M1T]
2986 [mc "<%s-G> Move to next find hit" $M1T]
2987 [mc "<Return> Move to next find hit"]
2988 [mc "/ Focus the search box"]
2989 [mc "? Move to previous find hit"]
2990 [mc "f Scroll diff view to next file"]
2991 [mc "<%s-S> Search for next hit in diff view" $M1T]
2992 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2993 [mc "<%s-KP+> Increase font size" $M1T]
2994 [mc "<%s-plus> Increase font size" $M1T]
2995 [mc "<%s-KP-> Decrease font size" $M1T]
2996 [mc "<%s-minus> Decrease font size" $M1T]
2997 [mc "<F5> Update"]
2999 -justify left -bg white -border 2 -relief groove
3000 pack $w.m -side top -fill both -padx 2 -pady 2
3001 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3002 bind $w <Key-Escape> [list destroy $w]
3003 pack $w.ok -side bottom
3004 bind $w <Visibility> "focus $w.ok"
3005 bind $w <Key-Escape> "destroy $w"
3006 bind $w <Key-Return> "destroy $w"
3009 # Procedures for manipulating the file list window at the
3010 # bottom right of the overall window.
3012 proc treeview {w l openlevs} {
3013 global treecontents treediropen treeheight treeparent treeindex
3015 set ix 0
3016 set treeindex() 0
3017 set lev 0
3018 set prefix {}
3019 set prefixend -1
3020 set prefendstack {}
3021 set htstack {}
3022 set ht 0
3023 set treecontents() {}
3024 $w conf -state normal
3025 foreach f $l {
3026 while {[string range $f 0 $prefixend] ne $prefix} {
3027 if {$lev <= $openlevs} {
3028 $w mark set e:$treeindex($prefix) "end -1c"
3029 $w mark gravity e:$treeindex($prefix) left
3031 set treeheight($prefix) $ht
3032 incr ht [lindex $htstack end]
3033 set htstack [lreplace $htstack end end]
3034 set prefixend [lindex $prefendstack end]
3035 set prefendstack [lreplace $prefendstack end end]
3036 set prefix [string range $prefix 0 $prefixend]
3037 incr lev -1
3039 set tail [string range $f [expr {$prefixend+1}] end]
3040 while {[set slash [string first "/" $tail]] >= 0} {
3041 lappend htstack $ht
3042 set ht 0
3043 lappend prefendstack $prefixend
3044 incr prefixend [expr {$slash + 1}]
3045 set d [string range $tail 0 $slash]
3046 lappend treecontents($prefix) $d
3047 set oldprefix $prefix
3048 append prefix $d
3049 set treecontents($prefix) {}
3050 set treeindex($prefix) [incr ix]
3051 set treeparent($prefix) $oldprefix
3052 set tail [string range $tail [expr {$slash+1}] end]
3053 if {$lev <= $openlevs} {
3054 set ht 1
3055 set treediropen($prefix) [expr {$lev < $openlevs}]
3056 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3057 $w mark set d:$ix "end -1c"
3058 $w mark gravity d:$ix left
3059 set str "\n"
3060 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3061 $w insert end $str
3062 $w image create end -align center -image $bm -padx 1 \
3063 -name a:$ix
3064 $w insert end $d [highlight_tag $prefix]
3065 $w mark set s:$ix "end -1c"
3066 $w mark gravity s:$ix left
3068 incr lev
3070 if {$tail ne {}} {
3071 if {$lev <= $openlevs} {
3072 incr ht
3073 set str "\n"
3074 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3075 $w insert end $str
3076 $w insert end $tail [highlight_tag $f]
3078 lappend treecontents($prefix) $tail
3081 while {$htstack ne {}} {
3082 set treeheight($prefix) $ht
3083 incr ht [lindex $htstack end]
3084 set htstack [lreplace $htstack end end]
3085 set prefixend [lindex $prefendstack end]
3086 set prefendstack [lreplace $prefendstack end end]
3087 set prefix [string range $prefix 0 $prefixend]
3089 $w conf -state disabled
3092 proc linetoelt {l} {
3093 global treeheight treecontents
3095 set y 2
3096 set prefix {}
3097 while {1} {
3098 foreach e $treecontents($prefix) {
3099 if {$y == $l} {
3100 return "$prefix$e"
3102 set n 1
3103 if {[string index $e end] eq "/"} {
3104 set n $treeheight($prefix$e)
3105 if {$y + $n > $l} {
3106 append prefix $e
3107 incr y
3108 break
3111 incr y $n
3116 proc highlight_tree {y prefix} {
3117 global treeheight treecontents cflist
3119 foreach e $treecontents($prefix) {
3120 set path $prefix$e
3121 if {[highlight_tag $path] ne {}} {
3122 $cflist tag add bold $y.0 "$y.0 lineend"
3124 incr y
3125 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3126 set y [highlight_tree $y $path]
3129 return $y
3132 proc treeclosedir {w dir} {
3133 global treediropen treeheight treeparent treeindex
3135 set ix $treeindex($dir)
3136 $w conf -state normal
3137 $w delete s:$ix e:$ix
3138 set treediropen($dir) 0
3139 $w image configure a:$ix -image tri-rt
3140 $w conf -state disabled
3141 set n [expr {1 - $treeheight($dir)}]
3142 while {$dir ne {}} {
3143 incr treeheight($dir) $n
3144 set dir $treeparent($dir)
3148 proc treeopendir {w dir} {
3149 global treediropen treeheight treeparent treecontents treeindex
3151 set ix $treeindex($dir)
3152 $w conf -state normal
3153 $w image configure a:$ix -image tri-dn
3154 $w mark set e:$ix s:$ix
3155 $w mark gravity e:$ix right
3156 set lev 0
3157 set str "\n"
3158 set n [llength $treecontents($dir)]
3159 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3160 incr lev
3161 append str "\t"
3162 incr treeheight($x) $n
3164 foreach e $treecontents($dir) {
3165 set de $dir$e
3166 if {[string index $e end] eq "/"} {
3167 set iy $treeindex($de)
3168 $w mark set d:$iy e:$ix
3169 $w mark gravity d:$iy left
3170 $w insert e:$ix $str
3171 set treediropen($de) 0
3172 $w image create e:$ix -align center -image tri-rt -padx 1 \
3173 -name a:$iy
3174 $w insert e:$ix $e [highlight_tag $de]
3175 $w mark set s:$iy e:$ix
3176 $w mark gravity s:$iy left
3177 set treeheight($de) 1
3178 } else {
3179 $w insert e:$ix $str
3180 $w insert e:$ix $e [highlight_tag $de]
3183 $w mark gravity e:$ix right
3184 $w conf -state disabled
3185 set treediropen($dir) 1
3186 set top [lindex [split [$w index @0,0] .] 0]
3187 set ht [$w cget -height]
3188 set l [lindex [split [$w index s:$ix] .] 0]
3189 if {$l < $top} {
3190 $w yview $l.0
3191 } elseif {$l + $n + 1 > $top + $ht} {
3192 set top [expr {$l + $n + 2 - $ht}]
3193 if {$l < $top} {
3194 set top $l
3196 $w yview $top.0
3200 proc treeclick {w x y} {
3201 global treediropen cmitmode ctext cflist cflist_top
3203 if {$cmitmode ne "tree"} return
3204 if {![info exists cflist_top]} return
3205 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3206 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3207 $cflist tag add highlight $l.0 "$l.0 lineend"
3208 set cflist_top $l
3209 if {$l == 1} {
3210 $ctext yview 1.0
3211 return
3213 set e [linetoelt $l]
3214 if {[string index $e end] ne "/"} {
3215 showfile $e
3216 } elseif {$treediropen($e)} {
3217 treeclosedir $w $e
3218 } else {
3219 treeopendir $w $e
3223 proc setfilelist {id} {
3224 global treefilelist cflist jump_to_here
3226 treeview $cflist $treefilelist($id) 0
3227 if {$jump_to_here ne {}} {
3228 set f [lindex $jump_to_here 0]
3229 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3230 showfile $f
3235 image create bitmap tri-rt -background black -foreground blue -data {
3236 #define tri-rt_width 13
3237 #define tri-rt_height 13
3238 static unsigned char tri-rt_bits[] = {
3239 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3240 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3241 0x00, 0x00};
3242 } -maskdata {
3243 #define tri-rt-mask_width 13
3244 #define tri-rt-mask_height 13
3245 static unsigned char tri-rt-mask_bits[] = {
3246 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3247 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3248 0x08, 0x00};
3250 image create bitmap tri-dn -background black -foreground blue -data {
3251 #define tri-dn_width 13
3252 #define tri-dn_height 13
3253 static unsigned char tri-dn_bits[] = {
3254 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3255 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3256 0x00, 0x00};
3257 } -maskdata {
3258 #define tri-dn-mask_width 13
3259 #define tri-dn-mask_height 13
3260 static unsigned char tri-dn-mask_bits[] = {
3261 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3262 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3263 0x00, 0x00};
3266 image create bitmap reficon-T -background black -foreground yellow -data {
3267 #define tagicon_width 13
3268 #define tagicon_height 9
3269 static unsigned char tagicon_bits[] = {
3270 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3271 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3272 } -maskdata {
3273 #define tagicon-mask_width 13
3274 #define tagicon-mask_height 9
3275 static unsigned char tagicon-mask_bits[] = {
3276 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3277 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3279 set rectdata {
3280 #define headicon_width 13
3281 #define headicon_height 9
3282 static unsigned char headicon_bits[] = {
3283 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3284 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3286 set rectmask {
3287 #define headicon-mask_width 13
3288 #define headicon-mask_height 9
3289 static unsigned char headicon-mask_bits[] = {
3290 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3291 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3293 image create bitmap reficon-H -background black -foreground green \
3294 -data $rectdata -maskdata $rectmask
3295 image create bitmap reficon-o -background black -foreground "#ddddff" \
3296 -data $rectdata -maskdata $rectmask
3298 proc init_flist {first} {
3299 global cflist cflist_top difffilestart
3301 $cflist conf -state normal
3302 $cflist delete 0.0 end
3303 if {$first ne {}} {
3304 $cflist insert end $first
3305 set cflist_top 1
3306 $cflist tag add highlight 1.0 "1.0 lineend"
3307 } else {
3308 catch {unset cflist_top}
3310 $cflist conf -state disabled
3311 set difffilestart {}
3314 proc highlight_tag {f} {
3315 global highlight_paths
3317 foreach p $highlight_paths {
3318 if {[string match $p $f]} {
3319 return "bold"
3322 return {}
3325 proc highlight_filelist {} {
3326 global cmitmode cflist
3328 $cflist conf -state normal
3329 if {$cmitmode ne "tree"} {
3330 set end [lindex [split [$cflist index end] .] 0]
3331 for {set l 2} {$l < $end} {incr l} {
3332 set line [$cflist get $l.0 "$l.0 lineend"]
3333 if {[highlight_tag $line] ne {}} {
3334 $cflist tag add bold $l.0 "$l.0 lineend"
3337 } else {
3338 highlight_tree 2 {}
3340 $cflist conf -state disabled
3343 proc unhighlight_filelist {} {
3344 global cflist
3346 $cflist conf -state normal
3347 $cflist tag remove bold 1.0 end
3348 $cflist conf -state disabled
3351 proc add_flist {fl} {
3352 global cflist
3354 $cflist conf -state normal
3355 foreach f $fl {
3356 $cflist insert end "\n"
3357 $cflist insert end $f [highlight_tag $f]
3359 $cflist conf -state disabled
3362 proc sel_flist {w x y} {
3363 global ctext difffilestart cflist cflist_top cmitmode
3365 if {$cmitmode eq "tree"} return
3366 if {![info exists cflist_top]} return
3367 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3368 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3369 $cflist tag add highlight $l.0 "$l.0 lineend"
3370 set cflist_top $l
3371 if {$l == 1} {
3372 $ctext yview 1.0
3373 } else {
3374 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3376 suppress_highlighting_file_for_current_scrollpos
3379 proc pop_flist_menu {w X Y x y} {
3380 global ctext cflist cmitmode flist_menu flist_menu_file
3381 global treediffs diffids
3383 stopfinding
3384 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3385 if {$l <= 1} return
3386 if {$cmitmode eq "tree"} {
3387 set e [linetoelt $l]
3388 if {[string index $e end] eq "/"} return
3389 } else {
3390 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3392 set flist_menu_file $e
3393 set xdiffstate "normal"
3394 if {$cmitmode eq "tree"} {
3395 set xdiffstate "disabled"
3397 # Disable "External diff" item in tree mode
3398 $flist_menu entryconf 2 -state $xdiffstate
3399 tk_popup $flist_menu $X $Y
3402 proc find_ctext_fileinfo {line} {
3403 global ctext_file_names ctext_file_lines
3405 set ok [bsearch $ctext_file_lines $line]
3406 set tline [lindex $ctext_file_lines $ok]
3408 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3409 return {}
3410 } else {
3411 return [list [lindex $ctext_file_names $ok] $tline]
3415 proc pop_diff_menu {w X Y x y} {
3416 global ctext diff_menu flist_menu_file
3417 global diff_menu_txtpos diff_menu_line
3418 global diff_menu_filebase
3420 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3421 set diff_menu_line [lindex $diff_menu_txtpos 0]
3422 # don't pop up the menu on hunk-separator or file-separator lines
3423 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3424 return
3426 stopfinding
3427 set f [find_ctext_fileinfo $diff_menu_line]
3428 if {$f eq {}} return
3429 set flist_menu_file [lindex $f 0]
3430 set diff_menu_filebase [lindex $f 1]
3431 tk_popup $diff_menu $X $Y
3434 proc flist_hl {only} {
3435 global flist_menu_file findstring gdttype
3437 set x [shellquote $flist_menu_file]
3438 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3439 set findstring $x
3440 } else {
3441 append findstring " " $x
3443 set gdttype [mc "touching paths:"]
3446 proc gitknewtmpdir {} {
3447 global diffnum gitktmpdir gitdir
3449 if {![info exists gitktmpdir]} {
3450 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3451 if {[catch {file mkdir $gitktmpdir} err]} {
3452 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3453 unset gitktmpdir
3454 return {}
3456 set diffnum 0
3458 incr diffnum
3459 set diffdir [file join $gitktmpdir $diffnum]
3460 if {[catch {file mkdir $diffdir} err]} {
3461 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3462 return {}
3464 return $diffdir
3467 proc save_file_from_commit {filename output what} {
3468 global nullfile
3470 if {[catch {exec git show $filename -- > $output} err]} {
3471 if {[string match "fatal: bad revision *" $err]} {
3472 return $nullfile
3474 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3475 return {}
3477 return $output
3480 proc external_diff_get_one_file {diffid filename diffdir} {
3481 global nullid nullid2 nullfile
3482 global worktree
3484 if {$diffid == $nullid} {
3485 set difffile [file join $worktree $filename]
3486 if {[file exists $difffile]} {
3487 return $difffile
3489 return $nullfile
3491 if {$diffid == $nullid2} {
3492 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3493 return [save_file_from_commit :$filename $difffile index]
3495 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3496 return [save_file_from_commit $diffid:$filename $difffile \
3497 "revision $diffid"]
3500 proc external_diff {} {
3501 global nullid nullid2
3502 global flist_menu_file
3503 global diffids
3504 global extdifftool
3506 if {[llength $diffids] == 1} {
3507 # no reference commit given
3508 set diffidto [lindex $diffids 0]
3509 if {$diffidto eq $nullid} {
3510 # diffing working copy with index
3511 set diffidfrom $nullid2
3512 } elseif {$diffidto eq $nullid2} {
3513 # diffing index with HEAD
3514 set diffidfrom "HEAD"
3515 } else {
3516 # use first parent commit
3517 global parentlist selectedline
3518 set diffidfrom [lindex $parentlist $selectedline 0]
3520 } else {
3521 set diffidfrom [lindex $diffids 0]
3522 set diffidto [lindex $diffids 1]
3525 # make sure that several diffs wont collide
3526 set diffdir [gitknewtmpdir]
3527 if {$diffdir eq {}} return
3529 # gather files to diff
3530 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3531 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3533 if {$difffromfile ne {} && $difftofile ne {}} {
3534 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3535 if {[catch {set fl [open |$cmd r]} err]} {
3536 file delete -force $diffdir
3537 error_popup "$extdifftool: [mc "command failed:"] $err"
3538 } else {
3539 fconfigure $fl -blocking 0
3540 filerun $fl [list delete_at_eof $fl $diffdir]
3545 proc find_hunk_blamespec {base line} {
3546 global ctext
3548 # Find and parse the hunk header
3549 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3550 if {$s_lix eq {}} return
3552 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3553 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3554 s_line old_specs osz osz1 new_line nsz]} {
3555 return
3558 # base lines for the parents
3559 set base_lines [list $new_line]
3560 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3561 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3562 old_spec old_line osz]} {
3563 return
3565 lappend base_lines $old_line
3568 # Now scan the lines to determine offset within the hunk
3569 set max_parent [expr {[llength $base_lines]-2}]
3570 set dline 0
3571 set s_lno [lindex [split $s_lix "."] 0]
3573 # Determine if the line is removed
3574 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3575 if {[string match {[-+ ]*} $chunk]} {
3576 set removed_idx [string first "-" $chunk]
3577 # Choose a parent index
3578 if {$removed_idx >= 0} {
3579 set parent $removed_idx
3580 } else {
3581 set unchanged_idx [string first " " $chunk]
3582 if {$unchanged_idx >= 0} {
3583 set parent $unchanged_idx
3584 } else {
3585 # blame the current commit
3586 set parent -1
3589 # then count other lines that belong to it
3590 for {set i $line} {[incr i -1] > $s_lno} {} {
3591 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3592 # Determine if the line is removed
3593 set removed_idx [string first "-" $chunk]
3594 if {$parent >= 0} {
3595 set code [string index $chunk $parent]
3596 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3597 incr dline
3599 } else {
3600 if {$removed_idx < 0} {
3601 incr dline
3605 incr parent
3606 } else {
3607 set parent 0
3610 incr dline [lindex $base_lines $parent]
3611 return [list $parent $dline]
3614 proc external_blame_diff {} {
3615 global currentid cmitmode
3616 global diff_menu_txtpos diff_menu_line
3617 global diff_menu_filebase flist_menu_file
3619 if {$cmitmode eq "tree"} {
3620 set parent_idx 0
3621 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3622 } else {
3623 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3624 if {$hinfo ne {}} {
3625 set parent_idx [lindex $hinfo 0]
3626 set line [lindex $hinfo 1]
3627 } else {
3628 set parent_idx 0
3629 set line 0
3633 external_blame $parent_idx $line
3636 # Find the SHA1 ID of the blob for file $fname in the index
3637 # at stage 0 or 2
3638 proc index_sha1 {fname} {
3639 set f [open [list | git ls-files -s $fname] r]
3640 while {[gets $f line] >= 0} {
3641 set info [lindex [split $line "\t"] 0]
3642 set stage [lindex $info 2]
3643 if {$stage eq "0" || $stage eq "2"} {
3644 close $f
3645 return [lindex $info 1]
3648 close $f
3649 return {}
3652 # Turn an absolute path into one relative to the current directory
3653 proc make_relative {f} {
3654 if {[file pathtype $f] eq "relative"} {
3655 return $f
3657 set elts [file split $f]
3658 set here [file split [pwd]]
3659 set ei 0
3660 set hi 0
3661 set res {}
3662 foreach d $here {
3663 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3664 lappend res ".."
3665 } else {
3666 incr ei
3668 incr hi
3670 set elts [concat $res [lrange $elts $ei end]]
3671 return [eval file join $elts]
3674 proc external_blame {parent_idx {line {}}} {
3675 global flist_menu_file cdup
3676 global nullid nullid2
3677 global parentlist selectedline currentid
3679 if {$parent_idx > 0} {
3680 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3681 } else {
3682 set base_commit $currentid
3685 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3686 error_popup [mc "No such commit"]
3687 return
3690 set cmdline [list git gui blame]
3691 if {$line ne {} && $line > 1} {
3692 lappend cmdline "--line=$line"
3694 set f [file join $cdup $flist_menu_file]
3695 # Unfortunately it seems git gui blame doesn't like
3696 # being given an absolute path...
3697 set f [make_relative $f]
3698 lappend cmdline $base_commit $f
3699 if {[catch {eval exec $cmdline &} err]} {
3700 error_popup "[mc "git gui blame: command failed:"] $err"
3704 proc show_line_source {} {
3705 global cmitmode currentid parents curview blamestuff blameinst
3706 global diff_menu_line diff_menu_filebase flist_menu_file
3707 global nullid nullid2 gitdir cdup
3709 set from_index {}
3710 if {$cmitmode eq "tree"} {
3711 set id $currentid
3712 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3713 } else {
3714 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3715 if {$h eq {}} return
3716 set pi [lindex $h 0]
3717 if {$pi == 0} {
3718 mark_ctext_line $diff_menu_line
3719 return
3721 incr pi -1
3722 if {$currentid eq $nullid} {
3723 if {$pi > 0} {
3724 # must be a merge in progress...
3725 if {[catch {
3726 # get the last line from .git/MERGE_HEAD
3727 set f [open [file join $gitdir MERGE_HEAD] r]
3728 set id [lindex [split [read $f] "\n"] end-1]
3729 close $f
3730 } err]} {
3731 error_popup [mc "Couldn't read merge head: %s" $err]
3732 return
3734 } elseif {$parents($curview,$currentid) eq $nullid2} {
3735 # need to do the blame from the index
3736 if {[catch {
3737 set from_index [index_sha1 $flist_menu_file]
3738 } err]} {
3739 error_popup [mc "Error reading index: %s" $err]
3740 return
3742 } else {
3743 set id $parents($curview,$currentid)
3745 } else {
3746 set id [lindex $parents($curview,$currentid) $pi]
3748 set line [lindex $h 1]
3750 set blameargs {}
3751 if {$from_index ne {}} {
3752 lappend blameargs | git cat-file blob $from_index
3754 lappend blameargs | git blame -p -L$line,+1
3755 if {$from_index ne {}} {
3756 lappend blameargs --contents -
3757 } else {
3758 lappend blameargs $id
3760 lappend blameargs -- [file join $cdup $flist_menu_file]
3761 if {[catch {
3762 set f [open $blameargs r]
3763 } err]} {
3764 error_popup [mc "Couldn't start git blame: %s" $err]
3765 return
3767 nowbusy blaming [mc "Searching"]
3768 fconfigure $f -blocking 0
3769 set i [reg_instance $f]
3770 set blamestuff($i) {}
3771 set blameinst $i
3772 filerun $f [list read_line_source $f $i]
3775 proc stopblaming {} {
3776 global blameinst
3778 if {[info exists blameinst]} {
3779 stop_instance $blameinst
3780 unset blameinst
3781 notbusy blaming
3785 proc read_line_source {fd inst} {
3786 global blamestuff curview commfd blameinst nullid nullid2
3788 while {[gets $fd line] >= 0} {
3789 lappend blamestuff($inst) $line
3791 if {![eof $fd]} {
3792 return 1
3794 unset commfd($inst)
3795 unset blameinst
3796 notbusy blaming
3797 fconfigure $fd -blocking 1
3798 if {[catch {close $fd} err]} {
3799 error_popup [mc "Error running git blame: %s" $err]
3800 return 0
3803 set fname {}
3804 set line [split [lindex $blamestuff($inst) 0] " "]
3805 set id [lindex $line 0]
3806 set lnum [lindex $line 1]
3807 if {[string length $id] == 40 && [string is xdigit $id] &&
3808 [string is digit -strict $lnum]} {
3809 # look for "filename" line
3810 foreach l $blamestuff($inst) {
3811 if {[string match "filename *" $l]} {
3812 set fname [string range $l 9 end]
3813 break
3817 if {$fname ne {}} {
3818 # all looks good, select it
3819 if {$id eq $nullid} {
3820 # blame uses all-zeroes to mean not committed,
3821 # which would mean a change in the index
3822 set id $nullid2
3824 if {[commitinview $id $curview]} {
3825 selectline [rowofcommit $id] 1 [list $fname $lnum]
3826 } else {
3827 error_popup [mc "That line comes from commit %s, \
3828 which is not in this view" [shortids $id]]
3830 } else {
3831 puts "oops couldn't parse git blame output"
3833 return 0
3836 # delete $dir when we see eof on $f (presumably because the child has exited)
3837 proc delete_at_eof {f dir} {
3838 while {[gets $f line] >= 0} {}
3839 if {[eof $f]} {
3840 if {[catch {close $f} err]} {
3841 error_popup "[mc "External diff viewer failed:"] $err"
3843 file delete -force $dir
3844 return 0
3846 return 1
3849 # Functions for adding and removing shell-type quoting
3851 proc shellquote {str} {
3852 if {![string match "*\['\"\\ \t]*" $str]} {
3853 return $str
3855 if {![string match "*\['\"\\]*" $str]} {
3856 return "\"$str\""
3858 if {![string match "*'*" $str]} {
3859 return "'$str'"
3861 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3864 proc shellarglist {l} {
3865 set str {}
3866 foreach a $l {
3867 if {$str ne {}} {
3868 append str " "
3870 append str [shellquote $a]
3872 return $str
3875 proc shelldequote {str} {
3876 set ret {}
3877 set used -1
3878 while {1} {
3879 incr used
3880 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3881 append ret [string range $str $used end]
3882 set used [string length $str]
3883 break
3885 set first [lindex $first 0]
3886 set ch [string index $str $first]
3887 if {$first > $used} {
3888 append ret [string range $str $used [expr {$first - 1}]]
3889 set used $first
3891 if {$ch eq " " || $ch eq "\t"} break
3892 incr used
3893 if {$ch eq "'"} {
3894 set first [string first "'" $str $used]
3895 if {$first < 0} {
3896 error "unmatched single-quote"
3898 append ret [string range $str $used [expr {$first - 1}]]
3899 set used $first
3900 continue
3902 if {$ch eq "\\"} {
3903 if {$used >= [string length $str]} {
3904 error "trailing backslash"
3906 append ret [string index $str $used]
3907 continue
3909 # here ch == "\""
3910 while {1} {
3911 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3912 error "unmatched double-quote"
3914 set first [lindex $first 0]
3915 set ch [string index $str $first]
3916 if {$first > $used} {
3917 append ret [string range $str $used [expr {$first - 1}]]
3918 set used $first
3920 if {$ch eq "\""} break
3921 incr used
3922 append ret [string index $str $used]
3923 incr used
3926 return [list $used $ret]
3929 proc shellsplit {str} {
3930 set l {}
3931 while {1} {
3932 set str [string trimleft $str]
3933 if {$str eq {}} break
3934 set dq [shelldequote $str]
3935 set n [lindex $dq 0]
3936 set word [lindex $dq 1]
3937 set str [string range $str $n end]
3938 lappend l $word
3940 return $l
3943 # Code to implement multiple views
3945 proc newview {ishighlight} {
3946 global nextviewnum newviewname newishighlight
3947 global revtreeargs viewargscmd newviewopts curview
3949 set newishighlight $ishighlight
3950 set top .gitkview
3951 if {[winfo exists $top]} {
3952 raise $top
3953 return
3955 decode_view_opts $nextviewnum $revtreeargs
3956 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3957 set newviewopts($nextviewnum,perm) 0
3958 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3959 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3962 set known_view_options {
3963 {perm b . {} {mc "Remember this view"}}
3964 {reflabel l + {} {mc "References (space separated list):"}}
3965 {refs t15 .. {} {mc "Branches & tags:"}}
3966 {allrefs b *. "--all" {mc "All refs"}}
3967 {branches b . "--branches" {mc "All (local) branches"}}
3968 {tags b . "--tags" {mc "All tags"}}
3969 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3970 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3971 {author t15 .. "--author=*" {mc "Author:"}}
3972 {committer t15 . "--committer=*" {mc "Committer:"}}
3973 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3974 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3975 {changes_l l + {} {mc "Changes to Files:"}}
3976 {pickaxe_s r0 . {} {mc "Fixed String"}}
3977 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3978 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3979 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3980 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3981 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3982 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3983 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3984 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3985 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3986 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3987 {lright b . "--left-right" {mc "Mark branch sides"}}
3988 {first b . "--first-parent" {mc "Limit to first parent"}}
3989 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3990 {args t50 *. {} {mc "Additional arguments to git log:"}}
3991 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3992 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3995 # Convert $newviewopts($n, ...) into args for git log.
3996 proc encode_view_opts {n} {
3997 global known_view_options newviewopts
3999 set rargs [list]
4000 foreach opt $known_view_options {
4001 set patterns [lindex $opt 3]
4002 if {$patterns eq {}} continue
4003 set pattern [lindex $patterns 0]
4005 if {[lindex $opt 1] eq "b"} {
4006 set val $newviewopts($n,[lindex $opt 0])
4007 if {$val} {
4008 lappend rargs $pattern
4010 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4011 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4012 set val $newviewopts($n,$button_id)
4013 if {$val eq $value} {
4014 lappend rargs $pattern
4016 } else {
4017 set val $newviewopts($n,[lindex $opt 0])
4018 set val [string trim $val]
4019 if {$val ne {}} {
4020 set pfix [string range $pattern 0 end-1]
4021 lappend rargs $pfix$val
4025 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4026 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4029 # Fill $newviewopts($n, ...) based on args for git log.
4030 proc decode_view_opts {n view_args} {
4031 global known_view_options newviewopts
4033 foreach opt $known_view_options {
4034 set id [lindex $opt 0]
4035 if {[lindex $opt 1] eq "b"} {
4036 # Checkboxes
4037 set val 0
4038 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4039 # Radiobuttons
4040 regexp {^(.*_)} $id uselessvar id
4041 set val 0
4042 } else {
4043 # Text fields
4044 set val {}
4046 set newviewopts($n,$id) $val
4048 set oargs [list]
4049 set refargs [list]
4050 foreach arg $view_args {
4051 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4052 && ![info exists found(limit)]} {
4053 set newviewopts($n,limit) $cnt
4054 set found(limit) 1
4055 continue
4057 catch { unset val }
4058 foreach opt $known_view_options {
4059 set id [lindex $opt 0]
4060 if {[info exists found($id)]} continue
4061 foreach pattern [lindex $opt 3] {
4062 if {![string match $pattern $arg]} continue
4063 if {[lindex $opt 1] eq "b"} {
4064 # Check buttons
4065 set val 1
4066 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4067 # Radio buttons
4068 regexp {^(.*_)} $id uselessvar id
4069 set val $num
4070 } else {
4071 # Text input fields
4072 set size [string length $pattern]
4073 set val [string range $arg [expr {$size-1}] end]
4075 set newviewopts($n,$id) $val
4076 set found($id) 1
4077 break
4079 if {[info exists val]} break
4081 if {[info exists val]} continue
4082 if {[regexp {^-} $arg]} {
4083 lappend oargs $arg
4084 } else {
4085 lappend refargs $arg
4088 set newviewopts($n,refs) [shellarglist $refargs]
4089 set newviewopts($n,args) [shellarglist $oargs]
4092 proc edit_or_newview {} {
4093 global curview
4095 if {$curview > 0} {
4096 editview
4097 } else {
4098 newview 0
4102 proc editview {} {
4103 global curview
4104 global viewname viewperm newviewname newviewopts
4105 global viewargs viewargscmd
4107 set top .gitkvedit-$curview
4108 if {[winfo exists $top]} {
4109 raise $top
4110 return
4112 decode_view_opts $curview $viewargs($curview)
4113 set newviewname($curview) $viewname($curview)
4114 set newviewopts($curview,perm) $viewperm($curview)
4115 set newviewopts($curview,cmd) $viewargscmd($curview)
4116 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4119 proc vieweditor {top n title} {
4120 global newviewname newviewopts viewfiles bgcolor
4121 global known_view_options NS
4123 ttk_toplevel $top
4124 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4125 make_transient $top .
4127 # View name
4128 ${NS}::frame $top.nfr
4129 ${NS}::label $top.nl -text [mc "View Name"]
4130 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4131 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4132 pack $top.nl -in $top.nfr -side left -padx {0 5}
4133 pack $top.name -in $top.nfr -side left -padx {0 25}
4135 # View options
4136 set cframe $top.nfr
4137 set cexpand 0
4138 set cnt 0
4139 foreach opt $known_view_options {
4140 set id [lindex $opt 0]
4141 set type [lindex $opt 1]
4142 set flags [lindex $opt 2]
4143 set title [eval [lindex $opt 4]]
4144 set lxpad 0
4146 if {$flags eq "+" || $flags eq "*"} {
4147 set cframe $top.fr$cnt
4148 incr cnt
4149 ${NS}::frame $cframe
4150 pack $cframe -in $top -fill x -pady 3 -padx 3
4151 set cexpand [expr {$flags eq "*"}]
4152 } elseif {$flags eq ".." || $flags eq "*."} {
4153 set cframe $top.fr$cnt
4154 incr cnt
4155 ${NS}::frame $cframe
4156 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4157 set cexpand [expr {$flags eq "*."}]
4158 } else {
4159 set lxpad 5
4162 if {$type eq "l"} {
4163 ${NS}::label $cframe.l_$id -text $title
4164 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4165 } elseif {$type eq "b"} {
4166 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4167 pack $cframe.c_$id -in $cframe -side left \
4168 -padx [list $lxpad 0] -expand $cexpand -anchor w
4169 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4170 regexp {^(.*_)} $id uselessvar button_id
4171 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4172 pack $cframe.c_$id -in $cframe -side left \
4173 -padx [list $lxpad 0] -expand $cexpand -anchor w
4174 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4175 ${NS}::label $cframe.l_$id -text $title
4176 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4177 -textvariable newviewopts($n,$id)
4178 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4179 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4180 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4181 ${NS}::label $cframe.l_$id -text $title
4182 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4183 -textvariable newviewopts($n,$id)
4184 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4185 pack $cframe.e_$id -in $cframe -side top -fill x
4186 } elseif {$type eq "path"} {
4187 ${NS}::label $top.l -text $title
4188 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4189 text $top.t -width 40 -height 5 -background $bgcolor
4190 if {[info exists viewfiles($n)]} {
4191 foreach f $viewfiles($n) {
4192 $top.t insert end $f
4193 $top.t insert end "\n"
4195 $top.t delete {end - 1c} end
4196 $top.t mark set insert 0.0
4198 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4202 ${NS}::frame $top.buts
4203 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4204 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4205 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4206 bind $top <Control-Return> [list newviewok $top $n]
4207 bind $top <F5> [list newviewok $top $n 1]
4208 bind $top <Escape> [list destroy $top]
4209 grid $top.buts.ok $top.buts.apply $top.buts.can
4210 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4211 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4212 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4213 pack $top.buts -in $top -side top -fill x
4214 focus $top.t
4217 proc doviewmenu {m first cmd op argv} {
4218 set nmenu [$m index end]
4219 for {set i $first} {$i <= $nmenu} {incr i} {
4220 if {[$m entrycget $i -command] eq $cmd} {
4221 eval $m $op $i $argv
4222 break
4227 proc allviewmenus {n op args} {
4228 # global viewhlmenu
4230 doviewmenu .bar.view 5 [list showview $n] $op $args
4231 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4234 proc newviewok {top n {apply 0}} {
4235 global nextviewnum newviewperm newviewname newishighlight
4236 global viewname viewfiles viewperm selectedview curview
4237 global viewargs viewargscmd newviewopts viewhlmenu
4239 if {[catch {
4240 set newargs [encode_view_opts $n]
4241 } err]} {
4242 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4243 return
4245 set files {}
4246 foreach f [split [$top.t get 0.0 end] "\n"] {
4247 set ft [string trim $f]
4248 if {$ft ne {}} {
4249 lappend files $ft
4252 if {![info exists viewfiles($n)]} {
4253 # creating a new view
4254 incr nextviewnum
4255 set viewname($n) $newviewname($n)
4256 set viewperm($n) $newviewopts($n,perm)
4257 set viewfiles($n) $files
4258 set viewargs($n) $newargs
4259 set viewargscmd($n) $newviewopts($n,cmd)
4260 addviewmenu $n
4261 if {!$newishighlight} {
4262 run showview $n
4263 } else {
4264 run addvhighlight $n
4266 } else {
4267 # editing an existing view
4268 set viewperm($n) $newviewopts($n,perm)
4269 if {$newviewname($n) ne $viewname($n)} {
4270 set viewname($n) $newviewname($n)
4271 doviewmenu .bar.view 5 [list showview $n] \
4272 entryconf [list -label $viewname($n)]
4273 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4274 # entryconf [list -label $viewname($n) -value $viewname($n)]
4276 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4277 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4278 set viewfiles($n) $files
4279 set viewargs($n) $newargs
4280 set viewargscmd($n) $newviewopts($n,cmd)
4281 if {$curview == $n} {
4282 run reloadcommits
4286 if {$apply} return
4287 catch {destroy $top}
4290 proc delview {} {
4291 global curview viewperm hlview selectedhlview
4293 if {$curview == 0} return
4294 if {[info exists hlview] && $hlview == $curview} {
4295 set selectedhlview [mc "None"]
4296 unset hlview
4298 allviewmenus $curview delete
4299 set viewperm($curview) 0
4300 showview 0
4303 proc addviewmenu {n} {
4304 global viewname viewhlmenu
4306 .bar.view add radiobutton -label $viewname($n) \
4307 -command [list showview $n] -variable selectedview -value $n
4308 #$viewhlmenu add radiobutton -label $viewname($n) \
4309 # -command [list addvhighlight $n] -variable selectedhlview
4312 proc showview {n} {
4313 global curview cached_commitrow ordertok
4314 global displayorder parentlist rowidlist rowisopt rowfinal
4315 global colormap rowtextx nextcolor canvxmax
4316 global numcommits viewcomplete
4317 global selectedline currentid canv canvy0
4318 global treediffs
4319 global pending_select mainheadid
4320 global commitidx
4321 global selectedview
4322 global hlview selectedhlview commitinterest
4324 if {$n == $curview} return
4325 set selid {}
4326 set ymax [lindex [$canv cget -scrollregion] 3]
4327 set span [$canv yview]
4328 set ytop [expr {[lindex $span 0] * $ymax}]
4329 set ybot [expr {[lindex $span 1] * $ymax}]
4330 set yscreen [expr {($ybot - $ytop) / 2}]
4331 if {$selectedline ne {}} {
4332 set selid $currentid
4333 set y [yc $selectedline]
4334 if {$ytop < $y && $y < $ybot} {
4335 set yscreen [expr {$y - $ytop}]
4337 } elseif {[info exists pending_select]} {
4338 set selid $pending_select
4339 unset pending_select
4341 unselectline
4342 normalline
4343 catch {unset treediffs}
4344 clear_display
4345 if {[info exists hlview] && $hlview == $n} {
4346 unset hlview
4347 set selectedhlview [mc "None"]
4349 catch {unset commitinterest}
4350 catch {unset cached_commitrow}
4351 catch {unset ordertok}
4353 set curview $n
4354 set selectedview $n
4355 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4356 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4358 run refill_reflist
4359 if {![info exists viewcomplete($n)]} {
4360 getcommits $selid
4361 return
4364 set displayorder {}
4365 set parentlist {}
4366 set rowidlist {}
4367 set rowisopt {}
4368 set rowfinal {}
4369 set numcommits $commitidx($n)
4371 catch {unset colormap}
4372 catch {unset rowtextx}
4373 set nextcolor 0
4374 set canvxmax [$canv cget -width]
4375 set curview $n
4376 set row 0
4377 setcanvscroll
4378 set yf 0
4379 set row {}
4380 if {$selid ne {} && [commitinview $selid $n]} {
4381 set row [rowofcommit $selid]
4382 # try to get the selected row in the same position on the screen
4383 set ymax [lindex [$canv cget -scrollregion] 3]
4384 set ytop [expr {[yc $row] - $yscreen}]
4385 if {$ytop < 0} {
4386 set ytop 0
4388 set yf [expr {$ytop * 1.0 / $ymax}]
4390 allcanvs yview moveto $yf
4391 drawvisible
4392 if {$row ne {}} {
4393 selectline $row 0
4394 } elseif {!$viewcomplete($n)} {
4395 reset_pending_select $selid
4396 } else {
4397 reset_pending_select {}
4399 if {[commitinview $pending_select $curview]} {
4400 selectline [rowofcommit $pending_select] 1
4401 } else {
4402 set row [first_real_row]
4403 if {$row < $numcommits} {
4404 selectline $row 0
4408 if {!$viewcomplete($n)} {
4409 if {$numcommits == 0} {
4410 show_status [mc "Reading commits..."]
4412 } elseif {$numcommits == 0} {
4413 show_status [mc "No commits selected"]
4417 # Stuff relating to the highlighting facility
4419 proc ishighlighted {id} {
4420 global vhighlights fhighlights nhighlights rhighlights
4422 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4423 return $nhighlights($id)
4425 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4426 return $vhighlights($id)
4428 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4429 return $fhighlights($id)
4431 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4432 return $rhighlights($id)
4434 return 0
4437 proc bolden {id font} {
4438 global canv linehtag currentid boldids need_redisplay markedid
4440 # need_redisplay = 1 means the display is stale and about to be redrawn
4441 if {$need_redisplay} return
4442 lappend boldids $id
4443 $canv itemconf $linehtag($id) -font $font
4444 if {[info exists currentid] && $id eq $currentid} {
4445 $canv delete secsel
4446 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4447 -outline {{}} -tags secsel \
4448 -fill [$canv cget -selectbackground]]
4449 $canv lower $t
4451 if {[info exists markedid] && $id eq $markedid} {
4452 make_idmark $id
4456 proc bolden_name {id font} {
4457 global canv2 linentag currentid boldnameids need_redisplay
4459 if {$need_redisplay} return
4460 lappend boldnameids $id
4461 $canv2 itemconf $linentag($id) -font $font
4462 if {[info exists currentid] && $id eq $currentid} {
4463 $canv2 delete secsel
4464 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4465 -outline {{}} -tags secsel \
4466 -fill [$canv2 cget -selectbackground]]
4467 $canv2 lower $t
4471 proc unbolden {} {
4472 global boldids
4474 set stillbold {}
4475 foreach id $boldids {
4476 if {![ishighlighted $id]} {
4477 bolden $id mainfont
4478 } else {
4479 lappend stillbold $id
4482 set boldids $stillbold
4485 proc addvhighlight {n} {
4486 global hlview viewcomplete curview vhl_done commitidx
4488 if {[info exists hlview]} {
4489 delvhighlight
4491 set hlview $n
4492 if {$n != $curview && ![info exists viewcomplete($n)]} {
4493 start_rev_list $n
4495 set vhl_done $commitidx($hlview)
4496 if {$vhl_done > 0} {
4497 drawvisible
4501 proc delvhighlight {} {
4502 global hlview vhighlights
4504 if {![info exists hlview]} return
4505 unset hlview
4506 catch {unset vhighlights}
4507 unbolden
4510 proc vhighlightmore {} {
4511 global hlview vhl_done commitidx vhighlights curview
4513 set max $commitidx($hlview)
4514 set vr [visiblerows]
4515 set r0 [lindex $vr 0]
4516 set r1 [lindex $vr 1]
4517 for {set i $vhl_done} {$i < $max} {incr i} {
4518 set id [commitonrow $i $hlview]
4519 if {[commitinview $id $curview]} {
4520 set row [rowofcommit $id]
4521 if {$r0 <= $row && $row <= $r1} {
4522 if {![highlighted $row]} {
4523 bolden $id mainfontbold
4525 set vhighlights($id) 1
4529 set vhl_done $max
4530 return 0
4533 proc askvhighlight {row id} {
4534 global hlview vhighlights iddrawn
4536 if {[commitinview $id $hlview]} {
4537 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4538 bolden $id mainfontbold
4540 set vhighlights($id) 1
4541 } else {
4542 set vhighlights($id) 0
4546 proc hfiles_change {} {
4547 global highlight_files filehighlight fhighlights fh_serial
4548 global highlight_paths
4550 if {[info exists filehighlight]} {
4551 # delete previous highlights
4552 catch {close $filehighlight}
4553 unset filehighlight
4554 catch {unset fhighlights}
4555 unbolden
4556 unhighlight_filelist
4558 set highlight_paths {}
4559 after cancel do_file_hl $fh_serial
4560 incr fh_serial
4561 if {$highlight_files ne {}} {
4562 after 300 do_file_hl $fh_serial
4566 proc gdttype_change {name ix op} {
4567 global gdttype highlight_files findstring findpattern
4569 stopfinding
4570 if {$findstring ne {}} {
4571 if {$gdttype eq [mc "containing:"]} {
4572 if {$highlight_files ne {}} {
4573 set highlight_files {}
4574 hfiles_change
4576 findcom_change
4577 } else {
4578 if {$findpattern ne {}} {
4579 set findpattern {}
4580 findcom_change
4582 set highlight_files $findstring
4583 hfiles_change
4585 drawvisible
4587 # enable/disable findtype/findloc menus too
4590 proc find_change {name ix op} {
4591 global gdttype findstring highlight_files
4593 stopfinding
4594 if {$gdttype eq [mc "containing:"]} {
4595 findcom_change
4596 } else {
4597 if {$highlight_files ne $findstring} {
4598 set highlight_files $findstring
4599 hfiles_change
4602 drawvisible
4605 proc findcom_change args {
4606 global nhighlights boldnameids
4607 global findpattern findtype findstring gdttype
4609 stopfinding
4610 # delete previous highlights, if any
4611 foreach id $boldnameids {
4612 bolden_name $id mainfont
4614 set boldnameids {}
4615 catch {unset nhighlights}
4616 unbolden
4617 unmarkmatches
4618 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4619 set findpattern {}
4620 } elseif {$findtype eq [mc "Regexp"]} {
4621 set findpattern $findstring
4622 } else {
4623 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4624 $findstring]
4625 set findpattern "*$e*"
4629 proc makepatterns {l} {
4630 set ret {}
4631 foreach e $l {
4632 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4633 if {[string index $ee end] eq "/"} {
4634 lappend ret "$ee*"
4635 } else {
4636 lappend ret $ee
4637 lappend ret "$ee/*"
4640 return $ret
4643 proc do_file_hl {serial} {
4644 global highlight_files filehighlight highlight_paths gdttype fhl_list
4645 global cdup findtype
4647 if {$gdttype eq [mc "touching paths:"]} {
4648 # If "exact" match then convert backslashes to forward slashes.
4649 # Most useful to support Windows-flavoured file paths.
4650 if {$findtype eq [mc "Exact"]} {
4651 set highlight_files [string map {"\\" "/"} $highlight_files]
4653 if {[catch {set paths [shellsplit $highlight_files]}]} return
4654 set highlight_paths [makepatterns $paths]
4655 highlight_filelist
4656 set relative_paths {}
4657 foreach path $paths {
4658 lappend relative_paths [file join $cdup $path]
4660 set gdtargs [concat -- $relative_paths]
4661 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4662 set gdtargs [list "-S$highlight_files"]
4663 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4664 set gdtargs [list "-G$highlight_files"]
4665 } else {
4666 # must be "containing:", i.e. we're searching commit info
4667 return
4669 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4670 set filehighlight [open $cmd r+]
4671 fconfigure $filehighlight -blocking 0
4672 filerun $filehighlight readfhighlight
4673 set fhl_list {}
4674 drawvisible
4675 flushhighlights
4678 proc flushhighlights {} {
4679 global filehighlight fhl_list
4681 if {[info exists filehighlight]} {
4682 lappend fhl_list {}
4683 puts $filehighlight ""
4684 flush $filehighlight
4688 proc askfilehighlight {row id} {
4689 global filehighlight fhighlights fhl_list
4691 lappend fhl_list $id
4692 set fhighlights($id) -1
4693 puts $filehighlight $id
4696 proc readfhighlight {} {
4697 global filehighlight fhighlights curview iddrawn
4698 global fhl_list find_dirn
4700 if {![info exists filehighlight]} {
4701 return 0
4703 set nr 0
4704 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4705 set line [string trim $line]
4706 set i [lsearch -exact $fhl_list $line]
4707 if {$i < 0} continue
4708 for {set j 0} {$j < $i} {incr j} {
4709 set id [lindex $fhl_list $j]
4710 set fhighlights($id) 0
4712 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4713 if {$line eq {}} continue
4714 if {![commitinview $line $curview]} continue
4715 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4716 bolden $line mainfontbold
4718 set fhighlights($line) 1
4720 if {[eof $filehighlight]} {
4721 # strange...
4722 puts "oops, git diff-tree died"
4723 catch {close $filehighlight}
4724 unset filehighlight
4725 return 0
4727 if {[info exists find_dirn]} {
4728 run findmore
4730 return 1
4733 proc doesmatch {f} {
4734 global findtype findpattern
4736 if {$findtype eq [mc "Regexp"]} {
4737 return [regexp $findpattern $f]
4738 } elseif {$findtype eq [mc "IgnCase"]} {
4739 return [string match -nocase $findpattern $f]
4740 } else {
4741 return [string match $findpattern $f]
4745 proc askfindhighlight {row id} {
4746 global nhighlights commitinfo iddrawn
4747 global findloc
4748 global markingmatches
4750 if {![info exists commitinfo($id)]} {
4751 getcommit $id
4753 set info $commitinfo($id)
4754 set isbold 0
4755 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4756 foreach f $info ty $fldtypes {
4757 if {$ty eq ""} continue
4758 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4759 [doesmatch $f]} {
4760 if {$ty eq [mc "Author"]} {
4761 set isbold 2
4762 break
4764 set isbold 1
4767 if {$isbold && [info exists iddrawn($id)]} {
4768 if {![ishighlighted $id]} {
4769 bolden $id mainfontbold
4770 if {$isbold > 1} {
4771 bolden_name $id mainfontbold
4774 if {$markingmatches} {
4775 markrowmatches $row $id
4778 set nhighlights($id) $isbold
4781 proc markrowmatches {row id} {
4782 global canv canv2 linehtag linentag commitinfo findloc
4784 set headline [lindex $commitinfo($id) 0]
4785 set author [lindex $commitinfo($id) 1]
4786 $canv delete match$row
4787 $canv2 delete match$row
4788 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4789 set m [findmatches $headline]
4790 if {$m ne {}} {
4791 markmatches $canv $row $headline $linehtag($id) $m \
4792 [$canv itemcget $linehtag($id) -font] $row
4795 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4796 set m [findmatches $author]
4797 if {$m ne {}} {
4798 markmatches $canv2 $row $author $linentag($id) $m \
4799 [$canv2 itemcget $linentag($id) -font] $row
4804 proc vrel_change {name ix op} {
4805 global highlight_related
4807 rhighlight_none
4808 if {$highlight_related ne [mc "None"]} {
4809 run drawvisible
4813 # prepare for testing whether commits are descendents or ancestors of a
4814 proc rhighlight_sel {a} {
4815 global descendent desc_todo ancestor anc_todo
4816 global highlight_related
4818 catch {unset descendent}
4819 set desc_todo [list $a]
4820 catch {unset ancestor}
4821 set anc_todo [list $a]
4822 if {$highlight_related ne [mc "None"]} {
4823 rhighlight_none
4824 run drawvisible
4828 proc rhighlight_none {} {
4829 global rhighlights
4831 catch {unset rhighlights}
4832 unbolden
4835 proc is_descendent {a} {
4836 global curview children descendent desc_todo
4838 set v $curview
4839 set la [rowofcommit $a]
4840 set todo $desc_todo
4841 set leftover {}
4842 set done 0
4843 for {set i 0} {$i < [llength $todo]} {incr i} {
4844 set do [lindex $todo $i]
4845 if {[rowofcommit $do] < $la} {
4846 lappend leftover $do
4847 continue
4849 foreach nk $children($v,$do) {
4850 if {![info exists descendent($nk)]} {
4851 set descendent($nk) 1
4852 lappend todo $nk
4853 if {$nk eq $a} {
4854 set done 1
4858 if {$done} {
4859 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4860 return
4863 set descendent($a) 0
4864 set desc_todo $leftover
4867 proc is_ancestor {a} {
4868 global curview parents ancestor anc_todo
4870 set v $curview
4871 set la [rowofcommit $a]
4872 set todo $anc_todo
4873 set leftover {}
4874 set done 0
4875 for {set i 0} {$i < [llength $todo]} {incr i} {
4876 set do [lindex $todo $i]
4877 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4878 lappend leftover $do
4879 continue
4881 foreach np $parents($v,$do) {
4882 if {![info exists ancestor($np)]} {
4883 set ancestor($np) 1
4884 lappend todo $np
4885 if {$np eq $a} {
4886 set done 1
4890 if {$done} {
4891 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4892 return
4895 set ancestor($a) 0
4896 set anc_todo $leftover
4899 proc askrelhighlight {row id} {
4900 global descendent highlight_related iddrawn rhighlights
4901 global selectedline ancestor
4903 if {$selectedline eq {}} return
4904 set isbold 0
4905 if {$highlight_related eq [mc "Descendant"] ||
4906 $highlight_related eq [mc "Not descendant"]} {
4907 if {![info exists descendent($id)]} {
4908 is_descendent $id
4910 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4911 set isbold 1
4913 } elseif {$highlight_related eq [mc "Ancestor"] ||
4914 $highlight_related eq [mc "Not ancestor"]} {
4915 if {![info exists ancestor($id)]} {
4916 is_ancestor $id
4918 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4919 set isbold 1
4922 if {[info exists iddrawn($id)]} {
4923 if {$isbold && ![ishighlighted $id]} {
4924 bolden $id mainfontbold
4927 set rhighlights($id) $isbold
4930 # Graph layout functions
4932 proc shortids {ids} {
4933 set res {}
4934 foreach id $ids {
4935 if {[llength $id] > 1} {
4936 lappend res [shortids $id]
4937 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4938 lappend res [string range $id 0 7]
4939 } else {
4940 lappend res $id
4943 return $res
4946 proc ntimes {n o} {
4947 set ret {}
4948 set o [list $o]
4949 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4950 if {($n & $mask) != 0} {
4951 set ret [concat $ret $o]
4953 set o [concat $o $o]
4955 return $ret
4958 proc ordertoken {id} {
4959 global ordertok curview varcid varcstart varctok curview parents children
4960 global nullid nullid2
4962 if {[info exists ordertok($id)]} {
4963 return $ordertok($id)
4965 set origid $id
4966 set todo {}
4967 while {1} {
4968 if {[info exists varcid($curview,$id)]} {
4969 set a $varcid($curview,$id)
4970 set p [lindex $varcstart($curview) $a]
4971 } else {
4972 set p [lindex $children($curview,$id) 0]
4974 if {[info exists ordertok($p)]} {
4975 set tok $ordertok($p)
4976 break
4978 set id [first_real_child $curview,$p]
4979 if {$id eq {}} {
4980 # it's a root
4981 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4982 break
4984 if {[llength $parents($curview,$id)] == 1} {
4985 lappend todo [list $p {}]
4986 } else {
4987 set j [lsearch -exact $parents($curview,$id) $p]
4988 if {$j < 0} {
4989 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4991 lappend todo [list $p [strrep $j]]
4994 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4995 set p [lindex $todo $i 0]
4996 append tok [lindex $todo $i 1]
4997 set ordertok($p) $tok
4999 set ordertok($origid) $tok
5000 return $tok
5003 # Work out where id should go in idlist so that order-token
5004 # values increase from left to right
5005 proc idcol {idlist id {i 0}} {
5006 set t [ordertoken $id]
5007 if {$i < 0} {
5008 set i 0
5010 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5011 if {$i > [llength $idlist]} {
5012 set i [llength $idlist]
5014 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5015 incr i
5016 } else {
5017 if {$t > [ordertoken [lindex $idlist $i]]} {
5018 while {[incr i] < [llength $idlist] &&
5019 $t >= [ordertoken [lindex $idlist $i]]} {}
5022 return $i
5025 proc initlayout {} {
5026 global rowidlist rowisopt rowfinal displayorder parentlist
5027 global numcommits canvxmax canv
5028 global nextcolor
5029 global colormap rowtextx
5031 set numcommits 0
5032 set displayorder {}
5033 set parentlist {}
5034 set nextcolor 0
5035 set rowidlist {}
5036 set rowisopt {}
5037 set rowfinal {}
5038 set canvxmax [$canv cget -width]
5039 catch {unset colormap}
5040 catch {unset rowtextx}
5041 setcanvscroll
5044 proc setcanvscroll {} {
5045 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5046 global lastscrollset lastscrollrows
5048 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5049 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5050 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5051 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5052 set lastscrollset [clock clicks -milliseconds]
5053 set lastscrollrows $numcommits
5056 proc visiblerows {} {
5057 global canv numcommits linespc
5059 set ymax [lindex [$canv cget -scrollregion] 3]
5060 if {$ymax eq {} || $ymax == 0} return
5061 set f [$canv yview]
5062 set y0 [expr {int([lindex $f 0] * $ymax)}]
5063 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5064 if {$r0 < 0} {
5065 set r0 0
5067 set y1 [expr {int([lindex $f 1] * $ymax)}]
5068 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5069 if {$r1 >= $numcommits} {
5070 set r1 [expr {$numcommits - 1}]
5072 return [list $r0 $r1]
5075 proc layoutmore {} {
5076 global commitidx viewcomplete curview
5077 global numcommits pending_select curview
5078 global lastscrollset lastscrollrows
5080 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5081 [clock clicks -milliseconds] - $lastscrollset > 500} {
5082 setcanvscroll
5084 if {[info exists pending_select] &&
5085 [commitinview $pending_select $curview]} {
5086 update
5087 selectline [rowofcommit $pending_select] 1
5089 drawvisible
5092 # With path limiting, we mightn't get the actual HEAD commit,
5093 # so ask git rev-list what is the first ancestor of HEAD that
5094 # touches a file in the path limit.
5095 proc get_viewmainhead {view} {
5096 global viewmainheadid vfilelimit viewinstances mainheadid
5098 catch {
5099 set rfd [open [concat | git rev-list -1 $mainheadid \
5100 -- $vfilelimit($view)] r]
5101 set j [reg_instance $rfd]
5102 lappend viewinstances($view) $j
5103 fconfigure $rfd -blocking 0
5104 filerun $rfd [list getviewhead $rfd $j $view]
5105 set viewmainheadid($curview) {}
5109 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5110 proc getviewhead {fd inst view} {
5111 global viewmainheadid commfd curview viewinstances showlocalchanges
5113 set id {}
5114 if {[gets $fd line] < 0} {
5115 if {![eof $fd]} {
5116 return 1
5118 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5119 set id $line
5121 set viewmainheadid($view) $id
5122 close $fd
5123 unset commfd($inst)
5124 set i [lsearch -exact $viewinstances($view) $inst]
5125 if {$i >= 0} {
5126 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5128 if {$showlocalchanges && $id ne {} && $view == $curview} {
5129 doshowlocalchanges
5131 return 0
5134 proc doshowlocalchanges {} {
5135 global curview viewmainheadid
5137 if {$viewmainheadid($curview) eq {}} return
5138 if {[commitinview $viewmainheadid($curview) $curview]} {
5139 dodiffindex
5140 } else {
5141 interestedin $viewmainheadid($curview) dodiffindex
5145 proc dohidelocalchanges {} {
5146 global nullid nullid2 lserial curview
5148 if {[commitinview $nullid $curview]} {
5149 removefakerow $nullid
5151 if {[commitinview $nullid2 $curview]} {
5152 removefakerow $nullid2
5154 incr lserial
5157 # spawn off a process to do git diff-index --cached HEAD
5158 proc dodiffindex {} {
5159 global lserial showlocalchanges vfilelimit curview
5160 global hasworktree
5162 if {!$showlocalchanges || !$hasworktree} return
5163 incr lserial
5164 set cmd "|git diff-index --cached HEAD"
5165 if {$vfilelimit($curview) ne {}} {
5166 set cmd [concat $cmd -- $vfilelimit($curview)]
5168 set fd [open $cmd r]
5169 fconfigure $fd -blocking 0
5170 set i [reg_instance $fd]
5171 filerun $fd [list readdiffindex $fd $lserial $i]
5174 proc readdiffindex {fd serial inst} {
5175 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5176 global vfilelimit
5178 set isdiff 1
5179 if {[gets $fd line] < 0} {
5180 if {![eof $fd]} {
5181 return 1
5183 set isdiff 0
5185 # we only need to see one line and we don't really care what it says...
5186 stop_instance $inst
5188 if {$serial != $lserial} {
5189 return 0
5192 # now see if there are any local changes not checked in to the index
5193 set cmd "|git diff-files"
5194 if {$vfilelimit($curview) ne {}} {
5195 set cmd [concat $cmd -- $vfilelimit($curview)]
5197 set fd [open $cmd r]
5198 fconfigure $fd -blocking 0
5199 set i [reg_instance $fd]
5200 filerun $fd [list readdifffiles $fd $serial $i]
5202 if {$isdiff && ![commitinview $nullid2 $curview]} {
5203 # add the line for the changes in the index to the graph
5204 set hl [mc "Local changes checked in to index but not committed"]
5205 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5206 set commitdata($nullid2) "\n $hl\n"
5207 if {[commitinview $nullid $curview]} {
5208 removefakerow $nullid
5210 insertfakerow $nullid2 $viewmainheadid($curview)
5211 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5212 if {[commitinview $nullid $curview]} {
5213 removefakerow $nullid
5215 removefakerow $nullid2
5217 return 0
5220 proc readdifffiles {fd serial inst} {
5221 global viewmainheadid nullid nullid2 curview
5222 global commitinfo commitdata lserial
5224 set isdiff 1
5225 if {[gets $fd line] < 0} {
5226 if {![eof $fd]} {
5227 return 1
5229 set isdiff 0
5231 # we only need to see one line and we don't really care what it says...
5232 stop_instance $inst
5234 if {$serial != $lserial} {
5235 return 0
5238 if {$isdiff && ![commitinview $nullid $curview]} {
5239 # add the line for the local diff to the graph
5240 set hl [mc "Local uncommitted changes, not checked in to index"]
5241 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5242 set commitdata($nullid) "\n $hl\n"
5243 if {[commitinview $nullid2 $curview]} {
5244 set p $nullid2
5245 } else {
5246 set p $viewmainheadid($curview)
5248 insertfakerow $nullid $p
5249 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5250 removefakerow $nullid
5252 return 0
5255 proc nextuse {id row} {
5256 global curview children
5258 if {[info exists children($curview,$id)]} {
5259 foreach kid $children($curview,$id) {
5260 if {![commitinview $kid $curview]} {
5261 return -1
5263 if {[rowofcommit $kid] > $row} {
5264 return [rowofcommit $kid]
5268 if {[commitinview $id $curview]} {
5269 return [rowofcommit $id]
5271 return -1
5274 proc prevuse {id row} {
5275 global curview children
5277 set ret -1
5278 if {[info exists children($curview,$id)]} {
5279 foreach kid $children($curview,$id) {
5280 if {![commitinview $kid $curview]} break
5281 if {[rowofcommit $kid] < $row} {
5282 set ret [rowofcommit $kid]
5286 return $ret
5289 proc make_idlist {row} {
5290 global displayorder parentlist uparrowlen downarrowlen mingaplen
5291 global commitidx curview children
5293 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5294 if {$r < 0} {
5295 set r 0
5297 set ra [expr {$row - $downarrowlen}]
5298 if {$ra < 0} {
5299 set ra 0
5301 set rb [expr {$row + $uparrowlen}]
5302 if {$rb > $commitidx($curview)} {
5303 set rb $commitidx($curview)
5305 make_disporder $r [expr {$rb + 1}]
5306 set ids {}
5307 for {} {$r < $ra} {incr r} {
5308 set nextid [lindex $displayorder [expr {$r + 1}]]
5309 foreach p [lindex $parentlist $r] {
5310 if {$p eq $nextid} continue
5311 set rn [nextuse $p $r]
5312 if {$rn >= $row &&
5313 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5314 lappend ids [list [ordertoken $p] $p]
5318 for {} {$r < $row} {incr r} {
5319 set nextid [lindex $displayorder [expr {$r + 1}]]
5320 foreach p [lindex $parentlist $r] {
5321 if {$p eq $nextid} continue
5322 set rn [nextuse $p $r]
5323 if {$rn < 0 || $rn >= $row} {
5324 lappend ids [list [ordertoken $p] $p]
5328 set id [lindex $displayorder $row]
5329 lappend ids [list [ordertoken $id] $id]
5330 while {$r < $rb} {
5331 foreach p [lindex $parentlist $r] {
5332 set firstkid [lindex $children($curview,$p) 0]
5333 if {[rowofcommit $firstkid] < $row} {
5334 lappend ids [list [ordertoken $p] $p]
5337 incr r
5338 set id [lindex $displayorder $r]
5339 if {$id ne {}} {
5340 set firstkid [lindex $children($curview,$id) 0]
5341 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5342 lappend ids [list [ordertoken $id] $id]
5346 set idlist {}
5347 foreach idx [lsort -unique $ids] {
5348 lappend idlist [lindex $idx 1]
5350 return $idlist
5353 proc rowsequal {a b} {
5354 while {[set i [lsearch -exact $a {}]] >= 0} {
5355 set a [lreplace $a $i $i]
5357 while {[set i [lsearch -exact $b {}]] >= 0} {
5358 set b [lreplace $b $i $i]
5360 return [expr {$a eq $b}]
5363 proc makeupline {id row rend col} {
5364 global rowidlist uparrowlen downarrowlen mingaplen
5366 for {set r $rend} {1} {set r $rstart} {
5367 set rstart [prevuse $id $r]
5368 if {$rstart < 0} return
5369 if {$rstart < $row} break
5371 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5372 set rstart [expr {$rend - $uparrowlen - 1}]
5374 for {set r $rstart} {[incr r] <= $row} {} {
5375 set idlist [lindex $rowidlist $r]
5376 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5377 set col [idcol $idlist $id $col]
5378 lset rowidlist $r [linsert $idlist $col $id]
5379 changedrow $r
5384 proc layoutrows {row endrow} {
5385 global rowidlist rowisopt rowfinal displayorder
5386 global uparrowlen downarrowlen maxwidth mingaplen
5387 global children parentlist
5388 global commitidx viewcomplete curview
5390 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5391 set idlist {}
5392 if {$row > 0} {
5393 set rm1 [expr {$row - 1}]
5394 foreach id [lindex $rowidlist $rm1] {
5395 if {$id ne {}} {
5396 lappend idlist $id
5399 set final [lindex $rowfinal $rm1]
5401 for {} {$row < $endrow} {incr row} {
5402 set rm1 [expr {$row - 1}]
5403 if {$rm1 < 0 || $idlist eq {}} {
5404 set idlist [make_idlist $row]
5405 set final 1
5406 } else {
5407 set id [lindex $displayorder $rm1]
5408 set col [lsearch -exact $idlist $id]
5409 set idlist [lreplace $idlist $col $col]
5410 foreach p [lindex $parentlist $rm1] {
5411 if {[lsearch -exact $idlist $p] < 0} {
5412 set col [idcol $idlist $p $col]
5413 set idlist [linsert $idlist $col $p]
5414 # if not the first child, we have to insert a line going up
5415 if {$id ne [lindex $children($curview,$p) 0]} {
5416 makeupline $p $rm1 $row $col
5420 set id [lindex $displayorder $row]
5421 if {$row > $downarrowlen} {
5422 set termrow [expr {$row - $downarrowlen - 1}]
5423 foreach p [lindex $parentlist $termrow] {
5424 set i [lsearch -exact $idlist $p]
5425 if {$i < 0} continue
5426 set nr [nextuse $p $termrow]
5427 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5428 set idlist [lreplace $idlist $i $i]
5432 set col [lsearch -exact $idlist $id]
5433 if {$col < 0} {
5434 set col [idcol $idlist $id]
5435 set idlist [linsert $idlist $col $id]
5436 if {$children($curview,$id) ne {}} {
5437 makeupline $id $rm1 $row $col
5440 set r [expr {$row + $uparrowlen - 1}]
5441 if {$r < $commitidx($curview)} {
5442 set x $col
5443 foreach p [lindex $parentlist $r] {
5444 if {[lsearch -exact $idlist $p] >= 0} continue
5445 set fk [lindex $children($curview,$p) 0]
5446 if {[rowofcommit $fk] < $row} {
5447 set x [idcol $idlist $p $x]
5448 set idlist [linsert $idlist $x $p]
5451 if {[incr r] < $commitidx($curview)} {
5452 set p [lindex $displayorder $r]
5453 if {[lsearch -exact $idlist $p] < 0} {
5454 set fk [lindex $children($curview,$p) 0]
5455 if {$fk ne {} && [rowofcommit $fk] < $row} {
5456 set x [idcol $idlist $p $x]
5457 set idlist [linsert $idlist $x $p]
5463 if {$final && !$viewcomplete($curview) &&
5464 $row + $uparrowlen + $mingaplen + $downarrowlen
5465 >= $commitidx($curview)} {
5466 set final 0
5468 set l [llength $rowidlist]
5469 if {$row == $l} {
5470 lappend rowidlist $idlist
5471 lappend rowisopt 0
5472 lappend rowfinal $final
5473 } elseif {$row < $l} {
5474 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5475 lset rowidlist $row $idlist
5476 changedrow $row
5478 lset rowfinal $row $final
5479 } else {
5480 set pad [ntimes [expr {$row - $l}] {}]
5481 set rowidlist [concat $rowidlist $pad]
5482 lappend rowidlist $idlist
5483 set rowfinal [concat $rowfinal $pad]
5484 lappend rowfinal $final
5485 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5488 return $row
5491 proc changedrow {row} {
5492 global displayorder iddrawn rowisopt need_redisplay
5494 set l [llength $rowisopt]
5495 if {$row < $l} {
5496 lset rowisopt $row 0
5497 if {$row + 1 < $l} {
5498 lset rowisopt [expr {$row + 1}] 0
5499 if {$row + 2 < $l} {
5500 lset rowisopt [expr {$row + 2}] 0
5504 set id [lindex $displayorder $row]
5505 if {[info exists iddrawn($id)]} {
5506 set need_redisplay 1
5510 proc insert_pad {row col npad} {
5511 global rowidlist
5513 set pad [ntimes $npad {}]
5514 set idlist [lindex $rowidlist $row]
5515 set bef [lrange $idlist 0 [expr {$col - 1}]]
5516 set aft [lrange $idlist $col end]
5517 set i [lsearch -exact $aft {}]
5518 if {$i > 0} {
5519 set aft [lreplace $aft $i $i]
5521 lset rowidlist $row [concat $bef $pad $aft]
5522 changedrow $row
5525 proc optimize_rows {row col endrow} {
5526 global rowidlist rowisopt displayorder curview children
5528 if {$row < 1} {
5529 set row 1
5531 for {} {$row < $endrow} {incr row; set col 0} {
5532 if {[lindex $rowisopt $row]} continue
5533 set haspad 0
5534 set y0 [expr {$row - 1}]
5535 set ym [expr {$row - 2}]
5536 set idlist [lindex $rowidlist $row]
5537 set previdlist [lindex $rowidlist $y0]
5538 if {$idlist eq {} || $previdlist eq {}} continue
5539 if {$ym >= 0} {
5540 set pprevidlist [lindex $rowidlist $ym]
5541 if {$pprevidlist eq {}} continue
5542 } else {
5543 set pprevidlist {}
5545 set x0 -1
5546 set xm -1
5547 for {} {$col < [llength $idlist]} {incr col} {
5548 set id [lindex $idlist $col]
5549 if {[lindex $previdlist $col] eq $id} continue
5550 if {$id eq {}} {
5551 set haspad 1
5552 continue
5554 set x0 [lsearch -exact $previdlist $id]
5555 if {$x0 < 0} continue
5556 set z [expr {$x0 - $col}]
5557 set isarrow 0
5558 set z0 {}
5559 if {$ym >= 0} {
5560 set xm [lsearch -exact $pprevidlist $id]
5561 if {$xm >= 0} {
5562 set z0 [expr {$xm - $x0}]
5565 if {$z0 eq {}} {
5566 # if row y0 is the first child of $id then it's not an arrow
5567 if {[lindex $children($curview,$id) 0] ne
5568 [lindex $displayorder $y0]} {
5569 set isarrow 1
5572 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5573 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5574 set isarrow 1
5576 # Looking at lines from this row to the previous row,
5577 # make them go straight up if they end in an arrow on
5578 # the previous row; otherwise make them go straight up
5579 # or at 45 degrees.
5580 if {$z < -1 || ($z < 0 && $isarrow)} {
5581 # Line currently goes left too much;
5582 # insert pads in the previous row, then optimize it
5583 set npad [expr {-1 - $z + $isarrow}]
5584 insert_pad $y0 $x0 $npad
5585 if {$y0 > 0} {
5586 optimize_rows $y0 $x0 $row
5588 set previdlist [lindex $rowidlist $y0]
5589 set x0 [lsearch -exact $previdlist $id]
5590 set z [expr {$x0 - $col}]
5591 if {$z0 ne {}} {
5592 set pprevidlist [lindex $rowidlist $ym]
5593 set xm [lsearch -exact $pprevidlist $id]
5594 set z0 [expr {$xm - $x0}]
5596 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5597 # Line currently goes right too much;
5598 # insert pads in this line
5599 set npad [expr {$z - 1 + $isarrow}]
5600 insert_pad $row $col $npad
5601 set idlist [lindex $rowidlist $row]
5602 incr col $npad
5603 set z [expr {$x0 - $col}]
5604 set haspad 1
5606 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5607 # this line links to its first child on row $row-2
5608 set id [lindex $displayorder $ym]
5609 set xc [lsearch -exact $pprevidlist $id]
5610 if {$xc >= 0} {
5611 set z0 [expr {$xc - $x0}]
5614 # avoid lines jigging left then immediately right
5615 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5616 insert_pad $y0 $x0 1
5617 incr x0
5618 optimize_rows $y0 $x0 $row
5619 set previdlist [lindex $rowidlist $y0]
5622 if {!$haspad} {
5623 # Find the first column that doesn't have a line going right
5624 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5625 set id [lindex $idlist $col]
5626 if {$id eq {}} break
5627 set x0 [lsearch -exact $previdlist $id]
5628 if {$x0 < 0} {
5629 # check if this is the link to the first child
5630 set kid [lindex $displayorder $y0]
5631 if {[lindex $children($curview,$id) 0] eq $kid} {
5632 # it is, work out offset to child
5633 set x0 [lsearch -exact $previdlist $kid]
5636 if {$x0 <= $col} break
5638 # Insert a pad at that column as long as it has a line and
5639 # isn't the last column
5640 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5641 set idlist [linsert $idlist $col {}]
5642 lset rowidlist $row $idlist
5643 changedrow $row
5649 proc xc {row col} {
5650 global canvx0 linespc
5651 return [expr {$canvx0 + $col * $linespc}]
5654 proc yc {row} {
5655 global canvy0 linespc
5656 return [expr {$canvy0 + $row * $linespc}]
5659 proc linewidth {id} {
5660 global thickerline lthickness
5662 set wid $lthickness
5663 if {[info exists thickerline] && $id eq $thickerline} {
5664 set wid [expr {2 * $lthickness}]
5666 return $wid
5669 proc rowranges {id} {
5670 global curview children uparrowlen downarrowlen
5671 global rowidlist
5673 set kids $children($curview,$id)
5674 if {$kids eq {}} {
5675 return {}
5677 set ret {}
5678 lappend kids $id
5679 foreach child $kids {
5680 if {![commitinview $child $curview]} break
5681 set row [rowofcommit $child]
5682 if {![info exists prev]} {
5683 lappend ret [expr {$row + 1}]
5684 } else {
5685 if {$row <= $prevrow} {
5686 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5688 # see if the line extends the whole way from prevrow to row
5689 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5690 [lsearch -exact [lindex $rowidlist \
5691 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5692 # it doesn't, see where it ends
5693 set r [expr {$prevrow + $downarrowlen}]
5694 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5695 while {[incr r -1] > $prevrow &&
5696 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5697 } else {
5698 while {[incr r] <= $row &&
5699 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5700 incr r -1
5702 lappend ret $r
5703 # see where it starts up again
5704 set r [expr {$row - $uparrowlen}]
5705 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5706 while {[incr r] < $row &&
5707 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5708 } else {
5709 while {[incr r -1] >= $prevrow &&
5710 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5711 incr r
5713 lappend ret $r
5716 if {$child eq $id} {
5717 lappend ret $row
5719 set prev $child
5720 set prevrow $row
5722 return $ret
5725 proc drawlineseg {id row endrow arrowlow} {
5726 global rowidlist displayorder iddrawn linesegs
5727 global canv colormap linespc curview maxlinelen parentlist
5729 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5730 set le [expr {$row + 1}]
5731 set arrowhigh 1
5732 while {1} {
5733 set c [lsearch -exact [lindex $rowidlist $le] $id]
5734 if {$c < 0} {
5735 incr le -1
5736 break
5738 lappend cols $c
5739 set x [lindex $displayorder $le]
5740 if {$x eq $id} {
5741 set arrowhigh 0
5742 break
5744 if {[info exists iddrawn($x)] || $le == $endrow} {
5745 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5746 if {$c >= 0} {
5747 lappend cols $c
5748 set arrowhigh 0
5750 break
5752 incr le
5754 if {$le <= $row} {
5755 return $row
5758 set lines {}
5759 set i 0
5760 set joinhigh 0
5761 if {[info exists linesegs($id)]} {
5762 set lines $linesegs($id)
5763 foreach li $lines {
5764 set r0 [lindex $li 0]
5765 if {$r0 > $row} {
5766 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5767 set joinhigh 1
5769 break
5771 incr i
5774 set joinlow 0
5775 if {$i > 0} {
5776 set li [lindex $lines [expr {$i-1}]]
5777 set r1 [lindex $li 1]
5778 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5779 set joinlow 1
5783 set x [lindex $cols [expr {$le - $row}]]
5784 set xp [lindex $cols [expr {$le - 1 - $row}]]
5785 set dir [expr {$xp - $x}]
5786 if {$joinhigh} {
5787 set ith [lindex $lines $i 2]
5788 set coords [$canv coords $ith]
5789 set ah [$canv itemcget $ith -arrow]
5790 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5791 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5792 if {$x2 ne {} && $x - $x2 == $dir} {
5793 set coords [lrange $coords 0 end-2]
5795 } else {
5796 set coords [list [xc $le $x] [yc $le]]
5798 if {$joinlow} {
5799 set itl [lindex $lines [expr {$i-1}] 2]
5800 set al [$canv itemcget $itl -arrow]
5801 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5802 } elseif {$arrowlow} {
5803 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5804 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5805 set arrowlow 0
5808 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5809 for {set y $le} {[incr y -1] > $row} {} {
5810 set x $xp
5811 set xp [lindex $cols [expr {$y - 1 - $row}]]
5812 set ndir [expr {$xp - $x}]
5813 if {$dir != $ndir || $xp < 0} {
5814 lappend coords [xc $y $x] [yc $y]
5816 set dir $ndir
5818 if {!$joinlow} {
5819 if {$xp < 0} {
5820 # join parent line to first child
5821 set ch [lindex $displayorder $row]
5822 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5823 if {$xc < 0} {
5824 puts "oops: drawlineseg: child $ch not on row $row"
5825 } elseif {$xc != $x} {
5826 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5827 set d [expr {int(0.5 * $linespc)}]
5828 set x1 [xc $row $x]
5829 if {$xc < $x} {
5830 set x2 [expr {$x1 - $d}]
5831 } else {
5832 set x2 [expr {$x1 + $d}]
5834 set y2 [yc $row]
5835 set y1 [expr {$y2 + $d}]
5836 lappend coords $x1 $y1 $x2 $y2
5837 } elseif {$xc < $x - 1} {
5838 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5839 } elseif {$xc > $x + 1} {
5840 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5842 set x $xc
5844 lappend coords [xc $row $x] [yc $row]
5845 } else {
5846 set xn [xc $row $xp]
5847 set yn [yc $row]
5848 lappend coords $xn $yn
5850 if {!$joinhigh} {
5851 assigncolor $id
5852 set t [$canv create line $coords -width [linewidth $id] \
5853 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5854 $canv lower $t
5855 bindline $t $id
5856 set lines [linsert $lines $i [list $row $le $t]]
5857 } else {
5858 $canv coords $ith $coords
5859 if {$arrow ne $ah} {
5860 $canv itemconf $ith -arrow $arrow
5862 lset lines $i 0 $row
5864 } else {
5865 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5866 set ndir [expr {$xo - $xp}]
5867 set clow [$canv coords $itl]
5868 if {$dir == $ndir} {
5869 set clow [lrange $clow 2 end]
5871 set coords [concat $coords $clow]
5872 if {!$joinhigh} {
5873 lset lines [expr {$i-1}] 1 $le
5874 } else {
5875 # coalesce two pieces
5876 $canv delete $ith
5877 set b [lindex $lines [expr {$i-1}] 0]
5878 set e [lindex $lines $i 1]
5879 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5881 $canv coords $itl $coords
5882 if {$arrow ne $al} {
5883 $canv itemconf $itl -arrow $arrow
5887 set linesegs($id) $lines
5888 return $le
5891 proc drawparentlinks {id row} {
5892 global rowidlist canv colormap curview parentlist
5893 global idpos linespc
5895 set rowids [lindex $rowidlist $row]
5896 set col [lsearch -exact $rowids $id]
5897 if {$col < 0} return
5898 set olds [lindex $parentlist $row]
5899 set row2 [expr {$row + 1}]
5900 set x [xc $row $col]
5901 set y [yc $row]
5902 set y2 [yc $row2]
5903 set d [expr {int(0.5 * $linespc)}]
5904 set ymid [expr {$y + $d}]
5905 set ids [lindex $rowidlist $row2]
5906 # rmx = right-most X coord used
5907 set rmx 0
5908 foreach p $olds {
5909 set i [lsearch -exact $ids $p]
5910 if {$i < 0} {
5911 puts "oops, parent $p of $id not in list"
5912 continue
5914 set x2 [xc $row2 $i]
5915 if {$x2 > $rmx} {
5916 set rmx $x2
5918 set j [lsearch -exact $rowids $p]
5919 if {$j < 0} {
5920 # drawlineseg will do this one for us
5921 continue
5923 assigncolor $p
5924 # should handle duplicated parents here...
5925 set coords [list $x $y]
5926 if {$i != $col} {
5927 # if attaching to a vertical segment, draw a smaller
5928 # slant for visual distinctness
5929 if {$i == $j} {
5930 if {$i < $col} {
5931 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5932 } else {
5933 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5935 } elseif {$i < $col && $i < $j} {
5936 # segment slants towards us already
5937 lappend coords [xc $row $j] $y
5938 } else {
5939 if {$i < $col - 1} {
5940 lappend coords [expr {$x2 + $linespc}] $y
5941 } elseif {$i > $col + 1} {
5942 lappend coords [expr {$x2 - $linespc}] $y
5944 lappend coords $x2 $y2
5946 } else {
5947 lappend coords $x2 $y2
5949 set t [$canv create line $coords -width [linewidth $p] \
5950 -fill $colormap($p) -tags lines.$p]
5951 $canv lower $t
5952 bindline $t $p
5954 if {$rmx > [lindex $idpos($id) 1]} {
5955 lset idpos($id) 1 $rmx
5956 redrawtags $id
5960 proc drawlines {id} {
5961 global canv
5963 $canv itemconf lines.$id -width [linewidth $id]
5966 proc drawcmittext {id row col} {
5967 global linespc canv canv2 canv3 fgcolor curview
5968 global cmitlisted commitinfo rowidlist parentlist
5969 global rowtextx idpos idtags idheads idotherrefs
5970 global linehtag linentag linedtag selectedline
5971 global canvxmax boldids boldnameids fgcolor markedid
5972 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5973 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
5974 global circleoutlinecolor
5976 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5977 set listed $cmitlisted($curview,$id)
5978 if {$id eq $nullid} {
5979 set ofill $workingfilescirclecolor
5980 } elseif {$id eq $nullid2} {
5981 set ofill $indexcirclecolor
5982 } elseif {$id eq $mainheadid} {
5983 set ofill $mainheadcirclecolor
5984 } else {
5985 set ofill [lindex $circlecolors $listed]
5987 set x [xc $row $col]
5988 set y [yc $row]
5989 set orad [expr {$linespc / 3}]
5990 if {$listed <= 2} {
5991 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5992 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5993 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
5994 } elseif {$listed == 3} {
5995 # triangle pointing left for left-side commits
5996 set t [$canv create polygon \
5997 [expr {$x - $orad}] $y \
5998 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5999 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6000 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6001 } else {
6002 # triangle pointing right for right-side commits
6003 set t [$canv create polygon \
6004 [expr {$x + $orad - 1}] $y \
6005 [expr {$x - $orad}] [expr {$y - $orad}] \
6006 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6007 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6009 set circleitem($row) $t
6010 $canv raise $t
6011 $canv bind $t <1> {selcanvline {} %x %y}
6012 set rmx [llength [lindex $rowidlist $row]]
6013 set olds [lindex $parentlist $row]
6014 if {$olds ne {}} {
6015 set nextids [lindex $rowidlist [expr {$row + 1}]]
6016 foreach p $olds {
6017 set i [lsearch -exact $nextids $p]
6018 if {$i > $rmx} {
6019 set rmx $i
6023 set xt [xc $row $rmx]
6024 set rowtextx($row) $xt
6025 set idpos($id) [list $x $xt $y]
6026 if {[info exists idtags($id)] || [info exists idheads($id)]
6027 || [info exists idotherrefs($id)]} {
6028 set xt [drawtags $id $x $xt $y]
6030 if {[lindex $commitinfo($id) 6] > 0} {
6031 set xt [drawnotesign $xt $y]
6033 set headline [lindex $commitinfo($id) 0]
6034 set name [lindex $commitinfo($id) 1]
6035 set date [lindex $commitinfo($id) 2]
6036 set date [formatdate $date]
6037 set font mainfont
6038 set nfont mainfont
6039 set isbold [ishighlighted $id]
6040 if {$isbold > 0} {
6041 lappend boldids $id
6042 set font mainfontbold
6043 if {$isbold > 1} {
6044 lappend boldnameids $id
6045 set nfont mainfontbold
6048 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6049 -text $headline -font $font -tags text]
6050 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6051 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6052 -text $name -font $nfont -tags text]
6053 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6054 -text $date -font mainfont -tags text]
6055 if {$selectedline == $row} {
6056 make_secsel $id
6058 if {[info exists markedid] && $markedid eq $id} {
6059 make_idmark $id
6061 set xr [expr {$xt + [font measure $font $headline]}]
6062 if {$xr > $canvxmax} {
6063 set canvxmax $xr
6064 setcanvscroll
6068 proc drawcmitrow {row} {
6069 global displayorder rowidlist nrows_drawn
6070 global iddrawn markingmatches
6071 global commitinfo numcommits
6072 global filehighlight fhighlights findpattern nhighlights
6073 global hlview vhighlights
6074 global highlight_related rhighlights
6076 if {$row >= $numcommits} return
6078 set id [lindex $displayorder $row]
6079 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6080 askvhighlight $row $id
6082 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6083 askfilehighlight $row $id
6085 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6086 askfindhighlight $row $id
6088 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6089 askrelhighlight $row $id
6091 if {![info exists iddrawn($id)]} {
6092 set col [lsearch -exact [lindex $rowidlist $row] $id]
6093 if {$col < 0} {
6094 puts "oops, row $row id $id not in list"
6095 return
6097 if {![info exists commitinfo($id)]} {
6098 getcommit $id
6100 assigncolor $id
6101 drawcmittext $id $row $col
6102 set iddrawn($id) 1
6103 incr nrows_drawn
6105 if {$markingmatches} {
6106 markrowmatches $row $id
6110 proc drawcommits {row {endrow {}}} {
6111 global numcommits iddrawn displayorder curview need_redisplay
6112 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6114 if {$row < 0} {
6115 set row 0
6117 if {$endrow eq {}} {
6118 set endrow $row
6120 if {$endrow >= $numcommits} {
6121 set endrow [expr {$numcommits - 1}]
6124 set rl1 [expr {$row - $downarrowlen - 3}]
6125 if {$rl1 < 0} {
6126 set rl1 0
6128 set ro1 [expr {$row - 3}]
6129 if {$ro1 < 0} {
6130 set ro1 0
6132 set r2 [expr {$endrow + $uparrowlen + 3}]
6133 if {$r2 > $numcommits} {
6134 set r2 $numcommits
6136 for {set r $rl1} {$r < $r2} {incr r} {
6137 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6138 if {$rl1 < $r} {
6139 layoutrows $rl1 $r
6141 set rl1 [expr {$r + 1}]
6144 if {$rl1 < $r} {
6145 layoutrows $rl1 $r
6147 optimize_rows $ro1 0 $r2
6148 if {$need_redisplay || $nrows_drawn > 2000} {
6149 clear_display
6152 # make the lines join to already-drawn rows either side
6153 set r [expr {$row - 1}]
6154 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6155 set r $row
6157 set er [expr {$endrow + 1}]
6158 if {$er >= $numcommits ||
6159 ![info exists iddrawn([lindex $displayorder $er])]} {
6160 set er $endrow
6162 for {} {$r <= $er} {incr r} {
6163 set id [lindex $displayorder $r]
6164 set wasdrawn [info exists iddrawn($id)]
6165 drawcmitrow $r
6166 if {$r == $er} break
6167 set nextid [lindex $displayorder [expr {$r + 1}]]
6168 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6169 drawparentlinks $id $r
6171 set rowids [lindex $rowidlist $r]
6172 foreach lid $rowids {
6173 if {$lid eq {}} continue
6174 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6175 if {$lid eq $id} {
6176 # see if this is the first child of any of its parents
6177 foreach p [lindex $parentlist $r] {
6178 if {[lsearch -exact $rowids $p] < 0} {
6179 # make this line extend up to the child
6180 set lineend($p) [drawlineseg $p $r $er 0]
6183 } else {
6184 set lineend($lid) [drawlineseg $lid $r $er 1]
6190 proc undolayout {row} {
6191 global uparrowlen mingaplen downarrowlen
6192 global rowidlist rowisopt rowfinal need_redisplay
6194 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6195 if {$r < 0} {
6196 set r 0
6198 if {[llength $rowidlist] > $r} {
6199 incr r -1
6200 set rowidlist [lrange $rowidlist 0 $r]
6201 set rowfinal [lrange $rowfinal 0 $r]
6202 set rowisopt [lrange $rowisopt 0 $r]
6203 set need_redisplay 1
6204 run drawvisible
6208 proc drawvisible {} {
6209 global canv linespc curview vrowmod selectedline targetrow targetid
6210 global need_redisplay cscroll numcommits
6212 set fs [$canv yview]
6213 set ymax [lindex [$canv cget -scrollregion] 3]
6214 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6215 set f0 [lindex $fs 0]
6216 set f1 [lindex $fs 1]
6217 set y0 [expr {int($f0 * $ymax)}]
6218 set y1 [expr {int($f1 * $ymax)}]
6220 if {[info exists targetid]} {
6221 if {[commitinview $targetid $curview]} {
6222 set r [rowofcommit $targetid]
6223 if {$r != $targetrow} {
6224 # Fix up the scrollregion and change the scrolling position
6225 # now that our target row has moved.
6226 set diff [expr {($r - $targetrow) * $linespc}]
6227 set targetrow $r
6228 setcanvscroll
6229 set ymax [lindex [$canv cget -scrollregion] 3]
6230 incr y0 $diff
6231 incr y1 $diff
6232 set f0 [expr {$y0 / $ymax}]
6233 set f1 [expr {$y1 / $ymax}]
6234 allcanvs yview moveto $f0
6235 $cscroll set $f0 $f1
6236 set need_redisplay 1
6238 } else {
6239 unset targetid
6243 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6244 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6245 if {$endrow >= $vrowmod($curview)} {
6246 update_arcrows $curview
6248 if {$selectedline ne {} &&
6249 $row <= $selectedline && $selectedline <= $endrow} {
6250 set targetrow $selectedline
6251 } elseif {[info exists targetid]} {
6252 set targetrow [expr {int(($row + $endrow) / 2)}]
6254 if {[info exists targetrow]} {
6255 if {$targetrow >= $numcommits} {
6256 set targetrow [expr {$numcommits - 1}]
6258 set targetid [commitonrow $targetrow]
6260 drawcommits $row $endrow
6263 proc clear_display {} {
6264 global iddrawn linesegs need_redisplay nrows_drawn
6265 global vhighlights fhighlights nhighlights rhighlights
6266 global linehtag linentag linedtag boldids boldnameids
6268 allcanvs delete all
6269 catch {unset iddrawn}
6270 catch {unset linesegs}
6271 catch {unset linehtag}
6272 catch {unset linentag}
6273 catch {unset linedtag}
6274 set boldids {}
6275 set boldnameids {}
6276 catch {unset vhighlights}
6277 catch {unset fhighlights}
6278 catch {unset nhighlights}
6279 catch {unset rhighlights}
6280 set need_redisplay 0
6281 set nrows_drawn 0
6284 proc findcrossings {id} {
6285 global rowidlist parentlist numcommits displayorder
6287 set cross {}
6288 set ccross {}
6289 foreach {s e} [rowranges $id] {
6290 if {$e >= $numcommits} {
6291 set e [expr {$numcommits - 1}]
6293 if {$e <= $s} continue
6294 for {set row $e} {[incr row -1] >= $s} {} {
6295 set x [lsearch -exact [lindex $rowidlist $row] $id]
6296 if {$x < 0} break
6297 set olds [lindex $parentlist $row]
6298 set kid [lindex $displayorder $row]
6299 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6300 if {$kidx < 0} continue
6301 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6302 foreach p $olds {
6303 set px [lsearch -exact $nextrow $p]
6304 if {$px < 0} continue
6305 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6306 if {[lsearch -exact $ccross $p] >= 0} continue
6307 if {$x == $px + ($kidx < $px? -1: 1)} {
6308 lappend ccross $p
6309 } elseif {[lsearch -exact $cross $p] < 0} {
6310 lappend cross $p
6316 return [concat $ccross {{}} $cross]
6319 proc assigncolor {id} {
6320 global colormap colors nextcolor
6321 global parents children children curview
6323 if {[info exists colormap($id)]} return
6324 set ncolors [llength $colors]
6325 if {[info exists children($curview,$id)]} {
6326 set kids $children($curview,$id)
6327 } else {
6328 set kids {}
6330 if {[llength $kids] == 1} {
6331 set child [lindex $kids 0]
6332 if {[info exists colormap($child)]
6333 && [llength $parents($curview,$child)] == 1} {
6334 set colormap($id) $colormap($child)
6335 return
6338 set badcolors {}
6339 set origbad {}
6340 foreach x [findcrossings $id] {
6341 if {$x eq {}} {
6342 # delimiter between corner crossings and other crossings
6343 if {[llength $badcolors] >= $ncolors - 1} break
6344 set origbad $badcolors
6346 if {[info exists colormap($x)]
6347 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6348 lappend badcolors $colormap($x)
6351 if {[llength $badcolors] >= $ncolors} {
6352 set badcolors $origbad
6354 set origbad $badcolors
6355 if {[llength $badcolors] < $ncolors - 1} {
6356 foreach child $kids {
6357 if {[info exists colormap($child)]
6358 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6359 lappend badcolors $colormap($child)
6361 foreach p $parents($curview,$child) {
6362 if {[info exists colormap($p)]
6363 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6364 lappend badcolors $colormap($p)
6368 if {[llength $badcolors] >= $ncolors} {
6369 set badcolors $origbad
6372 for {set i 0} {$i <= $ncolors} {incr i} {
6373 set c [lindex $colors $nextcolor]
6374 if {[incr nextcolor] >= $ncolors} {
6375 set nextcolor 0
6377 if {[lsearch -exact $badcolors $c]} break
6379 set colormap($id) $c
6382 proc bindline {t id} {
6383 global canv
6385 $canv bind $t <Enter> "lineenter %x %y $id"
6386 $canv bind $t <Motion> "linemotion %x %y $id"
6387 $canv bind $t <Leave> "lineleave $id"
6388 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6391 proc graph_pane_width {} {
6392 global use_ttk
6394 if {$use_ttk} {
6395 set g [.tf.histframe.pwclist sashpos 0]
6396 } else {
6397 set g [.tf.histframe.pwclist sash coord 0]
6399 return [lindex $g 0]
6402 proc totalwidth {l font extra} {
6403 set tot 0
6404 foreach str $l {
6405 set tot [expr {$tot + [font measure $font $str] + $extra}]
6407 return $tot
6410 proc drawtags {id x xt y1} {
6411 global idtags idheads idotherrefs mainhead
6412 global linespc lthickness
6413 global canv rowtextx curview fgcolor bgcolor ctxbut
6414 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6415 global tagbgcolor tagfgcolor tagoutlinecolor
6416 global reflinecolor
6418 set marks {}
6419 set ntags 0
6420 set nheads 0
6421 set singletag 0
6422 set maxtags 3
6423 set maxtagpct 25
6424 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6425 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6426 set extra [expr {$delta + $lthickness + $linespc}]
6428 if {[info exists idtags($id)]} {
6429 set marks $idtags($id)
6430 set ntags [llength $marks]
6431 if {$ntags > $maxtags ||
6432 [totalwidth $marks mainfont $extra] > $maxwidth} {
6433 # show just a single "n tags..." tag
6434 set singletag 1
6435 if {$ntags == 1} {
6436 set marks [list "tag..."]
6437 } else {
6438 set marks [list [format "%d tags..." $ntags]]
6440 set ntags 1
6443 if {[info exists idheads($id)]} {
6444 set marks [concat $marks $idheads($id)]
6445 set nheads [llength $idheads($id)]
6447 if {[info exists idotherrefs($id)]} {
6448 set marks [concat $marks $idotherrefs($id)]
6450 if {$marks eq {}} {
6451 return $xt
6454 set yt [expr {$y1 - 0.5 * $linespc}]
6455 set yb [expr {$yt + $linespc - 1}]
6456 set xvals {}
6457 set wvals {}
6458 set i -1
6459 foreach tag $marks {
6460 incr i
6461 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6462 set wid [font measure mainfontbold $tag]
6463 } else {
6464 set wid [font measure mainfont $tag]
6466 lappend xvals $xt
6467 lappend wvals $wid
6468 set xt [expr {$xt + $wid + $extra}]
6470 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6471 -width $lthickness -fill $reflinecolor -tags tag.$id]
6472 $canv lower $t
6473 foreach tag $marks x $xvals wid $wvals {
6474 set tag_quoted [string map {% %%} $tag]
6475 set xl [expr {$x + $delta}]
6476 set xr [expr {$x + $delta + $wid + $lthickness}]
6477 set font mainfont
6478 if {[incr ntags -1] >= 0} {
6479 # draw a tag
6480 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6481 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6482 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6483 -tags tag.$id]
6484 if {$singletag} {
6485 set tagclick [list showtags $id 1]
6486 } else {
6487 set tagclick [list showtag $tag_quoted 1]
6489 $canv bind $t <1> $tagclick
6490 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6491 } else {
6492 # draw a head or other ref
6493 if {[incr nheads -1] >= 0} {
6494 set col $headbgcolor
6495 if {$tag eq $mainhead} {
6496 set font mainfontbold
6498 } else {
6499 set col "#ddddff"
6501 set xl [expr {$xl - $delta/2}]
6502 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6503 -width 1 -outline black -fill $col -tags tag.$id
6504 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6505 set rwid [font measure mainfont $remoteprefix]
6506 set xi [expr {$x + 1}]
6507 set yti [expr {$yt + 1}]
6508 set xri [expr {$x + $rwid}]
6509 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6510 -width 0 -fill $remotebgcolor -tags tag.$id
6513 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6514 -font $font -tags [list tag.$id text]]
6515 if {$ntags >= 0} {
6516 $canv bind $t <1> $tagclick
6517 } elseif {$nheads >= 0} {
6518 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6521 return $xt
6524 proc drawnotesign {xt y} {
6525 global linespc canv fgcolor
6527 set orad [expr {$linespc / 3}]
6528 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6529 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6530 -fill yellow -outline $fgcolor -width 1 -tags circle]
6531 set xt [expr {$xt + $orad * 3}]
6532 return $xt
6535 proc xcoord {i level ln} {
6536 global canvx0 xspc1 xspc2
6538 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6539 if {$i > 0 && $i == $level} {
6540 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6541 } elseif {$i > $level} {
6542 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6544 return $x
6547 proc show_status {msg} {
6548 global canv fgcolor
6550 clear_display
6551 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6552 -tags text -fill $fgcolor
6555 # Don't change the text pane cursor if it is currently the hand cursor,
6556 # showing that we are over a sha1 ID link.
6557 proc settextcursor {c} {
6558 global ctext curtextcursor
6560 if {[$ctext cget -cursor] == $curtextcursor} {
6561 $ctext config -cursor $c
6563 set curtextcursor $c
6566 proc nowbusy {what {name {}}} {
6567 global isbusy busyname statusw
6569 if {[array names isbusy] eq {}} {
6570 . config -cursor watch
6571 settextcursor watch
6573 set isbusy($what) 1
6574 set busyname($what) $name
6575 if {$name ne {}} {
6576 $statusw conf -text $name
6580 proc notbusy {what} {
6581 global isbusy maincursor textcursor busyname statusw
6583 catch {
6584 unset isbusy($what)
6585 if {$busyname($what) ne {} &&
6586 [$statusw cget -text] eq $busyname($what)} {
6587 $statusw conf -text {}
6590 if {[array names isbusy] eq {}} {
6591 . config -cursor $maincursor
6592 settextcursor $textcursor
6596 proc findmatches {f} {
6597 global findtype findstring
6598 if {$findtype == [mc "Regexp"]} {
6599 set matches [regexp -indices -all -inline $findstring $f]
6600 } else {
6601 set fs $findstring
6602 if {$findtype == [mc "IgnCase"]} {
6603 set f [string tolower $f]
6604 set fs [string tolower $fs]
6606 set matches {}
6607 set i 0
6608 set l [string length $fs]
6609 while {[set j [string first $fs $f $i]] >= 0} {
6610 lappend matches [list $j [expr {$j+$l-1}]]
6611 set i [expr {$j + $l}]
6614 return $matches
6617 proc dofind {{dirn 1} {wrap 1}} {
6618 global findstring findstartline findcurline selectedline numcommits
6619 global gdttype filehighlight fh_serial find_dirn findallowwrap
6621 if {[info exists find_dirn]} {
6622 if {$find_dirn == $dirn} return
6623 stopfinding
6625 focus .
6626 if {$findstring eq {} || $numcommits == 0} return
6627 if {$selectedline eq {}} {
6628 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6629 } else {
6630 set findstartline $selectedline
6632 set findcurline $findstartline
6633 nowbusy finding [mc "Searching"]
6634 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6635 after cancel do_file_hl $fh_serial
6636 do_file_hl $fh_serial
6638 set find_dirn $dirn
6639 set findallowwrap $wrap
6640 run findmore
6643 proc stopfinding {} {
6644 global find_dirn findcurline fprogcoord
6646 if {[info exists find_dirn]} {
6647 unset find_dirn
6648 unset findcurline
6649 notbusy finding
6650 set fprogcoord 0
6651 adjustprogress
6653 stopblaming
6656 proc findmore {} {
6657 global commitdata commitinfo numcommits findpattern findloc
6658 global findstartline findcurline findallowwrap
6659 global find_dirn gdttype fhighlights fprogcoord
6660 global curview varcorder vrownum varccommits vrowmod
6662 if {![info exists find_dirn]} {
6663 return 0
6665 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6666 set l $findcurline
6667 set moretodo 0
6668 if {$find_dirn > 0} {
6669 incr l
6670 if {$l >= $numcommits} {
6671 set l 0
6673 if {$l <= $findstartline} {
6674 set lim [expr {$findstartline + 1}]
6675 } else {
6676 set lim $numcommits
6677 set moretodo $findallowwrap
6679 } else {
6680 if {$l == 0} {
6681 set l $numcommits
6683 incr l -1
6684 if {$l >= $findstartline} {
6685 set lim [expr {$findstartline - 1}]
6686 } else {
6687 set lim -1
6688 set moretodo $findallowwrap
6691 set n [expr {($lim - $l) * $find_dirn}]
6692 if {$n > 500} {
6693 set n 500
6694 set moretodo 1
6696 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6697 update_arcrows $curview
6699 set found 0
6700 set domore 1
6701 set ai [bsearch $vrownum($curview) $l]
6702 set a [lindex $varcorder($curview) $ai]
6703 set arow [lindex $vrownum($curview) $ai]
6704 set ids [lindex $varccommits($curview,$a)]
6705 set arowend [expr {$arow + [llength $ids]}]
6706 if {$gdttype eq [mc "containing:"]} {
6707 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6708 if {$l < $arow || $l >= $arowend} {
6709 incr ai $find_dirn
6710 set a [lindex $varcorder($curview) $ai]
6711 set arow [lindex $vrownum($curview) $ai]
6712 set ids [lindex $varccommits($curview,$a)]
6713 set arowend [expr {$arow + [llength $ids]}]
6715 set id [lindex $ids [expr {$l - $arow}]]
6716 # shouldn't happen unless git log doesn't give all the commits...
6717 if {![info exists commitdata($id)] ||
6718 ![doesmatch $commitdata($id)]} {
6719 continue
6721 if {![info exists commitinfo($id)]} {
6722 getcommit $id
6724 set info $commitinfo($id)
6725 foreach f $info ty $fldtypes {
6726 if {$ty eq ""} continue
6727 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6728 [doesmatch $f]} {
6729 set found 1
6730 break
6733 if {$found} break
6735 } else {
6736 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6737 if {$l < $arow || $l >= $arowend} {
6738 incr ai $find_dirn
6739 set a [lindex $varcorder($curview) $ai]
6740 set arow [lindex $vrownum($curview) $ai]
6741 set ids [lindex $varccommits($curview,$a)]
6742 set arowend [expr {$arow + [llength $ids]}]
6744 set id [lindex $ids [expr {$l - $arow}]]
6745 if {![info exists fhighlights($id)]} {
6746 # this sets fhighlights($id) to -1
6747 askfilehighlight $l $id
6749 if {$fhighlights($id) > 0} {
6750 set found $domore
6751 break
6753 if {$fhighlights($id) < 0} {
6754 if {$domore} {
6755 set domore 0
6756 set findcurline [expr {$l - $find_dirn}]
6761 if {$found || ($domore && !$moretodo)} {
6762 unset findcurline
6763 unset find_dirn
6764 notbusy finding
6765 set fprogcoord 0
6766 adjustprogress
6767 if {$found} {
6768 findselectline $l
6769 } else {
6770 bell
6772 return 0
6774 if {!$domore} {
6775 flushhighlights
6776 } else {
6777 set findcurline [expr {$l - $find_dirn}]
6779 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6780 if {$n < 0} {
6781 incr n $numcommits
6783 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6784 adjustprogress
6785 return $domore
6788 proc findselectline {l} {
6789 global findloc commentend ctext findcurline markingmatches gdttype
6791 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6792 set findcurline $l
6793 selectline $l 1
6794 if {$markingmatches &&
6795 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6796 # highlight the matches in the comments
6797 set f [$ctext get 1.0 $commentend]
6798 set matches [findmatches $f]
6799 foreach match $matches {
6800 set start [lindex $match 0]
6801 set end [expr {[lindex $match 1] + 1}]
6802 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6805 drawvisible
6808 # mark the bits of a headline or author that match a find string
6809 proc markmatches {canv l str tag matches font row} {
6810 global selectedline
6812 set bbox [$canv bbox $tag]
6813 set x0 [lindex $bbox 0]
6814 set y0 [lindex $bbox 1]
6815 set y1 [lindex $bbox 3]
6816 foreach match $matches {
6817 set start [lindex $match 0]
6818 set end [lindex $match 1]
6819 if {$start > $end} continue
6820 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6821 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6822 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6823 [expr {$x0+$xlen+2}] $y1 \
6824 -outline {} -tags [list match$l matches] -fill yellow]
6825 $canv lower $t
6826 if {$row == $selectedline} {
6827 $canv raise $t secsel
6832 proc unmarkmatches {} {
6833 global markingmatches
6835 allcanvs delete matches
6836 set markingmatches 0
6837 stopfinding
6840 proc selcanvline {w x y} {
6841 global canv canvy0 ctext linespc
6842 global rowtextx
6843 set ymax [lindex [$canv cget -scrollregion] 3]
6844 if {$ymax == {}} return
6845 set yfrac [lindex [$canv yview] 0]
6846 set y [expr {$y + $yfrac * $ymax}]
6847 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6848 if {$l < 0} {
6849 set l 0
6851 if {$w eq $canv} {
6852 set xmax [lindex [$canv cget -scrollregion] 2]
6853 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6854 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6856 unmarkmatches
6857 selectline $l 1
6860 proc commit_descriptor {p} {
6861 global commitinfo
6862 if {![info exists commitinfo($p)]} {
6863 getcommit $p
6865 set l "..."
6866 if {[llength $commitinfo($p)] > 1} {
6867 set l [lindex $commitinfo($p) 0]
6869 return "$p ($l)\n"
6872 # append some text to the ctext widget, and make any SHA1 ID
6873 # that we know about be a clickable link.
6874 proc appendwithlinks {text tags} {
6875 global ctext linknum curview
6877 set start [$ctext index "end - 1c"]
6878 $ctext insert end $text $tags
6879 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6880 foreach l $links {
6881 set s [lindex $l 0]
6882 set e [lindex $l 1]
6883 set linkid [string range $text $s $e]
6884 incr e
6885 $ctext tag delete link$linknum
6886 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6887 setlink $linkid link$linknum
6888 incr linknum
6892 proc setlink {id lk} {
6893 global curview ctext pendinglinks
6894 global linkfgcolor
6896 if {[string range $id 0 1] eq "-g"} {
6897 set id [string range $id 2 end]
6900 set known 0
6901 if {[string length $id] < 40} {
6902 set matches [longid $id]
6903 if {[llength $matches] > 0} {
6904 if {[llength $matches] > 1} return
6905 set known 1
6906 set id [lindex $matches 0]
6908 } else {
6909 set known [commitinview $id $curview]
6911 if {$known} {
6912 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
6913 $ctext tag bind $lk <1> [list selbyid $id]
6914 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6915 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6916 } else {
6917 lappend pendinglinks($id) $lk
6918 interestedin $id {makelink %P}
6922 proc appendshortlink {id {pre {}} {post {}}} {
6923 global ctext linknum
6925 $ctext insert end $pre
6926 $ctext tag delete link$linknum
6927 $ctext insert end [string range $id 0 7] link$linknum
6928 $ctext insert end $post
6929 setlink $id link$linknum
6930 incr linknum
6933 proc makelink {id} {
6934 global pendinglinks
6936 if {![info exists pendinglinks($id)]} return
6937 foreach lk $pendinglinks($id) {
6938 setlink $id $lk
6940 unset pendinglinks($id)
6943 proc linkcursor {w inc} {
6944 global linkentercount curtextcursor
6946 if {[incr linkentercount $inc] > 0} {
6947 $w configure -cursor hand2
6948 } else {
6949 $w configure -cursor $curtextcursor
6950 if {$linkentercount < 0} {
6951 set linkentercount 0
6956 proc viewnextline {dir} {
6957 global canv linespc
6959 $canv delete hover
6960 set ymax [lindex [$canv cget -scrollregion] 3]
6961 set wnow [$canv yview]
6962 set wtop [expr {[lindex $wnow 0] * $ymax}]
6963 set newtop [expr {$wtop + $dir * $linespc}]
6964 if {$newtop < 0} {
6965 set newtop 0
6966 } elseif {$newtop > $ymax} {
6967 set newtop $ymax
6969 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6972 # add a list of tag or branch names at position pos
6973 # returns the number of names inserted
6974 proc appendrefs {pos ids var} {
6975 global ctext linknum curview $var maxrefs mainheadid
6977 if {[catch {$ctext index $pos}]} {
6978 return 0
6980 $ctext conf -state normal
6981 $ctext delete $pos "$pos lineend"
6982 set tags {}
6983 foreach id $ids {
6984 foreach tag [set $var\($id\)] {
6985 lappend tags [list $tag $id]
6989 set sep {}
6990 set tags [lsort -index 0 -decreasing $tags]
6991 set nutags 0
6993 if {[llength $tags] > $maxrefs} {
6994 # If we are displaying heads, and there are too many,
6995 # see if there are some important heads to display.
6996 # Currently this means "master" and the current head.
6997 set itags {}
6998 if {$var eq "idheads"} {
6999 set utags {}
7000 foreach ti $tags {
7001 set hname [lindex $ti 0]
7002 set id [lindex $ti 1]
7003 if {($hname eq "master" || $id eq $mainheadid) &&
7004 [llength $itags] < $maxrefs} {
7005 lappend itags $ti
7006 } else {
7007 lappend utags $ti
7010 set tags $utags
7012 if {$itags ne {}} {
7013 set str [mc "and many more"]
7014 set sep " "
7015 } else {
7016 set str [mc "many"]
7018 $ctext insert $pos "$str ([llength $tags])"
7019 set nutags [llength $tags]
7020 set tags $itags
7023 foreach ti $tags {
7024 set id [lindex $ti 1]
7025 set lk link$linknum
7026 incr linknum
7027 $ctext tag delete $lk
7028 $ctext insert $pos $sep
7029 $ctext insert $pos [lindex $ti 0] $lk
7030 setlink $id $lk
7031 set sep ", "
7033 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7034 $ctext conf -state disabled
7035 return [expr {[llength $tags] + $nutags}]
7038 # called when we have finished computing the nearby tags
7039 proc dispneartags {delay} {
7040 global selectedline currentid showneartags tagphase
7042 if {$selectedline eq {} || !$showneartags} return
7043 after cancel dispnexttag
7044 if {$delay} {
7045 after 200 dispnexttag
7046 set tagphase -1
7047 } else {
7048 after idle dispnexttag
7049 set tagphase 0
7053 proc dispnexttag {} {
7054 global selectedline currentid showneartags tagphase ctext
7056 if {$selectedline eq {} || !$showneartags} return
7057 switch -- $tagphase {
7059 set dtags [desctags $currentid]
7060 if {$dtags ne {}} {
7061 appendrefs precedes $dtags idtags
7065 set atags [anctags $currentid]
7066 if {$atags ne {}} {
7067 appendrefs follows $atags idtags
7071 set dheads [descheads $currentid]
7072 if {$dheads ne {}} {
7073 if {[appendrefs branch $dheads idheads] > 1
7074 && [$ctext get "branch -3c"] eq "h"} {
7075 # turn "Branch" into "Branches"
7076 $ctext conf -state normal
7077 $ctext insert "branch -2c" "es"
7078 $ctext conf -state disabled
7083 if {[incr tagphase] <= 2} {
7084 after idle dispnexttag
7088 proc make_secsel {id} {
7089 global linehtag linentag linedtag canv canv2 canv3
7091 if {![info exists linehtag($id)]} return
7092 $canv delete secsel
7093 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7094 -tags secsel -fill [$canv cget -selectbackground]]
7095 $canv lower $t
7096 $canv2 delete secsel
7097 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7098 -tags secsel -fill [$canv2 cget -selectbackground]]
7099 $canv2 lower $t
7100 $canv3 delete secsel
7101 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7102 -tags secsel -fill [$canv3 cget -selectbackground]]
7103 $canv3 lower $t
7106 proc make_idmark {id} {
7107 global linehtag canv fgcolor
7109 if {![info exists linehtag($id)]} return
7110 $canv delete markid
7111 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7112 -tags markid -outline $fgcolor]
7113 $canv raise $t
7116 proc selectline {l isnew {desired_loc {}}} {
7117 global canv ctext commitinfo selectedline
7118 global canvy0 linespc parents children curview
7119 global currentid sha1entry
7120 global commentend idtags linknum
7121 global mergemax numcommits pending_select
7122 global cmitmode showneartags allcommits
7123 global targetrow targetid lastscrollrows
7124 global autoselect autosellen jump_to_here
7126 catch {unset pending_select}
7127 $canv delete hover
7128 normalline
7129 unsel_reflist
7130 stopfinding
7131 if {$l < 0 || $l >= $numcommits} return
7132 set id [commitonrow $l]
7133 set targetid $id
7134 set targetrow $l
7135 set selectedline $l
7136 set currentid $id
7137 if {$lastscrollrows < $numcommits} {
7138 setcanvscroll
7141 set y [expr {$canvy0 + $l * $linespc}]
7142 set ymax [lindex [$canv cget -scrollregion] 3]
7143 set ytop [expr {$y - $linespc - 1}]
7144 set ybot [expr {$y + $linespc + 1}]
7145 set wnow [$canv yview]
7146 set wtop [expr {[lindex $wnow 0] * $ymax}]
7147 set wbot [expr {[lindex $wnow 1] * $ymax}]
7148 set wh [expr {$wbot - $wtop}]
7149 set newtop $wtop
7150 if {$ytop < $wtop} {
7151 if {$ybot < $wtop} {
7152 set newtop [expr {$y - $wh / 2.0}]
7153 } else {
7154 set newtop $ytop
7155 if {$newtop > $wtop - $linespc} {
7156 set newtop [expr {$wtop - $linespc}]
7159 } elseif {$ybot > $wbot} {
7160 if {$ytop > $wbot} {
7161 set newtop [expr {$y - $wh / 2.0}]
7162 } else {
7163 set newtop [expr {$ybot - $wh}]
7164 if {$newtop < $wtop + $linespc} {
7165 set newtop [expr {$wtop + $linespc}]
7169 if {$newtop != $wtop} {
7170 if {$newtop < 0} {
7171 set newtop 0
7173 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7174 drawvisible
7177 make_secsel $id
7179 if {$isnew} {
7180 addtohistory [list selbyid $id 0] savecmitpos
7183 $sha1entry delete 0 end
7184 $sha1entry insert 0 $id
7185 if {$autoselect} {
7186 $sha1entry selection range 0 $autosellen
7188 rhighlight_sel $id
7190 $ctext conf -state normal
7191 clear_ctext
7192 set linknum 0
7193 if {![info exists commitinfo($id)]} {
7194 getcommit $id
7196 set info $commitinfo($id)
7197 set date [formatdate [lindex $info 2]]
7198 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7199 set date [formatdate [lindex $info 4]]
7200 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7201 if {[info exists idtags($id)]} {
7202 $ctext insert end [mc "Tags:"]
7203 foreach tag $idtags($id) {
7204 $ctext insert end " $tag"
7206 $ctext insert end "\n"
7209 set headers {}
7210 set olds $parents($curview,$id)
7211 if {[llength $olds] > 1} {
7212 set np 0
7213 foreach p $olds {
7214 if {$np >= $mergemax} {
7215 set tag mmax
7216 } else {
7217 set tag m$np
7219 $ctext insert end "[mc "Parent"]: " $tag
7220 appendwithlinks [commit_descriptor $p] {}
7221 incr np
7223 } else {
7224 foreach p $olds {
7225 append headers "[mc "Parent"]: [commit_descriptor $p]"
7229 foreach c $children($curview,$id) {
7230 append headers "[mc "Child"]: [commit_descriptor $c]"
7233 # make anything that looks like a SHA1 ID be a clickable link
7234 appendwithlinks $headers {}
7235 if {$showneartags} {
7236 if {![info exists allcommits]} {
7237 getallcommits
7239 $ctext insert end "[mc "Branch"]: "
7240 $ctext mark set branch "end -1c"
7241 $ctext mark gravity branch left
7242 $ctext insert end "\n[mc "Follows"]: "
7243 $ctext mark set follows "end -1c"
7244 $ctext mark gravity follows left
7245 $ctext insert end "\n[mc "Precedes"]: "
7246 $ctext mark set precedes "end -1c"
7247 $ctext mark gravity precedes left
7248 $ctext insert end "\n"
7249 dispneartags 1
7251 $ctext insert end "\n"
7252 set comment [lindex $info 5]
7253 if {[string first "\r" $comment] >= 0} {
7254 set comment [string map {"\r" "\n "} $comment]
7256 appendwithlinks $comment {comment}
7258 $ctext tag remove found 1.0 end
7259 $ctext conf -state disabled
7260 set commentend [$ctext index "end - 1c"]
7262 set jump_to_here $desired_loc
7263 init_flist [mc "Comments"]
7264 if {$cmitmode eq "tree"} {
7265 gettree $id
7266 } elseif {[llength $olds] <= 1} {
7267 startdiff $id
7268 } else {
7269 mergediff $id
7273 proc selfirstline {} {
7274 unmarkmatches
7275 selectline 0 1
7278 proc sellastline {} {
7279 global numcommits
7280 unmarkmatches
7281 set l [expr {$numcommits - 1}]
7282 selectline $l 1
7285 proc selnextline {dir} {
7286 global selectedline
7287 focus .
7288 if {$selectedline eq {}} return
7289 set l [expr {$selectedline + $dir}]
7290 unmarkmatches
7291 selectline $l 1
7294 proc selnextpage {dir} {
7295 global canv linespc selectedline numcommits
7297 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7298 if {$lpp < 1} {
7299 set lpp 1
7301 allcanvs yview scroll [expr {$dir * $lpp}] units
7302 drawvisible
7303 if {$selectedline eq {}} return
7304 set l [expr {$selectedline + $dir * $lpp}]
7305 if {$l < 0} {
7306 set l 0
7307 } elseif {$l >= $numcommits} {
7308 set l [expr $numcommits - 1]
7310 unmarkmatches
7311 selectline $l 1
7314 proc unselectline {} {
7315 global selectedline currentid
7317 set selectedline {}
7318 catch {unset currentid}
7319 allcanvs delete secsel
7320 rhighlight_none
7323 proc reselectline {} {
7324 global selectedline
7326 if {$selectedline ne {}} {
7327 selectline $selectedline 0
7331 proc addtohistory {cmd {saveproc {}}} {
7332 global history historyindex curview
7334 unset_posvars
7335 save_position
7336 set elt [list $curview $cmd $saveproc {}]
7337 if {$historyindex > 0
7338 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7339 return
7342 if {$historyindex < [llength $history]} {
7343 set history [lreplace $history $historyindex end $elt]
7344 } else {
7345 lappend history $elt
7347 incr historyindex
7348 if {$historyindex > 1} {
7349 .tf.bar.leftbut conf -state normal
7350 } else {
7351 .tf.bar.leftbut conf -state disabled
7353 .tf.bar.rightbut conf -state disabled
7356 # save the scrolling position of the diff display pane
7357 proc save_position {} {
7358 global historyindex history
7360 if {$historyindex < 1} return
7361 set hi [expr {$historyindex - 1}]
7362 set fn [lindex $history $hi 2]
7363 if {$fn ne {}} {
7364 lset history $hi 3 [eval $fn]
7368 proc unset_posvars {} {
7369 global last_posvars
7371 if {[info exists last_posvars]} {
7372 foreach {var val} $last_posvars {
7373 global $var
7374 catch {unset $var}
7376 unset last_posvars
7380 proc godo {elt} {
7381 global curview last_posvars
7383 set view [lindex $elt 0]
7384 set cmd [lindex $elt 1]
7385 set pv [lindex $elt 3]
7386 if {$curview != $view} {
7387 showview $view
7389 unset_posvars
7390 foreach {var val} $pv {
7391 global $var
7392 set $var $val
7394 set last_posvars $pv
7395 eval $cmd
7398 proc goback {} {
7399 global history historyindex
7400 focus .
7402 if {$historyindex > 1} {
7403 save_position
7404 incr historyindex -1
7405 godo [lindex $history [expr {$historyindex - 1}]]
7406 .tf.bar.rightbut conf -state normal
7408 if {$historyindex <= 1} {
7409 .tf.bar.leftbut conf -state disabled
7413 proc goforw {} {
7414 global history historyindex
7415 focus .
7417 if {$historyindex < [llength $history]} {
7418 save_position
7419 set cmd [lindex $history $historyindex]
7420 incr historyindex
7421 godo $cmd
7422 .tf.bar.leftbut conf -state normal
7424 if {$historyindex >= [llength $history]} {
7425 .tf.bar.rightbut conf -state disabled
7429 proc gettree {id} {
7430 global treefilelist treeidlist diffids diffmergeid treepending
7431 global nullid nullid2
7433 set diffids $id
7434 catch {unset diffmergeid}
7435 if {![info exists treefilelist($id)]} {
7436 if {![info exists treepending]} {
7437 if {$id eq $nullid} {
7438 set cmd [list | git ls-files]
7439 } elseif {$id eq $nullid2} {
7440 set cmd [list | git ls-files --stage -t]
7441 } else {
7442 set cmd [list | git ls-tree -r $id]
7444 if {[catch {set gtf [open $cmd r]}]} {
7445 return
7447 set treepending $id
7448 set treefilelist($id) {}
7449 set treeidlist($id) {}
7450 fconfigure $gtf -blocking 0 -encoding binary
7451 filerun $gtf [list gettreeline $gtf $id]
7453 } else {
7454 setfilelist $id
7458 proc gettreeline {gtf id} {
7459 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7461 set nl 0
7462 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7463 if {$diffids eq $nullid} {
7464 set fname $line
7465 } else {
7466 set i [string first "\t" $line]
7467 if {$i < 0} continue
7468 set fname [string range $line [expr {$i+1}] end]
7469 set line [string range $line 0 [expr {$i-1}]]
7470 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7471 set sha1 [lindex $line 2]
7472 lappend treeidlist($id) $sha1
7474 if {[string index $fname 0] eq "\""} {
7475 set fname [lindex $fname 0]
7477 set fname [encoding convertfrom $fname]
7478 lappend treefilelist($id) $fname
7480 if {![eof $gtf]} {
7481 return [expr {$nl >= 1000? 2: 1}]
7483 close $gtf
7484 unset treepending
7485 if {$cmitmode ne "tree"} {
7486 if {![info exists diffmergeid]} {
7487 gettreediffs $diffids
7489 } elseif {$id ne $diffids} {
7490 gettree $diffids
7491 } else {
7492 setfilelist $id
7494 return 0
7497 proc showfile {f} {
7498 global treefilelist treeidlist diffids nullid nullid2
7499 global ctext_file_names ctext_file_lines
7500 global ctext commentend
7502 set i [lsearch -exact $treefilelist($diffids) $f]
7503 if {$i < 0} {
7504 puts "oops, $f not in list for id $diffids"
7505 return
7507 if {$diffids eq $nullid} {
7508 if {[catch {set bf [open $f r]} err]} {
7509 puts "oops, can't read $f: $err"
7510 return
7512 } else {
7513 set blob [lindex $treeidlist($diffids) $i]
7514 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7515 puts "oops, error reading blob $blob: $err"
7516 return
7519 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7520 filerun $bf [list getblobline $bf $diffids]
7521 $ctext config -state normal
7522 clear_ctext $commentend
7523 lappend ctext_file_names $f
7524 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7525 $ctext insert end "\n"
7526 $ctext insert end "$f\n" filesep
7527 $ctext config -state disabled
7528 $ctext yview $commentend
7529 settabs 0
7532 proc getblobline {bf id} {
7533 global diffids cmitmode ctext
7535 if {$id ne $diffids || $cmitmode ne "tree"} {
7536 catch {close $bf}
7537 return 0
7539 $ctext config -state normal
7540 set nl 0
7541 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7542 $ctext insert end "$line\n"
7544 if {[eof $bf]} {
7545 global jump_to_here ctext_file_names commentend
7547 # delete last newline
7548 $ctext delete "end - 2c" "end - 1c"
7549 close $bf
7550 if {$jump_to_here ne {} &&
7551 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7552 set lnum [expr {[lindex $jump_to_here 1] +
7553 [lindex [split $commentend .] 0]}]
7554 mark_ctext_line $lnum
7556 $ctext config -state disabled
7557 return 0
7559 $ctext config -state disabled
7560 return [expr {$nl >= 1000? 2: 1}]
7563 proc mark_ctext_line {lnum} {
7564 global ctext markbgcolor
7566 $ctext tag delete omark
7567 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7568 $ctext tag conf omark -background $markbgcolor
7569 $ctext see $lnum.0
7572 proc mergediff {id} {
7573 global diffmergeid
7574 global diffids treediffs
7575 global parents curview
7577 set diffmergeid $id
7578 set diffids $id
7579 set treediffs($id) {}
7580 set np [llength $parents($curview,$id)]
7581 settabs $np
7582 getblobdiffs $id
7585 proc startdiff {ids} {
7586 global treediffs diffids treepending diffmergeid nullid nullid2
7588 settabs 1
7589 set diffids $ids
7590 catch {unset diffmergeid}
7591 if {![info exists treediffs($ids)] ||
7592 [lsearch -exact $ids $nullid] >= 0 ||
7593 [lsearch -exact $ids $nullid2] >= 0} {
7594 if {![info exists treepending]} {
7595 gettreediffs $ids
7597 } else {
7598 addtocflist $ids
7602 # If the filename (name) is under any of the passed filter paths
7603 # then return true to include the file in the listing.
7604 proc path_filter {filter name} {
7605 set worktree [gitworktree]
7606 foreach p $filter {
7607 set fq_p [file normalize $p]
7608 set fq_n [file normalize [file join $worktree $name]]
7609 if {[string match [file normalize $fq_p]* $fq_n]} {
7610 return 1
7613 return 0
7616 proc addtocflist {ids} {
7617 global treediffs
7619 add_flist $treediffs($ids)
7620 getblobdiffs $ids
7623 proc diffcmd {ids flags} {
7624 global log_showroot nullid nullid2
7626 set i [lsearch -exact $ids $nullid]
7627 set j [lsearch -exact $ids $nullid2]
7628 if {$i >= 0} {
7629 if {[llength $ids] > 1 && $j < 0} {
7630 # comparing working directory with some specific revision
7631 set cmd [concat | git diff-index $flags]
7632 if {$i == 0} {
7633 lappend cmd -R [lindex $ids 1]
7634 } else {
7635 lappend cmd [lindex $ids 0]
7637 } else {
7638 # comparing working directory with index
7639 set cmd [concat | git diff-files $flags]
7640 if {$j == 1} {
7641 lappend cmd -R
7644 } elseif {$j >= 0} {
7645 set cmd [concat | git diff-index --cached $flags]
7646 if {[llength $ids] > 1} {
7647 # comparing index with specific revision
7648 if {$j == 0} {
7649 lappend cmd -R [lindex $ids 1]
7650 } else {
7651 lappend cmd [lindex $ids 0]
7653 } else {
7654 # comparing index with HEAD
7655 lappend cmd HEAD
7657 } else {
7658 if {$log_showroot} {
7659 lappend flags --root
7661 set cmd [concat | git diff-tree -r $flags $ids]
7663 return $cmd
7666 proc gettreediffs {ids} {
7667 global treediff treepending limitdiffs vfilelimit curview
7669 set cmd [diffcmd $ids {--no-commit-id}]
7670 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7671 set cmd [concat $cmd -- $vfilelimit($curview)]
7673 if {[catch {set gdtf [open $cmd r]}]} return
7675 set treepending $ids
7676 set treediff {}
7677 fconfigure $gdtf -blocking 0 -encoding binary
7678 filerun $gdtf [list gettreediffline $gdtf $ids]
7681 proc gettreediffline {gdtf ids} {
7682 global treediff treediffs treepending diffids diffmergeid
7683 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7685 set nr 0
7686 set sublist {}
7687 set max 1000
7688 if {$perfile_attrs} {
7689 # cache_gitattr is slow, and even slower on win32 where we
7690 # have to invoke it for only about 30 paths at a time
7691 set max 500
7692 if {[tk windowingsystem] == "win32"} {
7693 set max 120
7696 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7697 set i [string first "\t" $line]
7698 if {$i >= 0} {
7699 set file [string range $line [expr {$i+1}] end]
7700 if {[string index $file 0] eq "\""} {
7701 set file [lindex $file 0]
7703 set file [encoding convertfrom $file]
7704 if {$file ne [lindex $treediff end]} {
7705 lappend treediff $file
7706 lappend sublist $file
7710 if {$perfile_attrs} {
7711 cache_gitattr encoding $sublist
7713 if {![eof $gdtf]} {
7714 return [expr {$nr >= $max? 2: 1}]
7716 close $gdtf
7717 set treediffs($ids) $treediff
7718 unset treepending
7719 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7720 gettree $diffids
7721 } elseif {$ids != $diffids} {
7722 if {![info exists diffmergeid]} {
7723 gettreediffs $diffids
7725 } else {
7726 addtocflist $ids
7728 return 0
7731 # empty string or positive integer
7732 proc diffcontextvalidate {v} {
7733 return [regexp {^(|[1-9][0-9]*)$} $v]
7736 proc diffcontextchange {n1 n2 op} {
7737 global diffcontextstring diffcontext
7739 if {[string is integer -strict $diffcontextstring]} {
7740 if {$diffcontextstring >= 0} {
7741 set diffcontext $diffcontextstring
7742 reselectline
7747 proc changeignorespace {} {
7748 reselectline
7751 proc changeworddiff {name ix op} {
7752 reselectline
7755 proc getblobdiffs {ids} {
7756 global blobdifffd diffids env
7757 global diffinhdr treediffs
7758 global diffcontext
7759 global ignorespace
7760 global worddiff
7761 global limitdiffs vfilelimit curview
7762 global diffencoding targetline diffnparents
7763 global git_version currdiffsubmod
7765 set textconv {}
7766 if {[package vcompare $git_version "1.6.1"] >= 0} {
7767 set textconv "--textconv"
7769 set submodule {}
7770 if {[package vcompare $git_version "1.6.6"] >= 0} {
7771 set submodule "--submodule"
7773 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7774 if {$ignorespace} {
7775 append cmd " -w"
7777 if {$worddiff ne [mc "Line diff"]} {
7778 append cmd " --word-diff=porcelain"
7780 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7781 set cmd [concat $cmd -- $vfilelimit($curview)]
7783 if {[catch {set bdf [open $cmd r]} err]} {
7784 error_popup [mc "Error getting diffs: %s" $err]
7785 return
7787 set targetline {}
7788 set diffnparents 0
7789 set diffinhdr 0
7790 set diffencoding [get_path_encoding {}]
7791 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7792 set blobdifffd($ids) $bdf
7793 set currdiffsubmod ""
7794 filerun $bdf [list getblobdiffline $bdf $diffids]
7797 proc savecmitpos {} {
7798 global ctext cmitmode
7800 if {$cmitmode eq "tree"} {
7801 return {}
7803 return [list target_scrollpos [$ctext index @0,0]]
7806 proc savectextpos {} {
7807 global ctext
7809 return [list target_scrollpos [$ctext index @0,0]]
7812 proc maybe_scroll_ctext {ateof} {
7813 global ctext target_scrollpos
7815 if {![info exists target_scrollpos]} return
7816 if {!$ateof} {
7817 set nlines [expr {[winfo height $ctext]
7818 / [font metrics textfont -linespace]}]
7819 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7821 $ctext yview $target_scrollpos
7822 unset target_scrollpos
7825 proc setinlist {var i val} {
7826 global $var
7828 while {[llength [set $var]] < $i} {
7829 lappend $var {}
7831 if {[llength [set $var]] == $i} {
7832 lappend $var $val
7833 } else {
7834 lset $var $i $val
7838 proc makediffhdr {fname ids} {
7839 global ctext curdiffstart treediffs diffencoding
7840 global ctext_file_names jump_to_here targetline diffline
7842 set fname [encoding convertfrom $fname]
7843 set diffencoding [get_path_encoding $fname]
7844 set i [lsearch -exact $treediffs($ids) $fname]
7845 if {$i >= 0} {
7846 setinlist difffilestart $i $curdiffstart
7848 lset ctext_file_names end $fname
7849 set l [expr {(78 - [string length $fname]) / 2}]
7850 set pad [string range "----------------------------------------" 1 $l]
7851 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7852 set targetline {}
7853 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7854 set targetline [lindex $jump_to_here 1]
7856 set diffline 0
7859 proc getblobdiffline {bdf ids} {
7860 global diffids blobdifffd ctext curdiffstart
7861 global diffnexthead diffnextnote difffilestart
7862 global ctext_file_names ctext_file_lines
7863 global diffinhdr treediffs mergemax diffnparents
7864 global diffencoding jump_to_here targetline diffline currdiffsubmod
7865 global worddiff
7867 set nr 0
7868 $ctext conf -state normal
7869 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7870 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7871 catch {close $bdf}
7872 return 0
7874 if {![string compare -length 5 "diff " $line]} {
7875 if {![regexp {^diff (--cc|--git) } $line m type]} {
7876 set line [encoding convertfrom $line]
7877 $ctext insert end "$line\n" hunksep
7878 continue
7880 # start of a new file
7881 set diffinhdr 1
7882 $ctext insert end "\n"
7883 set curdiffstart [$ctext index "end - 1c"]
7884 lappend ctext_file_names ""
7885 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7886 $ctext insert end "\n" filesep
7888 if {$type eq "--cc"} {
7889 # start of a new file in a merge diff
7890 set fname [string range $line 10 end]
7891 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7892 lappend treediffs($ids) $fname
7893 add_flist [list $fname]
7896 } else {
7897 set line [string range $line 11 end]
7898 # If the name hasn't changed the length will be odd,
7899 # the middle char will be a space, and the two bits either
7900 # side will be a/name and b/name, or "a/name" and "b/name".
7901 # If the name has changed we'll get "rename from" and
7902 # "rename to" or "copy from" and "copy to" lines following
7903 # this, and we'll use them to get the filenames.
7904 # This complexity is necessary because spaces in the
7905 # filename(s) don't get escaped.
7906 set l [string length $line]
7907 set i [expr {$l / 2}]
7908 if {!(($l & 1) && [string index $line $i] eq " " &&
7909 [string range $line 2 [expr {$i - 1}]] eq \
7910 [string range $line [expr {$i + 3}] end])} {
7911 continue
7913 # unescape if quoted and chop off the a/ from the front
7914 if {[string index $line 0] eq "\""} {
7915 set fname [string range [lindex $line 0] 2 end]
7916 } else {
7917 set fname [string range $line 2 [expr {$i - 1}]]
7920 makediffhdr $fname $ids
7922 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7923 set fname [encoding convertfrom [string range $line 16 end]]
7924 $ctext insert end "\n"
7925 set curdiffstart [$ctext index "end - 1c"]
7926 lappend ctext_file_names $fname
7927 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7928 $ctext insert end "$line\n" filesep
7929 set i [lsearch -exact $treediffs($ids) $fname]
7930 if {$i >= 0} {
7931 setinlist difffilestart $i $curdiffstart
7934 } elseif {![string compare -length 2 "@@" $line]} {
7935 regexp {^@@+} $line ats
7936 set line [encoding convertfrom $diffencoding $line]
7937 $ctext insert end "$line\n" hunksep
7938 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7939 set diffline $nl
7941 set diffnparents [expr {[string length $ats] - 1}]
7942 set diffinhdr 0
7944 } elseif {![string compare -length 10 "Submodule " $line]} {
7945 # start of a new submodule
7946 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
7947 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
7948 } else {
7949 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
7951 if {$currdiffsubmod != $fname} {
7952 $ctext insert end "\n"; # Add newline after commit message
7954 set curdiffstart [$ctext index "end - 1c"]
7955 lappend ctext_file_names ""
7956 if {$currdiffsubmod != $fname} {
7957 lappend ctext_file_lines $fname
7958 makediffhdr $fname $ids
7959 set currdiffsubmod $fname
7960 $ctext insert end "\n$line\n" filesep
7961 } else {
7962 $ctext insert end "$line\n" filesep
7964 } elseif {![string compare -length 3 " >" $line]} {
7965 set $currdiffsubmod ""
7966 set line [encoding convertfrom $diffencoding $line]
7967 $ctext insert end "$line\n" dresult
7968 } elseif {![string compare -length 3 " <" $line]} {
7969 set $currdiffsubmod ""
7970 set line [encoding convertfrom $diffencoding $line]
7971 $ctext insert end "$line\n" d0
7972 } elseif {$diffinhdr} {
7973 if {![string compare -length 12 "rename from " $line]} {
7974 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7975 if {[string index $fname 0] eq "\""} {
7976 set fname [lindex $fname 0]
7978 set fname [encoding convertfrom $fname]
7979 set i [lsearch -exact $treediffs($ids) $fname]
7980 if {$i >= 0} {
7981 setinlist difffilestart $i $curdiffstart
7983 } elseif {![string compare -length 10 $line "rename to "] ||
7984 ![string compare -length 8 $line "copy to "]} {
7985 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7986 if {[string index $fname 0] eq "\""} {
7987 set fname [lindex $fname 0]
7989 makediffhdr $fname $ids
7990 } elseif {[string compare -length 3 $line "---"] == 0} {
7991 # do nothing
7992 continue
7993 } elseif {[string compare -length 3 $line "+++"] == 0} {
7994 set diffinhdr 0
7995 continue
7997 $ctext insert end "$line\n" filesep
7999 } else {
8000 set line [string map {\x1A ^Z} \
8001 [encoding convertfrom $diffencoding $line]]
8002 # parse the prefix - one ' ', '-' or '+' for each parent
8003 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8004 set tag [expr {$diffnparents > 1? "m": "d"}]
8005 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8006 set words_pre_markup ""
8007 set words_post_markup ""
8008 if {[string trim $prefix " -+"] eq {}} {
8009 # prefix only has " ", "-" and "+" in it: normal diff line
8010 set num [string first "-" $prefix]
8011 if {$dowords} {
8012 set line [string range $line 1 end]
8014 if {$num >= 0} {
8015 # removed line, first parent with line is $num
8016 if {$num >= $mergemax} {
8017 set num "max"
8019 if {$dowords && $worddiff eq [mc "Markup words"]} {
8020 $ctext insert end "\[-$line-\]" $tag$num
8021 } else {
8022 $ctext insert end "$line" $tag$num
8024 if {!$dowords} {
8025 $ctext insert end "\n" $tag$num
8027 } else {
8028 set tags {}
8029 if {[string first "+" $prefix] >= 0} {
8030 # added line
8031 lappend tags ${tag}result
8032 if {$diffnparents > 1} {
8033 set num [string first " " $prefix]
8034 if {$num >= 0} {
8035 if {$num >= $mergemax} {
8036 set num "max"
8038 lappend tags m$num
8041 set words_pre_markup "{+"
8042 set words_post_markup "+}"
8044 if {$targetline ne {}} {
8045 if {$diffline == $targetline} {
8046 set seehere [$ctext index "end - 1 chars"]
8047 set targetline {}
8048 } else {
8049 incr diffline
8052 if {$dowords && $worddiff eq [mc "Markup words"]} {
8053 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8054 } else {
8055 $ctext insert end "$line" $tags
8057 if {!$dowords} {
8058 $ctext insert end "\n" $tags
8061 } elseif {$dowords && $prefix eq "~"} {
8062 $ctext insert end "\n" {}
8063 } else {
8064 # "\ No newline at end of file",
8065 # or something else we don't recognize
8066 $ctext insert end "$line\n" hunksep
8070 if {[info exists seehere]} {
8071 mark_ctext_line [lindex [split $seehere .] 0]
8073 maybe_scroll_ctext [eof $bdf]
8074 $ctext conf -state disabled
8075 if {[eof $bdf]} {
8076 catch {close $bdf}
8077 return 0
8079 return [expr {$nr >= 1000? 2: 1}]
8082 proc changediffdisp {} {
8083 global ctext diffelide
8085 $ctext tag conf d0 -elide [lindex $diffelide 0]
8086 $ctext tag conf dresult -elide [lindex $diffelide 1]
8089 proc highlightfile {cline} {
8090 global cflist cflist_top
8092 if {![info exists cflist_top]} return
8094 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8095 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8096 $cflist see $cline.0
8097 set cflist_top $cline
8100 proc highlightfile_for_scrollpos {topidx} {
8101 global cmitmode difffilestart
8103 if {$cmitmode eq "tree"} return
8104 if {![info exists difffilestart]} return
8106 set top [lindex [split $topidx .] 0]
8107 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8108 highlightfile 0
8109 } else {
8110 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8114 proc prevfile {} {
8115 global difffilestart ctext cmitmode
8117 if {$cmitmode eq "tree"} return
8118 set prev 0.0
8119 set here [$ctext index @0,0]
8120 foreach loc $difffilestart {
8121 if {[$ctext compare $loc >= $here]} {
8122 $ctext yview $prev
8123 return
8125 set prev $loc
8127 $ctext yview $prev
8130 proc nextfile {} {
8131 global difffilestart ctext cmitmode
8133 if {$cmitmode eq "tree"} return
8134 set here [$ctext index @0,0]
8135 foreach loc $difffilestart {
8136 if {[$ctext compare $loc > $here]} {
8137 $ctext yview $loc
8138 return
8143 proc clear_ctext {{first 1.0}} {
8144 global ctext smarktop smarkbot
8145 global ctext_file_names ctext_file_lines
8146 global pendinglinks
8148 set l [lindex [split $first .] 0]
8149 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8150 set smarktop $l
8152 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8153 set smarkbot $l
8155 $ctext delete $first end
8156 if {$first eq "1.0"} {
8157 catch {unset pendinglinks}
8159 set ctext_file_names {}
8160 set ctext_file_lines {}
8163 proc settabs {{firstab {}}} {
8164 global firsttabstop tabstop ctext have_tk85
8166 if {$firstab ne {} && $have_tk85} {
8167 set firsttabstop $firstab
8169 set w [font measure textfont "0"]
8170 if {$firsttabstop != 0} {
8171 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8172 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8173 } elseif {$have_tk85 || $tabstop != 8} {
8174 $ctext conf -tabs [expr {$tabstop * $w}]
8175 } else {
8176 $ctext conf -tabs {}
8180 proc incrsearch {name ix op} {
8181 global ctext searchstring searchdirn
8183 if {[catch {$ctext index anchor}]} {
8184 # no anchor set, use start of selection, or of visible area
8185 set sel [$ctext tag ranges sel]
8186 if {$sel ne {}} {
8187 $ctext mark set anchor [lindex $sel 0]
8188 } elseif {$searchdirn eq "-forwards"} {
8189 $ctext mark set anchor @0,0
8190 } else {
8191 $ctext mark set anchor @0,[winfo height $ctext]
8194 if {$searchstring ne {}} {
8195 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8196 if {$here ne {}} {
8197 $ctext see $here
8198 set mend "$here + $mlen c"
8199 $ctext tag remove sel 1.0 end
8200 $ctext tag add sel $here $mend
8201 suppress_highlighting_file_for_current_scrollpos
8202 highlightfile_for_scrollpos $here
8205 rehighlight_search_results
8208 proc dosearch {} {
8209 global sstring ctext searchstring searchdirn
8211 focus $sstring
8212 $sstring icursor end
8213 set searchdirn -forwards
8214 if {$searchstring ne {}} {
8215 set sel [$ctext tag ranges sel]
8216 if {$sel ne {}} {
8217 set start "[lindex $sel 0] + 1c"
8218 } elseif {[catch {set start [$ctext index anchor]}]} {
8219 set start "@0,0"
8221 set match [$ctext search -count mlen -- $searchstring $start]
8222 $ctext tag remove sel 1.0 end
8223 if {$match eq {}} {
8224 bell
8225 return
8227 $ctext see $match
8228 suppress_highlighting_file_for_current_scrollpos
8229 highlightfile_for_scrollpos $match
8230 set mend "$match + $mlen c"
8231 $ctext tag add sel $match $mend
8232 $ctext mark unset anchor
8233 rehighlight_search_results
8237 proc dosearchback {} {
8238 global sstring ctext searchstring searchdirn
8240 focus $sstring
8241 $sstring icursor end
8242 set searchdirn -backwards
8243 if {$searchstring ne {}} {
8244 set sel [$ctext tag ranges sel]
8245 if {$sel ne {}} {
8246 set start [lindex $sel 0]
8247 } elseif {[catch {set start [$ctext index anchor]}]} {
8248 set start @0,[winfo height $ctext]
8250 set match [$ctext search -backwards -count ml -- $searchstring $start]
8251 $ctext tag remove sel 1.0 end
8252 if {$match eq {}} {
8253 bell
8254 return
8256 $ctext see $match
8257 suppress_highlighting_file_for_current_scrollpos
8258 highlightfile_for_scrollpos $match
8259 set mend "$match + $ml c"
8260 $ctext tag add sel $match $mend
8261 $ctext mark unset anchor
8262 rehighlight_search_results
8266 proc rehighlight_search_results {} {
8267 global ctext searchstring
8269 $ctext tag remove found 1.0 end
8270 $ctext tag remove currentsearchhit 1.0 end
8272 if {$searchstring ne {}} {
8273 searchmarkvisible 1
8277 proc searchmark {first last} {
8278 global ctext searchstring
8280 set sel [$ctext tag ranges sel]
8282 set mend $first.0
8283 while {1} {
8284 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8285 if {$match eq {}} break
8286 set mend "$match + $mlen c"
8287 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8288 $ctext tag add currentsearchhit $match $mend
8289 } else {
8290 $ctext tag add found $match $mend
8295 proc searchmarkvisible {doall} {
8296 global ctext smarktop smarkbot
8298 set topline [lindex [split [$ctext index @0,0] .] 0]
8299 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8300 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8301 # no overlap with previous
8302 searchmark $topline $botline
8303 set smarktop $topline
8304 set smarkbot $botline
8305 } else {
8306 if {$topline < $smarktop} {
8307 searchmark $topline [expr {$smarktop-1}]
8308 set smarktop $topline
8310 if {$botline > $smarkbot} {
8311 searchmark [expr {$smarkbot+1}] $botline
8312 set smarkbot $botline
8317 proc suppress_highlighting_file_for_current_scrollpos {} {
8318 global ctext suppress_highlighting_file_for_this_scrollpos
8320 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8323 proc scrolltext {f0 f1} {
8324 global searchstring cmitmode ctext
8325 global suppress_highlighting_file_for_this_scrollpos
8327 set topidx [$ctext index @0,0]
8328 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8329 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8330 highlightfile_for_scrollpos $topidx
8333 catch {unset suppress_highlighting_file_for_this_scrollpos}
8335 .bleft.bottom.sb set $f0 $f1
8336 if {$searchstring ne {}} {
8337 searchmarkvisible 0
8341 proc setcoords {} {
8342 global linespc charspc canvx0 canvy0
8343 global xspc1 xspc2 lthickness
8345 set linespc [font metrics mainfont -linespace]
8346 set charspc [font measure mainfont "m"]
8347 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8348 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8349 set lthickness [expr {int($linespc / 9) + 1}]
8350 set xspc1(0) $linespc
8351 set xspc2 $linespc
8354 proc redisplay {} {
8355 global canv
8356 global selectedline
8358 set ymax [lindex [$canv cget -scrollregion] 3]
8359 if {$ymax eq {} || $ymax == 0} return
8360 set span [$canv yview]
8361 clear_display
8362 setcanvscroll
8363 allcanvs yview moveto [lindex $span 0]
8364 drawvisible
8365 if {$selectedline ne {}} {
8366 selectline $selectedline 0
8367 allcanvs yview moveto [lindex $span 0]
8371 proc parsefont {f n} {
8372 global fontattr
8374 set fontattr($f,family) [lindex $n 0]
8375 set s [lindex $n 1]
8376 if {$s eq {} || $s == 0} {
8377 set s 10
8378 } elseif {$s < 0} {
8379 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8381 set fontattr($f,size) $s
8382 set fontattr($f,weight) normal
8383 set fontattr($f,slant) roman
8384 foreach style [lrange $n 2 end] {
8385 switch -- $style {
8386 "normal" -
8387 "bold" {set fontattr($f,weight) $style}
8388 "roman" -
8389 "italic" {set fontattr($f,slant) $style}
8394 proc fontflags {f {isbold 0}} {
8395 global fontattr
8397 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8398 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8399 -slant $fontattr($f,slant)]
8402 proc fontname {f} {
8403 global fontattr
8405 set n [list $fontattr($f,family) $fontattr($f,size)]
8406 if {$fontattr($f,weight) eq "bold"} {
8407 lappend n "bold"
8409 if {$fontattr($f,slant) eq "italic"} {
8410 lappend n "italic"
8412 return $n
8415 proc incrfont {inc} {
8416 global mainfont textfont ctext canv cflist showrefstop
8417 global stopped entries fontattr
8419 unmarkmatches
8420 set s $fontattr(mainfont,size)
8421 incr s $inc
8422 if {$s < 1} {
8423 set s 1
8425 set fontattr(mainfont,size) $s
8426 font config mainfont -size $s
8427 font config mainfontbold -size $s
8428 set mainfont [fontname mainfont]
8429 set s $fontattr(textfont,size)
8430 incr s $inc
8431 if {$s < 1} {
8432 set s 1
8434 set fontattr(textfont,size) $s
8435 font config textfont -size $s
8436 font config textfontbold -size $s
8437 set textfont [fontname textfont]
8438 setcoords
8439 settabs
8440 redisplay
8443 proc clearsha1 {} {
8444 global sha1entry sha1string
8445 if {[string length $sha1string] == 40} {
8446 $sha1entry delete 0 end
8450 proc sha1change {n1 n2 op} {
8451 global sha1string currentid sha1but
8452 if {$sha1string == {}
8453 || ([info exists currentid] && $sha1string == $currentid)} {
8454 set state disabled
8455 } else {
8456 set state normal
8458 if {[$sha1but cget -state] == $state} return
8459 if {$state == "normal"} {
8460 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8461 } else {
8462 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8466 proc gotocommit {} {
8467 global sha1string tagids headids curview varcid
8469 if {$sha1string == {}
8470 || ([info exists currentid] && $sha1string == $currentid)} return
8471 if {[info exists tagids($sha1string)]} {
8472 set id $tagids($sha1string)
8473 } elseif {[info exists headids($sha1string)]} {
8474 set id $headids($sha1string)
8475 } else {
8476 set id [string tolower $sha1string]
8477 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8478 set matches [longid $id]
8479 if {$matches ne {}} {
8480 if {[llength $matches] > 1} {
8481 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8482 return
8484 set id [lindex $matches 0]
8486 } else {
8487 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8488 error_popup [mc "Revision %s is not known" $sha1string]
8489 return
8493 if {[commitinview $id $curview]} {
8494 selectline [rowofcommit $id] 1
8495 return
8497 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8498 set msg [mc "SHA1 id %s is not known" $sha1string]
8499 } else {
8500 set msg [mc "Revision %s is not in the current view" $sha1string]
8502 error_popup $msg
8505 proc lineenter {x y id} {
8506 global hoverx hovery hoverid hovertimer
8507 global commitinfo canv
8509 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8510 set hoverx $x
8511 set hovery $y
8512 set hoverid $id
8513 if {[info exists hovertimer]} {
8514 after cancel $hovertimer
8516 set hovertimer [after 500 linehover]
8517 $canv delete hover
8520 proc linemotion {x y id} {
8521 global hoverx hovery hoverid hovertimer
8523 if {[info exists hoverid] && $id == $hoverid} {
8524 set hoverx $x
8525 set hovery $y
8526 if {[info exists hovertimer]} {
8527 after cancel $hovertimer
8529 set hovertimer [after 500 linehover]
8533 proc lineleave {id} {
8534 global hoverid hovertimer canv
8536 if {[info exists hoverid] && $id == $hoverid} {
8537 $canv delete hover
8538 if {[info exists hovertimer]} {
8539 after cancel $hovertimer
8540 unset hovertimer
8542 unset hoverid
8546 proc linehover {} {
8547 global hoverx hovery hoverid hovertimer
8548 global canv linespc lthickness
8549 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8551 global commitinfo
8553 set text [lindex $commitinfo($hoverid) 0]
8554 set ymax [lindex [$canv cget -scrollregion] 3]
8555 if {$ymax == {}} return
8556 set yfrac [lindex [$canv yview] 0]
8557 set x [expr {$hoverx + 2 * $linespc}]
8558 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8559 set x0 [expr {$x - 2 * $lthickness}]
8560 set y0 [expr {$y - 2 * $lthickness}]
8561 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8562 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8563 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8564 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8565 -width 1 -tags hover]
8566 $canv raise $t
8567 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8568 -font mainfont -fill $linehoverfgcolor]
8569 $canv raise $t
8572 proc clickisonarrow {id y} {
8573 global lthickness
8575 set ranges [rowranges $id]
8576 set thresh [expr {2 * $lthickness + 6}]
8577 set n [expr {[llength $ranges] - 1}]
8578 for {set i 1} {$i < $n} {incr i} {
8579 set row [lindex $ranges $i]
8580 if {abs([yc $row] - $y) < $thresh} {
8581 return $i
8584 return {}
8587 proc arrowjump {id n y} {
8588 global canv
8590 # 1 <-> 2, 3 <-> 4, etc...
8591 set n [expr {(($n - 1) ^ 1) + 1}]
8592 set row [lindex [rowranges $id] $n]
8593 set yt [yc $row]
8594 set ymax [lindex [$canv cget -scrollregion] 3]
8595 if {$ymax eq {} || $ymax <= 0} return
8596 set view [$canv yview]
8597 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8598 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8599 if {$yfrac < 0} {
8600 set yfrac 0
8602 allcanvs yview moveto $yfrac
8605 proc lineclick {x y id isnew} {
8606 global ctext commitinfo children canv thickerline curview
8608 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8609 unmarkmatches
8610 unselectline
8611 normalline
8612 $canv delete hover
8613 # draw this line thicker than normal
8614 set thickerline $id
8615 drawlines $id
8616 if {$isnew} {
8617 set ymax [lindex [$canv cget -scrollregion] 3]
8618 if {$ymax eq {}} return
8619 set yfrac [lindex [$canv yview] 0]
8620 set y [expr {$y + $yfrac * $ymax}]
8622 set dirn [clickisonarrow $id $y]
8623 if {$dirn ne {}} {
8624 arrowjump $id $dirn $y
8625 return
8628 if {$isnew} {
8629 addtohistory [list lineclick $x $y $id 0] savectextpos
8631 # fill the details pane with info about this line
8632 $ctext conf -state normal
8633 clear_ctext
8634 settabs 0
8635 $ctext insert end "[mc "Parent"]:\t"
8636 $ctext insert end $id link0
8637 setlink $id link0
8638 set info $commitinfo($id)
8639 $ctext insert end "\n\t[lindex $info 0]\n"
8640 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8641 set date [formatdate [lindex $info 2]]
8642 $ctext insert end "\t[mc "Date"]:\t$date\n"
8643 set kids $children($curview,$id)
8644 if {$kids ne {}} {
8645 $ctext insert end "\n[mc "Children"]:"
8646 set i 0
8647 foreach child $kids {
8648 incr i
8649 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8650 set info $commitinfo($child)
8651 $ctext insert end "\n\t"
8652 $ctext insert end $child link$i
8653 setlink $child link$i
8654 $ctext insert end "\n\t[lindex $info 0]"
8655 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8656 set date [formatdate [lindex $info 2]]
8657 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8660 maybe_scroll_ctext 1
8661 $ctext conf -state disabled
8662 init_flist {}
8665 proc normalline {} {
8666 global thickerline
8667 if {[info exists thickerline]} {
8668 set id $thickerline
8669 unset thickerline
8670 drawlines $id
8674 proc selbyid {id {isnew 1}} {
8675 global curview
8676 if {[commitinview $id $curview]} {
8677 selectline [rowofcommit $id] $isnew
8681 proc mstime {} {
8682 global startmstime
8683 if {![info exists startmstime]} {
8684 set startmstime [clock clicks -milliseconds]
8686 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8689 proc rowmenu {x y id} {
8690 global rowctxmenu selectedline rowmenuid curview
8691 global nullid nullid2 fakerowmenu mainhead markedid
8693 stopfinding
8694 set rowmenuid $id
8695 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8696 set state disabled
8697 } else {
8698 set state normal
8700 if {[info exists markedid] && $markedid ne $id} {
8701 set mstate normal
8702 } else {
8703 set mstate disabled
8705 if {$id ne $nullid && $id ne $nullid2} {
8706 set menu $rowctxmenu
8707 if {$mainhead ne {}} {
8708 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8709 } else {
8710 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8712 $menu entryconfigure 9 -state $mstate
8713 $menu entryconfigure 10 -state $mstate
8714 $menu entryconfigure 11 -state $mstate
8715 } else {
8716 set menu $fakerowmenu
8718 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8719 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8720 $menu entryconfigure [mca "Make patch"] -state $state
8721 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8722 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8723 tk_popup $menu $x $y
8726 proc markhere {} {
8727 global rowmenuid markedid canv
8729 set markedid $rowmenuid
8730 make_idmark $markedid
8733 proc gotomark {} {
8734 global markedid
8736 if {[info exists markedid]} {
8737 selbyid $markedid
8741 proc replace_by_kids {l r} {
8742 global curview children
8744 set id [commitonrow $r]
8745 set l [lreplace $l 0 0]
8746 foreach kid $children($curview,$id) {
8747 lappend l [rowofcommit $kid]
8749 return [lsort -integer -decreasing -unique $l]
8752 proc find_common_desc {} {
8753 global markedid rowmenuid curview children
8755 if {![info exists markedid]} return
8756 if {![commitinview $markedid $curview] ||
8757 ![commitinview $rowmenuid $curview]} return
8758 #set t1 [clock clicks -milliseconds]
8759 set l1 [list [rowofcommit $markedid]]
8760 set l2 [list [rowofcommit $rowmenuid]]
8761 while 1 {
8762 set r1 [lindex $l1 0]
8763 set r2 [lindex $l2 0]
8764 if {$r1 eq {} || $r2 eq {}} break
8765 if {$r1 == $r2} {
8766 selectline $r1 1
8767 break
8769 if {$r1 > $r2} {
8770 set l1 [replace_by_kids $l1 $r1]
8771 } else {
8772 set l2 [replace_by_kids $l2 $r2]
8775 #set t2 [clock clicks -milliseconds]
8776 #puts "took [expr {$t2-$t1}]ms"
8779 proc compare_commits {} {
8780 global markedid rowmenuid curview children
8782 if {![info exists markedid]} return
8783 if {![commitinview $markedid $curview]} return
8784 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8785 do_cmp_commits $markedid $rowmenuid
8788 proc getpatchid {id} {
8789 global patchids
8791 if {![info exists patchids($id)]} {
8792 set cmd [diffcmd [list $id] {-p --root}]
8793 # trim off the initial "|"
8794 set cmd [lrange $cmd 1 end]
8795 if {[catch {
8796 set x [eval exec $cmd | git patch-id]
8797 set patchids($id) [lindex $x 0]
8798 }]} {
8799 set patchids($id) "error"
8802 return $patchids($id)
8805 proc do_cmp_commits {a b} {
8806 global ctext curview parents children patchids commitinfo
8808 $ctext conf -state normal
8809 clear_ctext
8810 init_flist {}
8811 for {set i 0} {$i < 100} {incr i} {
8812 set skipa 0
8813 set skipb 0
8814 if {[llength $parents($curview,$a)] > 1} {
8815 appendshortlink $a [mc "Skipping merge commit "] "\n"
8816 set skipa 1
8817 } else {
8818 set patcha [getpatchid $a]
8820 if {[llength $parents($curview,$b)] > 1} {
8821 appendshortlink $b [mc "Skipping merge commit "] "\n"
8822 set skipb 1
8823 } else {
8824 set patchb [getpatchid $b]
8826 if {!$skipa && !$skipb} {
8827 set heada [lindex $commitinfo($a) 0]
8828 set headb [lindex $commitinfo($b) 0]
8829 if {$patcha eq "error"} {
8830 appendshortlink $a [mc "Error getting patch ID for "] \
8831 [mc " - stopping\n"]
8832 break
8834 if {$patchb eq "error"} {
8835 appendshortlink $b [mc "Error getting patch ID for "] \
8836 [mc " - stopping\n"]
8837 break
8839 if {$patcha eq $patchb} {
8840 if {$heada eq $headb} {
8841 appendshortlink $a [mc "Commit "]
8842 appendshortlink $b " == " " $heada\n"
8843 } else {
8844 appendshortlink $a [mc "Commit "] " $heada\n"
8845 appendshortlink $b [mc " is the same patch as\n "] \
8846 " $headb\n"
8848 set skipa 1
8849 set skipb 1
8850 } else {
8851 $ctext insert end "\n"
8852 appendshortlink $a [mc "Commit "] " $heada\n"
8853 appendshortlink $b [mc " differs from\n "] \
8854 " $headb\n"
8855 $ctext insert end [mc "Diff of commits:\n\n"]
8856 $ctext conf -state disabled
8857 update
8858 diffcommits $a $b
8859 return
8862 if {$skipa} {
8863 set kids [real_children $curview,$a]
8864 if {[llength $kids] != 1} {
8865 $ctext insert end "\n"
8866 appendshortlink $a [mc "Commit "] \
8867 [mc " has %s children - stopping\n" [llength $kids]]
8868 break
8870 set a [lindex $kids 0]
8872 if {$skipb} {
8873 set kids [real_children $curview,$b]
8874 if {[llength $kids] != 1} {
8875 appendshortlink $b [mc "Commit "] \
8876 [mc " has %s children - stopping\n" [llength $kids]]
8877 break
8879 set b [lindex $kids 0]
8882 $ctext conf -state disabled
8885 proc diffcommits {a b} {
8886 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
8888 set tmpdir [gitknewtmpdir]
8889 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8890 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8891 if {[catch {
8892 exec git diff-tree -p --pretty $a >$fna
8893 exec git diff-tree -p --pretty $b >$fnb
8894 } err]} {
8895 error_popup [mc "Error writing commit to file: %s" $err]
8896 return
8898 if {[catch {
8899 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8900 } err]} {
8901 error_popup [mc "Error diffing commits: %s" $err]
8902 return
8904 set diffids [list commits $a $b]
8905 set blobdifffd($diffids) $fd
8906 set diffinhdr 0
8907 set currdiffsubmod ""
8908 filerun $fd [list getblobdiffline $fd $diffids]
8911 proc diffvssel {dirn} {
8912 global rowmenuid selectedline
8914 if {$selectedline eq {}} return
8915 if {$dirn} {
8916 set oldid [commitonrow $selectedline]
8917 set newid $rowmenuid
8918 } else {
8919 set oldid $rowmenuid
8920 set newid [commitonrow $selectedline]
8922 addtohistory [list doseldiff $oldid $newid] savectextpos
8923 doseldiff $oldid $newid
8926 proc diffvsmark {dirn} {
8927 global rowmenuid markedid
8929 if {![info exists markedid]} return
8930 if {$dirn} {
8931 set oldid $markedid
8932 set newid $rowmenuid
8933 } else {
8934 set oldid $rowmenuid
8935 set newid $markedid
8937 addtohistory [list doseldiff $oldid $newid] savectextpos
8938 doseldiff $oldid $newid
8941 proc doseldiff {oldid newid} {
8942 global ctext
8943 global commitinfo
8945 $ctext conf -state normal
8946 clear_ctext
8947 init_flist [mc "Top"]
8948 $ctext insert end "[mc "From"] "
8949 $ctext insert end $oldid link0
8950 setlink $oldid link0
8951 $ctext insert end "\n "
8952 $ctext insert end [lindex $commitinfo($oldid) 0]
8953 $ctext insert end "\n\n[mc "To"] "
8954 $ctext insert end $newid link1
8955 setlink $newid link1
8956 $ctext insert end "\n "
8957 $ctext insert end [lindex $commitinfo($newid) 0]
8958 $ctext insert end "\n"
8959 $ctext conf -state disabled
8960 $ctext tag remove found 1.0 end
8961 startdiff [list $oldid $newid]
8964 proc mkpatch {} {
8965 global rowmenuid currentid commitinfo patchtop patchnum NS
8967 if {![info exists currentid]} return
8968 set oldid $currentid
8969 set oldhead [lindex $commitinfo($oldid) 0]
8970 set newid $rowmenuid
8971 set newhead [lindex $commitinfo($newid) 0]
8972 set top .patch
8973 set patchtop $top
8974 catch {destroy $top}
8975 ttk_toplevel $top
8976 make_transient $top .
8977 ${NS}::label $top.title -text [mc "Generate patch"]
8978 grid $top.title - -pady 10
8979 ${NS}::label $top.from -text [mc "From:"]
8980 ${NS}::entry $top.fromsha1 -width 40
8981 $top.fromsha1 insert 0 $oldid
8982 $top.fromsha1 conf -state readonly
8983 grid $top.from $top.fromsha1 -sticky w
8984 ${NS}::entry $top.fromhead -width 60
8985 $top.fromhead insert 0 $oldhead
8986 $top.fromhead conf -state readonly
8987 grid x $top.fromhead -sticky w
8988 ${NS}::label $top.to -text [mc "To:"]
8989 ${NS}::entry $top.tosha1 -width 40
8990 $top.tosha1 insert 0 $newid
8991 $top.tosha1 conf -state readonly
8992 grid $top.to $top.tosha1 -sticky w
8993 ${NS}::entry $top.tohead -width 60
8994 $top.tohead insert 0 $newhead
8995 $top.tohead conf -state readonly
8996 grid x $top.tohead -sticky w
8997 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8998 grid $top.rev x -pady 10 -padx 5
8999 ${NS}::label $top.flab -text [mc "Output file:"]
9000 ${NS}::entry $top.fname -width 60
9001 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9002 incr patchnum
9003 grid $top.flab $top.fname -sticky w
9004 ${NS}::frame $top.buts
9005 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9006 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9007 bind $top <Key-Return> mkpatchgo
9008 bind $top <Key-Escape> mkpatchcan
9009 grid $top.buts.gen $top.buts.can
9010 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9011 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9012 grid $top.buts - -pady 10 -sticky ew
9013 focus $top.fname
9016 proc mkpatchrev {} {
9017 global patchtop
9019 set oldid [$patchtop.fromsha1 get]
9020 set oldhead [$patchtop.fromhead get]
9021 set newid [$patchtop.tosha1 get]
9022 set newhead [$patchtop.tohead get]
9023 foreach e [list fromsha1 fromhead tosha1 tohead] \
9024 v [list $newid $newhead $oldid $oldhead] {
9025 $patchtop.$e conf -state normal
9026 $patchtop.$e delete 0 end
9027 $patchtop.$e insert 0 $v
9028 $patchtop.$e conf -state readonly
9032 proc mkpatchgo {} {
9033 global patchtop nullid nullid2
9035 set oldid [$patchtop.fromsha1 get]
9036 set newid [$patchtop.tosha1 get]
9037 set fname [$patchtop.fname get]
9038 set cmd [diffcmd [list $oldid $newid] -p]
9039 # trim off the initial "|"
9040 set cmd [lrange $cmd 1 end]
9041 lappend cmd >$fname &
9042 if {[catch {eval exec $cmd} err]} {
9043 error_popup "[mc "Error creating patch:"] $err" $patchtop
9045 catch {destroy $patchtop}
9046 unset patchtop
9049 proc mkpatchcan {} {
9050 global patchtop
9052 catch {destroy $patchtop}
9053 unset patchtop
9056 proc mktag {} {
9057 global rowmenuid mktagtop commitinfo NS
9059 set top .maketag
9060 set mktagtop $top
9061 catch {destroy $top}
9062 ttk_toplevel $top
9063 make_transient $top .
9064 ${NS}::label $top.title -text [mc "Create tag"]
9065 grid $top.title - -pady 10
9066 ${NS}::label $top.id -text [mc "ID:"]
9067 ${NS}::entry $top.sha1 -width 40
9068 $top.sha1 insert 0 $rowmenuid
9069 $top.sha1 conf -state readonly
9070 grid $top.id $top.sha1 -sticky w
9071 ${NS}::entry $top.head -width 60
9072 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9073 $top.head conf -state readonly
9074 grid x $top.head -sticky w
9075 ${NS}::label $top.tlab -text [mc "Tag name:"]
9076 ${NS}::entry $top.tag -width 60
9077 grid $top.tlab $top.tag -sticky w
9078 ${NS}::label $top.op -text [mc "Tag message is optional"]
9079 grid $top.op -columnspan 2 -sticky we
9080 ${NS}::label $top.mlab -text [mc "Tag message:"]
9081 ${NS}::entry $top.msg -width 60
9082 grid $top.mlab $top.msg -sticky w
9083 ${NS}::frame $top.buts
9084 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9085 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9086 bind $top <Key-Return> mktaggo
9087 bind $top <Key-Escape> mktagcan
9088 grid $top.buts.gen $top.buts.can
9089 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9090 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9091 grid $top.buts - -pady 10 -sticky ew
9092 focus $top.tag
9095 proc domktag {} {
9096 global mktagtop env tagids idtags
9098 set id [$mktagtop.sha1 get]
9099 set tag [$mktagtop.tag get]
9100 set msg [$mktagtop.msg get]
9101 if {$tag == {}} {
9102 error_popup [mc "No tag name specified"] $mktagtop
9103 return 0
9105 if {[info exists tagids($tag)]} {
9106 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9107 return 0
9109 if {[catch {
9110 if {$msg != {}} {
9111 exec git tag -a -m $msg $tag $id
9112 } else {
9113 exec git tag $tag $id
9115 } err]} {
9116 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9117 return 0
9120 set tagids($tag) $id
9121 lappend idtags($id) $tag
9122 redrawtags $id
9123 addedtag $id
9124 dispneartags 0
9125 run refill_reflist
9126 return 1
9129 proc redrawtags {id} {
9130 global canv linehtag idpos currentid curview cmitlisted markedid
9131 global canvxmax iddrawn circleitem mainheadid circlecolors
9132 global mainheadcirclecolor
9134 if {![commitinview $id $curview]} return
9135 if {![info exists iddrawn($id)]} return
9136 set row [rowofcommit $id]
9137 if {$id eq $mainheadid} {
9138 set ofill $mainheadcirclecolor
9139 } else {
9140 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9142 $canv itemconf $circleitem($row) -fill $ofill
9143 $canv delete tag.$id
9144 set xt [eval drawtags $id $idpos($id)]
9145 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9146 set text [$canv itemcget $linehtag($id) -text]
9147 set font [$canv itemcget $linehtag($id) -font]
9148 set xr [expr {$xt + [font measure $font $text]}]
9149 if {$xr > $canvxmax} {
9150 set canvxmax $xr
9151 setcanvscroll
9153 if {[info exists currentid] && $currentid == $id} {
9154 make_secsel $id
9156 if {[info exists markedid] && $markedid eq $id} {
9157 make_idmark $id
9161 proc mktagcan {} {
9162 global mktagtop
9164 catch {destroy $mktagtop}
9165 unset mktagtop
9168 proc mktaggo {} {
9169 if {![domktag]} return
9170 mktagcan
9173 proc writecommit {} {
9174 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9176 set top .writecommit
9177 set wrcomtop $top
9178 catch {destroy $top}
9179 ttk_toplevel $top
9180 make_transient $top .
9181 ${NS}::label $top.title -text [mc "Write commit to file"]
9182 grid $top.title - -pady 10
9183 ${NS}::label $top.id -text [mc "ID:"]
9184 ${NS}::entry $top.sha1 -width 40
9185 $top.sha1 insert 0 $rowmenuid
9186 $top.sha1 conf -state readonly
9187 grid $top.id $top.sha1 -sticky w
9188 ${NS}::entry $top.head -width 60
9189 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9190 $top.head conf -state readonly
9191 grid x $top.head -sticky w
9192 ${NS}::label $top.clab -text [mc "Command:"]
9193 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9194 grid $top.clab $top.cmd -sticky w -pady 10
9195 ${NS}::label $top.flab -text [mc "Output file:"]
9196 ${NS}::entry $top.fname -width 60
9197 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9198 grid $top.flab $top.fname -sticky w
9199 ${NS}::frame $top.buts
9200 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9201 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9202 bind $top <Key-Return> wrcomgo
9203 bind $top <Key-Escape> wrcomcan
9204 grid $top.buts.gen $top.buts.can
9205 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9206 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9207 grid $top.buts - -pady 10 -sticky ew
9208 focus $top.fname
9211 proc wrcomgo {} {
9212 global wrcomtop
9214 set id [$wrcomtop.sha1 get]
9215 set cmd "echo $id | [$wrcomtop.cmd get]"
9216 set fname [$wrcomtop.fname get]
9217 if {[catch {exec sh -c $cmd >$fname &} err]} {
9218 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9220 catch {destroy $wrcomtop}
9221 unset wrcomtop
9224 proc wrcomcan {} {
9225 global wrcomtop
9227 catch {destroy $wrcomtop}
9228 unset wrcomtop
9231 proc mkbranch {} {
9232 global rowmenuid mkbrtop NS
9234 set top .makebranch
9235 catch {destroy $top}
9236 ttk_toplevel $top
9237 make_transient $top .
9238 ${NS}::label $top.title -text [mc "Create new branch"]
9239 grid $top.title - -pady 10
9240 ${NS}::label $top.id -text [mc "ID:"]
9241 ${NS}::entry $top.sha1 -width 40
9242 $top.sha1 insert 0 $rowmenuid
9243 $top.sha1 conf -state readonly
9244 grid $top.id $top.sha1 -sticky w
9245 ${NS}::label $top.nlab -text [mc "Name:"]
9246 ${NS}::entry $top.name -width 40
9247 grid $top.nlab $top.name -sticky w
9248 ${NS}::frame $top.buts
9249 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9250 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9251 bind $top <Key-Return> [list mkbrgo $top]
9252 bind $top <Key-Escape> "catch {destroy $top}"
9253 grid $top.buts.go $top.buts.can
9254 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9255 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9256 grid $top.buts - -pady 10 -sticky ew
9257 focus $top.name
9260 proc mkbrgo {top} {
9261 global headids idheads
9263 set name [$top.name get]
9264 set id [$top.sha1 get]
9265 set cmdargs {}
9266 set old_id {}
9267 if {$name eq {}} {
9268 error_popup [mc "Please specify a name for the new branch"] $top
9269 return
9271 if {[info exists headids($name)]} {
9272 if {![confirm_popup [mc \
9273 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9274 return
9276 set old_id $headids($name)
9277 lappend cmdargs -f
9279 catch {destroy $top}
9280 lappend cmdargs $name $id
9281 nowbusy newbranch
9282 update
9283 if {[catch {
9284 eval exec git branch $cmdargs
9285 } err]} {
9286 notbusy newbranch
9287 error_popup $err
9288 } else {
9289 notbusy newbranch
9290 if {$old_id ne {}} {
9291 movehead $id $name
9292 movedhead $id $name
9293 redrawtags $old_id
9294 redrawtags $id
9295 } else {
9296 set headids($name) $id
9297 lappend idheads($id) $name
9298 addedhead $id $name
9299 redrawtags $id
9301 dispneartags 0
9302 run refill_reflist
9306 proc exec_citool {tool_args {baseid {}}} {
9307 global commitinfo env
9309 set save_env [array get env GIT_AUTHOR_*]
9311 if {$baseid ne {}} {
9312 if {![info exists commitinfo($baseid)]} {
9313 getcommit $baseid
9315 set author [lindex $commitinfo($baseid) 1]
9316 set date [lindex $commitinfo($baseid) 2]
9317 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9318 $author author name email]
9319 && $date ne {}} {
9320 set env(GIT_AUTHOR_NAME) $name
9321 set env(GIT_AUTHOR_EMAIL) $email
9322 set env(GIT_AUTHOR_DATE) $date
9326 eval exec git citool $tool_args &
9328 array unset env GIT_AUTHOR_*
9329 array set env $save_env
9332 proc cherrypick {} {
9333 global rowmenuid curview
9334 global mainhead mainheadid
9335 global gitdir
9337 set oldhead [exec git rev-parse HEAD]
9338 set dheads [descheads $rowmenuid]
9339 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9340 set ok [confirm_popup [mc "Commit %s is already\
9341 included in branch %s -- really re-apply it?" \
9342 [string range $rowmenuid 0 7] $mainhead]]
9343 if {!$ok} return
9345 nowbusy cherrypick [mc "Cherry-picking"]
9346 update
9347 # Unfortunately git-cherry-pick writes stuff to stderr even when
9348 # no error occurs, and exec takes that as an indication of error...
9349 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9350 notbusy cherrypick
9351 if {[regexp -line \
9352 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9353 $err msg fname]} {
9354 error_popup [mc "Cherry-pick failed because of local changes\
9355 to file '%s'.\nPlease commit, reset or stash\
9356 your changes and try again." $fname]
9357 } elseif {[regexp -line \
9358 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9359 $err]} {
9360 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9361 conflict.\nDo you wish to run git citool to\
9362 resolve it?"]]} {
9363 # Force citool to read MERGE_MSG
9364 file delete [file join $gitdir "GITGUI_MSG"]
9365 exec_citool {} $rowmenuid
9367 } else {
9368 error_popup $err
9370 run updatecommits
9371 return
9373 set newhead [exec git rev-parse HEAD]
9374 if {$newhead eq $oldhead} {
9375 notbusy cherrypick
9376 error_popup [mc "No changes committed"]
9377 return
9379 addnewchild $newhead $oldhead
9380 if {[commitinview $oldhead $curview]} {
9381 # XXX this isn't right if we have a path limit...
9382 insertrow $newhead $oldhead $curview
9383 if {$mainhead ne {}} {
9384 movehead $newhead $mainhead
9385 movedhead $newhead $mainhead
9387 set mainheadid $newhead
9388 redrawtags $oldhead
9389 redrawtags $newhead
9390 selbyid $newhead
9392 notbusy cherrypick
9395 proc revert {} {
9396 global rowmenuid curview
9397 global mainhead mainheadid
9398 global gitdir
9400 set oldhead [exec git rev-parse HEAD]
9401 set dheads [descheads $rowmenuid]
9402 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9403 set ok [confirm_popup [mc "Commit %s is not\
9404 included in branch %s -- really revert it?" \
9405 [string range $rowmenuid 0 7] $mainhead]]
9406 if {!$ok} return
9408 nowbusy revert [mc "Reverting"]
9409 update
9411 if [catch {exec git revert --no-edit $rowmenuid} err] {
9412 notbusy revert
9413 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9414 $err match files] {
9415 regsub {\n( |\t)+} $files "\n" files
9416 error_popup [mc "Revert failed because of local changes to\
9417 the following files:%s Please commit, reset or stash \
9418 your changes and try again." $files]
9419 } elseif [regexp {error: could not revert} $err] {
9420 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9421 Do you wish to run git citool to resolve it?"]] {
9422 # Force citool to read MERGE_MSG
9423 file delete [file join $gitdir "GITGUI_MSG"]
9424 exec_citool {} $rowmenuid
9426 } else { error_popup $err }
9427 run updatecommits
9428 return
9431 set newhead [exec git rev-parse HEAD]
9432 if { $newhead eq $oldhead } {
9433 notbusy revert
9434 error_popup [mc "No changes committed"]
9435 return
9438 addnewchild $newhead $oldhead
9440 if [commitinview $oldhead $curview] {
9441 # XXX this isn't right if we have a path limit...
9442 insertrow $newhead $oldhead $curview
9443 if {$mainhead ne {}} {
9444 movehead $newhead $mainhead
9445 movedhead $newhead $mainhead
9447 set mainheadid $newhead
9448 redrawtags $oldhead
9449 redrawtags $newhead
9450 selbyid $newhead
9453 notbusy revert
9456 proc resethead {} {
9457 global mainhead rowmenuid confirm_ok resettype NS
9459 set confirm_ok 0
9460 set w ".confirmreset"
9461 ttk_toplevel $w
9462 make_transient $w .
9463 wm title $w [mc "Confirm reset"]
9464 ${NS}::label $w.m -text \
9465 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9466 pack $w.m -side top -fill x -padx 20 -pady 20
9467 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9468 set resettype mixed
9469 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9470 -text [mc "Soft: Leave working tree and index untouched"]
9471 grid $w.f.soft -sticky w
9472 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9473 -text [mc "Mixed: Leave working tree untouched, reset index"]
9474 grid $w.f.mixed -sticky w
9475 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9476 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9477 grid $w.f.hard -sticky w
9478 pack $w.f -side top -fill x -padx 4
9479 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9480 pack $w.ok -side left -fill x -padx 20 -pady 20
9481 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9482 bind $w <Key-Escape> [list destroy $w]
9483 pack $w.cancel -side right -fill x -padx 20 -pady 20
9484 bind $w <Visibility> "grab $w; focus $w"
9485 tkwait window $w
9486 if {!$confirm_ok} return
9487 if {[catch {set fd [open \
9488 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9489 error_popup $err
9490 } else {
9491 dohidelocalchanges
9492 filerun $fd [list readresetstat $fd]
9493 nowbusy reset [mc "Resetting"]
9494 selbyid $rowmenuid
9498 proc readresetstat {fd} {
9499 global mainhead mainheadid showlocalchanges rprogcoord
9501 if {[gets $fd line] >= 0} {
9502 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9503 set rprogcoord [expr {1.0 * $m / $n}]
9504 adjustprogress
9506 return 1
9508 set rprogcoord 0
9509 adjustprogress
9510 notbusy reset
9511 if {[catch {close $fd} err]} {
9512 error_popup $err
9514 set oldhead $mainheadid
9515 set newhead [exec git rev-parse HEAD]
9516 if {$newhead ne $oldhead} {
9517 movehead $newhead $mainhead
9518 movedhead $newhead $mainhead
9519 set mainheadid $newhead
9520 redrawtags $oldhead
9521 redrawtags $newhead
9523 if {$showlocalchanges} {
9524 doshowlocalchanges
9526 return 0
9529 # context menu for a head
9530 proc headmenu {x y id head} {
9531 global headmenuid headmenuhead headctxmenu mainhead
9533 stopfinding
9534 set headmenuid $id
9535 set headmenuhead $head
9536 set state normal
9537 if {[string match "remotes/*" $head]} {
9538 set state disabled
9540 if {$head eq $mainhead} {
9541 set state disabled
9543 $headctxmenu entryconfigure 0 -state $state
9544 $headctxmenu entryconfigure 1 -state $state
9545 tk_popup $headctxmenu $x $y
9548 proc cobranch {} {
9549 global headmenuid headmenuhead headids
9550 global showlocalchanges
9552 # check the tree is clean first??
9553 nowbusy checkout [mc "Checking out"]
9554 update
9555 dohidelocalchanges
9556 if {[catch {
9557 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9558 } err]} {
9559 notbusy checkout
9560 error_popup $err
9561 if {$showlocalchanges} {
9562 dodiffindex
9564 } else {
9565 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9569 proc readcheckoutstat {fd newhead newheadid} {
9570 global mainhead mainheadid headids showlocalchanges progresscoords
9571 global viewmainheadid curview
9573 if {[gets $fd line] >= 0} {
9574 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9575 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9576 adjustprogress
9578 return 1
9580 set progresscoords {0 0}
9581 adjustprogress
9582 notbusy checkout
9583 if {[catch {close $fd} err]} {
9584 error_popup $err
9586 set oldmainid $mainheadid
9587 set mainhead $newhead
9588 set mainheadid $newheadid
9589 set viewmainheadid($curview) $newheadid
9590 redrawtags $oldmainid
9591 redrawtags $newheadid
9592 selbyid $newheadid
9593 if {$showlocalchanges} {
9594 dodiffindex
9598 proc rmbranch {} {
9599 global headmenuid headmenuhead mainhead
9600 global idheads
9602 set head $headmenuhead
9603 set id $headmenuid
9604 # this check shouldn't be needed any more...
9605 if {$head eq $mainhead} {
9606 error_popup [mc "Cannot delete the currently checked-out branch"]
9607 return
9609 set dheads [descheads $id]
9610 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9611 # the stuff on this branch isn't on any other branch
9612 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9613 branch.\nReally delete branch %s?" $head $head]]} return
9615 nowbusy rmbranch
9616 update
9617 if {[catch {exec git branch -D $head} err]} {
9618 notbusy rmbranch
9619 error_popup $err
9620 return
9622 removehead $id $head
9623 removedhead $id $head
9624 redrawtags $id
9625 notbusy rmbranch
9626 dispneartags 0
9627 run refill_reflist
9630 # Display a list of tags and heads
9631 proc showrefs {} {
9632 global showrefstop bgcolor fgcolor selectbgcolor NS
9633 global bglist fglist reflistfilter reflist maincursor
9635 set top .showrefs
9636 set showrefstop $top
9637 if {[winfo exists $top]} {
9638 raise $top
9639 refill_reflist
9640 return
9642 ttk_toplevel $top
9643 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9644 make_transient $top .
9645 text $top.list -background $bgcolor -foreground $fgcolor \
9646 -selectbackground $selectbgcolor -font mainfont \
9647 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9648 -width 30 -height 20 -cursor $maincursor \
9649 -spacing1 1 -spacing3 1 -state disabled
9650 $top.list tag configure highlight -background $selectbgcolor
9651 lappend bglist $top.list
9652 lappend fglist $top.list
9653 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9654 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9655 grid $top.list $top.ysb -sticky nsew
9656 grid $top.xsb x -sticky ew
9657 ${NS}::frame $top.f
9658 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9659 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9660 set reflistfilter "*"
9661 trace add variable reflistfilter write reflistfilter_change
9662 pack $top.f.e -side right -fill x -expand 1
9663 pack $top.f.l -side left
9664 grid $top.f - -sticky ew -pady 2
9665 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9666 bind $top <Key-Escape> [list destroy $top]
9667 grid $top.close -
9668 grid columnconfigure $top 0 -weight 1
9669 grid rowconfigure $top 0 -weight 1
9670 bind $top.list <1> {break}
9671 bind $top.list <B1-Motion> {break}
9672 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9673 set reflist {}
9674 refill_reflist
9677 proc sel_reflist {w x y} {
9678 global showrefstop reflist headids tagids otherrefids
9680 if {![winfo exists $showrefstop]} return
9681 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9682 set ref [lindex $reflist [expr {$l-1}]]
9683 set n [lindex $ref 0]
9684 switch -- [lindex $ref 1] {
9685 "H" {selbyid $headids($n)}
9686 "T" {selbyid $tagids($n)}
9687 "o" {selbyid $otherrefids($n)}
9689 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9692 proc unsel_reflist {} {
9693 global showrefstop
9695 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9696 $showrefstop.list tag remove highlight 0.0 end
9699 proc reflistfilter_change {n1 n2 op} {
9700 global reflistfilter
9702 after cancel refill_reflist
9703 after 200 refill_reflist
9706 proc refill_reflist {} {
9707 global reflist reflistfilter showrefstop headids tagids otherrefids
9708 global curview
9710 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9711 set refs {}
9712 foreach n [array names headids] {
9713 if {[string match $reflistfilter $n]} {
9714 if {[commitinview $headids($n) $curview]} {
9715 lappend refs [list $n H]
9716 } else {
9717 interestedin $headids($n) {run refill_reflist}
9721 foreach n [array names tagids] {
9722 if {[string match $reflistfilter $n]} {
9723 if {[commitinview $tagids($n) $curview]} {
9724 lappend refs [list $n T]
9725 } else {
9726 interestedin $tagids($n) {run refill_reflist}
9730 foreach n [array names otherrefids] {
9731 if {[string match $reflistfilter $n]} {
9732 if {[commitinview $otherrefids($n) $curview]} {
9733 lappend refs [list $n o]
9734 } else {
9735 interestedin $otherrefids($n) {run refill_reflist}
9739 set refs [lsort -index 0 $refs]
9740 if {$refs eq $reflist} return
9742 # Update the contents of $showrefstop.list according to the
9743 # differences between $reflist (old) and $refs (new)
9744 $showrefstop.list conf -state normal
9745 $showrefstop.list insert end "\n"
9746 set i 0
9747 set j 0
9748 while {$i < [llength $reflist] || $j < [llength $refs]} {
9749 if {$i < [llength $reflist]} {
9750 if {$j < [llength $refs]} {
9751 set cmp [string compare [lindex $reflist $i 0] \
9752 [lindex $refs $j 0]]
9753 if {$cmp == 0} {
9754 set cmp [string compare [lindex $reflist $i 1] \
9755 [lindex $refs $j 1]]
9757 } else {
9758 set cmp -1
9760 } else {
9761 set cmp 1
9763 switch -- $cmp {
9764 -1 {
9765 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9766 incr i
9769 incr i
9770 incr j
9773 set l [expr {$j + 1}]
9774 $showrefstop.list image create $l.0 -align baseline \
9775 -image reficon-[lindex $refs $j 1] -padx 2
9776 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9777 incr j
9781 set reflist $refs
9782 # delete last newline
9783 $showrefstop.list delete end-2c end-1c
9784 $showrefstop.list conf -state disabled
9787 # Stuff for finding nearby tags
9788 proc getallcommits {} {
9789 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9790 global idheads idtags idotherrefs allparents tagobjid
9791 global gitdir
9793 if {![info exists allcommits]} {
9794 set nextarc 0
9795 set allcommits 0
9796 set seeds {}
9797 set allcwait 0
9798 set cachedarcs 0
9799 set allccache [file join $gitdir "gitk.cache"]
9800 if {![catch {
9801 set f [open $allccache r]
9802 set allcwait 1
9803 getcache $f
9804 }]} return
9807 if {$allcwait} {
9808 return
9810 set cmd [list | git rev-list --parents]
9811 set allcupdate [expr {$seeds ne {}}]
9812 if {!$allcupdate} {
9813 set ids "--all"
9814 } else {
9815 set refs [concat [array names idheads] [array names idtags] \
9816 [array names idotherrefs]]
9817 set ids {}
9818 set tagobjs {}
9819 foreach name [array names tagobjid] {
9820 lappend tagobjs $tagobjid($name)
9822 foreach id [lsort -unique $refs] {
9823 if {![info exists allparents($id)] &&
9824 [lsearch -exact $tagobjs $id] < 0} {
9825 lappend ids $id
9828 if {$ids ne {}} {
9829 foreach id $seeds {
9830 lappend ids "^$id"
9834 if {$ids ne {}} {
9835 set fd [open [concat $cmd $ids] r]
9836 fconfigure $fd -blocking 0
9837 incr allcommits
9838 nowbusy allcommits
9839 filerun $fd [list getallclines $fd]
9840 } else {
9841 dispneartags 0
9845 # Since most commits have 1 parent and 1 child, we group strings of
9846 # such commits into "arcs" joining branch/merge points (BMPs), which
9847 # are commits that either don't have 1 parent or don't have 1 child.
9849 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9850 # arcout(id) - outgoing arcs for BMP
9851 # arcids(a) - list of IDs on arc including end but not start
9852 # arcstart(a) - BMP ID at start of arc
9853 # arcend(a) - BMP ID at end of arc
9854 # growing(a) - arc a is still growing
9855 # arctags(a) - IDs out of arcids (excluding end) that have tags
9856 # archeads(a) - IDs out of arcids (excluding end) that have heads
9857 # The start of an arc is at the descendent end, so "incoming" means
9858 # coming from descendents, and "outgoing" means going towards ancestors.
9860 proc getallclines {fd} {
9861 global allparents allchildren idtags idheads nextarc
9862 global arcnos arcids arctags arcout arcend arcstart archeads growing
9863 global seeds allcommits cachedarcs allcupdate
9865 set nid 0
9866 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9867 set id [lindex $line 0]
9868 if {[info exists allparents($id)]} {
9869 # seen it already
9870 continue
9872 set cachedarcs 0
9873 set olds [lrange $line 1 end]
9874 set allparents($id) $olds
9875 if {![info exists allchildren($id)]} {
9876 set allchildren($id) {}
9877 set arcnos($id) {}
9878 lappend seeds $id
9879 } else {
9880 set a $arcnos($id)
9881 if {[llength $olds] == 1 && [llength $a] == 1} {
9882 lappend arcids($a) $id
9883 if {[info exists idtags($id)]} {
9884 lappend arctags($a) $id
9886 if {[info exists idheads($id)]} {
9887 lappend archeads($a) $id
9889 if {[info exists allparents($olds)]} {
9890 # seen parent already
9891 if {![info exists arcout($olds)]} {
9892 splitarc $olds
9894 lappend arcids($a) $olds
9895 set arcend($a) $olds
9896 unset growing($a)
9898 lappend allchildren($olds) $id
9899 lappend arcnos($olds) $a
9900 continue
9903 foreach a $arcnos($id) {
9904 lappend arcids($a) $id
9905 set arcend($a) $id
9906 unset growing($a)
9909 set ao {}
9910 foreach p $olds {
9911 lappend allchildren($p) $id
9912 set a [incr nextarc]
9913 set arcstart($a) $id
9914 set archeads($a) {}
9915 set arctags($a) {}
9916 set archeads($a) {}
9917 set arcids($a) {}
9918 lappend ao $a
9919 set growing($a) 1
9920 if {[info exists allparents($p)]} {
9921 # seen it already, may need to make a new branch
9922 if {![info exists arcout($p)]} {
9923 splitarc $p
9925 lappend arcids($a) $p
9926 set arcend($a) $p
9927 unset growing($a)
9929 lappend arcnos($p) $a
9931 set arcout($id) $ao
9933 if {$nid > 0} {
9934 global cached_dheads cached_dtags cached_atags
9935 catch {unset cached_dheads}
9936 catch {unset cached_dtags}
9937 catch {unset cached_atags}
9939 if {![eof $fd]} {
9940 return [expr {$nid >= 1000? 2: 1}]
9942 set cacheok 1
9943 if {[catch {
9944 fconfigure $fd -blocking 1
9945 close $fd
9946 } err]} {
9947 # got an error reading the list of commits
9948 # if we were updating, try rereading the whole thing again
9949 if {$allcupdate} {
9950 incr allcommits -1
9951 dropcache $err
9952 return
9954 error_popup "[mc "Error reading commit topology information;\
9955 branch and preceding/following tag information\
9956 will be incomplete."]\n($err)"
9957 set cacheok 0
9959 if {[incr allcommits -1] == 0} {
9960 notbusy allcommits
9961 if {$cacheok} {
9962 run savecache
9965 dispneartags 0
9966 return 0
9969 proc recalcarc {a} {
9970 global arctags archeads arcids idtags idheads
9972 set at {}
9973 set ah {}
9974 foreach id [lrange $arcids($a) 0 end-1] {
9975 if {[info exists idtags($id)]} {
9976 lappend at $id
9978 if {[info exists idheads($id)]} {
9979 lappend ah $id
9982 set arctags($a) $at
9983 set archeads($a) $ah
9986 proc splitarc {p} {
9987 global arcnos arcids nextarc arctags archeads idtags idheads
9988 global arcstart arcend arcout allparents growing
9990 set a $arcnos($p)
9991 if {[llength $a] != 1} {
9992 puts "oops splitarc called but [llength $a] arcs already"
9993 return
9995 set a [lindex $a 0]
9996 set i [lsearch -exact $arcids($a) $p]
9997 if {$i < 0} {
9998 puts "oops splitarc $p not in arc $a"
9999 return
10001 set na [incr nextarc]
10002 if {[info exists arcend($a)]} {
10003 set arcend($na) $arcend($a)
10004 } else {
10005 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10006 set j [lsearch -exact $arcnos($l) $a]
10007 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10009 set tail [lrange $arcids($a) [expr {$i+1}] end]
10010 set arcids($a) [lrange $arcids($a) 0 $i]
10011 set arcend($a) $p
10012 set arcstart($na) $p
10013 set arcout($p) $na
10014 set arcids($na) $tail
10015 if {[info exists growing($a)]} {
10016 set growing($na) 1
10017 unset growing($a)
10020 foreach id $tail {
10021 if {[llength $arcnos($id)] == 1} {
10022 set arcnos($id) $na
10023 } else {
10024 set j [lsearch -exact $arcnos($id) $a]
10025 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10029 # reconstruct tags and heads lists
10030 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10031 recalcarc $a
10032 recalcarc $na
10033 } else {
10034 set arctags($na) {}
10035 set archeads($na) {}
10039 # Update things for a new commit added that is a child of one
10040 # existing commit. Used when cherry-picking.
10041 proc addnewchild {id p} {
10042 global allparents allchildren idtags nextarc
10043 global arcnos arcids arctags arcout arcend arcstart archeads growing
10044 global seeds allcommits
10046 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10047 set allparents($id) [list $p]
10048 set allchildren($id) {}
10049 set arcnos($id) {}
10050 lappend seeds $id
10051 lappend allchildren($p) $id
10052 set a [incr nextarc]
10053 set arcstart($a) $id
10054 set archeads($a) {}
10055 set arctags($a) {}
10056 set arcids($a) [list $p]
10057 set arcend($a) $p
10058 if {![info exists arcout($p)]} {
10059 splitarc $p
10061 lappend arcnos($p) $a
10062 set arcout($id) [list $a]
10065 # This implements a cache for the topology information.
10066 # The cache saves, for each arc, the start and end of the arc,
10067 # the ids on the arc, and the outgoing arcs from the end.
10068 proc readcache {f} {
10069 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10070 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10071 global allcwait
10073 set a $nextarc
10074 set lim $cachedarcs
10075 if {$lim - $a > 500} {
10076 set lim [expr {$a + 500}]
10078 if {[catch {
10079 if {$a == $lim} {
10080 # finish reading the cache and setting up arctags, etc.
10081 set line [gets $f]
10082 if {$line ne "1"} {error "bad final version"}
10083 close $f
10084 foreach id [array names idtags] {
10085 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10086 [llength $allparents($id)] == 1} {
10087 set a [lindex $arcnos($id) 0]
10088 if {$arctags($a) eq {}} {
10089 recalcarc $a
10093 foreach id [array names idheads] {
10094 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10095 [llength $allparents($id)] == 1} {
10096 set a [lindex $arcnos($id) 0]
10097 if {$archeads($a) eq {}} {
10098 recalcarc $a
10102 foreach id [lsort -unique $possible_seeds] {
10103 if {$arcnos($id) eq {}} {
10104 lappend seeds $id
10107 set allcwait 0
10108 } else {
10109 while {[incr a] <= $lim} {
10110 set line [gets $f]
10111 if {[llength $line] != 3} {error "bad line"}
10112 set s [lindex $line 0]
10113 set arcstart($a) $s
10114 lappend arcout($s) $a
10115 if {![info exists arcnos($s)]} {
10116 lappend possible_seeds $s
10117 set arcnos($s) {}
10119 set e [lindex $line 1]
10120 if {$e eq {}} {
10121 set growing($a) 1
10122 } else {
10123 set arcend($a) $e
10124 if {![info exists arcout($e)]} {
10125 set arcout($e) {}
10128 set arcids($a) [lindex $line 2]
10129 foreach id $arcids($a) {
10130 lappend allparents($s) $id
10131 set s $id
10132 lappend arcnos($id) $a
10134 if {![info exists allparents($s)]} {
10135 set allparents($s) {}
10137 set arctags($a) {}
10138 set archeads($a) {}
10140 set nextarc [expr {$a - 1}]
10142 } err]} {
10143 dropcache $err
10144 return 0
10146 if {!$allcwait} {
10147 getallcommits
10149 return $allcwait
10152 proc getcache {f} {
10153 global nextarc cachedarcs possible_seeds
10155 if {[catch {
10156 set line [gets $f]
10157 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10158 # make sure it's an integer
10159 set cachedarcs [expr {int([lindex $line 1])}]
10160 if {$cachedarcs < 0} {error "bad number of arcs"}
10161 set nextarc 0
10162 set possible_seeds {}
10163 run readcache $f
10164 } err]} {
10165 dropcache $err
10167 return 0
10170 proc dropcache {err} {
10171 global allcwait nextarc cachedarcs seeds
10173 #puts "dropping cache ($err)"
10174 foreach v {arcnos arcout arcids arcstart arcend growing \
10175 arctags archeads allparents allchildren} {
10176 global $v
10177 catch {unset $v}
10179 set allcwait 0
10180 set nextarc 0
10181 set cachedarcs 0
10182 set seeds {}
10183 getallcommits
10186 proc writecache {f} {
10187 global cachearc cachedarcs allccache
10188 global arcstart arcend arcnos arcids arcout
10190 set a $cachearc
10191 set lim $cachedarcs
10192 if {$lim - $a > 1000} {
10193 set lim [expr {$a + 1000}]
10195 if {[catch {
10196 while {[incr a] <= $lim} {
10197 if {[info exists arcend($a)]} {
10198 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10199 } else {
10200 puts $f [list $arcstart($a) {} $arcids($a)]
10203 } err]} {
10204 catch {close $f}
10205 catch {file delete $allccache}
10206 #puts "writing cache failed ($err)"
10207 return 0
10209 set cachearc [expr {$a - 1}]
10210 if {$a > $cachedarcs} {
10211 puts $f "1"
10212 close $f
10213 return 0
10215 return 1
10218 proc savecache {} {
10219 global nextarc cachedarcs cachearc allccache
10221 if {$nextarc == $cachedarcs} return
10222 set cachearc 0
10223 set cachedarcs $nextarc
10224 catch {
10225 set f [open $allccache w]
10226 puts $f [list 1 $cachedarcs]
10227 run writecache $f
10231 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10232 # or 0 if neither is true.
10233 proc anc_or_desc {a b} {
10234 global arcout arcstart arcend arcnos cached_isanc
10236 if {$arcnos($a) eq $arcnos($b)} {
10237 # Both are on the same arc(s); either both are the same BMP,
10238 # or if one is not a BMP, the other is also not a BMP or is
10239 # the BMP at end of the arc (and it only has 1 incoming arc).
10240 # Or both can be BMPs with no incoming arcs.
10241 if {$a eq $b || $arcnos($a) eq {}} {
10242 return 0
10244 # assert {[llength $arcnos($a)] == 1}
10245 set arc [lindex $arcnos($a) 0]
10246 set i [lsearch -exact $arcids($arc) $a]
10247 set j [lsearch -exact $arcids($arc) $b]
10248 if {$i < 0 || $i > $j} {
10249 return 1
10250 } else {
10251 return -1
10255 if {![info exists arcout($a)]} {
10256 set arc [lindex $arcnos($a) 0]
10257 if {[info exists arcend($arc)]} {
10258 set aend $arcend($arc)
10259 } else {
10260 set aend {}
10262 set a $arcstart($arc)
10263 } else {
10264 set aend $a
10266 if {![info exists arcout($b)]} {
10267 set arc [lindex $arcnos($b) 0]
10268 if {[info exists arcend($arc)]} {
10269 set bend $arcend($arc)
10270 } else {
10271 set bend {}
10273 set b $arcstart($arc)
10274 } else {
10275 set bend $b
10277 if {$a eq $bend} {
10278 return 1
10280 if {$b eq $aend} {
10281 return -1
10283 if {[info exists cached_isanc($a,$bend)]} {
10284 if {$cached_isanc($a,$bend)} {
10285 return 1
10288 if {[info exists cached_isanc($b,$aend)]} {
10289 if {$cached_isanc($b,$aend)} {
10290 return -1
10292 if {[info exists cached_isanc($a,$bend)]} {
10293 return 0
10297 set todo [list $a $b]
10298 set anc($a) a
10299 set anc($b) b
10300 for {set i 0} {$i < [llength $todo]} {incr i} {
10301 set x [lindex $todo $i]
10302 if {$anc($x) eq {}} {
10303 continue
10305 foreach arc $arcnos($x) {
10306 set xd $arcstart($arc)
10307 if {$xd eq $bend} {
10308 set cached_isanc($a,$bend) 1
10309 set cached_isanc($b,$aend) 0
10310 return 1
10311 } elseif {$xd eq $aend} {
10312 set cached_isanc($b,$aend) 1
10313 set cached_isanc($a,$bend) 0
10314 return -1
10316 if {![info exists anc($xd)]} {
10317 set anc($xd) $anc($x)
10318 lappend todo $xd
10319 } elseif {$anc($xd) ne $anc($x)} {
10320 set anc($xd) {}
10324 set cached_isanc($a,$bend) 0
10325 set cached_isanc($b,$aend) 0
10326 return 0
10329 # This identifies whether $desc has an ancestor that is
10330 # a growing tip of the graph and which is not an ancestor of $anc
10331 # and returns 0 if so and 1 if not.
10332 # If we subsequently discover a tag on such a growing tip, and that
10333 # turns out to be a descendent of $anc (which it could, since we
10334 # don't necessarily see children before parents), then $desc
10335 # isn't a good choice to display as a descendent tag of
10336 # $anc (since it is the descendent of another tag which is
10337 # a descendent of $anc). Similarly, $anc isn't a good choice to
10338 # display as a ancestor tag of $desc.
10340 proc is_certain {desc anc} {
10341 global arcnos arcout arcstart arcend growing problems
10343 set certain {}
10344 if {[llength $arcnos($anc)] == 1} {
10345 # tags on the same arc are certain
10346 if {$arcnos($desc) eq $arcnos($anc)} {
10347 return 1
10349 if {![info exists arcout($anc)]} {
10350 # if $anc is partway along an arc, use the start of the arc instead
10351 set a [lindex $arcnos($anc) 0]
10352 set anc $arcstart($a)
10355 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10356 set x $desc
10357 } else {
10358 set a [lindex $arcnos($desc) 0]
10359 set x $arcend($a)
10361 if {$x == $anc} {
10362 return 1
10364 set anclist [list $x]
10365 set dl($x) 1
10366 set nnh 1
10367 set ngrowanc 0
10368 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10369 set x [lindex $anclist $i]
10370 if {$dl($x)} {
10371 incr nnh -1
10373 set done($x) 1
10374 foreach a $arcout($x) {
10375 if {[info exists growing($a)]} {
10376 if {![info exists growanc($x)] && $dl($x)} {
10377 set growanc($x) 1
10378 incr ngrowanc
10380 } else {
10381 set y $arcend($a)
10382 if {[info exists dl($y)]} {
10383 if {$dl($y)} {
10384 if {!$dl($x)} {
10385 set dl($y) 0
10386 if {![info exists done($y)]} {
10387 incr nnh -1
10389 if {[info exists growanc($x)]} {
10390 incr ngrowanc -1
10392 set xl [list $y]
10393 for {set k 0} {$k < [llength $xl]} {incr k} {
10394 set z [lindex $xl $k]
10395 foreach c $arcout($z) {
10396 if {[info exists arcend($c)]} {
10397 set v $arcend($c)
10398 if {[info exists dl($v)] && $dl($v)} {
10399 set dl($v) 0
10400 if {![info exists done($v)]} {
10401 incr nnh -1
10403 if {[info exists growanc($v)]} {
10404 incr ngrowanc -1
10406 lappend xl $v
10413 } elseif {$y eq $anc || !$dl($x)} {
10414 set dl($y) 0
10415 lappend anclist $y
10416 } else {
10417 set dl($y) 1
10418 lappend anclist $y
10419 incr nnh
10424 foreach x [array names growanc] {
10425 if {$dl($x)} {
10426 return 0
10428 return 0
10430 return 1
10433 proc validate_arctags {a} {
10434 global arctags idtags
10436 set i -1
10437 set na $arctags($a)
10438 foreach id $arctags($a) {
10439 incr i
10440 if {![info exists idtags($id)]} {
10441 set na [lreplace $na $i $i]
10442 incr i -1
10445 set arctags($a) $na
10448 proc validate_archeads {a} {
10449 global archeads idheads
10451 set i -1
10452 set na $archeads($a)
10453 foreach id $archeads($a) {
10454 incr i
10455 if {![info exists idheads($id)]} {
10456 set na [lreplace $na $i $i]
10457 incr i -1
10460 set archeads($a) $na
10463 # Return the list of IDs that have tags that are descendents of id,
10464 # ignoring IDs that are descendents of IDs already reported.
10465 proc desctags {id} {
10466 global arcnos arcstart arcids arctags idtags allparents
10467 global growing cached_dtags
10469 if {![info exists allparents($id)]} {
10470 return {}
10472 set t1 [clock clicks -milliseconds]
10473 set argid $id
10474 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10475 # part-way along an arc; check that arc first
10476 set a [lindex $arcnos($id) 0]
10477 if {$arctags($a) ne {}} {
10478 validate_arctags $a
10479 set i [lsearch -exact $arcids($a) $id]
10480 set tid {}
10481 foreach t $arctags($a) {
10482 set j [lsearch -exact $arcids($a) $t]
10483 if {$j >= $i} break
10484 set tid $t
10486 if {$tid ne {}} {
10487 return $tid
10490 set id $arcstart($a)
10491 if {[info exists idtags($id)]} {
10492 return $id
10495 if {[info exists cached_dtags($id)]} {
10496 return $cached_dtags($id)
10499 set origid $id
10500 set todo [list $id]
10501 set queued($id) 1
10502 set nc 1
10503 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10504 set id [lindex $todo $i]
10505 set done($id) 1
10506 set ta [info exists hastaggedancestor($id)]
10507 if {!$ta} {
10508 incr nc -1
10510 # ignore tags on starting node
10511 if {!$ta && $i > 0} {
10512 if {[info exists idtags($id)]} {
10513 set tagloc($id) $id
10514 set ta 1
10515 } elseif {[info exists cached_dtags($id)]} {
10516 set tagloc($id) $cached_dtags($id)
10517 set ta 1
10520 foreach a $arcnos($id) {
10521 set d $arcstart($a)
10522 if {!$ta && $arctags($a) ne {}} {
10523 validate_arctags $a
10524 if {$arctags($a) ne {}} {
10525 lappend tagloc($id) [lindex $arctags($a) end]
10528 if {$ta || $arctags($a) ne {}} {
10529 set tomark [list $d]
10530 for {set j 0} {$j < [llength $tomark]} {incr j} {
10531 set dd [lindex $tomark $j]
10532 if {![info exists hastaggedancestor($dd)]} {
10533 if {[info exists done($dd)]} {
10534 foreach b $arcnos($dd) {
10535 lappend tomark $arcstart($b)
10537 if {[info exists tagloc($dd)]} {
10538 unset tagloc($dd)
10540 } elseif {[info exists queued($dd)]} {
10541 incr nc -1
10543 set hastaggedancestor($dd) 1
10547 if {![info exists queued($d)]} {
10548 lappend todo $d
10549 set queued($d) 1
10550 if {![info exists hastaggedancestor($d)]} {
10551 incr nc
10556 set tags {}
10557 foreach id [array names tagloc] {
10558 if {![info exists hastaggedancestor($id)]} {
10559 foreach t $tagloc($id) {
10560 if {[lsearch -exact $tags $t] < 0} {
10561 lappend tags $t
10566 set t2 [clock clicks -milliseconds]
10567 set loopix $i
10569 # remove tags that are descendents of other tags
10570 for {set i 0} {$i < [llength $tags]} {incr i} {
10571 set a [lindex $tags $i]
10572 for {set j 0} {$j < $i} {incr j} {
10573 set b [lindex $tags $j]
10574 set r [anc_or_desc $a $b]
10575 if {$r == 1} {
10576 set tags [lreplace $tags $j $j]
10577 incr j -1
10578 incr i -1
10579 } elseif {$r == -1} {
10580 set tags [lreplace $tags $i $i]
10581 incr i -1
10582 break
10587 if {[array names growing] ne {}} {
10588 # graph isn't finished, need to check if any tag could get
10589 # eclipsed by another tag coming later. Simply ignore any
10590 # tags that could later get eclipsed.
10591 set ctags {}
10592 foreach t $tags {
10593 if {[is_certain $t $origid]} {
10594 lappend ctags $t
10597 if {$tags eq $ctags} {
10598 set cached_dtags($origid) $tags
10599 } else {
10600 set tags $ctags
10602 } else {
10603 set cached_dtags($origid) $tags
10605 set t3 [clock clicks -milliseconds]
10606 if {0 && $t3 - $t1 >= 100} {
10607 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10608 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10610 return $tags
10613 proc anctags {id} {
10614 global arcnos arcids arcout arcend arctags idtags allparents
10615 global growing cached_atags
10617 if {![info exists allparents($id)]} {
10618 return {}
10620 set t1 [clock clicks -milliseconds]
10621 set argid $id
10622 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10623 # part-way along an arc; check that arc first
10624 set a [lindex $arcnos($id) 0]
10625 if {$arctags($a) ne {}} {
10626 validate_arctags $a
10627 set i [lsearch -exact $arcids($a) $id]
10628 foreach t $arctags($a) {
10629 set j [lsearch -exact $arcids($a) $t]
10630 if {$j > $i} {
10631 return $t
10635 if {![info exists arcend($a)]} {
10636 return {}
10638 set id $arcend($a)
10639 if {[info exists idtags($id)]} {
10640 return $id
10643 if {[info exists cached_atags($id)]} {
10644 return $cached_atags($id)
10647 set origid $id
10648 set todo [list $id]
10649 set queued($id) 1
10650 set taglist {}
10651 set nc 1
10652 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10653 set id [lindex $todo $i]
10654 set done($id) 1
10655 set td [info exists hastaggeddescendent($id)]
10656 if {!$td} {
10657 incr nc -1
10659 # ignore tags on starting node
10660 if {!$td && $i > 0} {
10661 if {[info exists idtags($id)]} {
10662 set tagloc($id) $id
10663 set td 1
10664 } elseif {[info exists cached_atags($id)]} {
10665 set tagloc($id) $cached_atags($id)
10666 set td 1
10669 foreach a $arcout($id) {
10670 if {!$td && $arctags($a) ne {}} {
10671 validate_arctags $a
10672 if {$arctags($a) ne {}} {
10673 lappend tagloc($id) [lindex $arctags($a) 0]
10676 if {![info exists arcend($a)]} continue
10677 set d $arcend($a)
10678 if {$td || $arctags($a) ne {}} {
10679 set tomark [list $d]
10680 for {set j 0} {$j < [llength $tomark]} {incr j} {
10681 set dd [lindex $tomark $j]
10682 if {![info exists hastaggeddescendent($dd)]} {
10683 if {[info exists done($dd)]} {
10684 foreach b $arcout($dd) {
10685 if {[info exists arcend($b)]} {
10686 lappend tomark $arcend($b)
10689 if {[info exists tagloc($dd)]} {
10690 unset tagloc($dd)
10692 } elseif {[info exists queued($dd)]} {
10693 incr nc -1
10695 set hastaggeddescendent($dd) 1
10699 if {![info exists queued($d)]} {
10700 lappend todo $d
10701 set queued($d) 1
10702 if {![info exists hastaggeddescendent($d)]} {
10703 incr nc
10708 set t2 [clock clicks -milliseconds]
10709 set loopix $i
10710 set tags {}
10711 foreach id [array names tagloc] {
10712 if {![info exists hastaggeddescendent($id)]} {
10713 foreach t $tagloc($id) {
10714 if {[lsearch -exact $tags $t] < 0} {
10715 lappend tags $t
10721 # remove tags that are ancestors of other tags
10722 for {set i 0} {$i < [llength $tags]} {incr i} {
10723 set a [lindex $tags $i]
10724 for {set j 0} {$j < $i} {incr j} {
10725 set b [lindex $tags $j]
10726 set r [anc_or_desc $a $b]
10727 if {$r == -1} {
10728 set tags [lreplace $tags $j $j]
10729 incr j -1
10730 incr i -1
10731 } elseif {$r == 1} {
10732 set tags [lreplace $tags $i $i]
10733 incr i -1
10734 break
10739 if {[array names growing] ne {}} {
10740 # graph isn't finished, need to check if any tag could get
10741 # eclipsed by another tag coming later. Simply ignore any
10742 # tags that could later get eclipsed.
10743 set ctags {}
10744 foreach t $tags {
10745 if {[is_certain $origid $t]} {
10746 lappend ctags $t
10749 if {$tags eq $ctags} {
10750 set cached_atags($origid) $tags
10751 } else {
10752 set tags $ctags
10754 } else {
10755 set cached_atags($origid) $tags
10757 set t3 [clock clicks -milliseconds]
10758 if {0 && $t3 - $t1 >= 100} {
10759 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10760 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10762 return $tags
10765 # Return the list of IDs that have heads that are descendents of id,
10766 # including id itself if it has a head.
10767 proc descheads {id} {
10768 global arcnos arcstart arcids archeads idheads cached_dheads
10769 global allparents arcout
10771 if {![info exists allparents($id)]} {
10772 return {}
10774 set aret {}
10775 if {![info exists arcout($id)]} {
10776 # part-way along an arc; check it first
10777 set a [lindex $arcnos($id) 0]
10778 if {$archeads($a) ne {}} {
10779 validate_archeads $a
10780 set i [lsearch -exact $arcids($a) $id]
10781 foreach t $archeads($a) {
10782 set j [lsearch -exact $arcids($a) $t]
10783 if {$j > $i} break
10784 lappend aret $t
10787 set id $arcstart($a)
10789 set origid $id
10790 set todo [list $id]
10791 set seen($id) 1
10792 set ret {}
10793 for {set i 0} {$i < [llength $todo]} {incr i} {
10794 set id [lindex $todo $i]
10795 if {[info exists cached_dheads($id)]} {
10796 set ret [concat $ret $cached_dheads($id)]
10797 } else {
10798 if {[info exists idheads($id)]} {
10799 lappend ret $id
10801 foreach a $arcnos($id) {
10802 if {$archeads($a) ne {}} {
10803 validate_archeads $a
10804 if {$archeads($a) ne {}} {
10805 set ret [concat $ret $archeads($a)]
10808 set d $arcstart($a)
10809 if {![info exists seen($d)]} {
10810 lappend todo $d
10811 set seen($d) 1
10816 set ret [lsort -unique $ret]
10817 set cached_dheads($origid) $ret
10818 return [concat $ret $aret]
10821 proc addedtag {id} {
10822 global arcnos arcout cached_dtags cached_atags
10824 if {![info exists arcnos($id)]} return
10825 if {![info exists arcout($id)]} {
10826 recalcarc [lindex $arcnos($id) 0]
10828 catch {unset cached_dtags}
10829 catch {unset cached_atags}
10832 proc addedhead {hid head} {
10833 global arcnos arcout cached_dheads
10835 if {![info exists arcnos($hid)]} return
10836 if {![info exists arcout($hid)]} {
10837 recalcarc [lindex $arcnos($hid) 0]
10839 catch {unset cached_dheads}
10842 proc removedhead {hid head} {
10843 global cached_dheads
10845 catch {unset cached_dheads}
10848 proc movedhead {hid head} {
10849 global arcnos arcout cached_dheads
10851 if {![info exists arcnos($hid)]} return
10852 if {![info exists arcout($hid)]} {
10853 recalcarc [lindex $arcnos($hid) 0]
10855 catch {unset cached_dheads}
10858 proc changedrefs {} {
10859 global cached_dheads cached_dtags cached_atags cached_tagcontent
10860 global arctags archeads arcnos arcout idheads idtags
10862 foreach id [concat [array names idheads] [array names idtags]] {
10863 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10864 set a [lindex $arcnos($id) 0]
10865 if {![info exists donearc($a)]} {
10866 recalcarc $a
10867 set donearc($a) 1
10871 catch {unset cached_tagcontent}
10872 catch {unset cached_dtags}
10873 catch {unset cached_atags}
10874 catch {unset cached_dheads}
10877 proc rereadrefs {} {
10878 global idtags idheads idotherrefs mainheadid
10880 set refids [concat [array names idtags] \
10881 [array names idheads] [array names idotherrefs]]
10882 foreach id $refids {
10883 if {![info exists ref($id)]} {
10884 set ref($id) [listrefs $id]
10887 set oldmainhead $mainheadid
10888 readrefs
10889 changedrefs
10890 set refids [lsort -unique [concat $refids [array names idtags] \
10891 [array names idheads] [array names idotherrefs]]]
10892 foreach id $refids {
10893 set v [listrefs $id]
10894 if {![info exists ref($id)] || $ref($id) != $v} {
10895 redrawtags $id
10898 if {$oldmainhead ne $mainheadid} {
10899 redrawtags $oldmainhead
10900 redrawtags $mainheadid
10902 run refill_reflist
10905 proc listrefs {id} {
10906 global idtags idheads idotherrefs
10908 set x {}
10909 if {[info exists idtags($id)]} {
10910 set x $idtags($id)
10912 set y {}
10913 if {[info exists idheads($id)]} {
10914 set y $idheads($id)
10916 set z {}
10917 if {[info exists idotherrefs($id)]} {
10918 set z $idotherrefs($id)
10920 return [list $x $y $z]
10923 proc add_tag_ctext {tag} {
10924 global ctext cached_tagcontent tagids
10926 if {![info exists cached_tagcontent($tag)]} {
10927 catch {
10928 set cached_tagcontent($tag) [exec git cat-file -p $tag]
10931 $ctext insert end "[mc "Tag"]: $tag\n" bold
10932 if {[info exists cached_tagcontent($tag)]} {
10933 set text $cached_tagcontent($tag)
10934 } else {
10935 set text "[mc "Id"]: $tagids($tag)"
10937 appendwithlinks $text {}
10940 proc showtag {tag isnew} {
10941 global ctext cached_tagcontent tagids linknum tagobjid
10943 if {$isnew} {
10944 addtohistory [list showtag $tag 0] savectextpos
10946 $ctext conf -state normal
10947 clear_ctext
10948 settabs 0
10949 set linknum 0
10950 add_tag_ctext $tag
10951 maybe_scroll_ctext 1
10952 $ctext conf -state disabled
10953 init_flist {}
10956 proc showtags {id isnew} {
10957 global idtags ctext linknum
10959 if {$isnew} {
10960 addtohistory [list showtags $id 0] savectextpos
10962 $ctext conf -state normal
10963 clear_ctext
10964 settabs 0
10965 set linknum 0
10966 set sep {}
10967 foreach tag $idtags($id) {
10968 $ctext insert end $sep
10969 add_tag_ctext $tag
10970 set sep "\n\n"
10972 maybe_scroll_ctext 1
10973 $ctext conf -state disabled
10974 init_flist {}
10977 proc doquit {} {
10978 global stopped
10979 global gitktmpdir
10981 set stopped 100
10982 savestuff .
10983 destroy .
10985 if {[info exists gitktmpdir]} {
10986 catch {file delete -force $gitktmpdir}
10990 proc mkfontdisp {font top which} {
10991 global fontattr fontpref $font NS use_ttk
10993 set fontpref($font) [set $font]
10994 ${NS}::button $top.${font}but -text $which \
10995 -command [list choosefont $font $which]
10996 ${NS}::label $top.$font -relief flat -font $font \
10997 -text $fontattr($font,family) -justify left
10998 grid x $top.${font}but $top.$font -sticky w
11001 proc choosefont {font which} {
11002 global fontparam fontlist fonttop fontattr
11003 global prefstop NS
11005 set fontparam(which) $which
11006 set fontparam(font) $font
11007 set fontparam(family) [font actual $font -family]
11008 set fontparam(size) $fontattr($font,size)
11009 set fontparam(weight) $fontattr($font,weight)
11010 set fontparam(slant) $fontattr($font,slant)
11011 set top .gitkfont
11012 set fonttop $top
11013 if {![winfo exists $top]} {
11014 font create sample
11015 eval font config sample [font actual $font]
11016 ttk_toplevel $top
11017 make_transient $top $prefstop
11018 wm title $top [mc "Gitk font chooser"]
11019 ${NS}::label $top.l -textvariable fontparam(which)
11020 pack $top.l -side top
11021 set fontlist [lsort [font families]]
11022 ${NS}::frame $top.f
11023 listbox $top.f.fam -listvariable fontlist \
11024 -yscrollcommand [list $top.f.sb set]
11025 bind $top.f.fam <<ListboxSelect>> selfontfam
11026 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11027 pack $top.f.sb -side right -fill y
11028 pack $top.f.fam -side left -fill both -expand 1
11029 pack $top.f -side top -fill both -expand 1
11030 ${NS}::frame $top.g
11031 spinbox $top.g.size -from 4 -to 40 -width 4 \
11032 -textvariable fontparam(size) \
11033 -validatecommand {string is integer -strict %s}
11034 checkbutton $top.g.bold -padx 5 \
11035 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11036 -variable fontparam(weight) -onvalue bold -offvalue normal
11037 checkbutton $top.g.ital -padx 5 \
11038 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11039 -variable fontparam(slant) -onvalue italic -offvalue roman
11040 pack $top.g.size $top.g.bold $top.g.ital -side left
11041 pack $top.g -side top
11042 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11043 -background white
11044 $top.c create text 100 25 -anchor center -text $which -font sample \
11045 -fill black -tags text
11046 bind $top.c <Configure> [list centertext $top.c]
11047 pack $top.c -side top -fill x
11048 ${NS}::frame $top.buts
11049 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11050 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11051 bind $top <Key-Return> fontok
11052 bind $top <Key-Escape> fontcan
11053 grid $top.buts.ok $top.buts.can
11054 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11055 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11056 pack $top.buts -side bottom -fill x
11057 trace add variable fontparam write chg_fontparam
11058 } else {
11059 raise $top
11060 $top.c itemconf text -text $which
11062 set i [lsearch -exact $fontlist $fontparam(family)]
11063 if {$i >= 0} {
11064 $top.f.fam selection set $i
11065 $top.f.fam see $i
11069 proc centertext {w} {
11070 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11073 proc fontok {} {
11074 global fontparam fontpref prefstop
11076 set f $fontparam(font)
11077 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11078 if {$fontparam(weight) eq "bold"} {
11079 lappend fontpref($f) "bold"
11081 if {$fontparam(slant) eq "italic"} {
11082 lappend fontpref($f) "italic"
11084 set w $prefstop.notebook.fonts.$f
11085 $w conf -text $fontparam(family) -font $fontpref($f)
11087 fontcan
11090 proc fontcan {} {
11091 global fonttop fontparam
11093 if {[info exists fonttop]} {
11094 catch {destroy $fonttop}
11095 catch {font delete sample}
11096 unset fonttop
11097 unset fontparam
11101 if {[package vsatisfies [package provide Tk] 8.6]} {
11102 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11103 # function to make use of it.
11104 proc choosefont {font which} {
11105 tk fontchooser configure -title $which -font $font \
11106 -command [list on_choosefont $font $which]
11107 tk fontchooser show
11109 proc on_choosefont {font which newfont} {
11110 global fontparam
11111 puts stderr "$font $newfont"
11112 array set f [font actual $newfont]
11113 set fontparam(which) $which
11114 set fontparam(font) $font
11115 set fontparam(family) $f(-family)
11116 set fontparam(size) $f(-size)
11117 set fontparam(weight) $f(-weight)
11118 set fontparam(slant) $f(-slant)
11119 fontok
11123 proc selfontfam {} {
11124 global fonttop fontparam
11126 set i [$fonttop.f.fam curselection]
11127 if {$i ne {}} {
11128 set fontparam(family) [$fonttop.f.fam get $i]
11132 proc chg_fontparam {v sub op} {
11133 global fontparam
11135 font config sample -$sub $fontparam($sub)
11138 # Create a property sheet tab page
11139 proc create_prefs_page {w} {
11140 global NS
11141 set parent [join [lrange [split $w .] 0 end-1] .]
11142 if {[winfo class $parent] eq "TNotebook"} {
11143 ${NS}::frame $w
11144 } else {
11145 ${NS}::labelframe $w
11149 proc prefspage_general {notebook} {
11150 global NS maxwidth maxgraphpct showneartags showlocalchanges
11151 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11152 global hideremotes want_ttk have_ttk maxrefs
11154 set page [create_prefs_page $notebook.general]
11156 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11157 grid $page.ldisp - -sticky w -pady 10
11158 ${NS}::label $page.spacer -text " "
11159 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11160 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11161 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11162 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11163 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11164 grid x $page.maxpctl $page.maxpct -sticky w
11165 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11166 -variable showlocalchanges
11167 grid x $page.showlocal -sticky w
11168 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11169 -variable autoselect
11170 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11171 grid x $page.autoselect $page.autosellen -sticky w
11172 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11173 -variable hideremotes
11174 grid x $page.hideremotes -sticky w
11176 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11177 grid $page.ddisp - -sticky w -pady 10
11178 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11179 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11180 grid x $page.tabstopl $page.tabstop -sticky w
11181 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11182 -variable showneartags
11183 grid x $page.ntag -sticky w
11184 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11185 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11186 grid x $page.maxrefsl $page.maxrefs -sticky w
11187 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11188 -variable limitdiffs
11189 grid x $page.ldiff -sticky w
11190 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11191 -variable perfile_attrs
11192 grid x $page.lattr -sticky w
11194 ${NS}::entry $page.extdifft -textvariable extdifftool
11195 ${NS}::frame $page.extdifff
11196 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11197 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11198 pack $page.extdifff.l $page.extdifff.b -side left
11199 pack configure $page.extdifff.l -padx 10
11200 grid x $page.extdifff $page.extdifft -sticky ew
11202 ${NS}::label $page.lgen -text [mc "General options"]
11203 grid $page.lgen - -sticky w -pady 10
11204 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11205 -text [mc "Use themed widgets"]
11206 if {$have_ttk} {
11207 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11208 } else {
11209 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11211 grid x $page.want_ttk $page.ttk_note -sticky w
11212 return $page
11215 proc prefspage_colors {notebook} {
11216 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11218 set page [create_prefs_page $notebook.colors]
11220 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11221 grid $page.cdisp - -sticky w -pady 10
11222 label $page.ui -padx 40 -relief sunk -background $uicolor
11223 ${NS}::button $page.uibut -text [mc "Interface"] \
11224 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11225 grid x $page.uibut $page.ui -sticky w
11226 label $page.bg -padx 40 -relief sunk -background $bgcolor
11227 ${NS}::button $page.bgbut -text [mc "Background"] \
11228 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11229 grid x $page.bgbut $page.bg -sticky w
11230 label $page.fg -padx 40 -relief sunk -background $fgcolor
11231 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11232 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11233 grid x $page.fgbut $page.fg -sticky w
11234 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11235 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11236 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11237 [list $ctext tag conf d0 -foreground]]
11238 grid x $page.diffoldbut $page.diffold -sticky w
11239 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11240 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11241 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11242 [list $ctext tag conf dresult -foreground]]
11243 grid x $page.diffnewbut $page.diffnew -sticky w
11244 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11245 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11246 -command [list choosecolor diffcolors 2 $page.hunksep \
11247 [mc "diff hunk header"] \
11248 [list $ctext tag conf hunksep -foreground]]
11249 grid x $page.hunksepbut $page.hunksep -sticky w
11250 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11251 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11252 -command [list choosecolor markbgcolor {} $page.markbgsep \
11253 [mc "marked line background"] \
11254 [list $ctext tag conf omark -background]]
11255 grid x $page.markbgbut $page.markbgsep -sticky w
11256 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11257 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11258 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11259 grid x $page.selbgbut $page.selbgsep -sticky w
11260 return $page
11263 proc prefspage_fonts {notebook} {
11264 global NS
11265 set page [create_prefs_page $notebook.fonts]
11266 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11267 grid $page.cfont - -sticky w -pady 10
11268 mkfontdisp mainfont $page [mc "Main font"]
11269 mkfontdisp textfont $page [mc "Diff display font"]
11270 mkfontdisp uifont $page [mc "User interface font"]
11271 return $page
11274 proc doprefs {} {
11275 global maxwidth maxgraphpct use_ttk NS
11276 global oldprefs prefstop showneartags showlocalchanges
11277 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11278 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11279 global hideremotes want_ttk have_ttk
11281 set top .gitkprefs
11282 set prefstop $top
11283 if {[winfo exists $top]} {
11284 raise $top
11285 return
11287 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11288 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11289 set oldprefs($v) [set $v]
11291 ttk_toplevel $top
11292 wm title $top [mc "Gitk preferences"]
11293 make_transient $top .
11295 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11296 set notebook [ttk::notebook $top.notebook]
11297 } else {
11298 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11301 lappend pages [prefspage_general $notebook] [mc "General"]
11302 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11303 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11304 set col 0
11305 foreach {page title} $pages {
11306 if {$use_notebook} {
11307 $notebook add $page -text $title
11308 } else {
11309 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11310 -text $title -command [list raise $page]]
11311 $page configure -text $title
11312 grid $btn -row 0 -column [incr col] -sticky w
11313 grid $page -row 1 -column 0 -sticky news -columnspan 100
11317 if {!$use_notebook} {
11318 grid columnconfigure $notebook 0 -weight 1
11319 grid rowconfigure $notebook 1 -weight 1
11320 raise [lindex $pages 0]
11323 grid $notebook -sticky news -padx 2 -pady 2
11324 grid rowconfigure $top 0 -weight 1
11325 grid columnconfigure $top 0 -weight 1
11327 ${NS}::frame $top.buts
11328 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11329 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11330 bind $top <Key-Return> prefsok
11331 bind $top <Key-Escape> prefscan
11332 grid $top.buts.ok $top.buts.can
11333 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11334 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11335 grid $top.buts - - -pady 10 -sticky ew
11336 grid columnconfigure $top 2 -weight 1
11337 bind $top <Visibility> [list focus $top.buts.ok]
11340 proc choose_extdiff {} {
11341 global extdifftool
11343 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11344 if {$prog ne {}} {
11345 set extdifftool $prog
11349 proc choosecolor {v vi w x cmd} {
11350 global $v
11352 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11353 -title [mc "Gitk: choose color for %s" $x]]
11354 if {$c eq {}} return
11355 $w conf -background $c
11356 lset $v $vi $c
11357 eval $cmd $c
11360 proc setselbg {c} {
11361 global bglist cflist
11362 foreach w $bglist {
11363 $w configure -selectbackground $c
11365 $cflist tag configure highlight \
11366 -background [$cflist cget -selectbackground]
11367 allcanvs itemconf secsel -fill $c
11370 # This sets the background color and the color scheme for the whole UI.
11371 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11372 # if we don't specify one ourselves, which makes the checkbuttons and
11373 # radiobuttons look bad. This chooses white for selectColor if the
11374 # background color is light, or black if it is dark.
11375 proc setui {c} {
11376 if {[tk windowingsystem] eq "win32"} { return }
11377 set bg [winfo rgb . $c]
11378 set selc black
11379 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11380 set selc white
11382 tk_setPalette background $c selectColor $selc
11385 proc setbg {c} {
11386 global bglist
11388 foreach w $bglist {
11389 $w conf -background $c
11393 proc setfg {c} {
11394 global fglist canv
11396 foreach w $fglist {
11397 $w conf -foreground $c
11399 allcanvs itemconf text -fill $c
11400 $canv itemconf circle -outline $c
11401 $canv itemconf markid -outline $c
11404 proc prefscan {} {
11405 global oldprefs prefstop
11407 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11408 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11409 global $v
11410 set $v $oldprefs($v)
11412 catch {destroy $prefstop}
11413 unset prefstop
11414 fontcan
11417 proc prefsok {} {
11418 global maxwidth maxgraphpct
11419 global oldprefs prefstop showneartags showlocalchanges
11420 global fontpref mainfont textfont uifont
11421 global limitdiffs treediffs perfile_attrs
11422 global hideremotes
11424 catch {destroy $prefstop}
11425 unset prefstop
11426 fontcan
11427 set fontchanged 0
11428 if {$mainfont ne $fontpref(mainfont)} {
11429 set mainfont $fontpref(mainfont)
11430 parsefont mainfont $mainfont
11431 eval font configure mainfont [fontflags mainfont]
11432 eval font configure mainfontbold [fontflags mainfont 1]
11433 setcoords
11434 set fontchanged 1
11436 if {$textfont ne $fontpref(textfont)} {
11437 set textfont $fontpref(textfont)
11438 parsefont textfont $textfont
11439 eval font configure textfont [fontflags textfont]
11440 eval font configure textfontbold [fontflags textfont 1]
11442 if {$uifont ne $fontpref(uifont)} {
11443 set uifont $fontpref(uifont)
11444 parsefont uifont $uifont
11445 eval font configure uifont [fontflags uifont]
11447 settabs
11448 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11449 if {$showlocalchanges} {
11450 doshowlocalchanges
11451 } else {
11452 dohidelocalchanges
11455 if {$limitdiffs != $oldprefs(limitdiffs) ||
11456 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11457 # treediffs elements are limited by path;
11458 # won't have encodings cached if perfile_attrs was just turned on
11459 catch {unset treediffs}
11461 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11462 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11463 redisplay
11464 } elseif {$showneartags != $oldprefs(showneartags) ||
11465 $limitdiffs != $oldprefs(limitdiffs)} {
11466 reselectline
11468 if {$hideremotes != $oldprefs(hideremotes)} {
11469 rereadrefs
11473 proc formatdate {d} {
11474 global datetimeformat
11475 if {$d ne {}} {
11476 set d [clock format [lindex $d 0] -format $datetimeformat]
11478 return $d
11481 # This list of encoding names and aliases is distilled from
11482 # http://www.iana.org/assignments/character-sets.
11483 # Not all of them are supported by Tcl.
11484 set encoding_aliases {
11485 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11486 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11487 { ISO-10646-UTF-1 csISO10646UTF1 }
11488 { ISO_646.basic:1983 ref csISO646basic1983 }
11489 { INVARIANT csINVARIANT }
11490 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11491 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11492 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11493 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11494 { NATS-DANO iso-ir-9-1 csNATSDANO }
11495 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11496 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11497 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11498 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11499 { ISO-2022-KR csISO2022KR }
11500 { EUC-KR csEUCKR }
11501 { ISO-2022-JP csISO2022JP }
11502 { ISO-2022-JP-2 csISO2022JP2 }
11503 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11504 csISO13JISC6220jp }
11505 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11506 { IT iso-ir-15 ISO646-IT csISO15Italian }
11507 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11508 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11509 { greek7-old iso-ir-18 csISO18Greek7Old }
11510 { latin-greek iso-ir-19 csISO19LatinGreek }
11511 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11512 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11513 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11514 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11515 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11516 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11517 { INIS iso-ir-49 csISO49INIS }
11518 { INIS-8 iso-ir-50 csISO50INIS8 }
11519 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11520 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11521 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11522 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11523 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11524 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11525 csISO60Norwegian1 }
11526 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11527 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11528 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11529 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11530 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11531 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11532 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11533 { greek7 iso-ir-88 csISO88Greek7 }
11534 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11535 { iso-ir-90 csISO90 }
11536 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11537 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11538 csISO92JISC62991984b }
11539 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11540 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11541 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11542 csISO95JIS62291984handadd }
11543 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11544 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11545 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11546 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11547 CP819 csISOLatin1 }
11548 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11549 { T.61-7bit iso-ir-102 csISO102T617bit }
11550 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11551 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11552 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11553 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11554 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11555 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11556 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11557 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11558 arabic csISOLatinArabic }
11559 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11560 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11561 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11562 greek greek8 csISOLatinGreek }
11563 { T.101-G2 iso-ir-128 csISO128T101G2 }
11564 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11565 csISOLatinHebrew }
11566 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11567 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11568 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11569 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11570 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11571 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11572 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11573 csISOLatinCyrillic }
11574 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11575 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11576 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11577 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11578 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11579 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11580 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11581 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11582 { ISO_10367-box iso-ir-155 csISO10367Box }
11583 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11584 { latin-lap lap iso-ir-158 csISO158Lap }
11585 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11586 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11587 { us-dk csUSDK }
11588 { dk-us csDKUS }
11589 { JIS_X0201 X0201 csHalfWidthKatakana }
11590 { KSC5636 ISO646-KR csKSC5636 }
11591 { ISO-10646-UCS-2 csUnicode }
11592 { ISO-10646-UCS-4 csUCS4 }
11593 { DEC-MCS dec csDECMCS }
11594 { hp-roman8 roman8 r8 csHPRoman8 }
11595 { macintosh mac csMacintosh }
11596 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11597 csIBM037 }
11598 { IBM038 EBCDIC-INT cp038 csIBM038 }
11599 { IBM273 CP273 csIBM273 }
11600 { IBM274 EBCDIC-BE CP274 csIBM274 }
11601 { IBM275 EBCDIC-BR cp275 csIBM275 }
11602 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11603 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11604 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11605 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11606 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11607 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11608 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11609 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11610 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11611 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11612 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11613 { IBM437 cp437 437 csPC8CodePage437 }
11614 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11615 { IBM775 cp775 csPC775Baltic }
11616 { IBM850 cp850 850 csPC850Multilingual }
11617 { IBM851 cp851 851 csIBM851 }
11618 { IBM852 cp852 852 csPCp852 }
11619 { IBM855 cp855 855 csIBM855 }
11620 { IBM857 cp857 857 csIBM857 }
11621 { IBM860 cp860 860 csIBM860 }
11622 { IBM861 cp861 861 cp-is csIBM861 }
11623 { IBM862 cp862 862 csPC862LatinHebrew }
11624 { IBM863 cp863 863 csIBM863 }
11625 { IBM864 cp864 csIBM864 }
11626 { IBM865 cp865 865 csIBM865 }
11627 { IBM866 cp866 866 csIBM866 }
11628 { IBM868 CP868 cp-ar csIBM868 }
11629 { IBM869 cp869 869 cp-gr csIBM869 }
11630 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11631 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11632 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11633 { IBM891 cp891 csIBM891 }
11634 { IBM903 cp903 csIBM903 }
11635 { IBM904 cp904 904 csIBBM904 }
11636 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11637 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11638 { IBM1026 CP1026 csIBM1026 }
11639 { EBCDIC-AT-DE csIBMEBCDICATDE }
11640 { EBCDIC-AT-DE-A csEBCDICATDEA }
11641 { EBCDIC-CA-FR csEBCDICCAFR }
11642 { EBCDIC-DK-NO csEBCDICDKNO }
11643 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11644 { EBCDIC-FI-SE csEBCDICFISE }
11645 { EBCDIC-FI-SE-A csEBCDICFISEA }
11646 { EBCDIC-FR csEBCDICFR }
11647 { EBCDIC-IT csEBCDICIT }
11648 { EBCDIC-PT csEBCDICPT }
11649 { EBCDIC-ES csEBCDICES }
11650 { EBCDIC-ES-A csEBCDICESA }
11651 { EBCDIC-ES-S csEBCDICESS }
11652 { EBCDIC-UK csEBCDICUK }
11653 { EBCDIC-US csEBCDICUS }
11654 { UNKNOWN-8BIT csUnknown8BiT }
11655 { MNEMONIC csMnemonic }
11656 { MNEM csMnem }
11657 { VISCII csVISCII }
11658 { VIQR csVIQR }
11659 { KOI8-R csKOI8R }
11660 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11661 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11662 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11663 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11664 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11665 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11666 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11667 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11668 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11669 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11670 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11671 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11672 { IBM1047 IBM-1047 }
11673 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11674 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11675 { UNICODE-1-1 csUnicode11 }
11676 { CESU-8 csCESU-8 }
11677 { BOCU-1 csBOCU-1 }
11678 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11679 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11680 l8 }
11681 { ISO-8859-15 ISO_8859-15 Latin-9 }
11682 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11683 { GBK CP936 MS936 windows-936 }
11684 { JIS_Encoding csJISEncoding }
11685 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11686 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11687 EUC-JP }
11688 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11689 { ISO-10646-UCS-Basic csUnicodeASCII }
11690 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11691 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11692 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11693 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11694 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11695 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11696 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11697 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11698 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11699 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11700 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11701 { Ventura-US csVenturaUS }
11702 { Ventura-International csVenturaInternational }
11703 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11704 { PC8-Turkish csPC8Turkish }
11705 { IBM-Symbols csIBMSymbols }
11706 { IBM-Thai csIBMThai }
11707 { HP-Legal csHPLegal }
11708 { HP-Pi-font csHPPiFont }
11709 { HP-Math8 csHPMath8 }
11710 { Adobe-Symbol-Encoding csHPPSMath }
11711 { HP-DeskTop csHPDesktop }
11712 { Ventura-Math csVenturaMath }
11713 { Microsoft-Publishing csMicrosoftPublishing }
11714 { Windows-31J csWindows31J }
11715 { GB2312 csGB2312 }
11716 { Big5 csBig5 }
11719 proc tcl_encoding {enc} {
11720 global encoding_aliases tcl_encoding_cache
11721 if {[info exists tcl_encoding_cache($enc)]} {
11722 return $tcl_encoding_cache($enc)
11724 set names [encoding names]
11725 set lcnames [string tolower $names]
11726 set enc [string tolower $enc]
11727 set i [lsearch -exact $lcnames $enc]
11728 if {$i < 0} {
11729 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11730 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11731 set i [lsearch -exact $lcnames $encx]
11734 if {$i < 0} {
11735 foreach l $encoding_aliases {
11736 set ll [string tolower $l]
11737 if {[lsearch -exact $ll $enc] < 0} continue
11738 # look through the aliases for one that tcl knows about
11739 foreach e $ll {
11740 set i [lsearch -exact $lcnames $e]
11741 if {$i < 0} {
11742 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11743 set i [lsearch -exact $lcnames $ex]
11746 if {$i >= 0} break
11748 break
11751 set tclenc {}
11752 if {$i >= 0} {
11753 set tclenc [lindex $names $i]
11755 set tcl_encoding_cache($enc) $tclenc
11756 return $tclenc
11759 proc gitattr {path attr default} {
11760 global path_attr_cache
11761 if {[info exists path_attr_cache($attr,$path)]} {
11762 set r $path_attr_cache($attr,$path)
11763 } else {
11764 set r "unspecified"
11765 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11766 regexp "(.*): $attr: (.*)" $line m f r
11768 set path_attr_cache($attr,$path) $r
11770 if {$r eq "unspecified"} {
11771 return $default
11773 return $r
11776 proc cache_gitattr {attr pathlist} {
11777 global path_attr_cache
11778 set newlist {}
11779 foreach path $pathlist {
11780 if {![info exists path_attr_cache($attr,$path)]} {
11781 lappend newlist $path
11784 set lim 1000
11785 if {[tk windowingsystem] == "win32"} {
11786 # windows has a 32k limit on the arguments to a command...
11787 set lim 30
11789 while {$newlist ne {}} {
11790 set head [lrange $newlist 0 [expr {$lim - 1}]]
11791 set newlist [lrange $newlist $lim end]
11792 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11793 foreach row [split $rlist "\n"] {
11794 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11795 if {[string index $path 0] eq "\""} {
11796 set path [encoding convertfrom [lindex $path 0]]
11798 set path_attr_cache($attr,$path) $value
11805 proc get_path_encoding {path} {
11806 global gui_encoding perfile_attrs
11807 set tcl_enc $gui_encoding
11808 if {$path ne {} && $perfile_attrs} {
11809 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11810 if {$enc2 ne {}} {
11811 set tcl_enc $enc2
11814 return $tcl_enc
11817 # First check that Tcl/Tk is recent enough
11818 if {[catch {package require Tk 8.4} err]} {
11819 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11820 Gitk requires at least Tcl/Tk 8.4." list
11821 exit 1
11824 # on OSX bring the current Wish process window to front
11825 if {[tk windowingsystem] eq "aqua"} {
11826 exec osascript -e [format {
11827 tell application "System Events"
11828 set frontmost of processes whose unix id is %d to true
11829 end tell
11830 } [pid] ]
11833 # Unset GIT_TRACE var if set
11834 if { [info exists ::env(GIT_TRACE)] } {
11835 unset ::env(GIT_TRACE)
11838 # defaults...
11839 set wrcomcmd "git diff-tree --stdin -p --pretty"
11841 set gitencoding {}
11842 catch {
11843 set gitencoding [exec git config --get i18n.commitencoding]
11845 catch {
11846 set gitencoding [exec git config --get i18n.logoutputencoding]
11848 if {$gitencoding == ""} {
11849 set gitencoding "utf-8"
11851 set tclencoding [tcl_encoding $gitencoding]
11852 if {$tclencoding == {}} {
11853 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11856 set gui_encoding [encoding system]
11857 catch {
11858 set enc [exec git config --get gui.encoding]
11859 if {$enc ne {}} {
11860 set tclenc [tcl_encoding $enc]
11861 if {$tclenc ne {}} {
11862 set gui_encoding $tclenc
11863 } else {
11864 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11869 set log_showroot true
11870 catch {
11871 set log_showroot [exec git config --bool --get log.showroot]
11874 if {[tk windowingsystem] eq "aqua"} {
11875 set mainfont {{Lucida Grande} 9}
11876 set textfont {Monaco 9}
11877 set uifont {{Lucida Grande} 9 bold}
11878 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
11879 # fontconfig!
11880 set mainfont {sans 9}
11881 set textfont {monospace 9}
11882 set uifont {sans 9 bold}
11883 } else {
11884 set mainfont {Helvetica 9}
11885 set textfont {Courier 9}
11886 set uifont {Helvetica 9 bold}
11888 set tabstop 8
11889 set findmergefiles 0
11890 set maxgraphpct 50
11891 set maxwidth 16
11892 set revlistorder 0
11893 set fastdate 0
11894 set uparrowlen 5
11895 set downarrowlen 5
11896 set mingaplen 100
11897 set cmitmode "patch"
11898 set wrapcomment "none"
11899 set showneartags 1
11900 set hideremotes 0
11901 set maxrefs 20
11902 set maxlinelen 200
11903 set showlocalchanges 1
11904 set limitdiffs 1
11905 set datetimeformat "%Y-%m-%d %H:%M:%S"
11906 set autoselect 1
11907 set autosellen 40
11908 set perfile_attrs 0
11909 set want_ttk 1
11911 if {[tk windowingsystem] eq "aqua"} {
11912 set extdifftool "opendiff"
11913 } else {
11914 set extdifftool "meld"
11917 set colors {green red blue magenta darkgrey brown orange}
11918 if {[tk windowingsystem] eq "win32"} {
11919 set uicolor SystemButtonFace
11920 set uifgcolor SystemButtonText
11921 set uifgdisabledcolor SystemDisabledText
11922 set bgcolor SystemWindow
11923 set fgcolor SystemWindowText
11924 set selectbgcolor SystemHighlight
11925 } else {
11926 set uicolor grey85
11927 set uifgcolor black
11928 set uifgdisabledcolor "#999"
11929 set bgcolor white
11930 set fgcolor black
11931 set selectbgcolor gray85
11933 set diffcolors {red "#00a000" blue}
11934 set diffcontext 3
11935 set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
11936 set ignorespace 0
11937 set worddiff ""
11938 set markbgcolor "#e0e0ff"
11940 set headbgcolor green
11941 set headfgcolor black
11942 set headoutlinecolor black
11943 set remotebgcolor #ffddaa
11944 set tagbgcolor yellow
11945 set tagfgcolor black
11946 set tagoutlinecolor black
11947 set reflinecolor black
11948 set filesepbgcolor #aaaaaa
11949 set filesepfgcolor black
11950 set linehoverbgcolor #ffff80
11951 set linehoverfgcolor black
11952 set linehoveroutlinecolor black
11953 set mainheadcirclecolor yellow
11954 set workingfilescirclecolor red
11955 set indexcirclecolor green
11956 set circlecolors {white blue gray blue blue}
11957 set linkfgcolor blue
11958 set circleoutlinecolor $fgcolor
11959 set foundbgcolor yellow
11960 set currentsearchhitbgcolor orange
11962 # button for popping up context menus
11963 if {[tk windowingsystem] eq "aqua"} {
11964 set ctxbut <Button-2>
11965 } else {
11966 set ctxbut <Button-3>
11969 ## For msgcat loading, first locate the installation location.
11970 if { [info exists ::env(GITK_MSGSDIR)] } {
11971 ## Msgsdir was manually set in the environment.
11972 set gitk_msgsdir $::env(GITK_MSGSDIR)
11973 } else {
11974 ## Let's guess the prefix from argv0.
11975 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11976 set gitk_libdir [file join $gitk_prefix share gitk lib]
11977 set gitk_msgsdir [file join $gitk_libdir msgs]
11978 unset gitk_prefix
11981 ## Internationalization (i18n) through msgcat and gettext. See
11982 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11983 package require msgcat
11984 namespace import ::msgcat::mc
11985 ## And eventually load the actual message catalog
11986 ::msgcat::mcload $gitk_msgsdir
11988 catch {source ~/.gitk}
11990 parsefont mainfont $mainfont
11991 eval font create mainfont [fontflags mainfont]
11992 eval font create mainfontbold [fontflags mainfont 1]
11994 parsefont textfont $textfont
11995 eval font create textfont [fontflags textfont]
11996 eval font create textfontbold [fontflags textfont 1]
11998 parsefont uifont $uifont
11999 eval font create uifont [fontflags uifont]
12001 setui $uicolor
12003 setoptions
12005 # check that we can find a .git directory somewhere...
12006 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12007 show_error {} . [mc "Cannot find a git repository here."]
12008 exit 1
12011 set selecthead {}
12012 set selectheadid {}
12014 set revtreeargs {}
12015 set cmdline_files {}
12016 set i 0
12017 set revtreeargscmd {}
12018 foreach arg $argv {
12019 switch -glob -- $arg {
12020 "" { }
12021 "--" {
12022 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12023 break
12025 "--select-commit=*" {
12026 set selecthead [string range $arg 16 end]
12028 "--argscmd=*" {
12029 set revtreeargscmd [string range $arg 10 end]
12031 default {
12032 lappend revtreeargs $arg
12035 incr i
12038 if {$selecthead eq "HEAD"} {
12039 set selecthead {}
12042 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12043 # no -- on command line, but some arguments (other than --argscmd)
12044 if {[catch {
12045 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12046 set cmdline_files [split $f "\n"]
12047 set n [llength $cmdline_files]
12048 set revtreeargs [lrange $revtreeargs 0 end-$n]
12049 # Unfortunately git rev-parse doesn't produce an error when
12050 # something is both a revision and a filename. To be consistent
12051 # with git log and git rev-list, check revtreeargs for filenames.
12052 foreach arg $revtreeargs {
12053 if {[file exists $arg]} {
12054 show_error {} . [mc "Ambiguous argument '%s': both revision\
12055 and filename" $arg]
12056 exit 1
12059 } err]} {
12060 # unfortunately we get both stdout and stderr in $err,
12061 # so look for "fatal:".
12062 set i [string first "fatal:" $err]
12063 if {$i > 0} {
12064 set err [string range $err [expr {$i + 6}] end]
12066 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12067 exit 1
12071 set nullid "0000000000000000000000000000000000000000"
12072 set nullid2 "0000000000000000000000000000000000000001"
12073 set nullfile "/dev/null"
12075 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12076 if {![info exists have_ttk]} {
12077 set have_ttk [llength [info commands ::ttk::style]]
12079 set use_ttk [expr {$have_ttk && $want_ttk}]
12080 set NS [expr {$use_ttk ? "ttk" : ""}]
12082 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12084 set show_notes {}
12085 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12086 set show_notes "--show-notes"
12089 set appname "gitk"
12091 set runq {}
12092 set history {}
12093 set historyindex 0
12094 set fh_serial 0
12095 set nhl_names {}
12096 set highlight_paths {}
12097 set findpattern {}
12098 set searchdirn -forwards
12099 set boldids {}
12100 set boldnameids {}
12101 set diffelide {0 0}
12102 set markingmatches 0
12103 set linkentercount 0
12104 set need_redisplay 0
12105 set nrows_drawn 0
12106 set firsttabstop 0
12108 set nextviewnum 1
12109 set curview 0
12110 set selectedview 0
12111 set selectedhlview [mc "None"]
12112 set highlight_related [mc "None"]
12113 set highlight_files {}
12114 set viewfiles(0) {}
12115 set viewperm(0) 0
12116 set viewargs(0) {}
12117 set viewargscmd(0) {}
12119 set selectedline {}
12120 set numcommits 0
12121 set loginstance 0
12122 set cmdlineok 0
12123 set stopped 0
12124 set stuffsaved 0
12125 set patchnum 0
12126 set lserial 0
12127 set hasworktree [hasworktree]
12128 set cdup {}
12129 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12130 set cdup [exec git rev-parse --show-cdup]
12132 set worktree [exec git rev-parse --show-toplevel]
12133 setcoords
12134 makewindow
12135 catch {
12136 image create photo gitlogo -width 16 -height 16
12138 image create photo gitlogominus -width 4 -height 2
12139 gitlogominus put #C00000 -to 0 0 4 2
12140 gitlogo copy gitlogominus -to 1 5
12141 gitlogo copy gitlogominus -to 6 5
12142 gitlogo copy gitlogominus -to 11 5
12143 image delete gitlogominus
12145 image create photo gitlogoplus -width 4 -height 4
12146 gitlogoplus put #008000 -to 1 0 3 4
12147 gitlogoplus put #008000 -to 0 1 4 3
12148 gitlogo copy gitlogoplus -to 1 9
12149 gitlogo copy gitlogoplus -to 6 9
12150 gitlogo copy gitlogoplus -to 11 9
12151 image delete gitlogoplus
12153 image create photo gitlogo32 -width 32 -height 32
12154 gitlogo32 copy gitlogo -zoom 2 2
12156 wm iconphoto . -default gitlogo gitlogo32
12158 # wait for the window to become visible
12159 tkwait visibility .
12160 wm title . "$appname: [reponame]"
12161 update
12162 readrefs
12164 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12165 # create a view for the files/dirs specified on the command line
12166 set curview 1
12167 set selectedview 1
12168 set nextviewnum 2
12169 set viewname(1) [mc "Command line"]
12170 set viewfiles(1) $cmdline_files
12171 set viewargs(1) $revtreeargs
12172 set viewargscmd(1) $revtreeargscmd
12173 set viewperm(1) 0
12174 set vdatemode(1) 0
12175 addviewmenu 1
12176 .bar.view entryconf [mca "Edit view..."] -state normal
12177 .bar.view entryconf [mca "Delete view"] -state normal
12180 if {[info exists permviews]} {
12181 foreach v $permviews {
12182 set n $nextviewnum
12183 incr nextviewnum
12184 set viewname($n) [lindex $v 0]
12185 set viewfiles($n) [lindex $v 1]
12186 set viewargs($n) [lindex $v 2]
12187 set viewargscmd($n) [lindex $v 3]
12188 set viewperm($n) 1
12189 addviewmenu $n
12193 if {[tk windowingsystem] eq "win32"} {
12194 focus -force .
12197 getcommits {}
12199 # Local variables:
12200 # mode: tcl
12201 # indent-tabs-mode: t
12202 # tab-width: 8
12203 # End: