gitk: Use symbolic font names "sans" and "monospace" when available
[git/mingw/4msysgit.git] / gitk
blob36a48d54cd64706c4bba9b8721e5d307848236a2
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
645 foreach vid [array names varcid $view,*] {
646 unset varcid($vid)
647 unset children($vid)
648 unset parents($vid)
650 # some commits might have children but haven't been seen yet
651 foreach vid [array names children $view,*] {
652 unset children($vid)
654 foreach va [array names varccommits $view,*] {
655 unset varccommits($va)
657 foreach vd [array names vseedcount $view,*] {
658 unset vseedcount($vd)
660 catch {unset ordertok}
663 # returns a list of the commits with no children
664 proc seeds {v} {
665 global vdownptr vleftptr varcstart
667 set ret {}
668 set a [lindex $vdownptr($v) 0]
669 while {$a != 0} {
670 lappend ret [lindex $varcstart($v) $a]
671 set a [lindex $vleftptr($v) $a]
673 return $ret
676 proc newvarc {view id} {
677 global varcid varctok parents children vdatemode
678 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
679 global commitdata commitinfo vseedcount varccommits vlastins
681 set a [llength $varctok($view)]
682 set vid $view,$id
683 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
684 if {![info exists commitinfo($id)]} {
685 parsecommit $id $commitdata($id) 1
687 set cdate [lindex [lindex $commitinfo($id) 4] 0]
688 if {![string is integer -strict $cdate]} {
689 set cdate 0
691 if {![info exists vseedcount($view,$cdate)]} {
692 set vseedcount($view,$cdate) -1
694 set c [incr vseedcount($view,$cdate)]
695 set cdate [expr {$cdate ^ 0xffffffff}]
696 set tok "s[strrep $cdate][strrep $c]"
697 } else {
698 set tok {}
700 set ka 0
701 if {[llength $children($vid)] > 0} {
702 set kid [lindex $children($vid) end]
703 set k $varcid($view,$kid)
704 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
705 set ki $kid
706 set ka $k
707 set tok [lindex $varctok($view) $k]
710 if {$ka != 0} {
711 set i [lsearch -exact $parents($view,$ki) $id]
712 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
713 append tok [strrep $j]
715 set c [lindex $vlastins($view) $ka]
716 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
717 set c $ka
718 set b [lindex $vdownptr($view) $ka]
719 } else {
720 set b [lindex $vleftptr($view) $c]
722 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
723 set c $b
724 set b [lindex $vleftptr($view) $c]
726 if {$c == $ka} {
727 lset vdownptr($view) $ka $a
728 lappend vbackptr($view) 0
729 } else {
730 lset vleftptr($view) $c $a
731 lappend vbackptr($view) $c
733 lset vlastins($view) $ka $a
734 lappend vupptr($view) $ka
735 lappend vleftptr($view) $b
736 if {$b != 0} {
737 lset vbackptr($view) $b $a
739 lappend varctok($view) $tok
740 lappend varcstart($view) $id
741 lappend vdownptr($view) 0
742 lappend varcrow($view) {}
743 lappend varcix($view) {}
744 set varccommits($view,$a) {}
745 lappend vlastins($view) 0
746 return $a
749 proc splitvarc {p v} {
750 global varcid varcstart varccommits varctok vtokmod
751 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
753 set oa $varcid($v,$p)
754 set otok [lindex $varctok($v) $oa]
755 set ac $varccommits($v,$oa)
756 set i [lsearch -exact $varccommits($v,$oa) $p]
757 if {$i <= 0} return
758 set na [llength $varctok($v)]
759 # "%" sorts before "0"...
760 set tok "$otok%[strrep $i]"
761 lappend varctok($v) $tok
762 lappend varcrow($v) {}
763 lappend varcix($v) {}
764 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
765 set varccommits($v,$na) [lrange $ac $i end]
766 lappend varcstart($v) $p
767 foreach id $varccommits($v,$na) {
768 set varcid($v,$id) $na
770 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
771 lappend vlastins($v) [lindex $vlastins($v) $oa]
772 lset vdownptr($v) $oa $na
773 lset vlastins($v) $oa 0
774 lappend vupptr($v) $oa
775 lappend vleftptr($v) 0
776 lappend vbackptr($v) 0
777 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
778 lset vupptr($v) $b $na
780 if {[string compare $otok $vtokmod($v)] <= 0} {
781 modify_arc $v $oa
785 proc renumbervarc {a v} {
786 global parents children varctok varcstart varccommits
787 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
789 set t1 [clock clicks -milliseconds]
790 set todo {}
791 set isrelated($a) 1
792 set kidchanged($a) 1
793 set ntot 0
794 while {$a != 0} {
795 if {[info exists isrelated($a)]} {
796 lappend todo $a
797 set id [lindex $varccommits($v,$a) end]
798 foreach p $parents($v,$id) {
799 if {[info exists varcid($v,$p)]} {
800 set isrelated($varcid($v,$p)) 1
804 incr ntot
805 set b [lindex $vdownptr($v) $a]
806 if {$b == 0} {
807 while {$a != 0} {
808 set b [lindex $vleftptr($v) $a]
809 if {$b != 0} break
810 set a [lindex $vupptr($v) $a]
813 set a $b
815 foreach a $todo {
816 if {![info exists kidchanged($a)]} continue
817 set id [lindex $varcstart($v) $a]
818 if {[llength $children($v,$id)] > 1} {
819 set children($v,$id) [lsort -command [list vtokcmp $v] \
820 $children($v,$id)]
822 set oldtok [lindex $varctok($v) $a]
823 if {!$vdatemode($v)} {
824 set tok {}
825 } else {
826 set tok $oldtok
828 set ka 0
829 set kid [last_real_child $v,$id]
830 if {$kid ne {}} {
831 set k $varcid($v,$kid)
832 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
833 set ki $kid
834 set ka $k
835 set tok [lindex $varctok($v) $k]
838 if {$ka != 0} {
839 set i [lsearch -exact $parents($v,$ki) $id]
840 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
841 append tok [strrep $j]
843 if {$tok eq $oldtok} {
844 continue
846 set id [lindex $varccommits($v,$a) end]
847 foreach p $parents($v,$id) {
848 if {[info exists varcid($v,$p)]} {
849 set kidchanged($varcid($v,$p)) 1
850 } else {
851 set sortkids($p) 1
854 lset varctok($v) $a $tok
855 set b [lindex $vupptr($v) $a]
856 if {$b != $ka} {
857 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
858 modify_arc $v $ka
860 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
861 modify_arc $v $b
863 set c [lindex $vbackptr($v) $a]
864 set d [lindex $vleftptr($v) $a]
865 if {$c == 0} {
866 lset vdownptr($v) $b $d
867 } else {
868 lset vleftptr($v) $c $d
870 if {$d != 0} {
871 lset vbackptr($v) $d $c
873 if {[lindex $vlastins($v) $b] == $a} {
874 lset vlastins($v) $b $c
876 lset vupptr($v) $a $ka
877 set c [lindex $vlastins($v) $ka]
878 if {$c == 0 || \
879 [string compare $tok [lindex $varctok($v) $c]] < 0} {
880 set c $ka
881 set b [lindex $vdownptr($v) $ka]
882 } else {
883 set b [lindex $vleftptr($v) $c]
885 while {$b != 0 && \
886 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
887 set c $b
888 set b [lindex $vleftptr($v) $c]
890 if {$c == $ka} {
891 lset vdownptr($v) $ka $a
892 lset vbackptr($v) $a 0
893 } else {
894 lset vleftptr($v) $c $a
895 lset vbackptr($v) $a $c
897 lset vleftptr($v) $a $b
898 if {$b != 0} {
899 lset vbackptr($v) $b $a
901 lset vlastins($v) $ka $a
904 foreach id [array names sortkids] {
905 if {[llength $children($v,$id)] > 1} {
906 set children($v,$id) [lsort -command [list vtokcmp $v] \
907 $children($v,$id)]
910 set t2 [clock clicks -milliseconds]
911 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
914 # Fix up the graph after we have found out that in view $v,
915 # $p (a commit that we have already seen) is actually the parent
916 # of the last commit in arc $a.
917 proc fix_reversal {p a v} {
918 global varcid varcstart varctok vupptr
920 set pa $varcid($v,$p)
921 if {$p ne [lindex $varcstart($v) $pa]} {
922 splitvarc $p $v
923 set pa $varcid($v,$p)
925 # seeds always need to be renumbered
926 if {[lindex $vupptr($v) $pa] == 0 ||
927 [string compare [lindex $varctok($v) $a] \
928 [lindex $varctok($v) $pa]] > 0} {
929 renumbervarc $pa $v
933 proc insertrow {id p v} {
934 global cmitlisted children parents varcid varctok vtokmod
935 global varccommits ordertok commitidx numcommits curview
936 global targetid targetrow
938 readcommit $id
939 set vid $v,$id
940 set cmitlisted($vid) 1
941 set children($vid) {}
942 set parents($vid) [list $p]
943 set a [newvarc $v $id]
944 set varcid($vid) $a
945 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
946 modify_arc $v $a
948 lappend varccommits($v,$a) $id
949 set vp $v,$p
950 if {[llength [lappend children($vp) $id]] > 1} {
951 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
952 catch {unset ordertok}
954 fix_reversal $p $a $v
955 incr commitidx($v)
956 if {$v == $curview} {
957 set numcommits $commitidx($v)
958 setcanvscroll
959 if {[info exists targetid]} {
960 if {![comes_before $targetid $p]} {
961 incr targetrow
967 proc insertfakerow {id p} {
968 global varcid varccommits parents children cmitlisted
969 global commitidx varctok vtokmod targetid targetrow curview numcommits
971 set v $curview
972 set a $varcid($v,$p)
973 set i [lsearch -exact $varccommits($v,$a) $p]
974 if {$i < 0} {
975 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
976 return
978 set children($v,$id) {}
979 set parents($v,$id) [list $p]
980 set varcid($v,$id) $a
981 lappend children($v,$p) $id
982 set cmitlisted($v,$id) 1
983 set numcommits [incr commitidx($v)]
984 # note we deliberately don't update varcstart($v) even if $i == 0
985 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
986 modify_arc $v $a $i
987 if {[info exists targetid]} {
988 if {![comes_before $targetid $p]} {
989 incr targetrow
992 setcanvscroll
993 drawvisible
996 proc removefakerow {id} {
997 global varcid varccommits parents children commitidx
998 global varctok vtokmod cmitlisted currentid selectedline
999 global targetid curview numcommits
1001 set v $curview
1002 if {[llength $parents($v,$id)] != 1} {
1003 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1004 return
1006 set p [lindex $parents($v,$id) 0]
1007 set a $varcid($v,$id)
1008 set i [lsearch -exact $varccommits($v,$a) $id]
1009 if {$i < 0} {
1010 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1011 return
1013 unset varcid($v,$id)
1014 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1015 unset parents($v,$id)
1016 unset children($v,$id)
1017 unset cmitlisted($v,$id)
1018 set numcommits [incr commitidx($v) -1]
1019 set j [lsearch -exact $children($v,$p) $id]
1020 if {$j >= 0} {
1021 set children($v,$p) [lreplace $children($v,$p) $j $j]
1023 modify_arc $v $a $i
1024 if {[info exist currentid] && $id eq $currentid} {
1025 unset currentid
1026 set selectedline {}
1028 if {[info exists targetid] && $targetid eq $id} {
1029 set targetid $p
1031 setcanvscroll
1032 drawvisible
1035 proc real_children {vp} {
1036 global children nullid nullid2
1038 set kids {}
1039 foreach id $children($vp) {
1040 if {$id ne $nullid && $id ne $nullid2} {
1041 lappend kids $id
1044 return $kids
1047 proc first_real_child {vp} {
1048 global children nullid nullid2
1050 foreach id $children($vp) {
1051 if {$id ne $nullid && $id ne $nullid2} {
1052 return $id
1055 return {}
1058 proc last_real_child {vp} {
1059 global children nullid nullid2
1061 set kids $children($vp)
1062 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1063 set id [lindex $kids $i]
1064 if {$id ne $nullid && $id ne $nullid2} {
1065 return $id
1068 return {}
1071 proc vtokcmp {v a b} {
1072 global varctok varcid
1074 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1075 [lindex $varctok($v) $varcid($v,$b)]]
1078 # This assumes that if lim is not given, the caller has checked that
1079 # arc a's token is less than $vtokmod($v)
1080 proc modify_arc {v a {lim {}}} {
1081 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1083 if {$lim ne {}} {
1084 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1085 if {$c > 0} return
1086 if {$c == 0} {
1087 set r [lindex $varcrow($v) $a]
1088 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1091 set vtokmod($v) [lindex $varctok($v) $a]
1092 set varcmod($v) $a
1093 if {$v == $curview} {
1094 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1095 set a [lindex $vupptr($v) $a]
1096 set lim {}
1098 set r 0
1099 if {$a != 0} {
1100 if {$lim eq {}} {
1101 set lim [llength $varccommits($v,$a)]
1103 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1105 set vrowmod($v) $r
1106 undolayout $r
1110 proc update_arcrows {v} {
1111 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1112 global varcid vrownum varcorder varcix varccommits
1113 global vupptr vdownptr vleftptr varctok
1114 global displayorder parentlist curview cached_commitrow
1116 if {$vrowmod($v) == $commitidx($v)} return
1117 if {$v == $curview} {
1118 if {[llength $displayorder] > $vrowmod($v)} {
1119 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1120 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1122 catch {unset cached_commitrow}
1124 set narctot [expr {[llength $varctok($v)] - 1}]
1125 set a $varcmod($v)
1126 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1127 # go up the tree until we find something that has a row number,
1128 # or we get to a seed
1129 set a [lindex $vupptr($v) $a]
1131 if {$a == 0} {
1132 set a [lindex $vdownptr($v) 0]
1133 if {$a == 0} return
1134 set vrownum($v) {0}
1135 set varcorder($v) [list $a]
1136 lset varcix($v) $a 0
1137 lset varcrow($v) $a 0
1138 set arcn 0
1139 set row 0
1140 } else {
1141 set arcn [lindex $varcix($v) $a]
1142 if {[llength $vrownum($v)] > $arcn + 1} {
1143 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1144 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1146 set row [lindex $varcrow($v) $a]
1148 while {1} {
1149 set p $a
1150 incr row [llength $varccommits($v,$a)]
1151 # go down if possible
1152 set b [lindex $vdownptr($v) $a]
1153 if {$b == 0} {
1154 # if not, go left, or go up until we can go left
1155 while {$a != 0} {
1156 set b [lindex $vleftptr($v) $a]
1157 if {$b != 0} break
1158 set a [lindex $vupptr($v) $a]
1160 if {$a == 0} break
1162 set a $b
1163 incr arcn
1164 lappend vrownum($v) $row
1165 lappend varcorder($v) $a
1166 lset varcix($v) $a $arcn
1167 lset varcrow($v) $a $row
1169 set vtokmod($v) [lindex $varctok($v) $p]
1170 set varcmod($v) $p
1171 set vrowmod($v) $row
1172 if {[info exists currentid]} {
1173 set selectedline [rowofcommit $currentid]
1177 # Test whether view $v contains commit $id
1178 proc commitinview {id v} {
1179 global varcid
1181 return [info exists varcid($v,$id)]
1184 # Return the row number for commit $id in the current view
1185 proc rowofcommit {id} {
1186 global varcid varccommits varcrow curview cached_commitrow
1187 global varctok vtokmod
1189 set v $curview
1190 if {![info exists varcid($v,$id)]} {
1191 puts "oops rowofcommit no arc for [shortids $id]"
1192 return {}
1194 set a $varcid($v,$id)
1195 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1196 update_arcrows $v
1198 if {[info exists cached_commitrow($id)]} {
1199 return $cached_commitrow($id)
1201 set i [lsearch -exact $varccommits($v,$a) $id]
1202 if {$i < 0} {
1203 puts "oops didn't find commit [shortids $id] in arc $a"
1204 return {}
1206 incr i [lindex $varcrow($v) $a]
1207 set cached_commitrow($id) $i
1208 return $i
1211 # Returns 1 if a is on an earlier row than b, otherwise 0
1212 proc comes_before {a b} {
1213 global varcid varctok curview
1215 set v $curview
1216 if {$a eq $b || ![info exists varcid($v,$a)] || \
1217 ![info exists varcid($v,$b)]} {
1218 return 0
1220 if {$varcid($v,$a) != $varcid($v,$b)} {
1221 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1222 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1224 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1227 proc bsearch {l elt} {
1228 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1229 return 0
1231 set lo 0
1232 set hi [llength $l]
1233 while {$hi - $lo > 1} {
1234 set mid [expr {int(($lo + $hi) / 2)}]
1235 set t [lindex $l $mid]
1236 if {$elt < $t} {
1237 set hi $mid
1238 } elseif {$elt > $t} {
1239 set lo $mid
1240 } else {
1241 return $mid
1244 return $lo
1247 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1248 proc make_disporder {start end} {
1249 global vrownum curview commitidx displayorder parentlist
1250 global varccommits varcorder parents vrowmod varcrow
1251 global d_valid_start d_valid_end
1253 if {$end > $vrowmod($curview)} {
1254 update_arcrows $curview
1256 set ai [bsearch $vrownum($curview) $start]
1257 set start [lindex $vrownum($curview) $ai]
1258 set narc [llength $vrownum($curview)]
1259 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1260 set a [lindex $varcorder($curview) $ai]
1261 set l [llength $displayorder]
1262 set al [llength $varccommits($curview,$a)]
1263 if {$l < $r + $al} {
1264 if {$l < $r} {
1265 set pad [ntimes [expr {$r - $l}] {}]
1266 set displayorder [concat $displayorder $pad]
1267 set parentlist [concat $parentlist $pad]
1268 } elseif {$l > $r} {
1269 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1270 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1272 foreach id $varccommits($curview,$a) {
1273 lappend displayorder $id
1274 lappend parentlist $parents($curview,$id)
1276 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1277 set i $r
1278 foreach id $varccommits($curview,$a) {
1279 lset displayorder $i $id
1280 lset parentlist $i $parents($curview,$id)
1281 incr i
1284 incr r $al
1288 proc commitonrow {row} {
1289 global displayorder
1291 set id [lindex $displayorder $row]
1292 if {$id eq {}} {
1293 make_disporder $row [expr {$row + 1}]
1294 set id [lindex $displayorder $row]
1296 return $id
1299 proc closevarcs {v} {
1300 global varctok varccommits varcid parents children
1301 global cmitlisted commitidx vtokmod
1303 set missing_parents 0
1304 set scripts {}
1305 set narcs [llength $varctok($v)]
1306 for {set a 1} {$a < $narcs} {incr a} {
1307 set id [lindex $varccommits($v,$a) end]
1308 foreach p $parents($v,$id) {
1309 if {[info exists varcid($v,$p)]} continue
1310 # add p as a new commit
1311 incr missing_parents
1312 set cmitlisted($v,$p) 0
1313 set parents($v,$p) {}
1314 if {[llength $children($v,$p)] == 1 &&
1315 [llength $parents($v,$id)] == 1} {
1316 set b $a
1317 } else {
1318 set b [newvarc $v $p]
1320 set varcid($v,$p) $b
1321 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1322 modify_arc $v $b
1324 lappend varccommits($v,$b) $p
1325 incr commitidx($v)
1326 set scripts [check_interest $p $scripts]
1329 if {$missing_parents > 0} {
1330 foreach s $scripts {
1331 eval $s
1336 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1337 # Assumes we already have an arc for $rwid.
1338 proc rewrite_commit {v id rwid} {
1339 global children parents varcid varctok vtokmod varccommits
1341 foreach ch $children($v,$id) {
1342 # make $rwid be $ch's parent in place of $id
1343 set i [lsearch -exact $parents($v,$ch) $id]
1344 if {$i < 0} {
1345 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1347 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1348 # add $ch to $rwid's children and sort the list if necessary
1349 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1350 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1351 $children($v,$rwid)]
1353 # fix the graph after joining $id to $rwid
1354 set a $varcid($v,$ch)
1355 fix_reversal $rwid $a $v
1356 # parentlist is wrong for the last element of arc $a
1357 # even if displayorder is right, hence the 3rd arg here
1358 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1362 # Mechanism for registering a command to be executed when we come
1363 # across a particular commit. To handle the case when only the
1364 # prefix of the commit is known, the commitinterest array is now
1365 # indexed by the first 4 characters of the ID. Each element is a
1366 # list of id, cmd pairs.
1367 proc interestedin {id cmd} {
1368 global commitinterest
1370 lappend commitinterest([string range $id 0 3]) $id $cmd
1373 proc check_interest {id scripts} {
1374 global commitinterest
1376 set prefix [string range $id 0 3]
1377 if {[info exists commitinterest($prefix)]} {
1378 set newlist {}
1379 foreach {i script} $commitinterest($prefix) {
1380 if {[string match "$i*" $id]} {
1381 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1382 } else {
1383 lappend newlist $i $script
1386 if {$newlist ne {}} {
1387 set commitinterest($prefix) $newlist
1388 } else {
1389 unset commitinterest($prefix)
1392 return $scripts
1395 proc getcommitlines {fd inst view updating} {
1396 global cmitlisted leftover
1397 global commitidx commitdata vdatemode
1398 global parents children curview hlview
1399 global idpending ordertok
1400 global varccommits varcid varctok vtokmod vfilelimit
1402 set stuff [read $fd 500000]
1403 # git log doesn't terminate the last commit with a null...
1404 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1405 set stuff "\0"
1407 if {$stuff == {}} {
1408 if {![eof $fd]} {
1409 return 1
1411 global commfd viewcomplete viewactive viewname
1412 global viewinstances
1413 unset commfd($inst)
1414 set i [lsearch -exact $viewinstances($view) $inst]
1415 if {$i >= 0} {
1416 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1418 # set it blocking so we wait for the process to terminate
1419 fconfigure $fd -blocking 1
1420 if {[catch {close $fd} err]} {
1421 set fv {}
1422 if {$view != $curview} {
1423 set fv " for the \"$viewname($view)\" view"
1425 if {[string range $err 0 4] == "usage"} {
1426 set err "Gitk: error reading commits$fv:\
1427 bad arguments to git log."
1428 if {$viewname($view) eq "Command line"} {
1429 append err \
1430 " (Note: arguments to gitk are passed to git log\
1431 to allow selection of commits to be displayed.)"
1433 } else {
1434 set err "Error reading commits$fv: $err"
1436 error_popup $err
1438 if {[incr viewactive($view) -1] <= 0} {
1439 set viewcomplete($view) 1
1440 # Check if we have seen any ids listed as parents that haven't
1441 # appeared in the list
1442 closevarcs $view
1443 notbusy $view
1445 if {$view == $curview} {
1446 run chewcommits
1448 return 0
1450 set start 0
1451 set gotsome 0
1452 set scripts {}
1453 while 1 {
1454 set i [string first "\0" $stuff $start]
1455 if {$i < 0} {
1456 append leftover($inst) [string range $stuff $start end]
1457 break
1459 if {$start == 0} {
1460 set cmit $leftover($inst)
1461 append cmit [string range $stuff 0 [expr {$i - 1}]]
1462 set leftover($inst) {}
1463 } else {
1464 set cmit [string range $stuff $start [expr {$i - 1}]]
1466 set start [expr {$i + 1}]
1467 set j [string first "\n" $cmit]
1468 set ok 0
1469 set listed 1
1470 if {$j >= 0 && [string match "commit *" $cmit]} {
1471 set ids [string range $cmit 7 [expr {$j - 1}]]
1472 if {[string match {[-^<>]*} $ids]} {
1473 switch -- [string index $ids 0] {
1474 "-" {set listed 0}
1475 "^" {set listed 2}
1476 "<" {set listed 3}
1477 ">" {set listed 4}
1479 set ids [string range $ids 1 end]
1481 set ok 1
1482 foreach id $ids {
1483 if {[string length $id] != 40} {
1484 set ok 0
1485 break
1489 if {!$ok} {
1490 set shortcmit $cmit
1491 if {[string length $shortcmit] > 80} {
1492 set shortcmit "[string range $shortcmit 0 80]..."
1494 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1495 exit 1
1497 set id [lindex $ids 0]
1498 set vid $view,$id
1500 if {!$listed && $updating && ![info exists varcid($vid)] &&
1501 $vfilelimit($view) ne {}} {
1502 # git log doesn't rewrite parents for unlisted commits
1503 # when doing path limiting, so work around that here
1504 # by working out the rewritten parent with git rev-list
1505 # and if we already know about it, using the rewritten
1506 # parent as a substitute parent for $id's children.
1507 if {![catch {
1508 set rwid [exec git rev-list --first-parent --max-count=1 \
1509 $id -- $vfilelimit($view)]
1510 }]} {
1511 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1512 # use $rwid in place of $id
1513 rewrite_commit $view $id $rwid
1514 continue
1519 set a 0
1520 if {[info exists varcid($vid)]} {
1521 if {$cmitlisted($vid) || !$listed} continue
1522 set a $varcid($vid)
1524 if {$listed} {
1525 set olds [lrange $ids 1 end]
1526 } else {
1527 set olds {}
1529 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1530 set cmitlisted($vid) $listed
1531 set parents($vid) $olds
1532 if {![info exists children($vid)]} {
1533 set children($vid) {}
1534 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1535 set k [lindex $children($vid) 0]
1536 if {[llength $parents($view,$k)] == 1 &&
1537 (!$vdatemode($view) ||
1538 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1539 set a $varcid($view,$k)
1542 if {$a == 0} {
1543 # new arc
1544 set a [newvarc $view $id]
1546 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1547 modify_arc $view $a
1549 if {![info exists varcid($vid)]} {
1550 set varcid($vid) $a
1551 lappend varccommits($view,$a) $id
1552 incr commitidx($view)
1555 set i 0
1556 foreach p $olds {
1557 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1558 set vp $view,$p
1559 if {[llength [lappend children($vp) $id]] > 1 &&
1560 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1561 set children($vp) [lsort -command [list vtokcmp $view] \
1562 $children($vp)]
1563 catch {unset ordertok}
1565 if {[info exists varcid($view,$p)]} {
1566 fix_reversal $p $a $view
1569 incr i
1572 set scripts [check_interest $id $scripts]
1573 set gotsome 1
1575 if {$gotsome} {
1576 global numcommits hlview
1578 if {$view == $curview} {
1579 set numcommits $commitidx($view)
1580 run chewcommits
1582 if {[info exists hlview] && $view == $hlview} {
1583 # we never actually get here...
1584 run vhighlightmore
1586 foreach s $scripts {
1587 eval $s
1590 return 2
1593 proc chewcommits {} {
1594 global curview hlview viewcomplete
1595 global pending_select
1597 layoutmore
1598 if {$viewcomplete($curview)} {
1599 global commitidx varctok
1600 global numcommits startmsecs
1602 if {[info exists pending_select]} {
1603 update
1604 reset_pending_select {}
1606 if {[commitinview $pending_select $curview]} {
1607 selectline [rowofcommit $pending_select] 1
1608 } else {
1609 set row [first_real_row]
1610 selectline $row 1
1613 if {$commitidx($curview) > 0} {
1614 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1615 #puts "overall $ms ms for $numcommits commits"
1616 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1617 } else {
1618 show_status [mc "No commits selected"]
1620 notbusy layout
1622 return 0
1625 proc do_readcommit {id} {
1626 global tclencoding
1628 # Invoke git-log to handle automatic encoding conversion
1629 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1630 # Read the results using i18n.logoutputencoding
1631 fconfigure $fd -translation lf -eofchar {}
1632 if {$tclencoding != {}} {
1633 fconfigure $fd -encoding $tclencoding
1635 set contents [read $fd]
1636 close $fd
1637 # Remove the heading line
1638 regsub {^commit [0-9a-f]+\n} $contents {} contents
1640 return $contents
1643 proc readcommit {id} {
1644 if {[catch {set contents [do_readcommit $id]}]} return
1645 parsecommit $id $contents 1
1648 proc parsecommit {id contents listed} {
1649 global commitinfo
1651 set inhdr 1
1652 set comment {}
1653 set headline {}
1654 set auname {}
1655 set audate {}
1656 set comname {}
1657 set comdate {}
1658 set hdrend [string first "\n\n" $contents]
1659 if {$hdrend < 0} {
1660 # should never happen...
1661 set hdrend [string length $contents]
1663 set header [string range $contents 0 [expr {$hdrend - 1}]]
1664 set comment [string range $contents [expr {$hdrend + 2}] end]
1665 foreach line [split $header "\n"] {
1666 set line [split $line " "]
1667 set tag [lindex $line 0]
1668 if {$tag == "author"} {
1669 set audate [lrange $line end-1 end]
1670 set auname [join [lrange $line 1 end-2] " "]
1671 } elseif {$tag == "committer"} {
1672 set comdate [lrange $line end-1 end]
1673 set comname [join [lrange $line 1 end-2] " "]
1676 set headline {}
1677 # take the first non-blank line of the comment as the headline
1678 set headline [string trimleft $comment]
1679 set i [string first "\n" $headline]
1680 if {$i >= 0} {
1681 set headline [string range $headline 0 $i]
1683 set headline [string trimright $headline]
1684 set i [string first "\r" $headline]
1685 if {$i >= 0} {
1686 set headline [string trimright [string range $headline 0 $i]]
1688 if {!$listed} {
1689 # git log indents the comment by 4 spaces;
1690 # if we got this via git cat-file, add the indentation
1691 set newcomment {}
1692 foreach line [split $comment "\n"] {
1693 append newcomment " "
1694 append newcomment $line
1695 append newcomment "\n"
1697 set comment $newcomment
1699 set hasnote [string first "\nNotes:\n" $contents]
1700 set commitinfo($id) [list $headline $auname $audate \
1701 $comname $comdate $comment $hasnote]
1704 proc getcommit {id} {
1705 global commitdata commitinfo
1707 if {[info exists commitdata($id)]} {
1708 parsecommit $id $commitdata($id) 1
1709 } else {
1710 readcommit $id
1711 if {![info exists commitinfo($id)]} {
1712 set commitinfo($id) [list [mc "No commit information available"]]
1715 return 1
1718 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1719 # and are present in the current view.
1720 # This is fairly slow...
1721 proc longid {prefix} {
1722 global varcid curview
1724 set ids {}
1725 foreach match [array names varcid "$curview,$prefix*"] {
1726 lappend ids [lindex [split $match ","] 1]
1728 return $ids
1731 proc readrefs {} {
1732 global tagids idtags headids idheads tagobjid
1733 global otherrefids idotherrefs mainhead mainheadid
1734 global selecthead selectheadid
1735 global hideremotes
1737 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1738 catch {unset $v}
1740 set refd [open [list | git show-ref -d] r]
1741 while {[gets $refd line] >= 0} {
1742 if {[string index $line 40] ne " "} continue
1743 set id [string range $line 0 39]
1744 set ref [string range $line 41 end]
1745 if {![string match "refs/*" $ref]} continue
1746 set name [string range $ref 5 end]
1747 if {[string match "remotes/*" $name]} {
1748 if {![string match "*/HEAD" $name] && !$hideremotes} {
1749 set headids($name) $id
1750 lappend idheads($id) $name
1752 } elseif {[string match "heads/*" $name]} {
1753 set name [string range $name 6 end]
1754 set headids($name) $id
1755 lappend idheads($id) $name
1756 } elseif {[string match "tags/*" $name]} {
1757 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1758 # which is what we want since the former is the commit ID
1759 set name [string range $name 5 end]
1760 if {[string match "*^{}" $name]} {
1761 set name [string range $name 0 end-3]
1762 } else {
1763 set tagobjid($name) $id
1765 set tagids($name) $id
1766 lappend idtags($id) $name
1767 } else {
1768 set otherrefids($name) $id
1769 lappend idotherrefs($id) $name
1772 catch {close $refd}
1773 set mainhead {}
1774 set mainheadid {}
1775 catch {
1776 set mainheadid [exec git rev-parse HEAD]
1777 set thehead [exec git symbolic-ref HEAD]
1778 if {[string match "refs/heads/*" $thehead]} {
1779 set mainhead [string range $thehead 11 end]
1782 set selectheadid {}
1783 if {$selecthead ne {}} {
1784 catch {
1785 set selectheadid [exec git rev-parse --verify $selecthead]
1790 # skip over fake commits
1791 proc first_real_row {} {
1792 global nullid nullid2 numcommits
1794 for {set row 0} {$row < $numcommits} {incr row} {
1795 set id [commitonrow $row]
1796 if {$id ne $nullid && $id ne $nullid2} {
1797 break
1800 return $row
1803 # update things for a head moved to a child of its previous location
1804 proc movehead {id name} {
1805 global headids idheads
1807 removehead $headids($name) $name
1808 set headids($name) $id
1809 lappend idheads($id) $name
1812 # update things when a head has been removed
1813 proc removehead {id name} {
1814 global headids idheads
1816 if {$idheads($id) eq $name} {
1817 unset idheads($id)
1818 } else {
1819 set i [lsearch -exact $idheads($id) $name]
1820 if {$i >= 0} {
1821 set idheads($id) [lreplace $idheads($id) $i $i]
1824 unset headids($name)
1827 proc ttk_toplevel {w args} {
1828 global use_ttk
1829 eval [linsert $args 0 ::toplevel $w]
1830 if {$use_ttk} {
1831 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1833 return $w
1836 proc make_transient {window origin} {
1837 global have_tk85
1839 # In MacOS Tk 8.4 transient appears to work by setting
1840 # overrideredirect, which is utterly useless, since the
1841 # windows get no border, and are not even kept above
1842 # the parent.
1843 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1845 wm transient $window $origin
1847 # Windows fails to place transient windows normally, so
1848 # schedule a callback to center them on the parent.
1849 if {[tk windowingsystem] eq {win32}} {
1850 after idle [list tk::PlaceWindow $window widget $origin]
1854 proc show_error {w top msg {mc mc}} {
1855 global NS
1856 if {![info exists NS]} {set NS ""}
1857 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1858 message $w.m -text $msg -justify center -aspect 400
1859 pack $w.m -side top -fill x -padx 20 -pady 20
1860 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1861 pack $w.ok -side bottom -fill x
1862 bind $top <Visibility> "grab $top; focus $top"
1863 bind $top <Key-Return> "destroy $top"
1864 bind $top <Key-space> "destroy $top"
1865 bind $top <Key-Escape> "destroy $top"
1866 tkwait window $top
1869 proc error_popup {msg {owner .}} {
1870 if {[tk windowingsystem] eq "win32"} {
1871 tk_messageBox -icon error -type ok -title [wm title .] \
1872 -parent $owner -message $msg
1873 } else {
1874 set w .error
1875 ttk_toplevel $w
1876 make_transient $w $owner
1877 show_error $w $w $msg
1881 proc confirm_popup {msg {owner .}} {
1882 global confirm_ok NS
1883 set confirm_ok 0
1884 set w .confirm
1885 ttk_toplevel $w
1886 make_transient $w $owner
1887 message $w.m -text $msg -justify center -aspect 400
1888 pack $w.m -side top -fill x -padx 20 -pady 20
1889 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1890 pack $w.ok -side left -fill x
1891 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1892 pack $w.cancel -side right -fill x
1893 bind $w <Visibility> "grab $w; focus $w"
1894 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1895 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1896 bind $w <Key-Escape> "destroy $w"
1897 tk::PlaceWindow $w widget $owner
1898 tkwait window $w
1899 return $confirm_ok
1902 proc setoptions {} {
1903 if {[tk windowingsystem] ne "win32"} {
1904 option add *Panedwindow.showHandle 1 startupFile
1905 option add *Panedwindow.sashRelief raised startupFile
1906 if {[tk windowingsystem] ne "aqua"} {
1907 option add *Menu.font uifont startupFile
1909 } else {
1910 option add *Menu.TearOff 0 startupFile
1912 option add *Button.font uifont startupFile
1913 option add *Checkbutton.font uifont startupFile
1914 option add *Radiobutton.font uifont startupFile
1915 option add *Menubutton.font uifont startupFile
1916 option add *Label.font uifont startupFile
1917 option add *Message.font uifont startupFile
1918 option add *Entry.font textfont startupFile
1919 option add *Text.font textfont startupFile
1920 option add *Labelframe.font uifont startupFile
1921 option add *Spinbox.font textfont startupFile
1922 option add *Listbox.font mainfont startupFile
1925 # Make a menu and submenus.
1926 # m is the window name for the menu, items is the list of menu items to add.
1927 # Each item is a list {mc label type description options...}
1928 # mc is ignored; it's so we can put mc there to alert xgettext
1929 # label is the string that appears in the menu
1930 # type is cascade, command or radiobutton (should add checkbutton)
1931 # description depends on type; it's the sublist for cascade, the
1932 # command to invoke for command, or {variable value} for radiobutton
1933 proc makemenu {m items} {
1934 menu $m
1935 if {[tk windowingsystem] eq {aqua}} {
1936 set Meta1 Cmd
1937 } else {
1938 set Meta1 Ctrl
1940 foreach i $items {
1941 set name [mc [lindex $i 1]]
1942 set type [lindex $i 2]
1943 set thing [lindex $i 3]
1944 set params [list $type]
1945 if {$name ne {}} {
1946 set u [string first "&" [string map {&& x} $name]]
1947 lappend params -label [string map {&& & & {}} $name]
1948 if {$u >= 0} {
1949 lappend params -underline $u
1952 switch -- $type {
1953 "cascade" {
1954 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1955 lappend params -menu $m.$submenu
1957 "command" {
1958 lappend params -command $thing
1960 "radiobutton" {
1961 lappend params -variable [lindex $thing 0] \
1962 -value [lindex $thing 1]
1965 set tail [lrange $i 4 end]
1966 regsub -all {\yMeta1\y} $tail $Meta1 tail
1967 eval $m add $params $tail
1968 if {$type eq "cascade"} {
1969 makemenu $m.$submenu $thing
1974 # translate string and remove ampersands
1975 proc mca {str} {
1976 return [string map {&& & & {}} [mc $str]]
1979 proc makedroplist {w varname args} {
1980 global use_ttk
1981 if {$use_ttk} {
1982 set width 0
1983 foreach label $args {
1984 set cx [string length $label]
1985 if {$cx > $width} {set width $cx}
1987 set gm [ttk::combobox $w -width $width -state readonly\
1988 -textvariable $varname -values $args]
1989 } else {
1990 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
1992 return $gm
1995 proc makewindow {} {
1996 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1997 global tabstop
1998 global findtype findtypemenu findloc findstring fstring geometry
1999 global entries sha1entry sha1string sha1but
2000 global diffcontextstring diffcontext
2001 global ignorespace
2002 global maincursor textcursor curtextcursor
2003 global rowctxmenu fakerowmenu mergemax wrapcomment
2004 global highlight_files gdttype
2005 global searchstring sstring
2006 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2007 global headctxmenu progresscanv progressitem progresscoords statusw
2008 global fprogitem fprogcoord lastprogupdate progupdatepending
2009 global rprogitem rprogcoord rownumsel numcommits
2010 global have_tk85 use_ttk NS
2011 global git_version
2012 global worddiff
2014 # The "mc" arguments here are purely so that xgettext
2015 # sees the following string as needing to be translated
2016 set file {
2017 mc "File" cascade {
2018 {mc "Update" command updatecommits -accelerator F5}
2019 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
2020 {mc "Reread references" command rereadrefs}
2021 {mc "List references" command showrefs -accelerator F2}
2022 {xx "" separator}
2023 {mc "Start git gui" command {exec git gui &}}
2024 {xx "" separator}
2025 {mc "Quit" command doquit -accelerator Meta1-Q}
2027 set edit {
2028 mc "Edit" cascade {
2029 {mc "Preferences" command doprefs}
2031 set view {
2032 mc "View" cascade {
2033 {mc "New view..." command {newview 0} -accelerator Shift-F4}
2034 {mc "Edit view..." command editview -state disabled -accelerator F4}
2035 {mc "Delete view" command delview -state disabled}
2036 {xx "" separator}
2037 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2039 if {[tk windowingsystem] ne "aqua"} {
2040 set help {
2041 mc "Help" cascade {
2042 {mc "About gitk" command about}
2043 {mc "Key bindings" command keys}
2045 set bar [list $file $edit $view $help]
2046 } else {
2047 proc ::tk::mac::ShowPreferences {} {doprefs}
2048 proc ::tk::mac::Quit {} {doquit}
2049 lset file end [lreplace [lindex $file end] end-1 end]
2050 set apple {
2051 xx "Apple" cascade {
2052 {mc "About gitk" command about}
2053 {xx "" separator}
2055 set help {
2056 mc "Help" cascade {
2057 {mc "Key bindings" command keys}
2059 set bar [list $apple $file $view $help]
2061 makemenu .bar $bar
2062 . configure -menu .bar
2064 if {$use_ttk} {
2065 # cover the non-themed toplevel with a themed frame.
2066 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2069 # the gui has upper and lower half, parts of a paned window.
2070 ${NS}::panedwindow .ctop -orient vertical
2072 # possibly use assumed geometry
2073 if {![info exists geometry(pwsash0)]} {
2074 set geometry(topheight) [expr {15 * $linespc}]
2075 set geometry(topwidth) [expr {80 * $charspc}]
2076 set geometry(botheight) [expr {15 * $linespc}]
2077 set geometry(botwidth) [expr {50 * $charspc}]
2078 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2079 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2082 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2083 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2084 ${NS}::frame .tf.histframe
2085 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2086 if {!$use_ttk} {
2087 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2090 # create three canvases
2091 set cscroll .tf.histframe.csb
2092 set canv .tf.histframe.pwclist.canv
2093 canvas $canv \
2094 -selectbackground $selectbgcolor \
2095 -background $bgcolor -bd 0 \
2096 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2097 .tf.histframe.pwclist add $canv
2098 set canv2 .tf.histframe.pwclist.canv2
2099 canvas $canv2 \
2100 -selectbackground $selectbgcolor \
2101 -background $bgcolor -bd 0 -yscrollincr $linespc
2102 .tf.histframe.pwclist add $canv2
2103 set canv3 .tf.histframe.pwclist.canv3
2104 canvas $canv3 \
2105 -selectbackground $selectbgcolor \
2106 -background $bgcolor -bd 0 -yscrollincr $linespc
2107 .tf.histframe.pwclist add $canv3
2108 if {$use_ttk} {
2109 bind .tf.histframe.pwclist <Map> {
2110 bind %W <Map> {}
2111 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2112 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2114 } else {
2115 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2116 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2119 # a scroll bar to rule them
2120 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2121 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2122 pack $cscroll -side right -fill y
2123 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2124 lappend bglist $canv $canv2 $canv3
2125 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2127 # we have two button bars at bottom of top frame. Bar 1
2128 ${NS}::frame .tf.bar
2129 ${NS}::frame .tf.lbar -height 15
2131 set sha1entry .tf.bar.sha1
2132 set entries $sha1entry
2133 set sha1but .tf.bar.sha1label
2134 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2135 -command gotocommit -width 8
2136 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2137 pack .tf.bar.sha1label -side left
2138 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2139 trace add variable sha1string write sha1change
2140 pack $sha1entry -side left -pady 2
2142 image create bitmap bm-left -data {
2143 #define left_width 16
2144 #define left_height 16
2145 static unsigned char left_bits[] = {
2146 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2147 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2148 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2150 image create bitmap bm-right -data {
2151 #define right_width 16
2152 #define right_height 16
2153 static unsigned char right_bits[] = {
2154 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2155 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2156 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2158 ${NS}::button .tf.bar.leftbut -image bm-left -command goback \
2159 -state disabled -width 26
2160 pack .tf.bar.leftbut -side left -fill y
2161 ${NS}::button .tf.bar.rightbut -image bm-right -command goforw \
2162 -state disabled -width 26
2163 pack .tf.bar.rightbut -side left -fill y
2165 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2166 set rownumsel {}
2167 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2168 -relief sunken -anchor e
2169 ${NS}::label .tf.bar.rowlabel2 -text "/"
2170 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2171 -relief sunken -anchor e
2172 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2173 -side left
2174 if {!$use_ttk} {
2175 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2177 global selectedline
2178 trace add variable selectedline write selectedline_change
2180 # Status label and progress bar
2181 set statusw .tf.bar.status
2182 ${NS}::label $statusw -width 15 -relief sunken
2183 pack $statusw -side left -padx 5
2184 if {$use_ttk} {
2185 set progresscanv [ttk::progressbar .tf.bar.progress]
2186 } else {
2187 set h [expr {[font metrics uifont -linespace] + 2}]
2188 set progresscanv .tf.bar.progress
2189 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2190 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2191 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2192 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2194 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2195 set progresscoords {0 0}
2196 set fprogcoord 0
2197 set rprogcoord 0
2198 bind $progresscanv <Configure> adjustprogress
2199 set lastprogupdate [clock clicks -milliseconds]
2200 set progupdatepending 0
2202 # build up the bottom bar of upper window
2203 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2204 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2205 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2206 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2207 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2208 -side left -fill y
2209 set gdttype [mc "containing:"]
2210 set gm [makedroplist .tf.lbar.gdttype gdttype \
2211 [mc "containing:"] \
2212 [mc "touching paths:"] \
2213 [mc "adding/removing string:"]]
2214 trace add variable gdttype write gdttype_change
2215 pack .tf.lbar.gdttype -side left -fill y
2217 set findstring {}
2218 set fstring .tf.lbar.findstring
2219 lappend entries $fstring
2220 ${NS}::entry $fstring -width 30 -textvariable findstring
2221 trace add variable findstring write find_change
2222 set findtype [mc "Exact"]
2223 set findtypemenu [makedroplist .tf.lbar.findtype \
2224 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2225 trace add variable findtype write findcom_change
2226 set findloc [mc "All fields"]
2227 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2228 [mc "Comments"] [mc "Author"] [mc "Committer"]
2229 trace add variable findloc write find_change
2230 pack .tf.lbar.findloc -side right
2231 pack .tf.lbar.findtype -side right
2232 pack $fstring -side left -expand 1 -fill x
2234 # Finish putting the upper half of the viewer together
2235 pack .tf.lbar -in .tf -side bottom -fill x
2236 pack .tf.bar -in .tf -side bottom -fill x
2237 pack .tf.histframe -fill both -side top -expand 1
2238 .ctop add .tf
2239 if {!$use_ttk} {
2240 .ctop paneconfigure .tf -height $geometry(topheight)
2241 .ctop paneconfigure .tf -width $geometry(topwidth)
2244 # now build up the bottom
2245 ${NS}::panedwindow .pwbottom -orient horizontal
2247 # lower left, a text box over search bar, scroll bar to the right
2248 # if we know window height, then that will set the lower text height, otherwise
2249 # we set lower text height which will drive window height
2250 if {[info exists geometry(main)]} {
2251 ${NS}::frame .bleft -width $geometry(botwidth)
2252 } else {
2253 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2255 ${NS}::frame .bleft.top
2256 ${NS}::frame .bleft.mid
2257 ${NS}::frame .bleft.bottom
2259 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2260 pack .bleft.top.search -side left -padx 5
2261 set sstring .bleft.top.sstring
2262 set searchstring ""
2263 ${NS}::entry $sstring -width 20 -textvariable searchstring
2264 lappend entries $sstring
2265 trace add variable searchstring write incrsearch
2266 pack $sstring -side left -expand 1 -fill x
2267 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2268 -command changediffdisp -variable diffelide -value {0 0}
2269 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2270 -command changediffdisp -variable diffelide -value {0 1}
2271 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2272 -command changediffdisp -variable diffelide -value {1 0}
2273 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2274 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2275 spinbox .bleft.mid.diffcontext -width 5 \
2276 -from 0 -increment 1 -to 10000000 \
2277 -validate all -validatecommand "diffcontextvalidate %P" \
2278 -textvariable diffcontextstring
2279 .bleft.mid.diffcontext set $diffcontext
2280 trace add variable diffcontextstring write diffcontextchange
2281 lappend entries .bleft.mid.diffcontext
2282 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2283 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2284 -command changeignorespace -variable ignorespace
2285 pack .bleft.mid.ignspace -side left -padx 5
2287 set worddiff [mc "Line diff"]
2288 if {[package vcompare $git_version "1.7.2"] >= 0} {
2289 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2290 [mc "Markup words"] [mc "Color words"]
2291 trace add variable worddiff write changeworddiff
2292 pack .bleft.mid.worddiff -side left -padx 5
2295 set ctext .bleft.bottom.ctext
2296 text $ctext -background $bgcolor -foreground $fgcolor \
2297 -state disabled -font textfont \
2298 -yscrollcommand scrolltext -wrap none \
2299 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2300 if {$have_tk85} {
2301 $ctext conf -tabstyle wordprocessor
2303 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2304 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2305 pack .bleft.top -side top -fill x
2306 pack .bleft.mid -side top -fill x
2307 grid $ctext .bleft.bottom.sb -sticky nsew
2308 grid .bleft.bottom.sbhorizontal -sticky ew
2309 grid columnconfigure .bleft.bottom 0 -weight 1
2310 grid rowconfigure .bleft.bottom 0 -weight 1
2311 grid rowconfigure .bleft.bottom 1 -weight 0
2312 pack .bleft.bottom -side top -fill both -expand 1
2313 lappend bglist $ctext
2314 lappend fglist $ctext
2316 $ctext tag conf comment -wrap $wrapcomment
2317 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2318 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2319 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2320 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2321 $ctext tag conf m0 -fore red
2322 $ctext tag conf m1 -fore blue
2323 $ctext tag conf m2 -fore green
2324 $ctext tag conf m3 -fore purple
2325 $ctext tag conf m4 -fore brown
2326 $ctext tag conf m5 -fore "#009090"
2327 $ctext tag conf m6 -fore magenta
2328 $ctext tag conf m7 -fore "#808000"
2329 $ctext tag conf m8 -fore "#009000"
2330 $ctext tag conf m9 -fore "#ff0080"
2331 $ctext tag conf m10 -fore cyan
2332 $ctext tag conf m11 -fore "#b07070"
2333 $ctext tag conf m12 -fore "#70b0f0"
2334 $ctext tag conf m13 -fore "#70f0b0"
2335 $ctext tag conf m14 -fore "#f0b070"
2336 $ctext tag conf m15 -fore "#ff70b0"
2337 $ctext tag conf mmax -fore darkgrey
2338 set mergemax 16
2339 $ctext tag conf mresult -font textfontbold
2340 $ctext tag conf msep -font textfontbold
2341 $ctext tag conf found -back yellow
2343 .pwbottom add .bleft
2344 if {!$use_ttk} {
2345 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2348 # lower right
2349 ${NS}::frame .bright
2350 ${NS}::frame .bright.mode
2351 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2352 -command reselectline -variable cmitmode -value "patch"
2353 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2354 -command reselectline -variable cmitmode -value "tree"
2355 grid .bright.mode.patch .bright.mode.tree -sticky ew
2356 pack .bright.mode -side top -fill x
2357 set cflist .bright.cfiles
2358 set indent [font measure mainfont "nn"]
2359 text $cflist \
2360 -selectbackground $selectbgcolor \
2361 -background $bgcolor -foreground $fgcolor \
2362 -font mainfont \
2363 -tabs [list $indent [expr {2 * $indent}]] \
2364 -yscrollcommand ".bright.sb set" \
2365 -cursor [. cget -cursor] \
2366 -spacing1 1 -spacing3 1
2367 lappend bglist $cflist
2368 lappend fglist $cflist
2369 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2370 pack .bright.sb -side right -fill y
2371 pack $cflist -side left -fill both -expand 1
2372 $cflist tag configure highlight \
2373 -background [$cflist cget -selectbackground]
2374 $cflist tag configure bold -font mainfontbold
2376 .pwbottom add .bright
2377 .ctop add .pwbottom
2379 # restore window width & height if known
2380 if {[info exists geometry(main)]} {
2381 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2382 if {$w > [winfo screenwidth .]} {
2383 set w [winfo screenwidth .]
2385 if {$h > [winfo screenheight .]} {
2386 set h [winfo screenheight .]
2388 wm geometry . "${w}x$h"
2392 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2393 wm state . $geometry(state)
2396 if {[tk windowingsystem] eq {aqua}} {
2397 set M1B M1
2398 set ::BM "3"
2399 } else {
2400 set M1B Control
2401 set ::BM "2"
2404 if {$use_ttk} {
2405 bind .ctop <Map> {
2406 bind %W <Map> {}
2407 %W sashpos 0 $::geometry(topheight)
2409 bind .pwbottom <Map> {
2410 bind %W <Map> {}
2411 %W sashpos 0 $::geometry(botwidth)
2415 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2416 pack .ctop -fill both -expand 1
2417 bindall <1> {selcanvline %W %x %y}
2418 #bindall <B1-Motion> {selcanvline %W %x %y}
2419 if {[tk windowingsystem] == "win32"} {
2420 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2421 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2422 } else {
2423 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2424 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2425 if {[tk windowingsystem] eq "aqua"} {
2426 bindall <MouseWheel> {
2427 set delta [expr {- (%D)}]
2428 allcanvs yview scroll $delta units
2430 bindall <Shift-MouseWheel> {
2431 set delta [expr {- (%D)}]
2432 $canv xview scroll $delta units
2436 bindall <$::BM> "canvscan mark %W %x %y"
2437 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2438 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2439 bind . <$M1B-Key-w> doquit
2440 bindkey <Home> selfirstline
2441 bindkey <End> sellastline
2442 bind . <Key-Up> "selnextline -1"
2443 bind . <Key-Down> "selnextline 1"
2444 bind . <Shift-Key-Up> "dofind -1 0"
2445 bind . <Shift-Key-Down> "dofind 1 0"
2446 bindkey <Key-Right> "goforw"
2447 bindkey <Key-Left> "goback"
2448 bind . <Key-Prior> "selnextpage -1"
2449 bind . <Key-Next> "selnextpage 1"
2450 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2451 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2452 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2453 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2454 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2455 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2456 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2457 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2458 bindkey <Key-space> "$ctext yview scroll 1 pages"
2459 bindkey p "selnextline -1"
2460 bindkey n "selnextline 1"
2461 bindkey z "goback"
2462 bindkey x "goforw"
2463 bindkey k "selnextline -1"
2464 bindkey j "selnextline 1"
2465 bindkey h "goback"
2466 bindkey l "goforw"
2467 bindkey b prevfile
2468 bindkey d "$ctext yview scroll 18 units"
2469 bindkey u "$ctext yview scroll -18 units"
2470 bindkey / {focus $fstring}
2471 bindkey <Key-KP_Divide> {focus $fstring}
2472 bindkey <Key-Return> {dofind 1 1}
2473 bindkey ? {dofind -1 1}
2474 bindkey f nextfile
2475 bind . <F5> updatecommits
2476 bind . <$M1B-F5> reloadcommits
2477 bind . <F2> showrefs
2478 bind . <Shift-F4> {newview 0}
2479 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2480 bind . <F4> edit_or_newview
2481 bind . <$M1B-q> doquit
2482 bind . <$M1B-f> {dofind 1 1}
2483 bind . <$M1B-g> {dofind 1 0}
2484 bind . <$M1B-r> dosearchback
2485 bind . <$M1B-s> dosearch
2486 bind . <$M1B-equal> {incrfont 1}
2487 bind . <$M1B-plus> {incrfont 1}
2488 bind . <$M1B-KP_Add> {incrfont 1}
2489 bind . <$M1B-minus> {incrfont -1}
2490 bind . <$M1B-KP_Subtract> {incrfont -1}
2491 wm protocol . WM_DELETE_WINDOW doquit
2492 bind . <Destroy> {stop_backends}
2493 bind . <Button-1> "click %W"
2494 bind $fstring <Key-Return> {dofind 1 1}
2495 bind $sha1entry <Key-Return> {gotocommit; break}
2496 bind $sha1entry <<PasteSelection>> clearsha1
2497 bind $cflist <1> {sel_flist %W %x %y; break}
2498 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2499 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2500 global ctxbut
2501 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2502 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2503 bind $ctext <Button-1> {focus %W}
2505 set maincursor [. cget -cursor]
2506 set textcursor [$ctext cget -cursor]
2507 set curtextcursor $textcursor
2509 set rowctxmenu .rowctxmenu
2510 makemenu $rowctxmenu {
2511 {mc "Diff this -> selected" command {diffvssel 0}}
2512 {mc "Diff selected -> this" command {diffvssel 1}}
2513 {mc "Make patch" command mkpatch}
2514 {mc "Create tag" command mktag}
2515 {mc "Write commit to file" command writecommit}
2516 {mc "Create new branch" command mkbranch}
2517 {mc "Cherry-pick this commit" command cherrypick}
2518 {mc "Reset HEAD branch to here" command resethead}
2519 {mc "Mark this commit" command markhere}
2520 {mc "Return to mark" command gotomark}
2521 {mc "Find descendant of this and mark" command find_common_desc}
2522 {mc "Compare with marked commit" command compare_commits}
2524 $rowctxmenu configure -tearoff 0
2526 set fakerowmenu .fakerowmenu
2527 makemenu $fakerowmenu {
2528 {mc "Diff this -> selected" command {diffvssel 0}}
2529 {mc "Diff selected -> this" command {diffvssel 1}}
2530 {mc "Make patch" command mkpatch}
2532 $fakerowmenu configure -tearoff 0
2534 set headctxmenu .headctxmenu
2535 makemenu $headctxmenu {
2536 {mc "Check out this branch" command cobranch}
2537 {mc "Remove this branch" command rmbranch}
2539 $headctxmenu configure -tearoff 0
2541 global flist_menu
2542 set flist_menu .flistctxmenu
2543 makemenu $flist_menu {
2544 {mc "Highlight this too" command {flist_hl 0}}
2545 {mc "Highlight this only" command {flist_hl 1}}
2546 {mc "External diff" command {external_diff}}
2547 {mc "Blame parent commit" command {external_blame 1}}
2549 $flist_menu configure -tearoff 0
2551 global diff_menu
2552 set diff_menu .diffctxmenu
2553 makemenu $diff_menu {
2554 {mc "Show origin of this line" command show_line_source}
2555 {mc "Run git gui blame on this line" command {external_blame_diff}}
2557 $diff_menu configure -tearoff 0
2560 # Windows sends all mouse wheel events to the current focused window, not
2561 # the one where the mouse hovers, so bind those events here and redirect
2562 # to the correct window
2563 proc windows_mousewheel_redirector {W X Y D} {
2564 global canv canv2 canv3
2565 set w [winfo containing -displayof $W $X $Y]
2566 if {$w ne ""} {
2567 set u [expr {$D < 0 ? 5 : -5}]
2568 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2569 allcanvs yview scroll $u units
2570 } else {
2571 catch {
2572 $w yview scroll $u units
2578 # Update row number label when selectedline changes
2579 proc selectedline_change {n1 n2 op} {
2580 global selectedline rownumsel
2582 if {$selectedline eq {}} {
2583 set rownumsel {}
2584 } else {
2585 set rownumsel [expr {$selectedline + 1}]
2589 # mouse-2 makes all windows scan vertically, but only the one
2590 # the cursor is in scans horizontally
2591 proc canvscan {op w x y} {
2592 global canv canv2 canv3
2593 foreach c [list $canv $canv2 $canv3] {
2594 if {$c == $w} {
2595 $c scan $op $x $y
2596 } else {
2597 $c scan $op 0 $y
2602 proc scrollcanv {cscroll f0 f1} {
2603 $cscroll set $f0 $f1
2604 drawvisible
2605 flushhighlights
2608 # when we make a key binding for the toplevel, make sure
2609 # it doesn't get triggered when that key is pressed in the
2610 # find string entry widget.
2611 proc bindkey {ev script} {
2612 global entries
2613 bind . $ev $script
2614 set escript [bind Entry $ev]
2615 if {$escript == {}} {
2616 set escript [bind Entry <Key>]
2618 foreach e $entries {
2619 bind $e $ev "$escript; break"
2623 # set the focus back to the toplevel for any click outside
2624 # the entry widgets
2625 proc click {w} {
2626 global ctext entries
2627 foreach e [concat $entries $ctext] {
2628 if {$w == $e} return
2630 focus .
2633 # Adjust the progress bar for a change in requested extent or canvas size
2634 proc adjustprogress {} {
2635 global progresscanv progressitem progresscoords
2636 global fprogitem fprogcoord lastprogupdate progupdatepending
2637 global rprogitem rprogcoord use_ttk
2639 if {$use_ttk} {
2640 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2641 return
2644 set w [expr {[winfo width $progresscanv] - 4}]
2645 set x0 [expr {$w * [lindex $progresscoords 0]}]
2646 set x1 [expr {$w * [lindex $progresscoords 1]}]
2647 set h [winfo height $progresscanv]
2648 $progresscanv coords $progressitem $x0 0 $x1 $h
2649 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2650 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2651 set now [clock clicks -milliseconds]
2652 if {$now >= $lastprogupdate + 100} {
2653 set progupdatepending 0
2654 update
2655 } elseif {!$progupdatepending} {
2656 set progupdatepending 1
2657 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2661 proc doprogupdate {} {
2662 global lastprogupdate progupdatepending
2664 if {$progupdatepending} {
2665 set progupdatepending 0
2666 set lastprogupdate [clock clicks -milliseconds]
2667 update
2671 proc savestuff {w} {
2672 global canv canv2 canv3 mainfont textfont uifont tabstop
2673 global stuffsaved findmergefiles maxgraphpct
2674 global maxwidth showneartags showlocalchanges
2675 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2676 global cmitmode wrapcomment datetimeformat limitdiffs
2677 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2678 global autoselect autosellen extdifftool perfile_attrs markbgcolor use_ttk
2679 global hideremotes want_ttk
2681 if {$stuffsaved} return
2682 if {![winfo viewable .]} return
2683 catch {
2684 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2685 set f [open "~/.gitk-new" w]
2686 if {$::tcl_platform(platform) eq {windows}} {
2687 file attributes "~/.gitk-new" -hidden true
2689 puts $f [list set mainfont $mainfont]
2690 puts $f [list set textfont $textfont]
2691 puts $f [list set uifont $uifont]
2692 puts $f [list set tabstop $tabstop]
2693 puts $f [list set findmergefiles $findmergefiles]
2694 puts $f [list set maxgraphpct $maxgraphpct]
2695 puts $f [list set maxwidth $maxwidth]
2696 puts $f [list set cmitmode $cmitmode]
2697 puts $f [list set wrapcomment $wrapcomment]
2698 puts $f [list set autoselect $autoselect]
2699 puts $f [list set autosellen $autosellen]
2700 puts $f [list set showneartags $showneartags]
2701 puts $f [list set hideremotes $hideremotes]
2702 puts $f [list set showlocalchanges $showlocalchanges]
2703 puts $f [list set datetimeformat $datetimeformat]
2704 puts $f [list set limitdiffs $limitdiffs]
2705 puts $f [list set uicolor $uicolor]
2706 puts $f [list set want_ttk $want_ttk]
2707 puts $f [list set bgcolor $bgcolor]
2708 puts $f [list set fgcolor $fgcolor]
2709 puts $f [list set colors $colors]
2710 puts $f [list set diffcolors $diffcolors]
2711 puts $f [list set markbgcolor $markbgcolor]
2712 puts $f [list set diffcontext $diffcontext]
2713 puts $f [list set selectbgcolor $selectbgcolor]
2714 puts $f [list set extdifftool $extdifftool]
2715 puts $f [list set perfile_attrs $perfile_attrs]
2717 puts $f "set geometry(main) [wm geometry .]"
2718 puts $f "set geometry(state) [wm state .]"
2719 puts $f "set geometry(topwidth) [winfo width .tf]"
2720 puts $f "set geometry(topheight) [winfo height .tf]"
2721 if {$use_ttk} {
2722 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2723 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2724 } else {
2725 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2726 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2728 puts $f "set geometry(botwidth) [winfo width .bleft]"
2729 puts $f "set geometry(botheight) [winfo height .bleft]"
2731 puts -nonewline $f "set permviews {"
2732 for {set v 0} {$v < $nextviewnum} {incr v} {
2733 if {$viewperm($v)} {
2734 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2737 puts $f "}"
2738 close $f
2739 file rename -force "~/.gitk-new" "~/.gitk"
2741 set stuffsaved 1
2744 proc resizeclistpanes {win w} {
2745 global oldwidth use_ttk
2746 if {[info exists oldwidth($win)]} {
2747 if {$use_ttk} {
2748 set s0 [$win sashpos 0]
2749 set s1 [$win sashpos 1]
2750 } else {
2751 set s0 [$win sash coord 0]
2752 set s1 [$win sash coord 1]
2754 if {$w < 60} {
2755 set sash0 [expr {int($w/2 - 2)}]
2756 set sash1 [expr {int($w*5/6 - 2)}]
2757 } else {
2758 set factor [expr {1.0 * $w / $oldwidth($win)}]
2759 set sash0 [expr {int($factor * [lindex $s0 0])}]
2760 set sash1 [expr {int($factor * [lindex $s1 0])}]
2761 if {$sash0 < 30} {
2762 set sash0 30
2764 if {$sash1 < $sash0 + 20} {
2765 set sash1 [expr {$sash0 + 20}]
2767 if {$sash1 > $w - 10} {
2768 set sash1 [expr {$w - 10}]
2769 if {$sash0 > $sash1 - 20} {
2770 set sash0 [expr {$sash1 - 20}]
2774 if {$use_ttk} {
2775 $win sashpos 0 $sash0
2776 $win sashpos 1 $sash1
2777 } else {
2778 $win sash place 0 $sash0 [lindex $s0 1]
2779 $win sash place 1 $sash1 [lindex $s1 1]
2782 set oldwidth($win) $w
2785 proc resizecdetpanes {win w} {
2786 global oldwidth use_ttk
2787 if {[info exists oldwidth($win)]} {
2788 if {$use_ttk} {
2789 set s0 [$win sashpos 0]
2790 } else {
2791 set s0 [$win sash coord 0]
2793 if {$w < 60} {
2794 set sash0 [expr {int($w*3/4 - 2)}]
2795 } else {
2796 set factor [expr {1.0 * $w / $oldwidth($win)}]
2797 set sash0 [expr {int($factor * [lindex $s0 0])}]
2798 if {$sash0 < 45} {
2799 set sash0 45
2801 if {$sash0 > $w - 15} {
2802 set sash0 [expr {$w - 15}]
2805 if {$use_ttk} {
2806 $win sashpos 0 $sash0
2807 } else {
2808 $win sash place 0 $sash0 [lindex $s0 1]
2811 set oldwidth($win) $w
2814 proc allcanvs args {
2815 global canv canv2 canv3
2816 eval $canv $args
2817 eval $canv2 $args
2818 eval $canv3 $args
2821 proc bindall {event action} {
2822 global canv canv2 canv3
2823 bind $canv $event $action
2824 bind $canv2 $event $action
2825 bind $canv3 $event $action
2828 proc about {} {
2829 global uifont NS
2830 set w .about
2831 if {[winfo exists $w]} {
2832 raise $w
2833 return
2835 ttk_toplevel $w
2836 wm title $w [mc "About gitk"]
2837 make_transient $w .
2838 message $w.m -text [mc "
2839 Gitk - a commit viewer for git
2841 Copyright \u00a9 2005-2011 Paul Mackerras
2843 Use and redistribute under the terms of the GNU General Public License"] \
2844 -justify center -aspect 400 -border 2 -bg white -relief groove
2845 pack $w.m -side top -fill x -padx 2 -pady 2
2846 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2847 pack $w.ok -side bottom
2848 bind $w <Visibility> "focus $w.ok"
2849 bind $w <Key-Escape> "destroy $w"
2850 bind $w <Key-Return> "destroy $w"
2851 tk::PlaceWindow $w widget .
2854 proc keys {} {
2855 global NS
2856 set w .keys
2857 if {[winfo exists $w]} {
2858 raise $w
2859 return
2861 if {[tk windowingsystem] eq {aqua}} {
2862 set M1T Cmd
2863 } else {
2864 set M1T Ctrl
2866 ttk_toplevel $w
2867 wm title $w [mc "Gitk key bindings"]
2868 make_transient $w .
2869 message $w.m -text "
2870 [mc "Gitk key bindings:"]
2872 [mc "<%s-Q> Quit" $M1T]
2873 [mc "<%s-W> Close window" $M1T]
2874 [mc "<Home> Move to first commit"]
2875 [mc "<End> Move to last commit"]
2876 [mc "<Up>, p, k Move up one commit"]
2877 [mc "<Down>, n, j Move down one commit"]
2878 [mc "<Left>, z, h Go back in history list"]
2879 [mc "<Right>, x, l Go forward in history list"]
2880 [mc "<PageUp> Move up one page in commit list"]
2881 [mc "<PageDown> Move down one page in commit list"]
2882 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2883 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2884 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2885 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2886 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2887 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2888 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2889 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2890 [mc "<Delete>, b Scroll diff view up one page"]
2891 [mc "<Backspace> Scroll diff view up one page"]
2892 [mc "<Space> Scroll diff view down one page"]
2893 [mc "u Scroll diff view up 18 lines"]
2894 [mc "d Scroll diff view down 18 lines"]
2895 [mc "<%s-F> Find" $M1T]
2896 [mc "<%s-G> Move to next find hit" $M1T]
2897 [mc "<Return> Move to next find hit"]
2898 [mc "/ Focus the search box"]
2899 [mc "? Move to previous find hit"]
2900 [mc "f Scroll diff view to next file"]
2901 [mc "<%s-S> Search for next hit in diff view" $M1T]
2902 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2903 [mc "<%s-KP+> Increase font size" $M1T]
2904 [mc "<%s-plus> Increase font size" $M1T]
2905 [mc "<%s-KP-> Decrease font size" $M1T]
2906 [mc "<%s-minus> Decrease font size" $M1T]
2907 [mc "<F5> Update"]
2909 -justify left -bg white -border 2 -relief groove
2910 pack $w.m -side top -fill both -padx 2 -pady 2
2911 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2912 bind $w <Key-Escape> [list destroy $w]
2913 pack $w.ok -side bottom
2914 bind $w <Visibility> "focus $w.ok"
2915 bind $w <Key-Escape> "destroy $w"
2916 bind $w <Key-Return> "destroy $w"
2919 # Procedures for manipulating the file list window at the
2920 # bottom right of the overall window.
2922 proc treeview {w l openlevs} {
2923 global treecontents treediropen treeheight treeparent treeindex
2925 set ix 0
2926 set treeindex() 0
2927 set lev 0
2928 set prefix {}
2929 set prefixend -1
2930 set prefendstack {}
2931 set htstack {}
2932 set ht 0
2933 set treecontents() {}
2934 $w conf -state normal
2935 foreach f $l {
2936 while {[string range $f 0 $prefixend] ne $prefix} {
2937 if {$lev <= $openlevs} {
2938 $w mark set e:$treeindex($prefix) "end -1c"
2939 $w mark gravity e:$treeindex($prefix) left
2941 set treeheight($prefix) $ht
2942 incr ht [lindex $htstack end]
2943 set htstack [lreplace $htstack end end]
2944 set prefixend [lindex $prefendstack end]
2945 set prefendstack [lreplace $prefendstack end end]
2946 set prefix [string range $prefix 0 $prefixend]
2947 incr lev -1
2949 set tail [string range $f [expr {$prefixend+1}] end]
2950 while {[set slash [string first "/" $tail]] >= 0} {
2951 lappend htstack $ht
2952 set ht 0
2953 lappend prefendstack $prefixend
2954 incr prefixend [expr {$slash + 1}]
2955 set d [string range $tail 0 $slash]
2956 lappend treecontents($prefix) $d
2957 set oldprefix $prefix
2958 append prefix $d
2959 set treecontents($prefix) {}
2960 set treeindex($prefix) [incr ix]
2961 set treeparent($prefix) $oldprefix
2962 set tail [string range $tail [expr {$slash+1}] end]
2963 if {$lev <= $openlevs} {
2964 set ht 1
2965 set treediropen($prefix) [expr {$lev < $openlevs}]
2966 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2967 $w mark set d:$ix "end -1c"
2968 $w mark gravity d:$ix left
2969 set str "\n"
2970 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2971 $w insert end $str
2972 $w image create end -align center -image $bm -padx 1 \
2973 -name a:$ix
2974 $w insert end $d [highlight_tag $prefix]
2975 $w mark set s:$ix "end -1c"
2976 $w mark gravity s:$ix left
2978 incr lev
2980 if {$tail ne {}} {
2981 if {$lev <= $openlevs} {
2982 incr ht
2983 set str "\n"
2984 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2985 $w insert end $str
2986 $w insert end $tail [highlight_tag $f]
2988 lappend treecontents($prefix) $tail
2991 while {$htstack ne {}} {
2992 set treeheight($prefix) $ht
2993 incr ht [lindex $htstack end]
2994 set htstack [lreplace $htstack end end]
2995 set prefixend [lindex $prefendstack end]
2996 set prefendstack [lreplace $prefendstack end end]
2997 set prefix [string range $prefix 0 $prefixend]
2999 $w conf -state disabled
3002 proc linetoelt {l} {
3003 global treeheight treecontents
3005 set y 2
3006 set prefix {}
3007 while {1} {
3008 foreach e $treecontents($prefix) {
3009 if {$y == $l} {
3010 return "$prefix$e"
3012 set n 1
3013 if {[string index $e end] eq "/"} {
3014 set n $treeheight($prefix$e)
3015 if {$y + $n > $l} {
3016 append prefix $e
3017 incr y
3018 break
3021 incr y $n
3026 proc highlight_tree {y prefix} {
3027 global treeheight treecontents cflist
3029 foreach e $treecontents($prefix) {
3030 set path $prefix$e
3031 if {[highlight_tag $path] ne {}} {
3032 $cflist tag add bold $y.0 "$y.0 lineend"
3034 incr y
3035 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3036 set y [highlight_tree $y $path]
3039 return $y
3042 proc treeclosedir {w dir} {
3043 global treediropen treeheight treeparent treeindex
3045 set ix $treeindex($dir)
3046 $w conf -state normal
3047 $w delete s:$ix e:$ix
3048 set treediropen($dir) 0
3049 $w image configure a:$ix -image tri-rt
3050 $w conf -state disabled
3051 set n [expr {1 - $treeheight($dir)}]
3052 while {$dir ne {}} {
3053 incr treeheight($dir) $n
3054 set dir $treeparent($dir)
3058 proc treeopendir {w dir} {
3059 global treediropen treeheight treeparent treecontents treeindex
3061 set ix $treeindex($dir)
3062 $w conf -state normal
3063 $w image configure a:$ix -image tri-dn
3064 $w mark set e:$ix s:$ix
3065 $w mark gravity e:$ix right
3066 set lev 0
3067 set str "\n"
3068 set n [llength $treecontents($dir)]
3069 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3070 incr lev
3071 append str "\t"
3072 incr treeheight($x) $n
3074 foreach e $treecontents($dir) {
3075 set de $dir$e
3076 if {[string index $e end] eq "/"} {
3077 set iy $treeindex($de)
3078 $w mark set d:$iy e:$ix
3079 $w mark gravity d:$iy left
3080 $w insert e:$ix $str
3081 set treediropen($de) 0
3082 $w image create e:$ix -align center -image tri-rt -padx 1 \
3083 -name a:$iy
3084 $w insert e:$ix $e [highlight_tag $de]
3085 $w mark set s:$iy e:$ix
3086 $w mark gravity s:$iy left
3087 set treeheight($de) 1
3088 } else {
3089 $w insert e:$ix $str
3090 $w insert e:$ix $e [highlight_tag $de]
3093 $w mark gravity e:$ix right
3094 $w conf -state disabled
3095 set treediropen($dir) 1
3096 set top [lindex [split [$w index @0,0] .] 0]
3097 set ht [$w cget -height]
3098 set l [lindex [split [$w index s:$ix] .] 0]
3099 if {$l < $top} {
3100 $w yview $l.0
3101 } elseif {$l + $n + 1 > $top + $ht} {
3102 set top [expr {$l + $n + 2 - $ht}]
3103 if {$l < $top} {
3104 set top $l
3106 $w yview $top.0
3110 proc treeclick {w x y} {
3111 global treediropen cmitmode ctext cflist cflist_top
3113 if {$cmitmode ne "tree"} return
3114 if {![info exists cflist_top]} return
3115 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3116 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3117 $cflist tag add highlight $l.0 "$l.0 lineend"
3118 set cflist_top $l
3119 if {$l == 1} {
3120 $ctext yview 1.0
3121 return
3123 set e [linetoelt $l]
3124 if {[string index $e end] ne "/"} {
3125 showfile $e
3126 } elseif {$treediropen($e)} {
3127 treeclosedir $w $e
3128 } else {
3129 treeopendir $w $e
3133 proc setfilelist {id} {
3134 global treefilelist cflist jump_to_here
3136 treeview $cflist $treefilelist($id) 0
3137 if {$jump_to_here ne {}} {
3138 set f [lindex $jump_to_here 0]
3139 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3140 showfile $f
3145 image create bitmap tri-rt -background black -foreground blue -data {
3146 #define tri-rt_width 13
3147 #define tri-rt_height 13
3148 static unsigned char tri-rt_bits[] = {
3149 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3150 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3151 0x00, 0x00};
3152 } -maskdata {
3153 #define tri-rt-mask_width 13
3154 #define tri-rt-mask_height 13
3155 static unsigned char tri-rt-mask_bits[] = {
3156 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3157 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3158 0x08, 0x00};
3160 image create bitmap tri-dn -background black -foreground blue -data {
3161 #define tri-dn_width 13
3162 #define tri-dn_height 13
3163 static unsigned char tri-dn_bits[] = {
3164 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3165 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3166 0x00, 0x00};
3167 } -maskdata {
3168 #define tri-dn-mask_width 13
3169 #define tri-dn-mask_height 13
3170 static unsigned char tri-dn-mask_bits[] = {
3171 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3172 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3173 0x00, 0x00};
3176 image create bitmap reficon-T -background black -foreground yellow -data {
3177 #define tagicon_width 13
3178 #define tagicon_height 9
3179 static unsigned char tagicon_bits[] = {
3180 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3181 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3182 } -maskdata {
3183 #define tagicon-mask_width 13
3184 #define tagicon-mask_height 9
3185 static unsigned char tagicon-mask_bits[] = {
3186 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3187 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3189 set rectdata {
3190 #define headicon_width 13
3191 #define headicon_height 9
3192 static unsigned char headicon_bits[] = {
3193 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3194 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3196 set rectmask {
3197 #define headicon-mask_width 13
3198 #define headicon-mask_height 9
3199 static unsigned char headicon-mask_bits[] = {
3200 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3201 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3203 image create bitmap reficon-H -background black -foreground green \
3204 -data $rectdata -maskdata $rectmask
3205 image create bitmap reficon-o -background black -foreground "#ddddff" \
3206 -data $rectdata -maskdata $rectmask
3208 proc init_flist {first} {
3209 global cflist cflist_top difffilestart
3211 $cflist conf -state normal
3212 $cflist delete 0.0 end
3213 if {$first ne {}} {
3214 $cflist insert end $first
3215 set cflist_top 1
3216 $cflist tag add highlight 1.0 "1.0 lineend"
3217 } else {
3218 catch {unset cflist_top}
3220 $cflist conf -state disabled
3221 set difffilestart {}
3224 proc highlight_tag {f} {
3225 global highlight_paths
3227 foreach p $highlight_paths {
3228 if {[string match $p $f]} {
3229 return "bold"
3232 return {}
3235 proc highlight_filelist {} {
3236 global cmitmode cflist
3238 $cflist conf -state normal
3239 if {$cmitmode ne "tree"} {
3240 set end [lindex [split [$cflist index end] .] 0]
3241 for {set l 2} {$l < $end} {incr l} {
3242 set line [$cflist get $l.0 "$l.0 lineend"]
3243 if {[highlight_tag $line] ne {}} {
3244 $cflist tag add bold $l.0 "$l.0 lineend"
3247 } else {
3248 highlight_tree 2 {}
3250 $cflist conf -state disabled
3253 proc unhighlight_filelist {} {
3254 global cflist
3256 $cflist conf -state normal
3257 $cflist tag remove bold 1.0 end
3258 $cflist conf -state disabled
3261 proc add_flist {fl} {
3262 global cflist
3264 $cflist conf -state normal
3265 foreach f $fl {
3266 $cflist insert end "\n"
3267 $cflist insert end $f [highlight_tag $f]
3269 $cflist conf -state disabled
3272 proc sel_flist {w x y} {
3273 global ctext difffilestart cflist cflist_top cmitmode
3275 if {$cmitmode eq "tree"} return
3276 if {![info exists cflist_top]} return
3277 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3278 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3279 $cflist tag add highlight $l.0 "$l.0 lineend"
3280 set cflist_top $l
3281 if {$l == 1} {
3282 $ctext yview 1.0
3283 } else {
3284 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3288 proc pop_flist_menu {w X Y x y} {
3289 global ctext cflist cmitmode flist_menu flist_menu_file
3290 global treediffs diffids
3292 stopfinding
3293 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3294 if {$l <= 1} return
3295 if {$cmitmode eq "tree"} {
3296 set e [linetoelt $l]
3297 if {[string index $e end] eq "/"} return
3298 } else {
3299 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3301 set flist_menu_file $e
3302 set xdiffstate "normal"
3303 if {$cmitmode eq "tree"} {
3304 set xdiffstate "disabled"
3306 # Disable "External diff" item in tree mode
3307 $flist_menu entryconf 2 -state $xdiffstate
3308 tk_popup $flist_menu $X $Y
3311 proc find_ctext_fileinfo {line} {
3312 global ctext_file_names ctext_file_lines
3314 set ok [bsearch $ctext_file_lines $line]
3315 set tline [lindex $ctext_file_lines $ok]
3317 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3318 return {}
3319 } else {
3320 return [list [lindex $ctext_file_names $ok] $tline]
3324 proc pop_diff_menu {w X Y x y} {
3325 global ctext diff_menu flist_menu_file
3326 global diff_menu_txtpos diff_menu_line
3327 global diff_menu_filebase
3329 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3330 set diff_menu_line [lindex $diff_menu_txtpos 0]
3331 # don't pop up the menu on hunk-separator or file-separator lines
3332 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3333 return
3335 stopfinding
3336 set f [find_ctext_fileinfo $diff_menu_line]
3337 if {$f eq {}} return
3338 set flist_menu_file [lindex $f 0]
3339 set diff_menu_filebase [lindex $f 1]
3340 tk_popup $diff_menu $X $Y
3343 proc flist_hl {only} {
3344 global flist_menu_file findstring gdttype
3346 set x [shellquote $flist_menu_file]
3347 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3348 set findstring $x
3349 } else {
3350 append findstring " " $x
3352 set gdttype [mc "touching paths:"]
3355 proc gitknewtmpdir {} {
3356 global diffnum gitktmpdir gitdir
3358 if {![info exists gitktmpdir]} {
3359 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3360 if {[catch {file mkdir $gitktmpdir} err]} {
3361 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3362 unset gitktmpdir
3363 return {}
3365 set diffnum 0
3367 incr diffnum
3368 set diffdir [file join $gitktmpdir $diffnum]
3369 if {[catch {file mkdir $diffdir} err]} {
3370 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3371 return {}
3373 return $diffdir
3376 proc save_file_from_commit {filename output what} {
3377 global nullfile
3379 if {[catch {exec git show $filename -- > $output} err]} {
3380 if {[string match "fatal: bad revision *" $err]} {
3381 return $nullfile
3383 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3384 return {}
3386 return $output
3389 proc external_diff_get_one_file {diffid filename diffdir} {
3390 global nullid nullid2 nullfile
3391 global worktree
3393 if {$diffid == $nullid} {
3394 set difffile [file join $worktree $filename]
3395 if {[file exists $difffile]} {
3396 return $difffile
3398 return $nullfile
3400 if {$diffid == $nullid2} {
3401 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3402 return [save_file_from_commit :$filename $difffile index]
3404 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3405 return [save_file_from_commit $diffid:$filename $difffile \
3406 "revision $diffid"]
3409 proc external_diff {} {
3410 global nullid nullid2
3411 global flist_menu_file
3412 global diffids
3413 global extdifftool
3415 if {[llength $diffids] == 1} {
3416 # no reference commit given
3417 set diffidto [lindex $diffids 0]
3418 if {$diffidto eq $nullid} {
3419 # diffing working copy with index
3420 set diffidfrom $nullid2
3421 } elseif {$diffidto eq $nullid2} {
3422 # diffing index with HEAD
3423 set diffidfrom "HEAD"
3424 } else {
3425 # use first parent commit
3426 global parentlist selectedline
3427 set diffidfrom [lindex $parentlist $selectedline 0]
3429 } else {
3430 set diffidfrom [lindex $diffids 0]
3431 set diffidto [lindex $diffids 1]
3434 # make sure that several diffs wont collide
3435 set diffdir [gitknewtmpdir]
3436 if {$diffdir eq {}} return
3438 # gather files to diff
3439 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3440 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3442 if {$difffromfile ne {} && $difftofile ne {}} {
3443 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3444 if {[catch {set fl [open |$cmd r]} err]} {
3445 file delete -force $diffdir
3446 error_popup "$extdifftool: [mc "command failed:"] $err"
3447 } else {
3448 fconfigure $fl -blocking 0
3449 filerun $fl [list delete_at_eof $fl $diffdir]
3454 proc find_hunk_blamespec {base line} {
3455 global ctext
3457 # Find and parse the hunk header
3458 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3459 if {$s_lix eq {}} return
3461 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3462 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3463 s_line old_specs osz osz1 new_line nsz]} {
3464 return
3467 # base lines for the parents
3468 set base_lines [list $new_line]
3469 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3470 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3471 old_spec old_line osz]} {
3472 return
3474 lappend base_lines $old_line
3477 # Now scan the lines to determine offset within the hunk
3478 set max_parent [expr {[llength $base_lines]-2}]
3479 set dline 0
3480 set s_lno [lindex [split $s_lix "."] 0]
3482 # Determine if the line is removed
3483 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3484 if {[string match {[-+ ]*} $chunk]} {
3485 set removed_idx [string first "-" $chunk]
3486 # Choose a parent index
3487 if {$removed_idx >= 0} {
3488 set parent $removed_idx
3489 } else {
3490 set unchanged_idx [string first " " $chunk]
3491 if {$unchanged_idx >= 0} {
3492 set parent $unchanged_idx
3493 } else {
3494 # blame the current commit
3495 set parent -1
3498 # then count other lines that belong to it
3499 for {set i $line} {[incr i -1] > $s_lno} {} {
3500 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3501 # Determine if the line is removed
3502 set removed_idx [string first "-" $chunk]
3503 if {$parent >= 0} {
3504 set code [string index $chunk $parent]
3505 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3506 incr dline
3508 } else {
3509 if {$removed_idx < 0} {
3510 incr dline
3514 incr parent
3515 } else {
3516 set parent 0
3519 incr dline [lindex $base_lines $parent]
3520 return [list $parent $dline]
3523 proc external_blame_diff {} {
3524 global currentid cmitmode
3525 global diff_menu_txtpos diff_menu_line
3526 global diff_menu_filebase flist_menu_file
3528 if {$cmitmode eq "tree"} {
3529 set parent_idx 0
3530 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3531 } else {
3532 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3533 if {$hinfo ne {}} {
3534 set parent_idx [lindex $hinfo 0]
3535 set line [lindex $hinfo 1]
3536 } else {
3537 set parent_idx 0
3538 set line 0
3542 external_blame $parent_idx $line
3545 # Find the SHA1 ID of the blob for file $fname in the index
3546 # at stage 0 or 2
3547 proc index_sha1 {fname} {
3548 set f [open [list | git ls-files -s $fname] r]
3549 while {[gets $f line] >= 0} {
3550 set info [lindex [split $line "\t"] 0]
3551 set stage [lindex $info 2]
3552 if {$stage eq "0" || $stage eq "2"} {
3553 close $f
3554 return [lindex $info 1]
3557 close $f
3558 return {}
3561 # Turn an absolute path into one relative to the current directory
3562 proc make_relative {f} {
3563 if {[file pathtype $f] eq "relative"} {
3564 return $f
3566 set elts [file split $f]
3567 set here [file split [pwd]]
3568 set ei 0
3569 set hi 0
3570 set res {}
3571 foreach d $here {
3572 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3573 lappend res ".."
3574 } else {
3575 incr ei
3577 incr hi
3579 set elts [concat $res [lrange $elts $ei end]]
3580 return [eval file join $elts]
3583 proc external_blame {parent_idx {line {}}} {
3584 global flist_menu_file cdup
3585 global nullid nullid2
3586 global parentlist selectedline currentid
3588 if {$parent_idx > 0} {
3589 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3590 } else {
3591 set base_commit $currentid
3594 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3595 error_popup [mc "No such commit"]
3596 return
3599 set cmdline [list git gui blame]
3600 if {$line ne {} && $line > 1} {
3601 lappend cmdline "--line=$line"
3603 set f [file join $cdup $flist_menu_file]
3604 # Unfortunately it seems git gui blame doesn't like
3605 # being given an absolute path...
3606 set f [make_relative $f]
3607 lappend cmdline $base_commit $f
3608 if {[catch {eval exec $cmdline &} err]} {
3609 error_popup "[mc "git gui blame: command failed:"] $err"
3613 proc show_line_source {} {
3614 global cmitmode currentid parents curview blamestuff blameinst
3615 global diff_menu_line diff_menu_filebase flist_menu_file
3616 global nullid nullid2 gitdir cdup
3618 set from_index {}
3619 if {$cmitmode eq "tree"} {
3620 set id $currentid
3621 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3622 } else {
3623 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3624 if {$h eq {}} return
3625 set pi [lindex $h 0]
3626 if {$pi == 0} {
3627 mark_ctext_line $diff_menu_line
3628 return
3630 incr pi -1
3631 if {$currentid eq $nullid} {
3632 if {$pi > 0} {
3633 # must be a merge in progress...
3634 if {[catch {
3635 # get the last line from .git/MERGE_HEAD
3636 set f [open [file join $gitdir MERGE_HEAD] r]
3637 set id [lindex [split [read $f] "\n"] end-1]
3638 close $f
3639 } err]} {
3640 error_popup [mc "Couldn't read merge head: %s" $err]
3641 return
3643 } elseif {$parents($curview,$currentid) eq $nullid2} {
3644 # need to do the blame from the index
3645 if {[catch {
3646 set from_index [index_sha1 $flist_menu_file]
3647 } err]} {
3648 error_popup [mc "Error reading index: %s" $err]
3649 return
3651 } else {
3652 set id $parents($curview,$currentid)
3654 } else {
3655 set id [lindex $parents($curview,$currentid) $pi]
3657 set line [lindex $h 1]
3659 set blameargs {}
3660 if {$from_index ne {}} {
3661 lappend blameargs | git cat-file blob $from_index
3663 lappend blameargs | git blame -p -L$line,+1
3664 if {$from_index ne {}} {
3665 lappend blameargs --contents -
3666 } else {
3667 lappend blameargs $id
3669 lappend blameargs -- [file join $cdup $flist_menu_file]
3670 if {[catch {
3671 set f [open $blameargs r]
3672 } err]} {
3673 error_popup [mc "Couldn't start git blame: %s" $err]
3674 return
3676 nowbusy blaming [mc "Searching"]
3677 fconfigure $f -blocking 0
3678 set i [reg_instance $f]
3679 set blamestuff($i) {}
3680 set blameinst $i
3681 filerun $f [list read_line_source $f $i]
3684 proc stopblaming {} {
3685 global blameinst
3687 if {[info exists blameinst]} {
3688 stop_instance $blameinst
3689 unset blameinst
3690 notbusy blaming
3694 proc read_line_source {fd inst} {
3695 global blamestuff curview commfd blameinst nullid nullid2
3697 while {[gets $fd line] >= 0} {
3698 lappend blamestuff($inst) $line
3700 if {![eof $fd]} {
3701 return 1
3703 unset commfd($inst)
3704 unset blameinst
3705 notbusy blaming
3706 fconfigure $fd -blocking 1
3707 if {[catch {close $fd} err]} {
3708 error_popup [mc "Error running git blame: %s" $err]
3709 return 0
3712 set fname {}
3713 set line [split [lindex $blamestuff($inst) 0] " "]
3714 set id [lindex $line 0]
3715 set lnum [lindex $line 1]
3716 if {[string length $id] == 40 && [string is xdigit $id] &&
3717 [string is digit -strict $lnum]} {
3718 # look for "filename" line
3719 foreach l $blamestuff($inst) {
3720 if {[string match "filename *" $l]} {
3721 set fname [string range $l 9 end]
3722 break
3726 if {$fname ne {}} {
3727 # all looks good, select it
3728 if {$id eq $nullid} {
3729 # blame uses all-zeroes to mean not committed,
3730 # which would mean a change in the index
3731 set id $nullid2
3733 if {[commitinview $id $curview]} {
3734 selectline [rowofcommit $id] 1 [list $fname $lnum]
3735 } else {
3736 error_popup [mc "That line comes from commit %s, \
3737 which is not in this view" [shortids $id]]
3739 } else {
3740 puts "oops couldn't parse git blame output"
3742 return 0
3745 # delete $dir when we see eof on $f (presumably because the child has exited)
3746 proc delete_at_eof {f dir} {
3747 while {[gets $f line] >= 0} {}
3748 if {[eof $f]} {
3749 if {[catch {close $f} err]} {
3750 error_popup "[mc "External diff viewer failed:"] $err"
3752 file delete -force $dir
3753 return 0
3755 return 1
3758 # Functions for adding and removing shell-type quoting
3760 proc shellquote {str} {
3761 if {![string match "*\['\"\\ \t]*" $str]} {
3762 return $str
3764 if {![string match "*\['\"\\]*" $str]} {
3765 return "\"$str\""
3767 if {![string match "*'*" $str]} {
3768 return "'$str'"
3770 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3773 proc shellarglist {l} {
3774 set str {}
3775 foreach a $l {
3776 if {$str ne {}} {
3777 append str " "
3779 append str [shellquote $a]
3781 return $str
3784 proc shelldequote {str} {
3785 set ret {}
3786 set used -1
3787 while {1} {
3788 incr used
3789 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3790 append ret [string range $str $used end]
3791 set used [string length $str]
3792 break
3794 set first [lindex $first 0]
3795 set ch [string index $str $first]
3796 if {$first > $used} {
3797 append ret [string range $str $used [expr {$first - 1}]]
3798 set used $first
3800 if {$ch eq " " || $ch eq "\t"} break
3801 incr used
3802 if {$ch eq "'"} {
3803 set first [string first "'" $str $used]
3804 if {$first < 0} {
3805 error "unmatched single-quote"
3807 append ret [string range $str $used [expr {$first - 1}]]
3808 set used $first
3809 continue
3811 if {$ch eq "\\"} {
3812 if {$used >= [string length $str]} {
3813 error "trailing backslash"
3815 append ret [string index $str $used]
3816 continue
3818 # here ch == "\""
3819 while {1} {
3820 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3821 error "unmatched double-quote"
3823 set first [lindex $first 0]
3824 set ch [string index $str $first]
3825 if {$first > $used} {
3826 append ret [string range $str $used [expr {$first - 1}]]
3827 set used $first
3829 if {$ch eq "\""} break
3830 incr used
3831 append ret [string index $str $used]
3832 incr used
3835 return [list $used $ret]
3838 proc shellsplit {str} {
3839 set l {}
3840 while {1} {
3841 set str [string trimleft $str]
3842 if {$str eq {}} break
3843 set dq [shelldequote $str]
3844 set n [lindex $dq 0]
3845 set word [lindex $dq 1]
3846 set str [string range $str $n end]
3847 lappend l $word
3849 return $l
3852 # Code to implement multiple views
3854 proc newview {ishighlight} {
3855 global nextviewnum newviewname newishighlight
3856 global revtreeargs viewargscmd newviewopts curview
3858 set newishighlight $ishighlight
3859 set top .gitkview
3860 if {[winfo exists $top]} {
3861 raise $top
3862 return
3864 decode_view_opts $nextviewnum $revtreeargs
3865 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3866 set newviewopts($nextviewnum,perm) 0
3867 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3868 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3871 set known_view_options {
3872 {perm b . {} {mc "Remember this view"}}
3873 {reflabel l + {} {mc "References (space separated list):"}}
3874 {refs t15 .. {} {mc "Branches & tags:"}}
3875 {allrefs b *. "--all" {mc "All refs"}}
3876 {branches b . "--branches" {mc "All (local) branches"}}
3877 {tags b . "--tags" {mc "All tags"}}
3878 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3879 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3880 {author t15 .. "--author=*" {mc "Author:"}}
3881 {committer t15 . "--committer=*" {mc "Committer:"}}
3882 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3883 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3884 {changes_l l + {} {mc "Changes to Files:"}}
3885 {pickaxe_s r0 . {} {mc "Fixed String"}}
3886 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3887 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3888 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3889 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3890 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3891 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3892 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3893 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3894 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3895 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3896 {lright b . "--left-right" {mc "Mark branch sides"}}
3897 {first b . "--first-parent" {mc "Limit to first parent"}}
3898 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3899 {args t50 *. {} {mc "Additional arguments to git log:"}}
3900 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3901 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3904 # Convert $newviewopts($n, ...) into args for git log.
3905 proc encode_view_opts {n} {
3906 global known_view_options newviewopts
3908 set rargs [list]
3909 foreach opt $known_view_options {
3910 set patterns [lindex $opt 3]
3911 if {$patterns eq {}} continue
3912 set pattern [lindex $patterns 0]
3914 if {[lindex $opt 1] eq "b"} {
3915 set val $newviewopts($n,[lindex $opt 0])
3916 if {$val} {
3917 lappend rargs $pattern
3919 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3920 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3921 set val $newviewopts($n,$button_id)
3922 if {$val eq $value} {
3923 lappend rargs $pattern
3925 } else {
3926 set val $newviewopts($n,[lindex $opt 0])
3927 set val [string trim $val]
3928 if {$val ne {}} {
3929 set pfix [string range $pattern 0 end-1]
3930 lappend rargs $pfix$val
3934 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3935 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3938 # Fill $newviewopts($n, ...) based on args for git log.
3939 proc decode_view_opts {n view_args} {
3940 global known_view_options newviewopts
3942 foreach opt $known_view_options {
3943 set id [lindex $opt 0]
3944 if {[lindex $opt 1] eq "b"} {
3945 # Checkboxes
3946 set val 0
3947 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3948 # Radiobuttons
3949 regexp {^(.*_)} $id uselessvar id
3950 set val 0
3951 } else {
3952 # Text fields
3953 set val {}
3955 set newviewopts($n,$id) $val
3957 set oargs [list]
3958 set refargs [list]
3959 foreach arg $view_args {
3960 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3961 && ![info exists found(limit)]} {
3962 set newviewopts($n,limit) $cnt
3963 set found(limit) 1
3964 continue
3966 catch { unset val }
3967 foreach opt $known_view_options {
3968 set id [lindex $opt 0]
3969 if {[info exists found($id)]} continue
3970 foreach pattern [lindex $opt 3] {
3971 if {![string match $pattern $arg]} continue
3972 if {[lindex $opt 1] eq "b"} {
3973 # Check buttons
3974 set val 1
3975 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3976 # Radio buttons
3977 regexp {^(.*_)} $id uselessvar id
3978 set val $num
3979 } else {
3980 # Text input fields
3981 set size [string length $pattern]
3982 set val [string range $arg [expr {$size-1}] end]
3984 set newviewopts($n,$id) $val
3985 set found($id) 1
3986 break
3988 if {[info exists val]} break
3990 if {[info exists val]} continue
3991 if {[regexp {^-} $arg]} {
3992 lappend oargs $arg
3993 } else {
3994 lappend refargs $arg
3997 set newviewopts($n,refs) [shellarglist $refargs]
3998 set newviewopts($n,args) [shellarglist $oargs]
4001 proc edit_or_newview {} {
4002 global curview
4004 if {$curview > 0} {
4005 editview
4006 } else {
4007 newview 0
4011 proc editview {} {
4012 global curview
4013 global viewname viewperm newviewname newviewopts
4014 global viewargs viewargscmd
4016 set top .gitkvedit-$curview
4017 if {[winfo exists $top]} {
4018 raise $top
4019 return
4021 decode_view_opts $curview $viewargs($curview)
4022 set newviewname($curview) $viewname($curview)
4023 set newviewopts($curview,perm) $viewperm($curview)
4024 set newviewopts($curview,cmd) $viewargscmd($curview)
4025 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4028 proc vieweditor {top n title} {
4029 global newviewname newviewopts viewfiles bgcolor
4030 global known_view_options NS
4032 ttk_toplevel $top
4033 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4034 make_transient $top .
4036 # View name
4037 ${NS}::frame $top.nfr
4038 ${NS}::label $top.nl -text [mc "View Name"]
4039 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4040 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4041 pack $top.nl -in $top.nfr -side left -padx {0 5}
4042 pack $top.name -in $top.nfr -side left -padx {0 25}
4044 # View options
4045 set cframe $top.nfr
4046 set cexpand 0
4047 set cnt 0
4048 foreach opt $known_view_options {
4049 set id [lindex $opt 0]
4050 set type [lindex $opt 1]
4051 set flags [lindex $opt 2]
4052 set title [eval [lindex $opt 4]]
4053 set lxpad 0
4055 if {$flags eq "+" || $flags eq "*"} {
4056 set cframe $top.fr$cnt
4057 incr cnt
4058 ${NS}::frame $cframe
4059 pack $cframe -in $top -fill x -pady 3 -padx 3
4060 set cexpand [expr {$flags eq "*"}]
4061 } elseif {$flags eq ".." || $flags eq "*."} {
4062 set cframe $top.fr$cnt
4063 incr cnt
4064 ${NS}::frame $cframe
4065 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4066 set cexpand [expr {$flags eq "*."}]
4067 } else {
4068 set lxpad 5
4071 if {$type eq "l"} {
4072 ${NS}::label $cframe.l_$id -text $title
4073 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4074 } elseif {$type eq "b"} {
4075 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4076 pack $cframe.c_$id -in $cframe -side left \
4077 -padx [list $lxpad 0] -expand $cexpand -anchor w
4078 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4079 regexp {^(.*_)} $id uselessvar button_id
4080 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4081 pack $cframe.c_$id -in $cframe -side left \
4082 -padx [list $lxpad 0] -expand $cexpand -anchor w
4083 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4084 ${NS}::label $cframe.l_$id -text $title
4085 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4086 -textvariable newviewopts($n,$id)
4087 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4088 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4089 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4090 ${NS}::label $cframe.l_$id -text $title
4091 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4092 -textvariable newviewopts($n,$id)
4093 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4094 pack $cframe.e_$id -in $cframe -side top -fill x
4095 } elseif {$type eq "path"} {
4096 ${NS}::label $top.l -text $title
4097 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4098 text $top.t -width 40 -height 5 -background $bgcolor
4099 if {[info exists viewfiles($n)]} {
4100 foreach f $viewfiles($n) {
4101 $top.t insert end $f
4102 $top.t insert end "\n"
4104 $top.t delete {end - 1c} end
4105 $top.t mark set insert 0.0
4107 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4111 ${NS}::frame $top.buts
4112 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4113 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4114 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4115 bind $top <Control-Return> [list newviewok $top $n]
4116 bind $top <F5> [list newviewok $top $n 1]
4117 bind $top <Escape> [list destroy $top]
4118 grid $top.buts.ok $top.buts.apply $top.buts.can
4119 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4120 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4121 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4122 pack $top.buts -in $top -side top -fill x
4123 focus $top.t
4126 proc doviewmenu {m first cmd op argv} {
4127 set nmenu [$m index end]
4128 for {set i $first} {$i <= $nmenu} {incr i} {
4129 if {[$m entrycget $i -command] eq $cmd} {
4130 eval $m $op $i $argv
4131 break
4136 proc allviewmenus {n op args} {
4137 # global viewhlmenu
4139 doviewmenu .bar.view 5 [list showview $n] $op $args
4140 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4143 proc newviewok {top n {apply 0}} {
4144 global nextviewnum newviewperm newviewname newishighlight
4145 global viewname viewfiles viewperm selectedview curview
4146 global viewargs viewargscmd newviewopts viewhlmenu
4148 if {[catch {
4149 set newargs [encode_view_opts $n]
4150 } err]} {
4151 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4152 return
4154 set files {}
4155 foreach f [split [$top.t get 0.0 end] "\n"] {
4156 set ft [string trim $f]
4157 if {$ft ne {}} {
4158 lappend files $ft
4161 if {![info exists viewfiles($n)]} {
4162 # creating a new view
4163 incr nextviewnum
4164 set viewname($n) $newviewname($n)
4165 set viewperm($n) $newviewopts($n,perm)
4166 set viewfiles($n) $files
4167 set viewargs($n) $newargs
4168 set viewargscmd($n) $newviewopts($n,cmd)
4169 addviewmenu $n
4170 if {!$newishighlight} {
4171 run showview $n
4172 } else {
4173 run addvhighlight $n
4175 } else {
4176 # editing an existing view
4177 set viewperm($n) $newviewopts($n,perm)
4178 if {$newviewname($n) ne $viewname($n)} {
4179 set viewname($n) $newviewname($n)
4180 doviewmenu .bar.view 5 [list showview $n] \
4181 entryconf [list -label $viewname($n)]
4182 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4183 # entryconf [list -label $viewname($n) -value $viewname($n)]
4185 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4186 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4187 set viewfiles($n) $files
4188 set viewargs($n) $newargs
4189 set viewargscmd($n) $newviewopts($n,cmd)
4190 if {$curview == $n} {
4191 run reloadcommits
4195 if {$apply} return
4196 catch {destroy $top}
4199 proc delview {} {
4200 global curview viewperm hlview selectedhlview
4202 if {$curview == 0} return
4203 if {[info exists hlview] && $hlview == $curview} {
4204 set selectedhlview [mc "None"]
4205 unset hlview
4207 allviewmenus $curview delete
4208 set viewperm($curview) 0
4209 showview 0
4212 proc addviewmenu {n} {
4213 global viewname viewhlmenu
4215 .bar.view add radiobutton -label $viewname($n) \
4216 -command [list showview $n] -variable selectedview -value $n
4217 #$viewhlmenu add radiobutton -label $viewname($n) \
4218 # -command [list addvhighlight $n] -variable selectedhlview
4221 proc showview {n} {
4222 global curview cached_commitrow ordertok
4223 global displayorder parentlist rowidlist rowisopt rowfinal
4224 global colormap rowtextx nextcolor canvxmax
4225 global numcommits viewcomplete
4226 global selectedline currentid canv canvy0
4227 global treediffs
4228 global pending_select mainheadid
4229 global commitidx
4230 global selectedview
4231 global hlview selectedhlview commitinterest
4233 if {$n == $curview} return
4234 set selid {}
4235 set ymax [lindex [$canv cget -scrollregion] 3]
4236 set span [$canv yview]
4237 set ytop [expr {[lindex $span 0] * $ymax}]
4238 set ybot [expr {[lindex $span 1] * $ymax}]
4239 set yscreen [expr {($ybot - $ytop) / 2}]
4240 if {$selectedline ne {}} {
4241 set selid $currentid
4242 set y [yc $selectedline]
4243 if {$ytop < $y && $y < $ybot} {
4244 set yscreen [expr {$y - $ytop}]
4246 } elseif {[info exists pending_select]} {
4247 set selid $pending_select
4248 unset pending_select
4250 unselectline
4251 normalline
4252 catch {unset treediffs}
4253 clear_display
4254 if {[info exists hlview] && $hlview == $n} {
4255 unset hlview
4256 set selectedhlview [mc "None"]
4258 catch {unset commitinterest}
4259 catch {unset cached_commitrow}
4260 catch {unset ordertok}
4262 set curview $n
4263 set selectedview $n
4264 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4265 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4267 run refill_reflist
4268 if {![info exists viewcomplete($n)]} {
4269 getcommits $selid
4270 return
4273 set displayorder {}
4274 set parentlist {}
4275 set rowidlist {}
4276 set rowisopt {}
4277 set rowfinal {}
4278 set numcommits $commitidx($n)
4280 catch {unset colormap}
4281 catch {unset rowtextx}
4282 set nextcolor 0
4283 set canvxmax [$canv cget -width]
4284 set curview $n
4285 set row 0
4286 setcanvscroll
4287 set yf 0
4288 set row {}
4289 if {$selid ne {} && [commitinview $selid $n]} {
4290 set row [rowofcommit $selid]
4291 # try to get the selected row in the same position on the screen
4292 set ymax [lindex [$canv cget -scrollregion] 3]
4293 set ytop [expr {[yc $row] - $yscreen}]
4294 if {$ytop < 0} {
4295 set ytop 0
4297 set yf [expr {$ytop * 1.0 / $ymax}]
4299 allcanvs yview moveto $yf
4300 drawvisible
4301 if {$row ne {}} {
4302 selectline $row 0
4303 } elseif {!$viewcomplete($n)} {
4304 reset_pending_select $selid
4305 } else {
4306 reset_pending_select {}
4308 if {[commitinview $pending_select $curview]} {
4309 selectline [rowofcommit $pending_select] 1
4310 } else {
4311 set row [first_real_row]
4312 if {$row < $numcommits} {
4313 selectline $row 0
4317 if {!$viewcomplete($n)} {
4318 if {$numcommits == 0} {
4319 show_status [mc "Reading commits..."]
4321 } elseif {$numcommits == 0} {
4322 show_status [mc "No commits selected"]
4326 # Stuff relating to the highlighting facility
4328 proc ishighlighted {id} {
4329 global vhighlights fhighlights nhighlights rhighlights
4331 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4332 return $nhighlights($id)
4334 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4335 return $vhighlights($id)
4337 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4338 return $fhighlights($id)
4340 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4341 return $rhighlights($id)
4343 return 0
4346 proc bolden {id font} {
4347 global canv linehtag currentid boldids need_redisplay markedid
4349 # need_redisplay = 1 means the display is stale and about to be redrawn
4350 if {$need_redisplay} return
4351 lappend boldids $id
4352 $canv itemconf $linehtag($id) -font $font
4353 if {[info exists currentid] && $id eq $currentid} {
4354 $canv delete secsel
4355 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4356 -outline {{}} -tags secsel \
4357 -fill [$canv cget -selectbackground]]
4358 $canv lower $t
4360 if {[info exists markedid] && $id eq $markedid} {
4361 make_idmark $id
4365 proc bolden_name {id font} {
4366 global canv2 linentag currentid boldnameids need_redisplay
4368 if {$need_redisplay} return
4369 lappend boldnameids $id
4370 $canv2 itemconf $linentag($id) -font $font
4371 if {[info exists currentid] && $id eq $currentid} {
4372 $canv2 delete secsel
4373 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4374 -outline {{}} -tags secsel \
4375 -fill [$canv2 cget -selectbackground]]
4376 $canv2 lower $t
4380 proc unbolden {} {
4381 global boldids
4383 set stillbold {}
4384 foreach id $boldids {
4385 if {![ishighlighted $id]} {
4386 bolden $id mainfont
4387 } else {
4388 lappend stillbold $id
4391 set boldids $stillbold
4394 proc addvhighlight {n} {
4395 global hlview viewcomplete curview vhl_done commitidx
4397 if {[info exists hlview]} {
4398 delvhighlight
4400 set hlview $n
4401 if {$n != $curview && ![info exists viewcomplete($n)]} {
4402 start_rev_list $n
4404 set vhl_done $commitidx($hlview)
4405 if {$vhl_done > 0} {
4406 drawvisible
4410 proc delvhighlight {} {
4411 global hlview vhighlights
4413 if {![info exists hlview]} return
4414 unset hlview
4415 catch {unset vhighlights}
4416 unbolden
4419 proc vhighlightmore {} {
4420 global hlview vhl_done commitidx vhighlights curview
4422 set max $commitidx($hlview)
4423 set vr [visiblerows]
4424 set r0 [lindex $vr 0]
4425 set r1 [lindex $vr 1]
4426 for {set i $vhl_done} {$i < $max} {incr i} {
4427 set id [commitonrow $i $hlview]
4428 if {[commitinview $id $curview]} {
4429 set row [rowofcommit $id]
4430 if {$r0 <= $row && $row <= $r1} {
4431 if {![highlighted $row]} {
4432 bolden $id mainfontbold
4434 set vhighlights($id) 1
4438 set vhl_done $max
4439 return 0
4442 proc askvhighlight {row id} {
4443 global hlview vhighlights iddrawn
4445 if {[commitinview $id $hlview]} {
4446 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4447 bolden $id mainfontbold
4449 set vhighlights($id) 1
4450 } else {
4451 set vhighlights($id) 0
4455 proc hfiles_change {} {
4456 global highlight_files filehighlight fhighlights fh_serial
4457 global highlight_paths
4459 if {[info exists filehighlight]} {
4460 # delete previous highlights
4461 catch {close $filehighlight}
4462 unset filehighlight
4463 catch {unset fhighlights}
4464 unbolden
4465 unhighlight_filelist
4467 set highlight_paths {}
4468 after cancel do_file_hl $fh_serial
4469 incr fh_serial
4470 if {$highlight_files ne {}} {
4471 after 300 do_file_hl $fh_serial
4475 proc gdttype_change {name ix op} {
4476 global gdttype highlight_files findstring findpattern
4478 stopfinding
4479 if {$findstring ne {}} {
4480 if {$gdttype eq [mc "containing:"]} {
4481 if {$highlight_files ne {}} {
4482 set highlight_files {}
4483 hfiles_change
4485 findcom_change
4486 } else {
4487 if {$findpattern ne {}} {
4488 set findpattern {}
4489 findcom_change
4491 set highlight_files $findstring
4492 hfiles_change
4494 drawvisible
4496 # enable/disable findtype/findloc menus too
4499 proc find_change {name ix op} {
4500 global gdttype findstring highlight_files
4502 stopfinding
4503 if {$gdttype eq [mc "containing:"]} {
4504 findcom_change
4505 } else {
4506 if {$highlight_files ne $findstring} {
4507 set highlight_files $findstring
4508 hfiles_change
4511 drawvisible
4514 proc findcom_change args {
4515 global nhighlights boldnameids
4516 global findpattern findtype findstring gdttype
4518 stopfinding
4519 # delete previous highlights, if any
4520 foreach id $boldnameids {
4521 bolden_name $id mainfont
4523 set boldnameids {}
4524 catch {unset nhighlights}
4525 unbolden
4526 unmarkmatches
4527 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4528 set findpattern {}
4529 } elseif {$findtype eq [mc "Regexp"]} {
4530 set findpattern $findstring
4531 } else {
4532 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4533 $findstring]
4534 set findpattern "*$e*"
4538 proc makepatterns {l} {
4539 set ret {}
4540 foreach e $l {
4541 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4542 if {[string index $ee end] eq "/"} {
4543 lappend ret "$ee*"
4544 } else {
4545 lappend ret $ee
4546 lappend ret "$ee/*"
4549 return $ret
4552 proc do_file_hl {serial} {
4553 global highlight_files filehighlight highlight_paths gdttype fhl_list
4554 global cdup findtype
4556 if {$gdttype eq [mc "touching paths:"]} {
4557 # If "exact" match then convert backslashes to forward slashes.
4558 # Most useful to support Windows-flavoured file paths.
4559 if {$findtype eq [mc "Exact"]} {
4560 set highlight_files [string map {"\\" "/"} $highlight_files]
4562 if {[catch {set paths [shellsplit $highlight_files]}]} return
4563 set highlight_paths [makepatterns $paths]
4564 highlight_filelist
4565 set relative_paths {}
4566 foreach path $paths {
4567 lappend relative_paths [file join $cdup $path]
4569 set gdtargs [concat -- $relative_paths]
4570 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4571 set gdtargs [list "-S$highlight_files"]
4572 } else {
4573 # must be "containing:", i.e. we're searching commit info
4574 return
4576 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4577 set filehighlight [open $cmd r+]
4578 fconfigure $filehighlight -blocking 0
4579 filerun $filehighlight readfhighlight
4580 set fhl_list {}
4581 drawvisible
4582 flushhighlights
4585 proc flushhighlights {} {
4586 global filehighlight fhl_list
4588 if {[info exists filehighlight]} {
4589 lappend fhl_list {}
4590 puts $filehighlight ""
4591 flush $filehighlight
4595 proc askfilehighlight {row id} {
4596 global filehighlight fhighlights fhl_list
4598 lappend fhl_list $id
4599 set fhighlights($id) -1
4600 puts $filehighlight $id
4603 proc readfhighlight {} {
4604 global filehighlight fhighlights curview iddrawn
4605 global fhl_list find_dirn
4607 if {![info exists filehighlight]} {
4608 return 0
4610 set nr 0
4611 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4612 set line [string trim $line]
4613 set i [lsearch -exact $fhl_list $line]
4614 if {$i < 0} continue
4615 for {set j 0} {$j < $i} {incr j} {
4616 set id [lindex $fhl_list $j]
4617 set fhighlights($id) 0
4619 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4620 if {$line eq {}} continue
4621 if {![commitinview $line $curview]} continue
4622 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4623 bolden $line mainfontbold
4625 set fhighlights($line) 1
4627 if {[eof $filehighlight]} {
4628 # strange...
4629 puts "oops, git diff-tree died"
4630 catch {close $filehighlight}
4631 unset filehighlight
4632 return 0
4634 if {[info exists find_dirn]} {
4635 run findmore
4637 return 1
4640 proc doesmatch {f} {
4641 global findtype findpattern
4643 if {$findtype eq [mc "Regexp"]} {
4644 return [regexp $findpattern $f]
4645 } elseif {$findtype eq [mc "IgnCase"]} {
4646 return [string match -nocase $findpattern $f]
4647 } else {
4648 return [string match $findpattern $f]
4652 proc askfindhighlight {row id} {
4653 global nhighlights commitinfo iddrawn
4654 global findloc
4655 global markingmatches
4657 if {![info exists commitinfo($id)]} {
4658 getcommit $id
4660 set info $commitinfo($id)
4661 set isbold 0
4662 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4663 foreach f $info ty $fldtypes {
4664 if {$ty eq ""} continue
4665 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4666 [doesmatch $f]} {
4667 if {$ty eq [mc "Author"]} {
4668 set isbold 2
4669 break
4671 set isbold 1
4674 if {$isbold && [info exists iddrawn($id)]} {
4675 if {![ishighlighted $id]} {
4676 bolden $id mainfontbold
4677 if {$isbold > 1} {
4678 bolden_name $id mainfontbold
4681 if {$markingmatches} {
4682 markrowmatches $row $id
4685 set nhighlights($id) $isbold
4688 proc markrowmatches {row id} {
4689 global canv canv2 linehtag linentag commitinfo findloc
4691 set headline [lindex $commitinfo($id) 0]
4692 set author [lindex $commitinfo($id) 1]
4693 $canv delete match$row
4694 $canv2 delete match$row
4695 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4696 set m [findmatches $headline]
4697 if {$m ne {}} {
4698 markmatches $canv $row $headline $linehtag($id) $m \
4699 [$canv itemcget $linehtag($id) -font] $row
4702 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4703 set m [findmatches $author]
4704 if {$m ne {}} {
4705 markmatches $canv2 $row $author $linentag($id) $m \
4706 [$canv2 itemcget $linentag($id) -font] $row
4711 proc vrel_change {name ix op} {
4712 global highlight_related
4714 rhighlight_none
4715 if {$highlight_related ne [mc "None"]} {
4716 run drawvisible
4720 # prepare for testing whether commits are descendents or ancestors of a
4721 proc rhighlight_sel {a} {
4722 global descendent desc_todo ancestor anc_todo
4723 global highlight_related
4725 catch {unset descendent}
4726 set desc_todo [list $a]
4727 catch {unset ancestor}
4728 set anc_todo [list $a]
4729 if {$highlight_related ne [mc "None"]} {
4730 rhighlight_none
4731 run drawvisible
4735 proc rhighlight_none {} {
4736 global rhighlights
4738 catch {unset rhighlights}
4739 unbolden
4742 proc is_descendent {a} {
4743 global curview children descendent desc_todo
4745 set v $curview
4746 set la [rowofcommit $a]
4747 set todo $desc_todo
4748 set leftover {}
4749 set done 0
4750 for {set i 0} {$i < [llength $todo]} {incr i} {
4751 set do [lindex $todo $i]
4752 if {[rowofcommit $do] < $la} {
4753 lappend leftover $do
4754 continue
4756 foreach nk $children($v,$do) {
4757 if {![info exists descendent($nk)]} {
4758 set descendent($nk) 1
4759 lappend todo $nk
4760 if {$nk eq $a} {
4761 set done 1
4765 if {$done} {
4766 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4767 return
4770 set descendent($a) 0
4771 set desc_todo $leftover
4774 proc is_ancestor {a} {
4775 global curview parents ancestor anc_todo
4777 set v $curview
4778 set la [rowofcommit $a]
4779 set todo $anc_todo
4780 set leftover {}
4781 set done 0
4782 for {set i 0} {$i < [llength $todo]} {incr i} {
4783 set do [lindex $todo $i]
4784 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4785 lappend leftover $do
4786 continue
4788 foreach np $parents($v,$do) {
4789 if {![info exists ancestor($np)]} {
4790 set ancestor($np) 1
4791 lappend todo $np
4792 if {$np eq $a} {
4793 set done 1
4797 if {$done} {
4798 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4799 return
4802 set ancestor($a) 0
4803 set anc_todo $leftover
4806 proc askrelhighlight {row id} {
4807 global descendent highlight_related iddrawn rhighlights
4808 global selectedline ancestor
4810 if {$selectedline eq {}} return
4811 set isbold 0
4812 if {$highlight_related eq [mc "Descendant"] ||
4813 $highlight_related eq [mc "Not descendant"]} {
4814 if {![info exists descendent($id)]} {
4815 is_descendent $id
4817 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4818 set isbold 1
4820 } elseif {$highlight_related eq [mc "Ancestor"] ||
4821 $highlight_related eq [mc "Not ancestor"]} {
4822 if {![info exists ancestor($id)]} {
4823 is_ancestor $id
4825 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4826 set isbold 1
4829 if {[info exists iddrawn($id)]} {
4830 if {$isbold && ![ishighlighted $id]} {
4831 bolden $id mainfontbold
4834 set rhighlights($id) $isbold
4837 # Graph layout functions
4839 proc shortids {ids} {
4840 set res {}
4841 foreach id $ids {
4842 if {[llength $id] > 1} {
4843 lappend res [shortids $id]
4844 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4845 lappend res [string range $id 0 7]
4846 } else {
4847 lappend res $id
4850 return $res
4853 proc ntimes {n o} {
4854 set ret {}
4855 set o [list $o]
4856 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4857 if {($n & $mask) != 0} {
4858 set ret [concat $ret $o]
4860 set o [concat $o $o]
4862 return $ret
4865 proc ordertoken {id} {
4866 global ordertok curview varcid varcstart varctok curview parents children
4867 global nullid nullid2
4869 if {[info exists ordertok($id)]} {
4870 return $ordertok($id)
4872 set origid $id
4873 set todo {}
4874 while {1} {
4875 if {[info exists varcid($curview,$id)]} {
4876 set a $varcid($curview,$id)
4877 set p [lindex $varcstart($curview) $a]
4878 } else {
4879 set p [lindex $children($curview,$id) 0]
4881 if {[info exists ordertok($p)]} {
4882 set tok $ordertok($p)
4883 break
4885 set id [first_real_child $curview,$p]
4886 if {$id eq {}} {
4887 # it's a root
4888 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4889 break
4891 if {[llength $parents($curview,$id)] == 1} {
4892 lappend todo [list $p {}]
4893 } else {
4894 set j [lsearch -exact $parents($curview,$id) $p]
4895 if {$j < 0} {
4896 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4898 lappend todo [list $p [strrep $j]]
4901 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4902 set p [lindex $todo $i 0]
4903 append tok [lindex $todo $i 1]
4904 set ordertok($p) $tok
4906 set ordertok($origid) $tok
4907 return $tok
4910 # Work out where id should go in idlist so that order-token
4911 # values increase from left to right
4912 proc idcol {idlist id {i 0}} {
4913 set t [ordertoken $id]
4914 if {$i < 0} {
4915 set i 0
4917 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4918 if {$i > [llength $idlist]} {
4919 set i [llength $idlist]
4921 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4922 incr i
4923 } else {
4924 if {$t > [ordertoken [lindex $idlist $i]]} {
4925 while {[incr i] < [llength $idlist] &&
4926 $t >= [ordertoken [lindex $idlist $i]]} {}
4929 return $i
4932 proc initlayout {} {
4933 global rowidlist rowisopt rowfinal displayorder parentlist
4934 global numcommits canvxmax canv
4935 global nextcolor
4936 global colormap rowtextx
4938 set numcommits 0
4939 set displayorder {}
4940 set parentlist {}
4941 set nextcolor 0
4942 set rowidlist {}
4943 set rowisopt {}
4944 set rowfinal {}
4945 set canvxmax [$canv cget -width]
4946 catch {unset colormap}
4947 catch {unset rowtextx}
4948 setcanvscroll
4951 proc setcanvscroll {} {
4952 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4953 global lastscrollset lastscrollrows
4955 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4956 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4957 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4958 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4959 set lastscrollset [clock clicks -milliseconds]
4960 set lastscrollrows $numcommits
4963 proc visiblerows {} {
4964 global canv numcommits linespc
4966 set ymax [lindex [$canv cget -scrollregion] 3]
4967 if {$ymax eq {} || $ymax == 0} return
4968 set f [$canv yview]
4969 set y0 [expr {int([lindex $f 0] * $ymax)}]
4970 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4971 if {$r0 < 0} {
4972 set r0 0
4974 set y1 [expr {int([lindex $f 1] * $ymax)}]
4975 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4976 if {$r1 >= $numcommits} {
4977 set r1 [expr {$numcommits - 1}]
4979 return [list $r0 $r1]
4982 proc layoutmore {} {
4983 global commitidx viewcomplete curview
4984 global numcommits pending_select curview
4985 global lastscrollset lastscrollrows
4987 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4988 [clock clicks -milliseconds] - $lastscrollset > 500} {
4989 setcanvscroll
4991 if {[info exists pending_select] &&
4992 [commitinview $pending_select $curview]} {
4993 update
4994 selectline [rowofcommit $pending_select] 1
4996 drawvisible
4999 # With path limiting, we mightn't get the actual HEAD commit,
5000 # so ask git rev-list what is the first ancestor of HEAD that
5001 # touches a file in the path limit.
5002 proc get_viewmainhead {view} {
5003 global viewmainheadid vfilelimit viewinstances mainheadid
5005 catch {
5006 set rfd [open [concat | git rev-list -1 $mainheadid \
5007 -- $vfilelimit($view)] r]
5008 set j [reg_instance $rfd]
5009 lappend viewinstances($view) $j
5010 fconfigure $rfd -blocking 0
5011 filerun $rfd [list getviewhead $rfd $j $view]
5012 set viewmainheadid($curview) {}
5016 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5017 proc getviewhead {fd inst view} {
5018 global viewmainheadid commfd curview viewinstances showlocalchanges
5020 set id {}
5021 if {[gets $fd line] < 0} {
5022 if {![eof $fd]} {
5023 return 1
5025 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5026 set id $line
5028 set viewmainheadid($view) $id
5029 close $fd
5030 unset commfd($inst)
5031 set i [lsearch -exact $viewinstances($view) $inst]
5032 if {$i >= 0} {
5033 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5035 if {$showlocalchanges && $id ne {} && $view == $curview} {
5036 doshowlocalchanges
5038 return 0
5041 proc doshowlocalchanges {} {
5042 global curview viewmainheadid
5044 if {$viewmainheadid($curview) eq {}} return
5045 if {[commitinview $viewmainheadid($curview) $curview]} {
5046 dodiffindex
5047 } else {
5048 interestedin $viewmainheadid($curview) dodiffindex
5052 proc dohidelocalchanges {} {
5053 global nullid nullid2 lserial curview
5055 if {[commitinview $nullid $curview]} {
5056 removefakerow $nullid
5058 if {[commitinview $nullid2 $curview]} {
5059 removefakerow $nullid2
5061 incr lserial
5064 # spawn off a process to do git diff-index --cached HEAD
5065 proc dodiffindex {} {
5066 global lserial showlocalchanges vfilelimit curview
5067 global hasworktree
5069 if {!$showlocalchanges || !$hasworktree} return
5070 incr lserial
5071 set cmd "|git diff-index --cached HEAD"
5072 if {$vfilelimit($curview) ne {}} {
5073 set cmd [concat $cmd -- $vfilelimit($curview)]
5075 set fd [open $cmd r]
5076 fconfigure $fd -blocking 0
5077 set i [reg_instance $fd]
5078 filerun $fd [list readdiffindex $fd $lserial $i]
5081 proc readdiffindex {fd serial inst} {
5082 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5083 global vfilelimit
5085 set isdiff 1
5086 if {[gets $fd line] < 0} {
5087 if {![eof $fd]} {
5088 return 1
5090 set isdiff 0
5092 # we only need to see one line and we don't really care what it says...
5093 stop_instance $inst
5095 if {$serial != $lserial} {
5096 return 0
5099 # now see if there are any local changes not checked in to the index
5100 set cmd "|git diff-files"
5101 if {$vfilelimit($curview) ne {}} {
5102 set cmd [concat $cmd -- $vfilelimit($curview)]
5104 set fd [open $cmd r]
5105 fconfigure $fd -blocking 0
5106 set i [reg_instance $fd]
5107 filerun $fd [list readdifffiles $fd $serial $i]
5109 if {$isdiff && ![commitinview $nullid2 $curview]} {
5110 # add the line for the changes in the index to the graph
5111 set hl [mc "Local changes checked in to index but not committed"]
5112 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5113 set commitdata($nullid2) "\n $hl\n"
5114 if {[commitinview $nullid $curview]} {
5115 removefakerow $nullid
5117 insertfakerow $nullid2 $viewmainheadid($curview)
5118 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5119 if {[commitinview $nullid $curview]} {
5120 removefakerow $nullid
5122 removefakerow $nullid2
5124 return 0
5127 proc readdifffiles {fd serial inst} {
5128 global viewmainheadid nullid nullid2 curview
5129 global commitinfo commitdata lserial
5131 set isdiff 1
5132 if {[gets $fd line] < 0} {
5133 if {![eof $fd]} {
5134 return 1
5136 set isdiff 0
5138 # we only need to see one line and we don't really care what it says...
5139 stop_instance $inst
5141 if {$serial != $lserial} {
5142 return 0
5145 if {$isdiff && ![commitinview $nullid $curview]} {
5146 # add the line for the local diff to the graph
5147 set hl [mc "Local uncommitted changes, not checked in to index"]
5148 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5149 set commitdata($nullid) "\n $hl\n"
5150 if {[commitinview $nullid2 $curview]} {
5151 set p $nullid2
5152 } else {
5153 set p $viewmainheadid($curview)
5155 insertfakerow $nullid $p
5156 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5157 removefakerow $nullid
5159 return 0
5162 proc nextuse {id row} {
5163 global curview children
5165 if {[info exists children($curview,$id)]} {
5166 foreach kid $children($curview,$id) {
5167 if {![commitinview $kid $curview]} {
5168 return -1
5170 if {[rowofcommit $kid] > $row} {
5171 return [rowofcommit $kid]
5175 if {[commitinview $id $curview]} {
5176 return [rowofcommit $id]
5178 return -1
5181 proc prevuse {id row} {
5182 global curview children
5184 set ret -1
5185 if {[info exists children($curview,$id)]} {
5186 foreach kid $children($curview,$id) {
5187 if {![commitinview $kid $curview]} break
5188 if {[rowofcommit $kid] < $row} {
5189 set ret [rowofcommit $kid]
5193 return $ret
5196 proc make_idlist {row} {
5197 global displayorder parentlist uparrowlen downarrowlen mingaplen
5198 global commitidx curview children
5200 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5201 if {$r < 0} {
5202 set r 0
5204 set ra [expr {$row - $downarrowlen}]
5205 if {$ra < 0} {
5206 set ra 0
5208 set rb [expr {$row + $uparrowlen}]
5209 if {$rb > $commitidx($curview)} {
5210 set rb $commitidx($curview)
5212 make_disporder $r [expr {$rb + 1}]
5213 set ids {}
5214 for {} {$r < $ra} {incr r} {
5215 set nextid [lindex $displayorder [expr {$r + 1}]]
5216 foreach p [lindex $parentlist $r] {
5217 if {$p eq $nextid} continue
5218 set rn [nextuse $p $r]
5219 if {$rn >= $row &&
5220 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5221 lappend ids [list [ordertoken $p] $p]
5225 for {} {$r < $row} {incr r} {
5226 set nextid [lindex $displayorder [expr {$r + 1}]]
5227 foreach p [lindex $parentlist $r] {
5228 if {$p eq $nextid} continue
5229 set rn [nextuse $p $r]
5230 if {$rn < 0 || $rn >= $row} {
5231 lappend ids [list [ordertoken $p] $p]
5235 set id [lindex $displayorder $row]
5236 lappend ids [list [ordertoken $id] $id]
5237 while {$r < $rb} {
5238 foreach p [lindex $parentlist $r] {
5239 set firstkid [lindex $children($curview,$p) 0]
5240 if {[rowofcommit $firstkid] < $row} {
5241 lappend ids [list [ordertoken $p] $p]
5244 incr r
5245 set id [lindex $displayorder $r]
5246 if {$id ne {}} {
5247 set firstkid [lindex $children($curview,$id) 0]
5248 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5249 lappend ids [list [ordertoken $id] $id]
5253 set idlist {}
5254 foreach idx [lsort -unique $ids] {
5255 lappend idlist [lindex $idx 1]
5257 return $idlist
5260 proc rowsequal {a b} {
5261 while {[set i [lsearch -exact $a {}]] >= 0} {
5262 set a [lreplace $a $i $i]
5264 while {[set i [lsearch -exact $b {}]] >= 0} {
5265 set b [lreplace $b $i $i]
5267 return [expr {$a eq $b}]
5270 proc makeupline {id row rend col} {
5271 global rowidlist uparrowlen downarrowlen mingaplen
5273 for {set r $rend} {1} {set r $rstart} {
5274 set rstart [prevuse $id $r]
5275 if {$rstart < 0} return
5276 if {$rstart < $row} break
5278 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5279 set rstart [expr {$rend - $uparrowlen - 1}]
5281 for {set r $rstart} {[incr r] <= $row} {} {
5282 set idlist [lindex $rowidlist $r]
5283 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5284 set col [idcol $idlist $id $col]
5285 lset rowidlist $r [linsert $idlist $col $id]
5286 changedrow $r
5291 proc layoutrows {row endrow} {
5292 global rowidlist rowisopt rowfinal displayorder
5293 global uparrowlen downarrowlen maxwidth mingaplen
5294 global children parentlist
5295 global commitidx viewcomplete curview
5297 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5298 set idlist {}
5299 if {$row > 0} {
5300 set rm1 [expr {$row - 1}]
5301 foreach id [lindex $rowidlist $rm1] {
5302 if {$id ne {}} {
5303 lappend idlist $id
5306 set final [lindex $rowfinal $rm1]
5308 for {} {$row < $endrow} {incr row} {
5309 set rm1 [expr {$row - 1}]
5310 if {$rm1 < 0 || $idlist eq {}} {
5311 set idlist [make_idlist $row]
5312 set final 1
5313 } else {
5314 set id [lindex $displayorder $rm1]
5315 set col [lsearch -exact $idlist $id]
5316 set idlist [lreplace $idlist $col $col]
5317 foreach p [lindex $parentlist $rm1] {
5318 if {[lsearch -exact $idlist $p] < 0} {
5319 set col [idcol $idlist $p $col]
5320 set idlist [linsert $idlist $col $p]
5321 # if not the first child, we have to insert a line going up
5322 if {$id ne [lindex $children($curview,$p) 0]} {
5323 makeupline $p $rm1 $row $col
5327 set id [lindex $displayorder $row]
5328 if {$row > $downarrowlen} {
5329 set termrow [expr {$row - $downarrowlen - 1}]
5330 foreach p [lindex $parentlist $termrow] {
5331 set i [lsearch -exact $idlist $p]
5332 if {$i < 0} continue
5333 set nr [nextuse $p $termrow]
5334 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5335 set idlist [lreplace $idlist $i $i]
5339 set col [lsearch -exact $idlist $id]
5340 if {$col < 0} {
5341 set col [idcol $idlist $id]
5342 set idlist [linsert $idlist $col $id]
5343 if {$children($curview,$id) ne {}} {
5344 makeupline $id $rm1 $row $col
5347 set r [expr {$row + $uparrowlen - 1}]
5348 if {$r < $commitidx($curview)} {
5349 set x $col
5350 foreach p [lindex $parentlist $r] {
5351 if {[lsearch -exact $idlist $p] >= 0} continue
5352 set fk [lindex $children($curview,$p) 0]
5353 if {[rowofcommit $fk] < $row} {
5354 set x [idcol $idlist $p $x]
5355 set idlist [linsert $idlist $x $p]
5358 if {[incr r] < $commitidx($curview)} {
5359 set p [lindex $displayorder $r]
5360 if {[lsearch -exact $idlist $p] < 0} {
5361 set fk [lindex $children($curview,$p) 0]
5362 if {$fk ne {} && [rowofcommit $fk] < $row} {
5363 set x [idcol $idlist $p $x]
5364 set idlist [linsert $idlist $x $p]
5370 if {$final && !$viewcomplete($curview) &&
5371 $row + $uparrowlen + $mingaplen + $downarrowlen
5372 >= $commitidx($curview)} {
5373 set final 0
5375 set l [llength $rowidlist]
5376 if {$row == $l} {
5377 lappend rowidlist $idlist
5378 lappend rowisopt 0
5379 lappend rowfinal $final
5380 } elseif {$row < $l} {
5381 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5382 lset rowidlist $row $idlist
5383 changedrow $row
5385 lset rowfinal $row $final
5386 } else {
5387 set pad [ntimes [expr {$row - $l}] {}]
5388 set rowidlist [concat $rowidlist $pad]
5389 lappend rowidlist $idlist
5390 set rowfinal [concat $rowfinal $pad]
5391 lappend rowfinal $final
5392 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5395 return $row
5398 proc changedrow {row} {
5399 global displayorder iddrawn rowisopt need_redisplay
5401 set l [llength $rowisopt]
5402 if {$row < $l} {
5403 lset rowisopt $row 0
5404 if {$row + 1 < $l} {
5405 lset rowisopt [expr {$row + 1}] 0
5406 if {$row + 2 < $l} {
5407 lset rowisopt [expr {$row + 2}] 0
5411 set id [lindex $displayorder $row]
5412 if {[info exists iddrawn($id)]} {
5413 set need_redisplay 1
5417 proc insert_pad {row col npad} {
5418 global rowidlist
5420 set pad [ntimes $npad {}]
5421 set idlist [lindex $rowidlist $row]
5422 set bef [lrange $idlist 0 [expr {$col - 1}]]
5423 set aft [lrange $idlist $col end]
5424 set i [lsearch -exact $aft {}]
5425 if {$i > 0} {
5426 set aft [lreplace $aft $i $i]
5428 lset rowidlist $row [concat $bef $pad $aft]
5429 changedrow $row
5432 proc optimize_rows {row col endrow} {
5433 global rowidlist rowisopt displayorder curview children
5435 if {$row < 1} {
5436 set row 1
5438 for {} {$row < $endrow} {incr row; set col 0} {
5439 if {[lindex $rowisopt $row]} continue
5440 set haspad 0
5441 set y0 [expr {$row - 1}]
5442 set ym [expr {$row - 2}]
5443 set idlist [lindex $rowidlist $row]
5444 set previdlist [lindex $rowidlist $y0]
5445 if {$idlist eq {} || $previdlist eq {}} continue
5446 if {$ym >= 0} {
5447 set pprevidlist [lindex $rowidlist $ym]
5448 if {$pprevidlist eq {}} continue
5449 } else {
5450 set pprevidlist {}
5452 set x0 -1
5453 set xm -1
5454 for {} {$col < [llength $idlist]} {incr col} {
5455 set id [lindex $idlist $col]
5456 if {[lindex $previdlist $col] eq $id} continue
5457 if {$id eq {}} {
5458 set haspad 1
5459 continue
5461 set x0 [lsearch -exact $previdlist $id]
5462 if {$x0 < 0} continue
5463 set z [expr {$x0 - $col}]
5464 set isarrow 0
5465 set z0 {}
5466 if {$ym >= 0} {
5467 set xm [lsearch -exact $pprevidlist $id]
5468 if {$xm >= 0} {
5469 set z0 [expr {$xm - $x0}]
5472 if {$z0 eq {}} {
5473 # if row y0 is the first child of $id then it's not an arrow
5474 if {[lindex $children($curview,$id) 0] ne
5475 [lindex $displayorder $y0]} {
5476 set isarrow 1
5479 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5480 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5481 set isarrow 1
5483 # Looking at lines from this row to the previous row,
5484 # make them go straight up if they end in an arrow on
5485 # the previous row; otherwise make them go straight up
5486 # or at 45 degrees.
5487 if {$z < -1 || ($z < 0 && $isarrow)} {
5488 # Line currently goes left too much;
5489 # insert pads in the previous row, then optimize it
5490 set npad [expr {-1 - $z + $isarrow}]
5491 insert_pad $y0 $x0 $npad
5492 if {$y0 > 0} {
5493 optimize_rows $y0 $x0 $row
5495 set previdlist [lindex $rowidlist $y0]
5496 set x0 [lsearch -exact $previdlist $id]
5497 set z [expr {$x0 - $col}]
5498 if {$z0 ne {}} {
5499 set pprevidlist [lindex $rowidlist $ym]
5500 set xm [lsearch -exact $pprevidlist $id]
5501 set z0 [expr {$xm - $x0}]
5503 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5504 # Line currently goes right too much;
5505 # insert pads in this line
5506 set npad [expr {$z - 1 + $isarrow}]
5507 insert_pad $row $col $npad
5508 set idlist [lindex $rowidlist $row]
5509 incr col $npad
5510 set z [expr {$x0 - $col}]
5511 set haspad 1
5513 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5514 # this line links to its first child on row $row-2
5515 set id [lindex $displayorder $ym]
5516 set xc [lsearch -exact $pprevidlist $id]
5517 if {$xc >= 0} {
5518 set z0 [expr {$xc - $x0}]
5521 # avoid lines jigging left then immediately right
5522 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5523 insert_pad $y0 $x0 1
5524 incr x0
5525 optimize_rows $y0 $x0 $row
5526 set previdlist [lindex $rowidlist $y0]
5529 if {!$haspad} {
5530 # Find the first column that doesn't have a line going right
5531 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5532 set id [lindex $idlist $col]
5533 if {$id eq {}} break
5534 set x0 [lsearch -exact $previdlist $id]
5535 if {$x0 < 0} {
5536 # check if this is the link to the first child
5537 set kid [lindex $displayorder $y0]
5538 if {[lindex $children($curview,$id) 0] eq $kid} {
5539 # it is, work out offset to child
5540 set x0 [lsearch -exact $previdlist $kid]
5543 if {$x0 <= $col} break
5545 # Insert a pad at that column as long as it has a line and
5546 # isn't the last column
5547 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5548 set idlist [linsert $idlist $col {}]
5549 lset rowidlist $row $idlist
5550 changedrow $row
5556 proc xc {row col} {
5557 global canvx0 linespc
5558 return [expr {$canvx0 + $col * $linespc}]
5561 proc yc {row} {
5562 global canvy0 linespc
5563 return [expr {$canvy0 + $row * $linespc}]
5566 proc linewidth {id} {
5567 global thickerline lthickness
5569 set wid $lthickness
5570 if {[info exists thickerline] && $id eq $thickerline} {
5571 set wid [expr {2 * $lthickness}]
5573 return $wid
5576 proc rowranges {id} {
5577 global curview children uparrowlen downarrowlen
5578 global rowidlist
5580 set kids $children($curview,$id)
5581 if {$kids eq {}} {
5582 return {}
5584 set ret {}
5585 lappend kids $id
5586 foreach child $kids {
5587 if {![commitinview $child $curview]} break
5588 set row [rowofcommit $child]
5589 if {![info exists prev]} {
5590 lappend ret [expr {$row + 1}]
5591 } else {
5592 if {$row <= $prevrow} {
5593 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5595 # see if the line extends the whole way from prevrow to row
5596 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5597 [lsearch -exact [lindex $rowidlist \
5598 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5599 # it doesn't, see where it ends
5600 set r [expr {$prevrow + $downarrowlen}]
5601 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5602 while {[incr r -1] > $prevrow &&
5603 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5604 } else {
5605 while {[incr r] <= $row &&
5606 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5607 incr r -1
5609 lappend ret $r
5610 # see where it starts up again
5611 set r [expr {$row - $uparrowlen}]
5612 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5613 while {[incr r] < $row &&
5614 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5615 } else {
5616 while {[incr r -1] >= $prevrow &&
5617 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5618 incr r
5620 lappend ret $r
5623 if {$child eq $id} {
5624 lappend ret $row
5626 set prev $child
5627 set prevrow $row
5629 return $ret
5632 proc drawlineseg {id row endrow arrowlow} {
5633 global rowidlist displayorder iddrawn linesegs
5634 global canv colormap linespc curview maxlinelen parentlist
5636 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5637 set le [expr {$row + 1}]
5638 set arrowhigh 1
5639 while {1} {
5640 set c [lsearch -exact [lindex $rowidlist $le] $id]
5641 if {$c < 0} {
5642 incr le -1
5643 break
5645 lappend cols $c
5646 set x [lindex $displayorder $le]
5647 if {$x eq $id} {
5648 set arrowhigh 0
5649 break
5651 if {[info exists iddrawn($x)] || $le == $endrow} {
5652 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5653 if {$c >= 0} {
5654 lappend cols $c
5655 set arrowhigh 0
5657 break
5659 incr le
5661 if {$le <= $row} {
5662 return $row
5665 set lines {}
5666 set i 0
5667 set joinhigh 0
5668 if {[info exists linesegs($id)]} {
5669 set lines $linesegs($id)
5670 foreach li $lines {
5671 set r0 [lindex $li 0]
5672 if {$r0 > $row} {
5673 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5674 set joinhigh 1
5676 break
5678 incr i
5681 set joinlow 0
5682 if {$i > 0} {
5683 set li [lindex $lines [expr {$i-1}]]
5684 set r1 [lindex $li 1]
5685 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5686 set joinlow 1
5690 set x [lindex $cols [expr {$le - $row}]]
5691 set xp [lindex $cols [expr {$le - 1 - $row}]]
5692 set dir [expr {$xp - $x}]
5693 if {$joinhigh} {
5694 set ith [lindex $lines $i 2]
5695 set coords [$canv coords $ith]
5696 set ah [$canv itemcget $ith -arrow]
5697 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5698 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5699 if {$x2 ne {} && $x - $x2 == $dir} {
5700 set coords [lrange $coords 0 end-2]
5702 } else {
5703 set coords [list [xc $le $x] [yc $le]]
5705 if {$joinlow} {
5706 set itl [lindex $lines [expr {$i-1}] 2]
5707 set al [$canv itemcget $itl -arrow]
5708 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5709 } elseif {$arrowlow} {
5710 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5711 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5712 set arrowlow 0
5715 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5716 for {set y $le} {[incr y -1] > $row} {} {
5717 set x $xp
5718 set xp [lindex $cols [expr {$y - 1 - $row}]]
5719 set ndir [expr {$xp - $x}]
5720 if {$dir != $ndir || $xp < 0} {
5721 lappend coords [xc $y $x] [yc $y]
5723 set dir $ndir
5725 if {!$joinlow} {
5726 if {$xp < 0} {
5727 # join parent line to first child
5728 set ch [lindex $displayorder $row]
5729 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5730 if {$xc < 0} {
5731 puts "oops: drawlineseg: child $ch not on row $row"
5732 } elseif {$xc != $x} {
5733 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5734 set d [expr {int(0.5 * $linespc)}]
5735 set x1 [xc $row $x]
5736 if {$xc < $x} {
5737 set x2 [expr {$x1 - $d}]
5738 } else {
5739 set x2 [expr {$x1 + $d}]
5741 set y2 [yc $row]
5742 set y1 [expr {$y2 + $d}]
5743 lappend coords $x1 $y1 $x2 $y2
5744 } elseif {$xc < $x - 1} {
5745 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5746 } elseif {$xc > $x + 1} {
5747 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5749 set x $xc
5751 lappend coords [xc $row $x] [yc $row]
5752 } else {
5753 set xn [xc $row $xp]
5754 set yn [yc $row]
5755 lappend coords $xn $yn
5757 if {!$joinhigh} {
5758 assigncolor $id
5759 set t [$canv create line $coords -width [linewidth $id] \
5760 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5761 $canv lower $t
5762 bindline $t $id
5763 set lines [linsert $lines $i [list $row $le $t]]
5764 } else {
5765 $canv coords $ith $coords
5766 if {$arrow ne $ah} {
5767 $canv itemconf $ith -arrow $arrow
5769 lset lines $i 0 $row
5771 } else {
5772 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5773 set ndir [expr {$xo - $xp}]
5774 set clow [$canv coords $itl]
5775 if {$dir == $ndir} {
5776 set clow [lrange $clow 2 end]
5778 set coords [concat $coords $clow]
5779 if {!$joinhigh} {
5780 lset lines [expr {$i-1}] 1 $le
5781 } else {
5782 # coalesce two pieces
5783 $canv delete $ith
5784 set b [lindex $lines [expr {$i-1}] 0]
5785 set e [lindex $lines $i 1]
5786 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5788 $canv coords $itl $coords
5789 if {$arrow ne $al} {
5790 $canv itemconf $itl -arrow $arrow
5794 set linesegs($id) $lines
5795 return $le
5798 proc drawparentlinks {id row} {
5799 global rowidlist canv colormap curview parentlist
5800 global idpos linespc
5802 set rowids [lindex $rowidlist $row]
5803 set col [lsearch -exact $rowids $id]
5804 if {$col < 0} return
5805 set olds [lindex $parentlist $row]
5806 set row2 [expr {$row + 1}]
5807 set x [xc $row $col]
5808 set y [yc $row]
5809 set y2 [yc $row2]
5810 set d [expr {int(0.5 * $linespc)}]
5811 set ymid [expr {$y + $d}]
5812 set ids [lindex $rowidlist $row2]
5813 # rmx = right-most X coord used
5814 set rmx 0
5815 foreach p $olds {
5816 set i [lsearch -exact $ids $p]
5817 if {$i < 0} {
5818 puts "oops, parent $p of $id not in list"
5819 continue
5821 set x2 [xc $row2 $i]
5822 if {$x2 > $rmx} {
5823 set rmx $x2
5825 set j [lsearch -exact $rowids $p]
5826 if {$j < 0} {
5827 # drawlineseg will do this one for us
5828 continue
5830 assigncolor $p
5831 # should handle duplicated parents here...
5832 set coords [list $x $y]
5833 if {$i != $col} {
5834 # if attaching to a vertical segment, draw a smaller
5835 # slant for visual distinctness
5836 if {$i == $j} {
5837 if {$i < $col} {
5838 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5839 } else {
5840 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5842 } elseif {$i < $col && $i < $j} {
5843 # segment slants towards us already
5844 lappend coords [xc $row $j] $y
5845 } else {
5846 if {$i < $col - 1} {
5847 lappend coords [expr {$x2 + $linespc}] $y
5848 } elseif {$i > $col + 1} {
5849 lappend coords [expr {$x2 - $linespc}] $y
5851 lappend coords $x2 $y2
5853 } else {
5854 lappend coords $x2 $y2
5856 set t [$canv create line $coords -width [linewidth $p] \
5857 -fill $colormap($p) -tags lines.$p]
5858 $canv lower $t
5859 bindline $t $p
5861 if {$rmx > [lindex $idpos($id) 1]} {
5862 lset idpos($id) 1 $rmx
5863 redrawtags $id
5867 proc drawlines {id} {
5868 global canv
5870 $canv itemconf lines.$id -width [linewidth $id]
5873 proc drawcmittext {id row col} {
5874 global linespc canv canv2 canv3 fgcolor curview
5875 global cmitlisted commitinfo rowidlist parentlist
5876 global rowtextx idpos idtags idheads idotherrefs
5877 global linehtag linentag linedtag selectedline
5878 global canvxmax boldids boldnameids fgcolor markedid
5879 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5881 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5882 set listed $cmitlisted($curview,$id)
5883 if {$id eq $nullid} {
5884 set ofill red
5885 } elseif {$id eq $nullid2} {
5886 set ofill green
5887 } elseif {$id eq $mainheadid} {
5888 set ofill yellow
5889 } else {
5890 set ofill [lindex $circlecolors $listed]
5892 set x [xc $row $col]
5893 set y [yc $row]
5894 set orad [expr {$linespc / 3}]
5895 if {$listed <= 2} {
5896 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5897 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5898 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5899 } elseif {$listed == 3} {
5900 # triangle pointing left for left-side commits
5901 set t [$canv create polygon \
5902 [expr {$x - $orad}] $y \
5903 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5904 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5905 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5906 } else {
5907 # triangle pointing right for right-side commits
5908 set t [$canv create polygon \
5909 [expr {$x + $orad - 1}] $y \
5910 [expr {$x - $orad}] [expr {$y - $orad}] \
5911 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5912 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5914 set circleitem($row) $t
5915 $canv raise $t
5916 $canv bind $t <1> {selcanvline {} %x %y}
5917 set rmx [llength [lindex $rowidlist $row]]
5918 set olds [lindex $parentlist $row]
5919 if {$olds ne {}} {
5920 set nextids [lindex $rowidlist [expr {$row + 1}]]
5921 foreach p $olds {
5922 set i [lsearch -exact $nextids $p]
5923 if {$i > $rmx} {
5924 set rmx $i
5928 set xt [xc $row $rmx]
5929 set rowtextx($row) $xt
5930 set idpos($id) [list $x $xt $y]
5931 if {[info exists idtags($id)] || [info exists idheads($id)]
5932 || [info exists idotherrefs($id)]} {
5933 set xt [drawtags $id $x $xt $y]
5935 if {[lindex $commitinfo($id) 6] > 0} {
5936 set xt [drawnotesign $xt $y]
5938 set headline [lindex $commitinfo($id) 0]
5939 set name [lindex $commitinfo($id) 1]
5940 set date [lindex $commitinfo($id) 2]
5941 set date [formatdate $date]
5942 set font mainfont
5943 set nfont mainfont
5944 set isbold [ishighlighted $id]
5945 if {$isbold > 0} {
5946 lappend boldids $id
5947 set font mainfontbold
5948 if {$isbold > 1} {
5949 lappend boldnameids $id
5950 set nfont mainfontbold
5953 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5954 -text $headline -font $font -tags text]
5955 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5956 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5957 -text $name -font $nfont -tags text]
5958 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5959 -text $date -font mainfont -tags text]
5960 if {$selectedline == $row} {
5961 make_secsel $id
5963 if {[info exists markedid] && $markedid eq $id} {
5964 make_idmark $id
5966 set xr [expr {$xt + [font measure $font $headline]}]
5967 if {$xr > $canvxmax} {
5968 set canvxmax $xr
5969 setcanvscroll
5973 proc drawcmitrow {row} {
5974 global displayorder rowidlist nrows_drawn
5975 global iddrawn markingmatches
5976 global commitinfo numcommits
5977 global filehighlight fhighlights findpattern nhighlights
5978 global hlview vhighlights
5979 global highlight_related rhighlights
5981 if {$row >= $numcommits} return
5983 set id [lindex $displayorder $row]
5984 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5985 askvhighlight $row $id
5987 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5988 askfilehighlight $row $id
5990 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5991 askfindhighlight $row $id
5993 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5994 askrelhighlight $row $id
5996 if {![info exists iddrawn($id)]} {
5997 set col [lsearch -exact [lindex $rowidlist $row] $id]
5998 if {$col < 0} {
5999 puts "oops, row $row id $id not in list"
6000 return
6002 if {![info exists commitinfo($id)]} {
6003 getcommit $id
6005 assigncolor $id
6006 drawcmittext $id $row $col
6007 set iddrawn($id) 1
6008 incr nrows_drawn
6010 if {$markingmatches} {
6011 markrowmatches $row $id
6015 proc drawcommits {row {endrow {}}} {
6016 global numcommits iddrawn displayorder curview need_redisplay
6017 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6019 if {$row < 0} {
6020 set row 0
6022 if {$endrow eq {}} {
6023 set endrow $row
6025 if {$endrow >= $numcommits} {
6026 set endrow [expr {$numcommits - 1}]
6029 set rl1 [expr {$row - $downarrowlen - 3}]
6030 if {$rl1 < 0} {
6031 set rl1 0
6033 set ro1 [expr {$row - 3}]
6034 if {$ro1 < 0} {
6035 set ro1 0
6037 set r2 [expr {$endrow + $uparrowlen + 3}]
6038 if {$r2 > $numcommits} {
6039 set r2 $numcommits
6041 for {set r $rl1} {$r < $r2} {incr r} {
6042 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6043 if {$rl1 < $r} {
6044 layoutrows $rl1 $r
6046 set rl1 [expr {$r + 1}]
6049 if {$rl1 < $r} {
6050 layoutrows $rl1 $r
6052 optimize_rows $ro1 0 $r2
6053 if {$need_redisplay || $nrows_drawn > 2000} {
6054 clear_display
6057 # make the lines join to already-drawn rows either side
6058 set r [expr {$row - 1}]
6059 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6060 set r $row
6062 set er [expr {$endrow + 1}]
6063 if {$er >= $numcommits ||
6064 ![info exists iddrawn([lindex $displayorder $er])]} {
6065 set er $endrow
6067 for {} {$r <= $er} {incr r} {
6068 set id [lindex $displayorder $r]
6069 set wasdrawn [info exists iddrawn($id)]
6070 drawcmitrow $r
6071 if {$r == $er} break
6072 set nextid [lindex $displayorder [expr {$r + 1}]]
6073 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6074 drawparentlinks $id $r
6076 set rowids [lindex $rowidlist $r]
6077 foreach lid $rowids {
6078 if {$lid eq {}} continue
6079 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6080 if {$lid eq $id} {
6081 # see if this is the first child of any of its parents
6082 foreach p [lindex $parentlist $r] {
6083 if {[lsearch -exact $rowids $p] < 0} {
6084 # make this line extend up to the child
6085 set lineend($p) [drawlineseg $p $r $er 0]
6088 } else {
6089 set lineend($lid) [drawlineseg $lid $r $er 1]
6095 proc undolayout {row} {
6096 global uparrowlen mingaplen downarrowlen
6097 global rowidlist rowisopt rowfinal need_redisplay
6099 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6100 if {$r < 0} {
6101 set r 0
6103 if {[llength $rowidlist] > $r} {
6104 incr r -1
6105 set rowidlist [lrange $rowidlist 0 $r]
6106 set rowfinal [lrange $rowfinal 0 $r]
6107 set rowisopt [lrange $rowisopt 0 $r]
6108 set need_redisplay 1
6109 run drawvisible
6113 proc drawvisible {} {
6114 global canv linespc curview vrowmod selectedline targetrow targetid
6115 global need_redisplay cscroll numcommits
6117 set fs [$canv yview]
6118 set ymax [lindex [$canv cget -scrollregion] 3]
6119 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6120 set f0 [lindex $fs 0]
6121 set f1 [lindex $fs 1]
6122 set y0 [expr {int($f0 * $ymax)}]
6123 set y1 [expr {int($f1 * $ymax)}]
6125 if {[info exists targetid]} {
6126 if {[commitinview $targetid $curview]} {
6127 set r [rowofcommit $targetid]
6128 if {$r != $targetrow} {
6129 # Fix up the scrollregion and change the scrolling position
6130 # now that our target row has moved.
6131 set diff [expr {($r - $targetrow) * $linespc}]
6132 set targetrow $r
6133 setcanvscroll
6134 set ymax [lindex [$canv cget -scrollregion] 3]
6135 incr y0 $diff
6136 incr y1 $diff
6137 set f0 [expr {$y0 / $ymax}]
6138 set f1 [expr {$y1 / $ymax}]
6139 allcanvs yview moveto $f0
6140 $cscroll set $f0 $f1
6141 set need_redisplay 1
6143 } else {
6144 unset targetid
6148 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6149 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6150 if {$endrow >= $vrowmod($curview)} {
6151 update_arcrows $curview
6153 if {$selectedline ne {} &&
6154 $row <= $selectedline && $selectedline <= $endrow} {
6155 set targetrow $selectedline
6156 } elseif {[info exists targetid]} {
6157 set targetrow [expr {int(($row + $endrow) / 2)}]
6159 if {[info exists targetrow]} {
6160 if {$targetrow >= $numcommits} {
6161 set targetrow [expr {$numcommits - 1}]
6163 set targetid [commitonrow $targetrow]
6165 drawcommits $row $endrow
6168 proc clear_display {} {
6169 global iddrawn linesegs need_redisplay nrows_drawn
6170 global vhighlights fhighlights nhighlights rhighlights
6171 global linehtag linentag linedtag boldids boldnameids
6173 allcanvs delete all
6174 catch {unset iddrawn}
6175 catch {unset linesegs}
6176 catch {unset linehtag}
6177 catch {unset linentag}
6178 catch {unset linedtag}
6179 set boldids {}
6180 set boldnameids {}
6181 catch {unset vhighlights}
6182 catch {unset fhighlights}
6183 catch {unset nhighlights}
6184 catch {unset rhighlights}
6185 set need_redisplay 0
6186 set nrows_drawn 0
6189 proc findcrossings {id} {
6190 global rowidlist parentlist numcommits displayorder
6192 set cross {}
6193 set ccross {}
6194 foreach {s e} [rowranges $id] {
6195 if {$e >= $numcommits} {
6196 set e [expr {$numcommits - 1}]
6198 if {$e <= $s} continue
6199 for {set row $e} {[incr row -1] >= $s} {} {
6200 set x [lsearch -exact [lindex $rowidlist $row] $id]
6201 if {$x < 0} break
6202 set olds [lindex $parentlist $row]
6203 set kid [lindex $displayorder $row]
6204 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6205 if {$kidx < 0} continue
6206 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6207 foreach p $olds {
6208 set px [lsearch -exact $nextrow $p]
6209 if {$px < 0} continue
6210 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6211 if {[lsearch -exact $ccross $p] >= 0} continue
6212 if {$x == $px + ($kidx < $px? -1: 1)} {
6213 lappend ccross $p
6214 } elseif {[lsearch -exact $cross $p] < 0} {
6215 lappend cross $p
6221 return [concat $ccross {{}} $cross]
6224 proc assigncolor {id} {
6225 global colormap colors nextcolor
6226 global parents children children curview
6228 if {[info exists colormap($id)]} return
6229 set ncolors [llength $colors]
6230 if {[info exists children($curview,$id)]} {
6231 set kids $children($curview,$id)
6232 } else {
6233 set kids {}
6235 if {[llength $kids] == 1} {
6236 set child [lindex $kids 0]
6237 if {[info exists colormap($child)]
6238 && [llength $parents($curview,$child)] == 1} {
6239 set colormap($id) $colormap($child)
6240 return
6243 set badcolors {}
6244 set origbad {}
6245 foreach x [findcrossings $id] {
6246 if {$x eq {}} {
6247 # delimiter between corner crossings and other crossings
6248 if {[llength $badcolors] >= $ncolors - 1} break
6249 set origbad $badcolors
6251 if {[info exists colormap($x)]
6252 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6253 lappend badcolors $colormap($x)
6256 if {[llength $badcolors] >= $ncolors} {
6257 set badcolors $origbad
6259 set origbad $badcolors
6260 if {[llength $badcolors] < $ncolors - 1} {
6261 foreach child $kids {
6262 if {[info exists colormap($child)]
6263 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6264 lappend badcolors $colormap($child)
6266 foreach p $parents($curview,$child) {
6267 if {[info exists colormap($p)]
6268 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6269 lappend badcolors $colormap($p)
6273 if {[llength $badcolors] >= $ncolors} {
6274 set badcolors $origbad
6277 for {set i 0} {$i <= $ncolors} {incr i} {
6278 set c [lindex $colors $nextcolor]
6279 if {[incr nextcolor] >= $ncolors} {
6280 set nextcolor 0
6282 if {[lsearch -exact $badcolors $c]} break
6284 set colormap($id) $c
6287 proc bindline {t id} {
6288 global canv
6290 $canv bind $t <Enter> "lineenter %x %y $id"
6291 $canv bind $t <Motion> "linemotion %x %y $id"
6292 $canv bind $t <Leave> "lineleave $id"
6293 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6296 proc drawtags {id x xt y1} {
6297 global idtags idheads idotherrefs mainhead
6298 global linespc lthickness
6299 global canv rowtextx curview fgcolor bgcolor ctxbut
6301 set marks {}
6302 set ntags 0
6303 set nheads 0
6304 if {[info exists idtags($id)]} {
6305 set marks $idtags($id)
6306 set ntags [llength $marks]
6308 if {[info exists idheads($id)]} {
6309 set marks [concat $marks $idheads($id)]
6310 set nheads [llength $idheads($id)]
6312 if {[info exists idotherrefs($id)]} {
6313 set marks [concat $marks $idotherrefs($id)]
6315 if {$marks eq {}} {
6316 return $xt
6319 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6320 set yt [expr {$y1 - 0.5 * $linespc}]
6321 set yb [expr {$yt + $linespc - 1}]
6322 set xvals {}
6323 set wvals {}
6324 set i -1
6325 foreach tag $marks {
6326 incr i
6327 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6328 set wid [font measure mainfontbold $tag]
6329 } else {
6330 set wid [font measure mainfont $tag]
6332 lappend xvals $xt
6333 lappend wvals $wid
6334 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6336 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6337 -width $lthickness -fill black -tags tag.$id]
6338 $canv lower $t
6339 foreach tag $marks x $xvals wid $wvals {
6340 set tag_quoted [string map {% %%} $tag]
6341 set xl [expr {$x + $delta}]
6342 set xr [expr {$x + $delta + $wid + $lthickness}]
6343 set font mainfont
6344 if {[incr ntags -1] >= 0} {
6345 # draw a tag
6346 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6347 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6348 -width 1 -outline black -fill yellow -tags tag.$id]
6349 $canv bind $t <1> [list showtag $tag_quoted 1]
6350 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6351 } else {
6352 # draw a head or other ref
6353 if {[incr nheads -1] >= 0} {
6354 set col green
6355 if {$tag eq $mainhead} {
6356 set font mainfontbold
6358 } else {
6359 set col "#ddddff"
6361 set xl [expr {$xl - $delta/2}]
6362 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6363 -width 1 -outline black -fill $col -tags tag.$id
6364 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6365 set rwid [font measure mainfont $remoteprefix]
6366 set xi [expr {$x + 1}]
6367 set yti [expr {$yt + 1}]
6368 set xri [expr {$x + $rwid}]
6369 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6370 -width 0 -fill "#ffddaa" -tags tag.$id
6373 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6374 -font $font -tags [list tag.$id text]]
6375 if {$ntags >= 0} {
6376 $canv bind $t <1> [list showtag $tag_quoted 1]
6377 } elseif {$nheads >= 0} {
6378 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6381 return $xt
6384 proc drawnotesign {xt y} {
6385 global linespc canv fgcolor
6387 set orad [expr {$linespc / 3}]
6388 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6389 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6390 -fill yellow -outline $fgcolor -width 1 -tags circle]
6391 set xt [expr {$xt + $orad * 3}]
6392 return $xt
6395 proc xcoord {i level ln} {
6396 global canvx0 xspc1 xspc2
6398 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6399 if {$i > 0 && $i == $level} {
6400 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6401 } elseif {$i > $level} {
6402 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6404 return $x
6407 proc show_status {msg} {
6408 global canv fgcolor
6410 clear_display
6411 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6412 -tags text -fill $fgcolor
6415 # Don't change the text pane cursor if it is currently the hand cursor,
6416 # showing that we are over a sha1 ID link.
6417 proc settextcursor {c} {
6418 global ctext curtextcursor
6420 if {[$ctext cget -cursor] == $curtextcursor} {
6421 $ctext config -cursor $c
6423 set curtextcursor $c
6426 proc nowbusy {what {name {}}} {
6427 global isbusy busyname statusw
6429 if {[array names isbusy] eq {}} {
6430 . config -cursor watch
6431 settextcursor watch
6433 set isbusy($what) 1
6434 set busyname($what) $name
6435 if {$name ne {}} {
6436 $statusw conf -text $name
6440 proc notbusy {what} {
6441 global isbusy maincursor textcursor busyname statusw
6443 catch {
6444 unset isbusy($what)
6445 if {$busyname($what) ne {} &&
6446 [$statusw cget -text] eq $busyname($what)} {
6447 $statusw conf -text {}
6450 if {[array names isbusy] eq {}} {
6451 . config -cursor $maincursor
6452 settextcursor $textcursor
6456 proc findmatches {f} {
6457 global findtype findstring
6458 if {$findtype == [mc "Regexp"]} {
6459 set matches [regexp -indices -all -inline $findstring $f]
6460 } else {
6461 set fs $findstring
6462 if {$findtype == [mc "IgnCase"]} {
6463 set f [string tolower $f]
6464 set fs [string tolower $fs]
6466 set matches {}
6467 set i 0
6468 set l [string length $fs]
6469 while {[set j [string first $fs $f $i]] >= 0} {
6470 lappend matches [list $j [expr {$j+$l-1}]]
6471 set i [expr {$j + $l}]
6474 return $matches
6477 proc dofind {{dirn 1} {wrap 1}} {
6478 global findstring findstartline findcurline selectedline numcommits
6479 global gdttype filehighlight fh_serial find_dirn findallowwrap
6481 if {[info exists find_dirn]} {
6482 if {$find_dirn == $dirn} return
6483 stopfinding
6485 focus .
6486 if {$findstring eq {} || $numcommits == 0} return
6487 if {$selectedline eq {}} {
6488 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6489 } else {
6490 set findstartline $selectedline
6492 set findcurline $findstartline
6493 nowbusy finding [mc "Searching"]
6494 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6495 after cancel do_file_hl $fh_serial
6496 do_file_hl $fh_serial
6498 set find_dirn $dirn
6499 set findallowwrap $wrap
6500 run findmore
6503 proc stopfinding {} {
6504 global find_dirn findcurline fprogcoord
6506 if {[info exists find_dirn]} {
6507 unset find_dirn
6508 unset findcurline
6509 notbusy finding
6510 set fprogcoord 0
6511 adjustprogress
6513 stopblaming
6516 proc findmore {} {
6517 global commitdata commitinfo numcommits findpattern findloc
6518 global findstartline findcurline findallowwrap
6519 global find_dirn gdttype fhighlights fprogcoord
6520 global curview varcorder vrownum varccommits vrowmod
6522 if {![info exists find_dirn]} {
6523 return 0
6525 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6526 set l $findcurline
6527 set moretodo 0
6528 if {$find_dirn > 0} {
6529 incr l
6530 if {$l >= $numcommits} {
6531 set l 0
6533 if {$l <= $findstartline} {
6534 set lim [expr {$findstartline + 1}]
6535 } else {
6536 set lim $numcommits
6537 set moretodo $findallowwrap
6539 } else {
6540 if {$l == 0} {
6541 set l $numcommits
6543 incr l -1
6544 if {$l >= $findstartline} {
6545 set lim [expr {$findstartline - 1}]
6546 } else {
6547 set lim -1
6548 set moretodo $findallowwrap
6551 set n [expr {($lim - $l) * $find_dirn}]
6552 if {$n > 500} {
6553 set n 500
6554 set moretodo 1
6556 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6557 update_arcrows $curview
6559 set found 0
6560 set domore 1
6561 set ai [bsearch $vrownum($curview) $l]
6562 set a [lindex $varcorder($curview) $ai]
6563 set arow [lindex $vrownum($curview) $ai]
6564 set ids [lindex $varccommits($curview,$a)]
6565 set arowend [expr {$arow + [llength $ids]}]
6566 if {$gdttype eq [mc "containing:"]} {
6567 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6568 if {$l < $arow || $l >= $arowend} {
6569 incr ai $find_dirn
6570 set a [lindex $varcorder($curview) $ai]
6571 set arow [lindex $vrownum($curview) $ai]
6572 set ids [lindex $varccommits($curview,$a)]
6573 set arowend [expr {$arow + [llength $ids]}]
6575 set id [lindex $ids [expr {$l - $arow}]]
6576 # shouldn't happen unless git log doesn't give all the commits...
6577 if {![info exists commitdata($id)] ||
6578 ![doesmatch $commitdata($id)]} {
6579 continue
6581 if {![info exists commitinfo($id)]} {
6582 getcommit $id
6584 set info $commitinfo($id)
6585 foreach f $info ty $fldtypes {
6586 if {$ty eq ""} continue
6587 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6588 [doesmatch $f]} {
6589 set found 1
6590 break
6593 if {$found} break
6595 } else {
6596 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6597 if {$l < $arow || $l >= $arowend} {
6598 incr ai $find_dirn
6599 set a [lindex $varcorder($curview) $ai]
6600 set arow [lindex $vrownum($curview) $ai]
6601 set ids [lindex $varccommits($curview,$a)]
6602 set arowend [expr {$arow + [llength $ids]}]
6604 set id [lindex $ids [expr {$l - $arow}]]
6605 if {![info exists fhighlights($id)]} {
6606 # this sets fhighlights($id) to -1
6607 askfilehighlight $l $id
6609 if {$fhighlights($id) > 0} {
6610 set found $domore
6611 break
6613 if {$fhighlights($id) < 0} {
6614 if {$domore} {
6615 set domore 0
6616 set findcurline [expr {$l - $find_dirn}]
6621 if {$found || ($domore && !$moretodo)} {
6622 unset findcurline
6623 unset find_dirn
6624 notbusy finding
6625 set fprogcoord 0
6626 adjustprogress
6627 if {$found} {
6628 findselectline $l
6629 } else {
6630 bell
6632 return 0
6634 if {!$domore} {
6635 flushhighlights
6636 } else {
6637 set findcurline [expr {$l - $find_dirn}]
6639 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6640 if {$n < 0} {
6641 incr n $numcommits
6643 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6644 adjustprogress
6645 return $domore
6648 proc findselectline {l} {
6649 global findloc commentend ctext findcurline markingmatches gdttype
6651 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6652 set findcurline $l
6653 selectline $l 1
6654 if {$markingmatches &&
6655 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6656 # highlight the matches in the comments
6657 set f [$ctext get 1.0 $commentend]
6658 set matches [findmatches $f]
6659 foreach match $matches {
6660 set start [lindex $match 0]
6661 set end [expr {[lindex $match 1] + 1}]
6662 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6665 drawvisible
6668 # mark the bits of a headline or author that match a find string
6669 proc markmatches {canv l str tag matches font row} {
6670 global selectedline
6672 set bbox [$canv bbox $tag]
6673 set x0 [lindex $bbox 0]
6674 set y0 [lindex $bbox 1]
6675 set y1 [lindex $bbox 3]
6676 foreach match $matches {
6677 set start [lindex $match 0]
6678 set end [lindex $match 1]
6679 if {$start > $end} continue
6680 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6681 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6682 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6683 [expr {$x0+$xlen+2}] $y1 \
6684 -outline {} -tags [list match$l matches] -fill yellow]
6685 $canv lower $t
6686 if {$row == $selectedline} {
6687 $canv raise $t secsel
6692 proc unmarkmatches {} {
6693 global markingmatches
6695 allcanvs delete matches
6696 set markingmatches 0
6697 stopfinding
6700 proc selcanvline {w x y} {
6701 global canv canvy0 ctext linespc
6702 global rowtextx
6703 set ymax [lindex [$canv cget -scrollregion] 3]
6704 if {$ymax == {}} return
6705 set yfrac [lindex [$canv yview] 0]
6706 set y [expr {$y + $yfrac * $ymax}]
6707 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6708 if {$l < 0} {
6709 set l 0
6711 if {$w eq $canv} {
6712 set xmax [lindex [$canv cget -scrollregion] 2]
6713 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6714 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6716 unmarkmatches
6717 selectline $l 1
6720 proc commit_descriptor {p} {
6721 global commitinfo
6722 if {![info exists commitinfo($p)]} {
6723 getcommit $p
6725 set l "..."
6726 if {[llength $commitinfo($p)] > 1} {
6727 set l [lindex $commitinfo($p) 0]
6729 return "$p ($l)\n"
6732 # append some text to the ctext widget, and make any SHA1 ID
6733 # that we know about be a clickable link.
6734 proc appendwithlinks {text tags} {
6735 global ctext linknum curview
6737 set start [$ctext index "end - 1c"]
6738 $ctext insert end $text $tags
6739 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6740 foreach l $links {
6741 set s [lindex $l 0]
6742 set e [lindex $l 1]
6743 set linkid [string range $text $s $e]
6744 incr e
6745 $ctext tag delete link$linknum
6746 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6747 setlink $linkid link$linknum
6748 incr linknum
6752 proc setlink {id lk} {
6753 global curview ctext pendinglinks
6755 if {[string range $id 0 1] eq "-g"} {
6756 set id [string range $id 2 end]
6759 set known 0
6760 if {[string length $id] < 40} {
6761 set matches [longid $id]
6762 if {[llength $matches] > 0} {
6763 if {[llength $matches] > 1} return
6764 set known 1
6765 set id [lindex $matches 0]
6767 } else {
6768 set known [commitinview $id $curview]
6770 if {$known} {
6771 $ctext tag conf $lk -foreground blue -underline 1
6772 $ctext tag bind $lk <1> [list selbyid $id]
6773 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6774 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6775 } else {
6776 lappend pendinglinks($id) $lk
6777 interestedin $id {makelink %P}
6781 proc appendshortlink {id {pre {}} {post {}}} {
6782 global ctext linknum
6784 $ctext insert end $pre
6785 $ctext tag delete link$linknum
6786 $ctext insert end [string range $id 0 7] link$linknum
6787 $ctext insert end $post
6788 setlink $id link$linknum
6789 incr linknum
6792 proc makelink {id} {
6793 global pendinglinks
6795 if {![info exists pendinglinks($id)]} return
6796 foreach lk $pendinglinks($id) {
6797 setlink $id $lk
6799 unset pendinglinks($id)
6802 proc linkcursor {w inc} {
6803 global linkentercount curtextcursor
6805 if {[incr linkentercount $inc] > 0} {
6806 $w configure -cursor hand2
6807 } else {
6808 $w configure -cursor $curtextcursor
6809 if {$linkentercount < 0} {
6810 set linkentercount 0
6815 proc viewnextline {dir} {
6816 global canv linespc
6818 $canv delete hover
6819 set ymax [lindex [$canv cget -scrollregion] 3]
6820 set wnow [$canv yview]
6821 set wtop [expr {[lindex $wnow 0] * $ymax}]
6822 set newtop [expr {$wtop + $dir * $linespc}]
6823 if {$newtop < 0} {
6824 set newtop 0
6825 } elseif {$newtop > $ymax} {
6826 set newtop $ymax
6828 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6831 # add a list of tag or branch names at position pos
6832 # returns the number of names inserted
6833 proc appendrefs {pos ids var} {
6834 global ctext linknum curview $var maxrefs
6836 if {[catch {$ctext index $pos}]} {
6837 return 0
6839 $ctext conf -state normal
6840 $ctext delete $pos "$pos lineend"
6841 set tags {}
6842 foreach id $ids {
6843 foreach tag [set $var\($id\)] {
6844 lappend tags [list $tag $id]
6847 if {[llength $tags] > $maxrefs} {
6848 $ctext insert $pos "[mc "many"] ([llength $tags])"
6849 } else {
6850 set tags [lsort -index 0 -decreasing $tags]
6851 set sep {}
6852 foreach ti $tags {
6853 set id [lindex $ti 1]
6854 set lk link$linknum
6855 incr linknum
6856 $ctext tag delete $lk
6857 $ctext insert $pos $sep
6858 $ctext insert $pos [lindex $ti 0] $lk
6859 setlink $id $lk
6860 set sep ", "
6863 $ctext conf -state disabled
6864 return [llength $tags]
6867 # called when we have finished computing the nearby tags
6868 proc dispneartags {delay} {
6869 global selectedline currentid showneartags tagphase
6871 if {$selectedline eq {} || !$showneartags} return
6872 after cancel dispnexttag
6873 if {$delay} {
6874 after 200 dispnexttag
6875 set tagphase -1
6876 } else {
6877 after idle dispnexttag
6878 set tagphase 0
6882 proc dispnexttag {} {
6883 global selectedline currentid showneartags tagphase ctext
6885 if {$selectedline eq {} || !$showneartags} return
6886 switch -- $tagphase {
6888 set dtags [desctags $currentid]
6889 if {$dtags ne {}} {
6890 appendrefs precedes $dtags idtags
6894 set atags [anctags $currentid]
6895 if {$atags ne {}} {
6896 appendrefs follows $atags idtags
6900 set dheads [descheads $currentid]
6901 if {$dheads ne {}} {
6902 if {[appendrefs branch $dheads idheads] > 1
6903 && [$ctext get "branch -3c"] eq "h"} {
6904 # turn "Branch" into "Branches"
6905 $ctext conf -state normal
6906 $ctext insert "branch -2c" "es"
6907 $ctext conf -state disabled
6912 if {[incr tagphase] <= 2} {
6913 after idle dispnexttag
6917 proc make_secsel {id} {
6918 global linehtag linentag linedtag canv canv2 canv3
6920 if {![info exists linehtag($id)]} return
6921 $canv delete secsel
6922 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6923 -tags secsel -fill [$canv cget -selectbackground]]
6924 $canv lower $t
6925 $canv2 delete secsel
6926 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6927 -tags secsel -fill [$canv2 cget -selectbackground]]
6928 $canv2 lower $t
6929 $canv3 delete secsel
6930 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6931 -tags secsel -fill [$canv3 cget -selectbackground]]
6932 $canv3 lower $t
6935 proc make_idmark {id} {
6936 global linehtag canv fgcolor
6938 if {![info exists linehtag($id)]} return
6939 $canv delete markid
6940 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6941 -tags markid -outline $fgcolor]
6942 $canv raise $t
6945 proc selectline {l isnew {desired_loc {}}} {
6946 global canv ctext commitinfo selectedline
6947 global canvy0 linespc parents children curview
6948 global currentid sha1entry
6949 global commentend idtags linknum
6950 global mergemax numcommits pending_select
6951 global cmitmode showneartags allcommits
6952 global targetrow targetid lastscrollrows
6953 global autoselect autosellen jump_to_here
6955 catch {unset pending_select}
6956 $canv delete hover
6957 normalline
6958 unsel_reflist
6959 stopfinding
6960 if {$l < 0 || $l >= $numcommits} return
6961 set id [commitonrow $l]
6962 set targetid $id
6963 set targetrow $l
6964 set selectedline $l
6965 set currentid $id
6966 if {$lastscrollrows < $numcommits} {
6967 setcanvscroll
6970 set y [expr {$canvy0 + $l * $linespc}]
6971 set ymax [lindex [$canv cget -scrollregion] 3]
6972 set ytop [expr {$y - $linespc - 1}]
6973 set ybot [expr {$y + $linespc + 1}]
6974 set wnow [$canv yview]
6975 set wtop [expr {[lindex $wnow 0] * $ymax}]
6976 set wbot [expr {[lindex $wnow 1] * $ymax}]
6977 set wh [expr {$wbot - $wtop}]
6978 set newtop $wtop
6979 if {$ytop < $wtop} {
6980 if {$ybot < $wtop} {
6981 set newtop [expr {$y - $wh / 2.0}]
6982 } else {
6983 set newtop $ytop
6984 if {$newtop > $wtop - $linespc} {
6985 set newtop [expr {$wtop - $linespc}]
6988 } elseif {$ybot > $wbot} {
6989 if {$ytop > $wbot} {
6990 set newtop [expr {$y - $wh / 2.0}]
6991 } else {
6992 set newtop [expr {$ybot - $wh}]
6993 if {$newtop < $wtop + $linespc} {
6994 set newtop [expr {$wtop + $linespc}]
6998 if {$newtop != $wtop} {
6999 if {$newtop < 0} {
7000 set newtop 0
7002 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7003 drawvisible
7006 make_secsel $id
7008 if {$isnew} {
7009 addtohistory [list selbyid $id 0] savecmitpos
7012 $sha1entry delete 0 end
7013 $sha1entry insert 0 $id
7014 if {$autoselect} {
7015 $sha1entry selection range 0 $autosellen
7017 rhighlight_sel $id
7019 $ctext conf -state normal
7020 clear_ctext
7021 set linknum 0
7022 if {![info exists commitinfo($id)]} {
7023 getcommit $id
7025 set info $commitinfo($id)
7026 set date [formatdate [lindex $info 2]]
7027 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7028 set date [formatdate [lindex $info 4]]
7029 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7030 if {[info exists idtags($id)]} {
7031 $ctext insert end [mc "Tags:"]
7032 foreach tag $idtags($id) {
7033 $ctext insert end " $tag"
7035 $ctext insert end "\n"
7038 set headers {}
7039 set olds $parents($curview,$id)
7040 if {[llength $olds] > 1} {
7041 set np 0
7042 foreach p $olds {
7043 if {$np >= $mergemax} {
7044 set tag mmax
7045 } else {
7046 set tag m$np
7048 $ctext insert end "[mc "Parent"]: " $tag
7049 appendwithlinks [commit_descriptor $p] {}
7050 incr np
7052 } else {
7053 foreach p $olds {
7054 append headers "[mc "Parent"]: [commit_descriptor $p]"
7058 foreach c $children($curview,$id) {
7059 append headers "[mc "Child"]: [commit_descriptor $c]"
7062 # make anything that looks like a SHA1 ID be a clickable link
7063 appendwithlinks $headers {}
7064 if {$showneartags} {
7065 if {![info exists allcommits]} {
7066 getallcommits
7068 $ctext insert end "[mc "Branch"]: "
7069 $ctext mark set branch "end -1c"
7070 $ctext mark gravity branch left
7071 $ctext insert end "\n[mc "Follows"]: "
7072 $ctext mark set follows "end -1c"
7073 $ctext mark gravity follows left
7074 $ctext insert end "\n[mc "Precedes"]: "
7075 $ctext mark set precedes "end -1c"
7076 $ctext mark gravity precedes left
7077 $ctext insert end "\n"
7078 dispneartags 1
7080 $ctext insert end "\n"
7081 set comment [lindex $info 5]
7082 if {[string first "\r" $comment] >= 0} {
7083 set comment [string map {"\r" "\n "} $comment]
7085 appendwithlinks $comment {comment}
7087 $ctext tag remove found 1.0 end
7088 $ctext conf -state disabled
7089 set commentend [$ctext index "end - 1c"]
7091 set jump_to_here $desired_loc
7092 init_flist [mc "Comments"]
7093 if {$cmitmode eq "tree"} {
7094 gettree $id
7095 } elseif {[llength $olds] <= 1} {
7096 startdiff $id
7097 } else {
7098 mergediff $id
7102 proc selfirstline {} {
7103 unmarkmatches
7104 selectline 0 1
7107 proc sellastline {} {
7108 global numcommits
7109 unmarkmatches
7110 set l [expr {$numcommits - 1}]
7111 selectline $l 1
7114 proc selnextline {dir} {
7115 global selectedline
7116 focus .
7117 if {$selectedline eq {}} return
7118 set l [expr {$selectedline + $dir}]
7119 unmarkmatches
7120 selectline $l 1
7123 proc selnextpage {dir} {
7124 global canv linespc selectedline numcommits
7126 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7127 if {$lpp < 1} {
7128 set lpp 1
7130 allcanvs yview scroll [expr {$dir * $lpp}] units
7131 drawvisible
7132 if {$selectedline eq {}} return
7133 set l [expr {$selectedline + $dir * $lpp}]
7134 if {$l < 0} {
7135 set l 0
7136 } elseif {$l >= $numcommits} {
7137 set l [expr $numcommits - 1]
7139 unmarkmatches
7140 selectline $l 1
7143 proc unselectline {} {
7144 global selectedline currentid
7146 set selectedline {}
7147 catch {unset currentid}
7148 allcanvs delete secsel
7149 rhighlight_none
7152 proc reselectline {} {
7153 global selectedline
7155 if {$selectedline ne {}} {
7156 selectline $selectedline 0
7160 proc addtohistory {cmd {saveproc {}}} {
7161 global history historyindex curview
7163 unset_posvars
7164 save_position
7165 set elt [list $curview $cmd $saveproc {}]
7166 if {$historyindex > 0
7167 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7168 return
7171 if {$historyindex < [llength $history]} {
7172 set history [lreplace $history $historyindex end $elt]
7173 } else {
7174 lappend history $elt
7176 incr historyindex
7177 if {$historyindex > 1} {
7178 .tf.bar.leftbut conf -state normal
7179 } else {
7180 .tf.bar.leftbut conf -state disabled
7182 .tf.bar.rightbut conf -state disabled
7185 # save the scrolling position of the diff display pane
7186 proc save_position {} {
7187 global historyindex history
7189 if {$historyindex < 1} return
7190 set hi [expr {$historyindex - 1}]
7191 set fn [lindex $history $hi 2]
7192 if {$fn ne {}} {
7193 lset history $hi 3 [eval $fn]
7197 proc unset_posvars {} {
7198 global last_posvars
7200 if {[info exists last_posvars]} {
7201 foreach {var val} $last_posvars {
7202 global $var
7203 catch {unset $var}
7205 unset last_posvars
7209 proc godo {elt} {
7210 global curview last_posvars
7212 set view [lindex $elt 0]
7213 set cmd [lindex $elt 1]
7214 set pv [lindex $elt 3]
7215 if {$curview != $view} {
7216 showview $view
7218 unset_posvars
7219 foreach {var val} $pv {
7220 global $var
7221 set $var $val
7223 set last_posvars $pv
7224 eval $cmd
7227 proc goback {} {
7228 global history historyindex
7229 focus .
7231 if {$historyindex > 1} {
7232 save_position
7233 incr historyindex -1
7234 godo [lindex $history [expr {$historyindex - 1}]]
7235 .tf.bar.rightbut conf -state normal
7237 if {$historyindex <= 1} {
7238 .tf.bar.leftbut conf -state disabled
7242 proc goforw {} {
7243 global history historyindex
7244 focus .
7246 if {$historyindex < [llength $history]} {
7247 save_position
7248 set cmd [lindex $history $historyindex]
7249 incr historyindex
7250 godo $cmd
7251 .tf.bar.leftbut conf -state normal
7253 if {$historyindex >= [llength $history]} {
7254 .tf.bar.rightbut conf -state disabled
7258 proc gettree {id} {
7259 global treefilelist treeidlist diffids diffmergeid treepending
7260 global nullid nullid2
7262 set diffids $id
7263 catch {unset diffmergeid}
7264 if {![info exists treefilelist($id)]} {
7265 if {![info exists treepending]} {
7266 if {$id eq $nullid} {
7267 set cmd [list | git ls-files]
7268 } elseif {$id eq $nullid2} {
7269 set cmd [list | git ls-files --stage -t]
7270 } else {
7271 set cmd [list | git ls-tree -r $id]
7273 if {[catch {set gtf [open $cmd r]}]} {
7274 return
7276 set treepending $id
7277 set treefilelist($id) {}
7278 set treeidlist($id) {}
7279 fconfigure $gtf -blocking 0 -encoding binary
7280 filerun $gtf [list gettreeline $gtf $id]
7282 } else {
7283 setfilelist $id
7287 proc gettreeline {gtf id} {
7288 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7290 set nl 0
7291 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7292 if {$diffids eq $nullid} {
7293 set fname $line
7294 } else {
7295 set i [string first "\t" $line]
7296 if {$i < 0} continue
7297 set fname [string range $line [expr {$i+1}] end]
7298 set line [string range $line 0 [expr {$i-1}]]
7299 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7300 set sha1 [lindex $line 2]
7301 lappend treeidlist($id) $sha1
7303 if {[string index $fname 0] eq "\""} {
7304 set fname [lindex $fname 0]
7306 set fname [encoding convertfrom $fname]
7307 lappend treefilelist($id) $fname
7309 if {![eof $gtf]} {
7310 return [expr {$nl >= 1000? 2: 1}]
7312 close $gtf
7313 unset treepending
7314 if {$cmitmode ne "tree"} {
7315 if {![info exists diffmergeid]} {
7316 gettreediffs $diffids
7318 } elseif {$id ne $diffids} {
7319 gettree $diffids
7320 } else {
7321 setfilelist $id
7323 return 0
7326 proc showfile {f} {
7327 global treefilelist treeidlist diffids nullid nullid2
7328 global ctext_file_names ctext_file_lines
7329 global ctext commentend
7331 set i [lsearch -exact $treefilelist($diffids) $f]
7332 if {$i < 0} {
7333 puts "oops, $f not in list for id $diffids"
7334 return
7336 if {$diffids eq $nullid} {
7337 if {[catch {set bf [open $f r]} err]} {
7338 puts "oops, can't read $f: $err"
7339 return
7341 } else {
7342 set blob [lindex $treeidlist($diffids) $i]
7343 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7344 puts "oops, error reading blob $blob: $err"
7345 return
7348 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7349 filerun $bf [list getblobline $bf $diffids]
7350 $ctext config -state normal
7351 clear_ctext $commentend
7352 lappend ctext_file_names $f
7353 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7354 $ctext insert end "\n"
7355 $ctext insert end "$f\n" filesep
7356 $ctext config -state disabled
7357 $ctext yview $commentend
7358 settabs 0
7361 proc getblobline {bf id} {
7362 global diffids cmitmode ctext
7364 if {$id ne $diffids || $cmitmode ne "tree"} {
7365 catch {close $bf}
7366 return 0
7368 $ctext config -state normal
7369 set nl 0
7370 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7371 $ctext insert end "$line\n"
7373 if {[eof $bf]} {
7374 global jump_to_here ctext_file_names commentend
7376 # delete last newline
7377 $ctext delete "end - 2c" "end - 1c"
7378 close $bf
7379 if {$jump_to_here ne {} &&
7380 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7381 set lnum [expr {[lindex $jump_to_here 1] +
7382 [lindex [split $commentend .] 0]}]
7383 mark_ctext_line $lnum
7385 $ctext config -state disabled
7386 return 0
7388 $ctext config -state disabled
7389 return [expr {$nl >= 1000? 2: 1}]
7392 proc mark_ctext_line {lnum} {
7393 global ctext markbgcolor
7395 $ctext tag delete omark
7396 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7397 $ctext tag conf omark -background $markbgcolor
7398 $ctext see $lnum.0
7401 proc mergediff {id} {
7402 global diffmergeid
7403 global diffids treediffs
7404 global parents curview
7406 set diffmergeid $id
7407 set diffids $id
7408 set treediffs($id) {}
7409 set np [llength $parents($curview,$id)]
7410 settabs $np
7411 getblobdiffs $id
7414 proc startdiff {ids} {
7415 global treediffs diffids treepending diffmergeid nullid nullid2
7417 settabs 1
7418 set diffids $ids
7419 catch {unset diffmergeid}
7420 if {![info exists treediffs($ids)] ||
7421 [lsearch -exact $ids $nullid] >= 0 ||
7422 [lsearch -exact $ids $nullid2] >= 0} {
7423 if {![info exists treepending]} {
7424 gettreediffs $ids
7426 } else {
7427 addtocflist $ids
7431 # If the filename (name) is under any of the passed filter paths
7432 # then return true to include the file in the listing.
7433 proc path_filter {filter name} {
7434 set worktree [gitworktree]
7435 foreach p $filter {
7436 set fq_p [file normalize $p]
7437 set fq_n [file normalize [file join $worktree $name]]
7438 if {[string match [file normalize $fq_p]* $fq_n]} {
7439 return 1
7442 return 0
7445 proc addtocflist {ids} {
7446 global treediffs
7448 add_flist $treediffs($ids)
7449 getblobdiffs $ids
7452 proc diffcmd {ids flags} {
7453 global nullid nullid2
7455 set i [lsearch -exact $ids $nullid]
7456 set j [lsearch -exact $ids $nullid2]
7457 if {$i >= 0} {
7458 if {[llength $ids] > 1 && $j < 0} {
7459 # comparing working directory with some specific revision
7460 set cmd [concat | git diff-index $flags]
7461 if {$i == 0} {
7462 lappend cmd -R [lindex $ids 1]
7463 } else {
7464 lappend cmd [lindex $ids 0]
7466 } else {
7467 # comparing working directory with index
7468 set cmd [concat | git diff-files $flags]
7469 if {$j == 1} {
7470 lappend cmd -R
7473 } elseif {$j >= 0} {
7474 set cmd [concat | git diff-index --cached $flags]
7475 if {[llength $ids] > 1} {
7476 # comparing index with specific revision
7477 if {$j == 0} {
7478 lappend cmd -R [lindex $ids 1]
7479 } else {
7480 lappend cmd [lindex $ids 0]
7482 } else {
7483 # comparing index with HEAD
7484 lappend cmd HEAD
7486 } else {
7487 set cmd [concat | git diff-tree -r $flags $ids]
7489 return $cmd
7492 proc gettreediffs {ids} {
7493 global treediff treepending
7495 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7497 set treepending $ids
7498 set treediff {}
7499 fconfigure $gdtf -blocking 0 -encoding binary
7500 filerun $gdtf [list gettreediffline $gdtf $ids]
7503 proc gettreediffline {gdtf ids} {
7504 global treediff treediffs treepending diffids diffmergeid
7505 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7507 set nr 0
7508 set sublist {}
7509 set max 1000
7510 if {$perfile_attrs} {
7511 # cache_gitattr is slow, and even slower on win32 where we
7512 # have to invoke it for only about 30 paths at a time
7513 set max 500
7514 if {[tk windowingsystem] == "win32"} {
7515 set max 120
7518 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7519 set i [string first "\t" $line]
7520 if {$i >= 0} {
7521 set file [string range $line [expr {$i+1}] end]
7522 if {[string index $file 0] eq "\""} {
7523 set file [lindex $file 0]
7525 set file [encoding convertfrom $file]
7526 if {$file ne [lindex $treediff end]} {
7527 lappend treediff $file
7528 lappend sublist $file
7532 if {$perfile_attrs} {
7533 cache_gitattr encoding $sublist
7535 if {![eof $gdtf]} {
7536 return [expr {$nr >= $max? 2: 1}]
7538 close $gdtf
7539 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7540 set flist {}
7541 foreach f $treediff {
7542 if {[path_filter $vfilelimit($curview) $f]} {
7543 lappend flist $f
7546 set treediffs($ids) $flist
7547 } else {
7548 set treediffs($ids) $treediff
7550 unset treepending
7551 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7552 gettree $diffids
7553 } elseif {$ids != $diffids} {
7554 if {![info exists diffmergeid]} {
7555 gettreediffs $diffids
7557 } else {
7558 addtocflist $ids
7560 return 0
7563 # empty string or positive integer
7564 proc diffcontextvalidate {v} {
7565 return [regexp {^(|[1-9][0-9]*)$} $v]
7568 proc diffcontextchange {n1 n2 op} {
7569 global diffcontextstring diffcontext
7571 if {[string is integer -strict $diffcontextstring]} {
7572 if {$diffcontextstring >= 0} {
7573 set diffcontext $diffcontextstring
7574 reselectline
7579 proc changeignorespace {} {
7580 reselectline
7583 proc changeworddiff {name ix op} {
7584 reselectline
7587 proc getblobdiffs {ids} {
7588 global blobdifffd diffids env
7589 global diffinhdr treediffs
7590 global diffcontext
7591 global ignorespace
7592 global worddiff
7593 global limitdiffs vfilelimit curview
7594 global diffencoding targetline diffnparents
7595 global git_version currdiffsubmod
7597 set textconv {}
7598 if {[package vcompare $git_version "1.6.1"] >= 0} {
7599 set textconv "--textconv"
7601 set submodule {}
7602 if {[package vcompare $git_version "1.6.6"] >= 0} {
7603 set submodule "--submodule"
7605 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7606 if {$ignorespace} {
7607 append cmd " -w"
7609 if {$worddiff ne [mc "Line diff"]} {
7610 append cmd " --word-diff=porcelain"
7612 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7613 set cmd [concat $cmd -- $vfilelimit($curview)]
7615 if {[catch {set bdf [open $cmd r]} err]} {
7616 error_popup [mc "Error getting diffs: %s" $err]
7617 return
7619 set targetline {}
7620 set diffnparents 0
7621 set diffinhdr 0
7622 set diffencoding [get_path_encoding {}]
7623 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7624 set blobdifffd($ids) $bdf
7625 set currdiffsubmod ""
7626 filerun $bdf [list getblobdiffline $bdf $diffids]
7629 proc savecmitpos {} {
7630 global ctext cmitmode
7632 if {$cmitmode eq "tree"} {
7633 return {}
7635 return [list target_scrollpos [$ctext index @0,0]]
7638 proc savectextpos {} {
7639 global ctext
7641 return [list target_scrollpos [$ctext index @0,0]]
7644 proc maybe_scroll_ctext {ateof} {
7645 global ctext target_scrollpos
7647 if {![info exists target_scrollpos]} return
7648 if {!$ateof} {
7649 set nlines [expr {[winfo height $ctext]
7650 / [font metrics textfont -linespace]}]
7651 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7653 $ctext yview $target_scrollpos
7654 unset target_scrollpos
7657 proc setinlist {var i val} {
7658 global $var
7660 while {[llength [set $var]] < $i} {
7661 lappend $var {}
7663 if {[llength [set $var]] == $i} {
7664 lappend $var $val
7665 } else {
7666 lset $var $i $val
7670 proc makediffhdr {fname ids} {
7671 global ctext curdiffstart treediffs diffencoding
7672 global ctext_file_names jump_to_here targetline diffline
7674 set fname [encoding convertfrom $fname]
7675 set diffencoding [get_path_encoding $fname]
7676 set i [lsearch -exact $treediffs($ids) $fname]
7677 if {$i >= 0} {
7678 setinlist difffilestart $i $curdiffstart
7680 lset ctext_file_names end $fname
7681 set l [expr {(78 - [string length $fname]) / 2}]
7682 set pad [string range "----------------------------------------" 1 $l]
7683 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7684 set targetline {}
7685 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7686 set targetline [lindex $jump_to_here 1]
7688 set diffline 0
7691 proc getblobdiffline {bdf ids} {
7692 global diffids blobdifffd ctext curdiffstart
7693 global diffnexthead diffnextnote difffilestart
7694 global ctext_file_names ctext_file_lines
7695 global diffinhdr treediffs mergemax diffnparents
7696 global diffencoding jump_to_here targetline diffline currdiffsubmod
7697 global worddiff
7699 set nr 0
7700 $ctext conf -state normal
7701 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7702 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7703 catch {close $bdf}
7704 return 0
7706 if {![string compare -length 5 "diff " $line]} {
7707 if {![regexp {^diff (--cc|--git) } $line m type]} {
7708 set line [encoding convertfrom $line]
7709 $ctext insert end "$line\n" hunksep
7710 continue
7712 # start of a new file
7713 set diffinhdr 1
7714 $ctext insert end "\n"
7715 set curdiffstart [$ctext index "end - 1c"]
7716 lappend ctext_file_names ""
7717 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7718 $ctext insert end "\n" filesep
7720 if {$type eq "--cc"} {
7721 # start of a new file in a merge diff
7722 set fname [string range $line 10 end]
7723 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7724 lappend treediffs($ids) $fname
7725 add_flist [list $fname]
7728 } else {
7729 set line [string range $line 11 end]
7730 # If the name hasn't changed the length will be odd,
7731 # the middle char will be a space, and the two bits either
7732 # side will be a/name and b/name, or "a/name" and "b/name".
7733 # If the name has changed we'll get "rename from" and
7734 # "rename to" or "copy from" and "copy to" lines following
7735 # this, and we'll use them to get the filenames.
7736 # This complexity is necessary because spaces in the
7737 # filename(s) don't get escaped.
7738 set l [string length $line]
7739 set i [expr {$l / 2}]
7740 if {!(($l & 1) && [string index $line $i] eq " " &&
7741 [string range $line 2 [expr {$i - 1}]] eq \
7742 [string range $line [expr {$i + 3}] end])} {
7743 continue
7745 # unescape if quoted and chop off the a/ from the front
7746 if {[string index $line 0] eq "\""} {
7747 set fname [string range [lindex $line 0] 2 end]
7748 } else {
7749 set fname [string range $line 2 [expr {$i - 1}]]
7752 makediffhdr $fname $ids
7754 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7755 set fname [encoding convertfrom [string range $line 16 end]]
7756 $ctext insert end "\n"
7757 set curdiffstart [$ctext index "end - 1c"]
7758 lappend ctext_file_names $fname
7759 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7760 $ctext insert end "$line\n" filesep
7761 set i [lsearch -exact $treediffs($ids) $fname]
7762 if {$i >= 0} {
7763 setinlist difffilestart $i $curdiffstart
7766 } elseif {![string compare -length 2 "@@" $line]} {
7767 regexp {^@@+} $line ats
7768 set line [encoding convertfrom $diffencoding $line]
7769 $ctext insert end "$line\n" hunksep
7770 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7771 set diffline $nl
7773 set diffnparents [expr {[string length $ats] - 1}]
7774 set diffinhdr 0
7776 } elseif {![string compare -length 10 "Submodule " $line]} {
7777 # start of a new submodule
7778 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
7779 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
7780 } else {
7781 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
7783 if {$currdiffsubmod != $fname} {
7784 $ctext insert end "\n"; # Add newline after commit message
7786 set curdiffstart [$ctext index "end - 1c"]
7787 lappend ctext_file_names ""
7788 if {$currdiffsubmod != $fname} {
7789 lappend ctext_file_lines $fname
7790 makediffhdr $fname $ids
7791 set currdiffsubmod $fname
7792 $ctext insert end "\n$line\n" filesep
7793 } else {
7794 $ctext insert end "$line\n" filesep
7796 } elseif {![string compare -length 3 " >" $line]} {
7797 set $currdiffsubmod ""
7798 set line [encoding convertfrom $diffencoding $line]
7799 $ctext insert end "$line\n" dresult
7800 } elseif {![string compare -length 3 " <" $line]} {
7801 set $currdiffsubmod ""
7802 set line [encoding convertfrom $diffencoding $line]
7803 $ctext insert end "$line\n" d0
7804 } elseif {$diffinhdr} {
7805 if {![string compare -length 12 "rename from " $line]} {
7806 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7807 if {[string index $fname 0] eq "\""} {
7808 set fname [lindex $fname 0]
7810 set fname [encoding convertfrom $fname]
7811 set i [lsearch -exact $treediffs($ids) $fname]
7812 if {$i >= 0} {
7813 setinlist difffilestart $i $curdiffstart
7815 } elseif {![string compare -length 10 $line "rename to "] ||
7816 ![string compare -length 8 $line "copy to "]} {
7817 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7818 if {[string index $fname 0] eq "\""} {
7819 set fname [lindex $fname 0]
7821 makediffhdr $fname $ids
7822 } elseif {[string compare -length 3 $line "---"] == 0} {
7823 # do nothing
7824 continue
7825 } elseif {[string compare -length 3 $line "+++"] == 0} {
7826 set diffinhdr 0
7827 continue
7829 $ctext insert end "$line\n" filesep
7831 } else {
7832 set line [string map {\x1A ^Z} \
7833 [encoding convertfrom $diffencoding $line]]
7834 # parse the prefix - one ' ', '-' or '+' for each parent
7835 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7836 set tag [expr {$diffnparents > 1? "m": "d"}]
7837 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
7838 set words_pre_markup ""
7839 set words_post_markup ""
7840 if {[string trim $prefix " -+"] eq {}} {
7841 # prefix only has " ", "-" and "+" in it: normal diff line
7842 set num [string first "-" $prefix]
7843 if {$dowords} {
7844 set line [string range $line 1 end]
7846 if {$num >= 0} {
7847 # removed line, first parent with line is $num
7848 if {$num >= $mergemax} {
7849 set num "max"
7851 if {$dowords && $worddiff eq [mc "Markup words"]} {
7852 $ctext insert end "\[-$line-\]" $tag$num
7853 } else {
7854 $ctext insert end "$line" $tag$num
7856 if {!$dowords} {
7857 $ctext insert end "\n" $tag$num
7859 } else {
7860 set tags {}
7861 if {[string first "+" $prefix] >= 0} {
7862 # added line
7863 lappend tags ${tag}result
7864 if {$diffnparents > 1} {
7865 set num [string first " " $prefix]
7866 if {$num >= 0} {
7867 if {$num >= $mergemax} {
7868 set num "max"
7870 lappend tags m$num
7873 set words_pre_markup "{+"
7874 set words_post_markup "+}"
7876 if {$targetline ne {}} {
7877 if {$diffline == $targetline} {
7878 set seehere [$ctext index "end - 1 chars"]
7879 set targetline {}
7880 } else {
7881 incr diffline
7884 if {$dowords && $worddiff eq [mc "Markup words"]} {
7885 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
7886 } else {
7887 $ctext insert end "$line" $tags
7889 if {!$dowords} {
7890 $ctext insert end "\n" $tags
7893 } elseif {$dowords && $prefix eq "~"} {
7894 $ctext insert end "\n" {}
7895 } else {
7896 # "\ No newline at end of file",
7897 # or something else we don't recognize
7898 $ctext insert end "$line\n" hunksep
7902 if {[info exists seehere]} {
7903 mark_ctext_line [lindex [split $seehere .] 0]
7905 maybe_scroll_ctext [eof $bdf]
7906 $ctext conf -state disabled
7907 if {[eof $bdf]} {
7908 catch {close $bdf}
7909 return 0
7911 return [expr {$nr >= 1000? 2: 1}]
7914 proc changediffdisp {} {
7915 global ctext diffelide
7917 $ctext tag conf d0 -elide [lindex $diffelide 0]
7918 $ctext tag conf dresult -elide [lindex $diffelide 1]
7921 proc highlightfile {loc cline} {
7922 global ctext cflist cflist_top
7924 $ctext yview $loc
7925 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7926 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7927 $cflist see $cline.0
7928 set cflist_top $cline
7931 proc prevfile {} {
7932 global difffilestart ctext cmitmode
7934 if {$cmitmode eq "tree"} return
7935 set prev 0.0
7936 set prevline 1
7937 set here [$ctext index @0,0]
7938 foreach loc $difffilestart {
7939 if {[$ctext compare $loc >= $here]} {
7940 highlightfile $prev $prevline
7941 return
7943 set prev $loc
7944 incr prevline
7946 highlightfile $prev $prevline
7949 proc nextfile {} {
7950 global difffilestart ctext cmitmode
7952 if {$cmitmode eq "tree"} return
7953 set here [$ctext index @0,0]
7954 set line 1
7955 foreach loc $difffilestart {
7956 incr line
7957 if {[$ctext compare $loc > $here]} {
7958 highlightfile $loc $line
7959 return
7964 proc clear_ctext {{first 1.0}} {
7965 global ctext smarktop smarkbot
7966 global ctext_file_names ctext_file_lines
7967 global pendinglinks
7969 set l [lindex [split $first .] 0]
7970 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7971 set smarktop $l
7973 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7974 set smarkbot $l
7976 $ctext delete $first end
7977 if {$first eq "1.0"} {
7978 catch {unset pendinglinks}
7980 set ctext_file_names {}
7981 set ctext_file_lines {}
7984 proc settabs {{firstab {}}} {
7985 global firsttabstop tabstop ctext have_tk85
7987 if {$firstab ne {} && $have_tk85} {
7988 set firsttabstop $firstab
7990 set w [font measure textfont "0"]
7991 if {$firsttabstop != 0} {
7992 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7993 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7994 } elseif {$have_tk85 || $tabstop != 8} {
7995 $ctext conf -tabs [expr {$tabstop * $w}]
7996 } else {
7997 $ctext conf -tabs {}
8001 proc incrsearch {name ix op} {
8002 global ctext searchstring searchdirn
8004 $ctext tag remove found 1.0 end
8005 if {[catch {$ctext index anchor}]} {
8006 # no anchor set, use start of selection, or of visible area
8007 set sel [$ctext tag ranges sel]
8008 if {$sel ne {}} {
8009 $ctext mark set anchor [lindex $sel 0]
8010 } elseif {$searchdirn eq "-forwards"} {
8011 $ctext mark set anchor @0,0
8012 } else {
8013 $ctext mark set anchor @0,[winfo height $ctext]
8016 if {$searchstring ne {}} {
8017 set here [$ctext search $searchdirn -- $searchstring anchor]
8018 if {$here ne {}} {
8019 $ctext see $here
8021 searchmarkvisible 1
8025 proc dosearch {} {
8026 global sstring ctext searchstring searchdirn
8028 focus $sstring
8029 $sstring icursor end
8030 set searchdirn -forwards
8031 if {$searchstring ne {}} {
8032 set sel [$ctext tag ranges sel]
8033 if {$sel ne {}} {
8034 set start "[lindex $sel 0] + 1c"
8035 } elseif {[catch {set start [$ctext index anchor]}]} {
8036 set start "@0,0"
8038 set match [$ctext search -count mlen -- $searchstring $start]
8039 $ctext tag remove sel 1.0 end
8040 if {$match eq {}} {
8041 bell
8042 return
8044 $ctext see $match
8045 set mend "$match + $mlen c"
8046 $ctext tag add sel $match $mend
8047 $ctext mark unset anchor
8051 proc dosearchback {} {
8052 global sstring ctext searchstring searchdirn
8054 focus $sstring
8055 $sstring icursor end
8056 set searchdirn -backwards
8057 if {$searchstring ne {}} {
8058 set sel [$ctext tag ranges sel]
8059 if {$sel ne {}} {
8060 set start [lindex $sel 0]
8061 } elseif {[catch {set start [$ctext index anchor]}]} {
8062 set start @0,[winfo height $ctext]
8064 set match [$ctext search -backwards -count ml -- $searchstring $start]
8065 $ctext tag remove sel 1.0 end
8066 if {$match eq {}} {
8067 bell
8068 return
8070 $ctext see $match
8071 set mend "$match + $ml c"
8072 $ctext tag add sel $match $mend
8073 $ctext mark unset anchor
8077 proc searchmark {first last} {
8078 global ctext searchstring
8080 set mend $first.0
8081 while {1} {
8082 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8083 if {$match eq {}} break
8084 set mend "$match + $mlen c"
8085 $ctext tag add found $match $mend
8089 proc searchmarkvisible {doall} {
8090 global ctext smarktop smarkbot
8092 set topline [lindex [split [$ctext index @0,0] .] 0]
8093 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8094 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8095 # no overlap with previous
8096 searchmark $topline $botline
8097 set smarktop $topline
8098 set smarkbot $botline
8099 } else {
8100 if {$topline < $smarktop} {
8101 searchmark $topline [expr {$smarktop-1}]
8102 set smarktop $topline
8104 if {$botline > $smarkbot} {
8105 searchmark [expr {$smarkbot+1}] $botline
8106 set smarkbot $botline
8111 proc scrolltext {f0 f1} {
8112 global searchstring
8114 .bleft.bottom.sb set $f0 $f1
8115 if {$searchstring ne {}} {
8116 searchmarkvisible 0
8120 proc setcoords {} {
8121 global linespc charspc canvx0 canvy0
8122 global xspc1 xspc2 lthickness
8124 set linespc [font metrics mainfont -linespace]
8125 set charspc [font measure mainfont "m"]
8126 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8127 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8128 set lthickness [expr {int($linespc / 9) + 1}]
8129 set xspc1(0) $linespc
8130 set xspc2 $linespc
8133 proc redisplay {} {
8134 global canv
8135 global selectedline
8137 set ymax [lindex [$canv cget -scrollregion] 3]
8138 if {$ymax eq {} || $ymax == 0} return
8139 set span [$canv yview]
8140 clear_display
8141 setcanvscroll
8142 allcanvs yview moveto [lindex $span 0]
8143 drawvisible
8144 if {$selectedline ne {}} {
8145 selectline $selectedline 0
8146 allcanvs yview moveto [lindex $span 0]
8150 proc parsefont {f n} {
8151 global fontattr
8153 set fontattr($f,family) [lindex $n 0]
8154 set s [lindex $n 1]
8155 if {$s eq {} || $s == 0} {
8156 set s 10
8157 } elseif {$s < 0} {
8158 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8160 set fontattr($f,size) $s
8161 set fontattr($f,weight) normal
8162 set fontattr($f,slant) roman
8163 foreach style [lrange $n 2 end] {
8164 switch -- $style {
8165 "normal" -
8166 "bold" {set fontattr($f,weight) $style}
8167 "roman" -
8168 "italic" {set fontattr($f,slant) $style}
8173 proc fontflags {f {isbold 0}} {
8174 global fontattr
8176 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8177 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8178 -slant $fontattr($f,slant)]
8181 proc fontname {f} {
8182 global fontattr
8184 set n [list $fontattr($f,family) $fontattr($f,size)]
8185 if {$fontattr($f,weight) eq "bold"} {
8186 lappend n "bold"
8188 if {$fontattr($f,slant) eq "italic"} {
8189 lappend n "italic"
8191 return $n
8194 proc incrfont {inc} {
8195 global mainfont textfont ctext canv cflist showrefstop
8196 global stopped entries fontattr
8198 unmarkmatches
8199 set s $fontattr(mainfont,size)
8200 incr s $inc
8201 if {$s < 1} {
8202 set s 1
8204 set fontattr(mainfont,size) $s
8205 font config mainfont -size $s
8206 font config mainfontbold -size $s
8207 set mainfont [fontname mainfont]
8208 set s $fontattr(textfont,size)
8209 incr s $inc
8210 if {$s < 1} {
8211 set s 1
8213 set fontattr(textfont,size) $s
8214 font config textfont -size $s
8215 font config textfontbold -size $s
8216 set textfont [fontname textfont]
8217 setcoords
8218 settabs
8219 redisplay
8222 proc clearsha1 {} {
8223 global sha1entry sha1string
8224 if {[string length $sha1string] == 40} {
8225 $sha1entry delete 0 end
8229 proc sha1change {n1 n2 op} {
8230 global sha1string currentid sha1but
8231 if {$sha1string == {}
8232 || ([info exists currentid] && $sha1string == $currentid)} {
8233 set state disabled
8234 } else {
8235 set state normal
8237 if {[$sha1but cget -state] == $state} return
8238 if {$state == "normal"} {
8239 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8240 } else {
8241 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8245 proc gotocommit {} {
8246 global sha1string tagids headids curview varcid
8248 if {$sha1string == {}
8249 || ([info exists currentid] && $sha1string == $currentid)} return
8250 if {[info exists tagids($sha1string)]} {
8251 set id $tagids($sha1string)
8252 } elseif {[info exists headids($sha1string)]} {
8253 set id $headids($sha1string)
8254 } else {
8255 set id [string tolower $sha1string]
8256 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8257 set matches [longid $id]
8258 if {$matches ne {}} {
8259 if {[llength $matches] > 1} {
8260 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8261 return
8263 set id [lindex $matches 0]
8265 } else {
8266 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8267 error_popup [mc "Revision %s is not known" $sha1string]
8268 return
8272 if {[commitinview $id $curview]} {
8273 selectline [rowofcommit $id] 1
8274 return
8276 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8277 set msg [mc "SHA1 id %s is not known" $sha1string]
8278 } else {
8279 set msg [mc "Revision %s is not in the current view" $sha1string]
8281 error_popup $msg
8284 proc lineenter {x y id} {
8285 global hoverx hovery hoverid hovertimer
8286 global commitinfo canv
8288 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8289 set hoverx $x
8290 set hovery $y
8291 set hoverid $id
8292 if {[info exists hovertimer]} {
8293 after cancel $hovertimer
8295 set hovertimer [after 500 linehover]
8296 $canv delete hover
8299 proc linemotion {x y id} {
8300 global hoverx hovery hoverid hovertimer
8302 if {[info exists hoverid] && $id == $hoverid} {
8303 set hoverx $x
8304 set hovery $y
8305 if {[info exists hovertimer]} {
8306 after cancel $hovertimer
8308 set hovertimer [after 500 linehover]
8312 proc lineleave {id} {
8313 global hoverid hovertimer canv
8315 if {[info exists hoverid] && $id == $hoverid} {
8316 $canv delete hover
8317 if {[info exists hovertimer]} {
8318 after cancel $hovertimer
8319 unset hovertimer
8321 unset hoverid
8325 proc linehover {} {
8326 global hoverx hovery hoverid hovertimer
8327 global canv linespc lthickness
8328 global commitinfo
8330 set text [lindex $commitinfo($hoverid) 0]
8331 set ymax [lindex [$canv cget -scrollregion] 3]
8332 if {$ymax == {}} return
8333 set yfrac [lindex [$canv yview] 0]
8334 set x [expr {$hoverx + 2 * $linespc}]
8335 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8336 set x0 [expr {$x - 2 * $lthickness}]
8337 set y0 [expr {$y - 2 * $lthickness}]
8338 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8339 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8340 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8341 -fill \#ffff80 -outline black -width 1 -tags hover]
8342 $canv raise $t
8343 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8344 -font mainfont]
8345 $canv raise $t
8348 proc clickisonarrow {id y} {
8349 global lthickness
8351 set ranges [rowranges $id]
8352 set thresh [expr {2 * $lthickness + 6}]
8353 set n [expr {[llength $ranges] - 1}]
8354 for {set i 1} {$i < $n} {incr i} {
8355 set row [lindex $ranges $i]
8356 if {abs([yc $row] - $y) < $thresh} {
8357 return $i
8360 return {}
8363 proc arrowjump {id n y} {
8364 global canv
8366 # 1 <-> 2, 3 <-> 4, etc...
8367 set n [expr {(($n - 1) ^ 1) + 1}]
8368 set row [lindex [rowranges $id] $n]
8369 set yt [yc $row]
8370 set ymax [lindex [$canv cget -scrollregion] 3]
8371 if {$ymax eq {} || $ymax <= 0} return
8372 set view [$canv yview]
8373 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8374 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8375 if {$yfrac < 0} {
8376 set yfrac 0
8378 allcanvs yview moveto $yfrac
8381 proc lineclick {x y id isnew} {
8382 global ctext commitinfo children canv thickerline curview
8384 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8385 unmarkmatches
8386 unselectline
8387 normalline
8388 $canv delete hover
8389 # draw this line thicker than normal
8390 set thickerline $id
8391 drawlines $id
8392 if {$isnew} {
8393 set ymax [lindex [$canv cget -scrollregion] 3]
8394 if {$ymax eq {}} return
8395 set yfrac [lindex [$canv yview] 0]
8396 set y [expr {$y + $yfrac * $ymax}]
8398 set dirn [clickisonarrow $id $y]
8399 if {$dirn ne {}} {
8400 arrowjump $id $dirn $y
8401 return
8404 if {$isnew} {
8405 addtohistory [list lineclick $x $y $id 0] savectextpos
8407 # fill the details pane with info about this line
8408 $ctext conf -state normal
8409 clear_ctext
8410 settabs 0
8411 $ctext insert end "[mc "Parent"]:\t"
8412 $ctext insert end $id link0
8413 setlink $id link0
8414 set info $commitinfo($id)
8415 $ctext insert end "\n\t[lindex $info 0]\n"
8416 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8417 set date [formatdate [lindex $info 2]]
8418 $ctext insert end "\t[mc "Date"]:\t$date\n"
8419 set kids $children($curview,$id)
8420 if {$kids ne {}} {
8421 $ctext insert end "\n[mc "Children"]:"
8422 set i 0
8423 foreach child $kids {
8424 incr i
8425 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8426 set info $commitinfo($child)
8427 $ctext insert end "\n\t"
8428 $ctext insert end $child link$i
8429 setlink $child link$i
8430 $ctext insert end "\n\t[lindex $info 0]"
8431 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8432 set date [formatdate [lindex $info 2]]
8433 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8436 maybe_scroll_ctext 1
8437 $ctext conf -state disabled
8438 init_flist {}
8441 proc normalline {} {
8442 global thickerline
8443 if {[info exists thickerline]} {
8444 set id $thickerline
8445 unset thickerline
8446 drawlines $id
8450 proc selbyid {id {isnew 1}} {
8451 global curview
8452 if {[commitinview $id $curview]} {
8453 selectline [rowofcommit $id] $isnew
8457 proc mstime {} {
8458 global startmstime
8459 if {![info exists startmstime]} {
8460 set startmstime [clock clicks -milliseconds]
8462 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8465 proc rowmenu {x y id} {
8466 global rowctxmenu selectedline rowmenuid curview
8467 global nullid nullid2 fakerowmenu mainhead markedid
8469 stopfinding
8470 set rowmenuid $id
8471 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8472 set state disabled
8473 } else {
8474 set state normal
8476 if {$id ne $nullid && $id ne $nullid2} {
8477 set menu $rowctxmenu
8478 if {$mainhead ne {}} {
8479 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8480 } else {
8481 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8483 if {[info exists markedid] && $markedid ne $id} {
8484 $menu entryconfigure 9 -state normal
8485 $menu entryconfigure 10 -state normal
8486 $menu entryconfigure 11 -state normal
8487 } else {
8488 $menu entryconfigure 9 -state disabled
8489 $menu entryconfigure 10 -state disabled
8490 $menu entryconfigure 11 -state disabled
8492 } else {
8493 set menu $fakerowmenu
8495 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8496 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8497 $menu entryconfigure [mca "Make patch"] -state $state
8498 tk_popup $menu $x $y
8501 proc markhere {} {
8502 global rowmenuid markedid canv
8504 set markedid $rowmenuid
8505 make_idmark $markedid
8508 proc gotomark {} {
8509 global markedid
8511 if {[info exists markedid]} {
8512 selbyid $markedid
8516 proc replace_by_kids {l r} {
8517 global curview children
8519 set id [commitonrow $r]
8520 set l [lreplace $l 0 0]
8521 foreach kid $children($curview,$id) {
8522 lappend l [rowofcommit $kid]
8524 return [lsort -integer -decreasing -unique $l]
8527 proc find_common_desc {} {
8528 global markedid rowmenuid curview children
8530 if {![info exists markedid]} return
8531 if {![commitinview $markedid $curview] ||
8532 ![commitinview $rowmenuid $curview]} return
8533 #set t1 [clock clicks -milliseconds]
8534 set l1 [list [rowofcommit $markedid]]
8535 set l2 [list [rowofcommit $rowmenuid]]
8536 while 1 {
8537 set r1 [lindex $l1 0]
8538 set r2 [lindex $l2 0]
8539 if {$r1 eq {} || $r2 eq {}} break
8540 if {$r1 == $r2} {
8541 selectline $r1 1
8542 break
8544 if {$r1 > $r2} {
8545 set l1 [replace_by_kids $l1 $r1]
8546 } else {
8547 set l2 [replace_by_kids $l2 $r2]
8550 #set t2 [clock clicks -milliseconds]
8551 #puts "took [expr {$t2-$t1}]ms"
8554 proc compare_commits {} {
8555 global markedid rowmenuid curview children
8557 if {![info exists markedid]} return
8558 if {![commitinview $markedid $curview]} return
8559 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8560 do_cmp_commits $markedid $rowmenuid
8563 proc getpatchid {id} {
8564 global patchids
8566 if {![info exists patchids($id)]} {
8567 set cmd [diffcmd [list $id] {-p --root}]
8568 # trim off the initial "|"
8569 set cmd [lrange $cmd 1 end]
8570 if {[catch {
8571 set x [eval exec $cmd | git patch-id]
8572 set patchids($id) [lindex $x 0]
8573 }]} {
8574 set patchids($id) "error"
8577 return $patchids($id)
8580 proc do_cmp_commits {a b} {
8581 global ctext curview parents children patchids commitinfo
8583 $ctext conf -state normal
8584 clear_ctext
8585 init_flist {}
8586 for {set i 0} {$i < 100} {incr i} {
8587 set skipa 0
8588 set skipb 0
8589 if {[llength $parents($curview,$a)] > 1} {
8590 appendshortlink $a [mc "Skipping merge commit "] "\n"
8591 set skipa 1
8592 } else {
8593 set patcha [getpatchid $a]
8595 if {[llength $parents($curview,$b)] > 1} {
8596 appendshortlink $b [mc "Skipping merge commit "] "\n"
8597 set skipb 1
8598 } else {
8599 set patchb [getpatchid $b]
8601 if {!$skipa && !$skipb} {
8602 set heada [lindex $commitinfo($a) 0]
8603 set headb [lindex $commitinfo($b) 0]
8604 if {$patcha eq "error"} {
8605 appendshortlink $a [mc "Error getting patch ID for "] \
8606 [mc " - stopping\n"]
8607 break
8609 if {$patchb eq "error"} {
8610 appendshortlink $b [mc "Error getting patch ID for "] \
8611 [mc " - stopping\n"]
8612 break
8614 if {$patcha eq $patchb} {
8615 if {$heada eq $headb} {
8616 appendshortlink $a [mc "Commit "]
8617 appendshortlink $b " == " " $heada\n"
8618 } else {
8619 appendshortlink $a [mc "Commit "] " $heada\n"
8620 appendshortlink $b [mc " is the same patch as\n "] \
8621 " $headb\n"
8623 set skipa 1
8624 set skipb 1
8625 } else {
8626 $ctext insert end "\n"
8627 appendshortlink $a [mc "Commit "] " $heada\n"
8628 appendshortlink $b [mc " differs from\n "] \
8629 " $headb\n"
8630 $ctext insert end [mc "Diff of commits:\n\n"]
8631 $ctext conf -state disabled
8632 update
8633 diffcommits $a $b
8634 return
8637 if {$skipa} {
8638 set kids [real_children $curview,$a]
8639 if {[llength $kids] != 1} {
8640 $ctext insert end "\n"
8641 appendshortlink $a [mc "Commit "] \
8642 [mc " has %s children - stopping\n" [llength $kids]]
8643 break
8645 set a [lindex $kids 0]
8647 if {$skipb} {
8648 set kids [real_children $curview,$b]
8649 if {[llength $kids] != 1} {
8650 appendshortlink $b [mc "Commit "] \
8651 [mc " has %s children - stopping\n" [llength $kids]]
8652 break
8654 set b [lindex $kids 0]
8657 $ctext conf -state disabled
8660 proc diffcommits {a b} {
8661 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
8663 set tmpdir [gitknewtmpdir]
8664 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8665 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8666 if {[catch {
8667 exec git diff-tree -p --pretty $a >$fna
8668 exec git diff-tree -p --pretty $b >$fnb
8669 } err]} {
8670 error_popup [mc "Error writing commit to file: %s" $err]
8671 return
8673 if {[catch {
8674 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8675 } err]} {
8676 error_popup [mc "Error diffing commits: %s" $err]
8677 return
8679 set diffids [list commits $a $b]
8680 set blobdifffd($diffids) $fd
8681 set diffinhdr 0
8682 set currdiffsubmod ""
8683 filerun $fd [list getblobdiffline $fd $diffids]
8686 proc diffvssel {dirn} {
8687 global rowmenuid selectedline
8689 if {$selectedline eq {}} return
8690 if {$dirn} {
8691 set oldid [commitonrow $selectedline]
8692 set newid $rowmenuid
8693 } else {
8694 set oldid $rowmenuid
8695 set newid [commitonrow $selectedline]
8697 addtohistory [list doseldiff $oldid $newid] savectextpos
8698 doseldiff $oldid $newid
8701 proc doseldiff {oldid newid} {
8702 global ctext
8703 global commitinfo
8705 $ctext conf -state normal
8706 clear_ctext
8707 init_flist [mc "Top"]
8708 $ctext insert end "[mc "From"] "
8709 $ctext insert end $oldid link0
8710 setlink $oldid link0
8711 $ctext insert end "\n "
8712 $ctext insert end [lindex $commitinfo($oldid) 0]
8713 $ctext insert end "\n\n[mc "To"] "
8714 $ctext insert end $newid link1
8715 setlink $newid link1
8716 $ctext insert end "\n "
8717 $ctext insert end [lindex $commitinfo($newid) 0]
8718 $ctext insert end "\n"
8719 $ctext conf -state disabled
8720 $ctext tag remove found 1.0 end
8721 startdiff [list $oldid $newid]
8724 proc mkpatch {} {
8725 global rowmenuid currentid commitinfo patchtop patchnum NS
8727 if {![info exists currentid]} return
8728 set oldid $currentid
8729 set oldhead [lindex $commitinfo($oldid) 0]
8730 set newid $rowmenuid
8731 set newhead [lindex $commitinfo($newid) 0]
8732 set top .patch
8733 set patchtop $top
8734 catch {destroy $top}
8735 ttk_toplevel $top
8736 make_transient $top .
8737 ${NS}::label $top.title -text [mc "Generate patch"]
8738 grid $top.title - -pady 10
8739 ${NS}::label $top.from -text [mc "From:"]
8740 ${NS}::entry $top.fromsha1 -width 40
8741 $top.fromsha1 insert 0 $oldid
8742 $top.fromsha1 conf -state readonly
8743 grid $top.from $top.fromsha1 -sticky w
8744 ${NS}::entry $top.fromhead -width 60
8745 $top.fromhead insert 0 $oldhead
8746 $top.fromhead conf -state readonly
8747 grid x $top.fromhead -sticky w
8748 ${NS}::label $top.to -text [mc "To:"]
8749 ${NS}::entry $top.tosha1 -width 40
8750 $top.tosha1 insert 0 $newid
8751 $top.tosha1 conf -state readonly
8752 grid $top.to $top.tosha1 -sticky w
8753 ${NS}::entry $top.tohead -width 60
8754 $top.tohead insert 0 $newhead
8755 $top.tohead conf -state readonly
8756 grid x $top.tohead -sticky w
8757 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8758 grid $top.rev x -pady 10 -padx 5
8759 ${NS}::label $top.flab -text [mc "Output file:"]
8760 ${NS}::entry $top.fname -width 60
8761 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8762 incr patchnum
8763 grid $top.flab $top.fname -sticky w
8764 ${NS}::frame $top.buts
8765 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8766 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8767 bind $top <Key-Return> mkpatchgo
8768 bind $top <Key-Escape> mkpatchcan
8769 grid $top.buts.gen $top.buts.can
8770 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8771 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8772 grid $top.buts - -pady 10 -sticky ew
8773 focus $top.fname
8776 proc mkpatchrev {} {
8777 global patchtop
8779 set oldid [$patchtop.fromsha1 get]
8780 set oldhead [$patchtop.fromhead get]
8781 set newid [$patchtop.tosha1 get]
8782 set newhead [$patchtop.tohead get]
8783 foreach e [list fromsha1 fromhead tosha1 tohead] \
8784 v [list $newid $newhead $oldid $oldhead] {
8785 $patchtop.$e conf -state normal
8786 $patchtop.$e delete 0 end
8787 $patchtop.$e insert 0 $v
8788 $patchtop.$e conf -state readonly
8792 proc mkpatchgo {} {
8793 global patchtop nullid nullid2
8795 set oldid [$patchtop.fromsha1 get]
8796 set newid [$patchtop.tosha1 get]
8797 set fname [$patchtop.fname get]
8798 set cmd [diffcmd [list $oldid $newid] -p]
8799 # trim off the initial "|"
8800 set cmd [lrange $cmd 1 end]
8801 lappend cmd >$fname &
8802 if {[catch {eval exec $cmd} err]} {
8803 error_popup "[mc "Error creating patch:"] $err" $patchtop
8805 catch {destroy $patchtop}
8806 unset patchtop
8809 proc mkpatchcan {} {
8810 global patchtop
8812 catch {destroy $patchtop}
8813 unset patchtop
8816 proc mktag {} {
8817 global rowmenuid mktagtop commitinfo NS
8819 set top .maketag
8820 set mktagtop $top
8821 catch {destroy $top}
8822 ttk_toplevel $top
8823 make_transient $top .
8824 ${NS}::label $top.title -text [mc "Create tag"]
8825 grid $top.title - -pady 10
8826 ${NS}::label $top.id -text [mc "ID:"]
8827 ${NS}::entry $top.sha1 -width 40
8828 $top.sha1 insert 0 $rowmenuid
8829 $top.sha1 conf -state readonly
8830 grid $top.id $top.sha1 -sticky w
8831 ${NS}::entry $top.head -width 60
8832 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8833 $top.head conf -state readonly
8834 grid x $top.head -sticky w
8835 ${NS}::label $top.tlab -text [mc "Tag name:"]
8836 ${NS}::entry $top.tag -width 60
8837 grid $top.tlab $top.tag -sticky w
8838 ${NS}::label $top.op -text [mc "Tag message is optional"]
8839 grid $top.op -columnspan 2 -sticky we
8840 ${NS}::label $top.mlab -text [mc "Tag message:"]
8841 ${NS}::entry $top.msg -width 60
8842 grid $top.mlab $top.msg -sticky w
8843 ${NS}::frame $top.buts
8844 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8845 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8846 bind $top <Key-Return> mktaggo
8847 bind $top <Key-Escape> mktagcan
8848 grid $top.buts.gen $top.buts.can
8849 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8850 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8851 grid $top.buts - -pady 10 -sticky ew
8852 focus $top.tag
8855 proc domktag {} {
8856 global mktagtop env tagids idtags
8858 set id [$mktagtop.sha1 get]
8859 set tag [$mktagtop.tag get]
8860 set msg [$mktagtop.msg get]
8861 if {$tag == {}} {
8862 error_popup [mc "No tag name specified"] $mktagtop
8863 return 0
8865 if {[info exists tagids($tag)]} {
8866 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8867 return 0
8869 if {[catch {
8870 if {$msg != {}} {
8871 exec git tag -a -m $msg $tag $id
8872 } else {
8873 exec git tag $tag $id
8875 } err]} {
8876 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8877 return 0
8880 set tagids($tag) $id
8881 lappend idtags($id) $tag
8882 redrawtags $id
8883 addedtag $id
8884 dispneartags 0
8885 run refill_reflist
8886 return 1
8889 proc redrawtags {id} {
8890 global canv linehtag idpos currentid curview cmitlisted markedid
8891 global canvxmax iddrawn circleitem mainheadid circlecolors
8893 if {![commitinview $id $curview]} return
8894 if {![info exists iddrawn($id)]} return
8895 set row [rowofcommit $id]
8896 if {$id eq $mainheadid} {
8897 set ofill yellow
8898 } else {
8899 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8901 $canv itemconf $circleitem($row) -fill $ofill
8902 $canv delete tag.$id
8903 set xt [eval drawtags $id $idpos($id)]
8904 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8905 set text [$canv itemcget $linehtag($id) -text]
8906 set font [$canv itemcget $linehtag($id) -font]
8907 set xr [expr {$xt + [font measure $font $text]}]
8908 if {$xr > $canvxmax} {
8909 set canvxmax $xr
8910 setcanvscroll
8912 if {[info exists currentid] && $currentid == $id} {
8913 make_secsel $id
8915 if {[info exists markedid] && $markedid eq $id} {
8916 make_idmark $id
8920 proc mktagcan {} {
8921 global mktagtop
8923 catch {destroy $mktagtop}
8924 unset mktagtop
8927 proc mktaggo {} {
8928 if {![domktag]} return
8929 mktagcan
8932 proc writecommit {} {
8933 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8935 set top .writecommit
8936 set wrcomtop $top
8937 catch {destroy $top}
8938 ttk_toplevel $top
8939 make_transient $top .
8940 ${NS}::label $top.title -text [mc "Write commit to file"]
8941 grid $top.title - -pady 10
8942 ${NS}::label $top.id -text [mc "ID:"]
8943 ${NS}::entry $top.sha1 -width 40
8944 $top.sha1 insert 0 $rowmenuid
8945 $top.sha1 conf -state readonly
8946 grid $top.id $top.sha1 -sticky w
8947 ${NS}::entry $top.head -width 60
8948 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8949 $top.head conf -state readonly
8950 grid x $top.head -sticky w
8951 ${NS}::label $top.clab -text [mc "Command:"]
8952 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8953 grid $top.clab $top.cmd -sticky w -pady 10
8954 ${NS}::label $top.flab -text [mc "Output file:"]
8955 ${NS}::entry $top.fname -width 60
8956 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8957 grid $top.flab $top.fname -sticky w
8958 ${NS}::frame $top.buts
8959 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8960 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8961 bind $top <Key-Return> wrcomgo
8962 bind $top <Key-Escape> wrcomcan
8963 grid $top.buts.gen $top.buts.can
8964 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8965 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8966 grid $top.buts - -pady 10 -sticky ew
8967 focus $top.fname
8970 proc wrcomgo {} {
8971 global wrcomtop
8973 set id [$wrcomtop.sha1 get]
8974 set cmd "echo $id | [$wrcomtop.cmd get]"
8975 set fname [$wrcomtop.fname get]
8976 if {[catch {exec sh -c $cmd >$fname &} err]} {
8977 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8979 catch {destroy $wrcomtop}
8980 unset wrcomtop
8983 proc wrcomcan {} {
8984 global wrcomtop
8986 catch {destroy $wrcomtop}
8987 unset wrcomtop
8990 proc mkbranch {} {
8991 global rowmenuid mkbrtop NS
8993 set top .makebranch
8994 catch {destroy $top}
8995 ttk_toplevel $top
8996 make_transient $top .
8997 ${NS}::label $top.title -text [mc "Create new branch"]
8998 grid $top.title - -pady 10
8999 ${NS}::label $top.id -text [mc "ID:"]
9000 ${NS}::entry $top.sha1 -width 40
9001 $top.sha1 insert 0 $rowmenuid
9002 $top.sha1 conf -state readonly
9003 grid $top.id $top.sha1 -sticky w
9004 ${NS}::label $top.nlab -text [mc "Name:"]
9005 ${NS}::entry $top.name -width 40
9006 grid $top.nlab $top.name -sticky w
9007 ${NS}::frame $top.buts
9008 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9009 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9010 bind $top <Key-Return> [list mkbrgo $top]
9011 bind $top <Key-Escape> "catch {destroy $top}"
9012 grid $top.buts.go $top.buts.can
9013 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9014 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9015 grid $top.buts - -pady 10 -sticky ew
9016 focus $top.name
9019 proc mkbrgo {top} {
9020 global headids idheads
9022 set name [$top.name get]
9023 set id [$top.sha1 get]
9024 set cmdargs {}
9025 set old_id {}
9026 if {$name eq {}} {
9027 error_popup [mc "Please specify a name for the new branch"] $top
9028 return
9030 if {[info exists headids($name)]} {
9031 if {![confirm_popup [mc \
9032 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9033 return
9035 set old_id $headids($name)
9036 lappend cmdargs -f
9038 catch {destroy $top}
9039 lappend cmdargs $name $id
9040 nowbusy newbranch
9041 update
9042 if {[catch {
9043 eval exec git branch $cmdargs
9044 } err]} {
9045 notbusy newbranch
9046 error_popup $err
9047 } else {
9048 notbusy newbranch
9049 if {$old_id ne {}} {
9050 movehead $id $name
9051 movedhead $id $name
9052 redrawtags $old_id
9053 redrawtags $id
9054 } else {
9055 set headids($name) $id
9056 lappend idheads($id) $name
9057 addedhead $id $name
9058 redrawtags $id
9060 dispneartags 0
9061 run refill_reflist
9065 proc exec_citool {tool_args {baseid {}}} {
9066 global commitinfo env
9068 set save_env [array get env GIT_AUTHOR_*]
9070 if {$baseid ne {}} {
9071 if {![info exists commitinfo($baseid)]} {
9072 getcommit $baseid
9074 set author [lindex $commitinfo($baseid) 1]
9075 set date [lindex $commitinfo($baseid) 2]
9076 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9077 $author author name email]
9078 && $date ne {}} {
9079 set env(GIT_AUTHOR_NAME) $name
9080 set env(GIT_AUTHOR_EMAIL) $email
9081 set env(GIT_AUTHOR_DATE) $date
9085 eval exec git citool $tool_args &
9087 array unset env GIT_AUTHOR_*
9088 array set env $save_env
9091 proc cherrypick {} {
9092 global rowmenuid curview
9093 global mainhead mainheadid
9094 global gitdir
9096 set oldhead [exec git rev-parse HEAD]
9097 set dheads [descheads $rowmenuid]
9098 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9099 set ok [confirm_popup [mc "Commit %s is already\
9100 included in branch %s -- really re-apply it?" \
9101 [string range $rowmenuid 0 7] $mainhead]]
9102 if {!$ok} return
9104 nowbusy cherrypick [mc "Cherry-picking"]
9105 update
9106 # Unfortunately git-cherry-pick writes stuff to stderr even when
9107 # no error occurs, and exec takes that as an indication of error...
9108 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9109 notbusy cherrypick
9110 if {[regexp -line \
9111 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9112 $err msg fname]} {
9113 error_popup [mc "Cherry-pick failed because of local changes\
9114 to file '%s'.\nPlease commit, reset or stash\
9115 your changes and try again." $fname]
9116 } elseif {[regexp -line \
9117 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9118 $err]} {
9119 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9120 conflict.\nDo you wish to run git citool to\
9121 resolve it?"]]} {
9122 # Force citool to read MERGE_MSG
9123 file delete [file join $gitdir "GITGUI_MSG"]
9124 exec_citool {} $rowmenuid
9126 } else {
9127 error_popup $err
9129 run updatecommits
9130 return
9132 set newhead [exec git rev-parse HEAD]
9133 if {$newhead eq $oldhead} {
9134 notbusy cherrypick
9135 error_popup [mc "No changes committed"]
9136 return
9138 addnewchild $newhead $oldhead
9139 if {[commitinview $oldhead $curview]} {
9140 # XXX this isn't right if we have a path limit...
9141 insertrow $newhead $oldhead $curview
9142 if {$mainhead ne {}} {
9143 movehead $newhead $mainhead
9144 movedhead $newhead $mainhead
9146 set mainheadid $newhead
9147 redrawtags $oldhead
9148 redrawtags $newhead
9149 selbyid $newhead
9151 notbusy cherrypick
9154 proc resethead {} {
9155 global mainhead rowmenuid confirm_ok resettype NS
9157 set confirm_ok 0
9158 set w ".confirmreset"
9159 ttk_toplevel $w
9160 make_transient $w .
9161 wm title $w [mc "Confirm reset"]
9162 ${NS}::label $w.m -text \
9163 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9164 pack $w.m -side top -fill x -padx 20 -pady 20
9165 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9166 set resettype mixed
9167 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9168 -text [mc "Soft: Leave working tree and index untouched"]
9169 grid $w.f.soft -sticky w
9170 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9171 -text [mc "Mixed: Leave working tree untouched, reset index"]
9172 grid $w.f.mixed -sticky w
9173 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9174 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9175 grid $w.f.hard -sticky w
9176 pack $w.f -side top -fill x -padx 4
9177 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9178 pack $w.ok -side left -fill x -padx 20 -pady 20
9179 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9180 bind $w <Key-Escape> [list destroy $w]
9181 pack $w.cancel -side right -fill x -padx 20 -pady 20
9182 bind $w <Visibility> "grab $w; focus $w"
9183 tkwait window $w
9184 if {!$confirm_ok} return
9185 if {[catch {set fd [open \
9186 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9187 error_popup $err
9188 } else {
9189 dohidelocalchanges
9190 filerun $fd [list readresetstat $fd]
9191 nowbusy reset [mc "Resetting"]
9192 selbyid $rowmenuid
9196 proc readresetstat {fd} {
9197 global mainhead mainheadid showlocalchanges rprogcoord
9199 if {[gets $fd line] >= 0} {
9200 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9201 set rprogcoord [expr {1.0 * $m / $n}]
9202 adjustprogress
9204 return 1
9206 set rprogcoord 0
9207 adjustprogress
9208 notbusy reset
9209 if {[catch {close $fd} err]} {
9210 error_popup $err
9212 set oldhead $mainheadid
9213 set newhead [exec git rev-parse HEAD]
9214 if {$newhead ne $oldhead} {
9215 movehead $newhead $mainhead
9216 movedhead $newhead $mainhead
9217 set mainheadid $newhead
9218 redrawtags $oldhead
9219 redrawtags $newhead
9221 if {$showlocalchanges} {
9222 doshowlocalchanges
9224 return 0
9227 # context menu for a head
9228 proc headmenu {x y id head} {
9229 global headmenuid headmenuhead headctxmenu mainhead
9231 stopfinding
9232 set headmenuid $id
9233 set headmenuhead $head
9234 set state normal
9235 if {[string match "remotes/*" $head]} {
9236 set state disabled
9238 if {$head eq $mainhead} {
9239 set state disabled
9241 $headctxmenu entryconfigure 0 -state $state
9242 $headctxmenu entryconfigure 1 -state $state
9243 tk_popup $headctxmenu $x $y
9246 proc cobranch {} {
9247 global headmenuid headmenuhead headids
9248 global showlocalchanges
9250 # check the tree is clean first??
9251 nowbusy checkout [mc "Checking out"]
9252 update
9253 dohidelocalchanges
9254 if {[catch {
9255 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9256 } err]} {
9257 notbusy checkout
9258 error_popup $err
9259 if {$showlocalchanges} {
9260 dodiffindex
9262 } else {
9263 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9267 proc readcheckoutstat {fd newhead newheadid} {
9268 global mainhead mainheadid headids showlocalchanges progresscoords
9269 global viewmainheadid curview
9271 if {[gets $fd line] >= 0} {
9272 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9273 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9274 adjustprogress
9276 return 1
9278 set progresscoords {0 0}
9279 adjustprogress
9280 notbusy checkout
9281 if {[catch {close $fd} err]} {
9282 error_popup $err
9284 set oldmainid $mainheadid
9285 set mainhead $newhead
9286 set mainheadid $newheadid
9287 set viewmainheadid($curview) $newheadid
9288 redrawtags $oldmainid
9289 redrawtags $newheadid
9290 selbyid $newheadid
9291 if {$showlocalchanges} {
9292 dodiffindex
9296 proc rmbranch {} {
9297 global headmenuid headmenuhead mainhead
9298 global idheads
9300 set head $headmenuhead
9301 set id $headmenuid
9302 # this check shouldn't be needed any more...
9303 if {$head eq $mainhead} {
9304 error_popup [mc "Cannot delete the currently checked-out branch"]
9305 return
9307 set dheads [descheads $id]
9308 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9309 # the stuff on this branch isn't on any other branch
9310 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9311 branch.\nReally delete branch %s?" $head $head]]} return
9313 nowbusy rmbranch
9314 update
9315 if {[catch {exec git branch -D $head} err]} {
9316 notbusy rmbranch
9317 error_popup $err
9318 return
9320 removehead $id $head
9321 removedhead $id $head
9322 redrawtags $id
9323 notbusy rmbranch
9324 dispneartags 0
9325 run refill_reflist
9328 # Display a list of tags and heads
9329 proc showrefs {} {
9330 global showrefstop bgcolor fgcolor selectbgcolor NS
9331 global bglist fglist reflistfilter reflist maincursor
9333 set top .showrefs
9334 set showrefstop $top
9335 if {[winfo exists $top]} {
9336 raise $top
9337 refill_reflist
9338 return
9340 ttk_toplevel $top
9341 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9342 make_transient $top .
9343 text $top.list -background $bgcolor -foreground $fgcolor \
9344 -selectbackground $selectbgcolor -font mainfont \
9345 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9346 -width 30 -height 20 -cursor $maincursor \
9347 -spacing1 1 -spacing3 1 -state disabled
9348 $top.list tag configure highlight -background $selectbgcolor
9349 lappend bglist $top.list
9350 lappend fglist $top.list
9351 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9352 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9353 grid $top.list $top.ysb -sticky nsew
9354 grid $top.xsb x -sticky ew
9355 ${NS}::frame $top.f
9356 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9357 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9358 set reflistfilter "*"
9359 trace add variable reflistfilter write reflistfilter_change
9360 pack $top.f.e -side right -fill x -expand 1
9361 pack $top.f.l -side left
9362 grid $top.f - -sticky ew -pady 2
9363 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9364 bind $top <Key-Escape> [list destroy $top]
9365 grid $top.close -
9366 grid columnconfigure $top 0 -weight 1
9367 grid rowconfigure $top 0 -weight 1
9368 bind $top.list <1> {break}
9369 bind $top.list <B1-Motion> {break}
9370 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9371 set reflist {}
9372 refill_reflist
9375 proc sel_reflist {w x y} {
9376 global showrefstop reflist headids tagids otherrefids
9378 if {![winfo exists $showrefstop]} return
9379 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9380 set ref [lindex $reflist [expr {$l-1}]]
9381 set n [lindex $ref 0]
9382 switch -- [lindex $ref 1] {
9383 "H" {selbyid $headids($n)}
9384 "T" {selbyid $tagids($n)}
9385 "o" {selbyid $otherrefids($n)}
9387 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9390 proc unsel_reflist {} {
9391 global showrefstop
9393 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9394 $showrefstop.list tag remove highlight 0.0 end
9397 proc reflistfilter_change {n1 n2 op} {
9398 global reflistfilter
9400 after cancel refill_reflist
9401 after 200 refill_reflist
9404 proc refill_reflist {} {
9405 global reflist reflistfilter showrefstop headids tagids otherrefids
9406 global curview
9408 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9409 set refs {}
9410 foreach n [array names headids] {
9411 if {[string match $reflistfilter $n]} {
9412 if {[commitinview $headids($n) $curview]} {
9413 lappend refs [list $n H]
9414 } else {
9415 interestedin $headids($n) {run refill_reflist}
9419 foreach n [array names tagids] {
9420 if {[string match $reflistfilter $n]} {
9421 if {[commitinview $tagids($n) $curview]} {
9422 lappend refs [list $n T]
9423 } else {
9424 interestedin $tagids($n) {run refill_reflist}
9428 foreach n [array names otherrefids] {
9429 if {[string match $reflistfilter $n]} {
9430 if {[commitinview $otherrefids($n) $curview]} {
9431 lappend refs [list $n o]
9432 } else {
9433 interestedin $otherrefids($n) {run refill_reflist}
9437 set refs [lsort -index 0 $refs]
9438 if {$refs eq $reflist} return
9440 # Update the contents of $showrefstop.list according to the
9441 # differences between $reflist (old) and $refs (new)
9442 $showrefstop.list conf -state normal
9443 $showrefstop.list insert end "\n"
9444 set i 0
9445 set j 0
9446 while {$i < [llength $reflist] || $j < [llength $refs]} {
9447 if {$i < [llength $reflist]} {
9448 if {$j < [llength $refs]} {
9449 set cmp [string compare [lindex $reflist $i 0] \
9450 [lindex $refs $j 0]]
9451 if {$cmp == 0} {
9452 set cmp [string compare [lindex $reflist $i 1] \
9453 [lindex $refs $j 1]]
9455 } else {
9456 set cmp -1
9458 } else {
9459 set cmp 1
9461 switch -- $cmp {
9462 -1 {
9463 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9464 incr i
9467 incr i
9468 incr j
9471 set l [expr {$j + 1}]
9472 $showrefstop.list image create $l.0 -align baseline \
9473 -image reficon-[lindex $refs $j 1] -padx 2
9474 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9475 incr j
9479 set reflist $refs
9480 # delete last newline
9481 $showrefstop.list delete end-2c end-1c
9482 $showrefstop.list conf -state disabled
9485 # Stuff for finding nearby tags
9486 proc getallcommits {} {
9487 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9488 global idheads idtags idotherrefs allparents tagobjid
9489 global gitdir
9491 if {![info exists allcommits]} {
9492 set nextarc 0
9493 set allcommits 0
9494 set seeds {}
9495 set allcwait 0
9496 set cachedarcs 0
9497 set allccache [file join $gitdir "gitk.cache"]
9498 if {![catch {
9499 set f [open $allccache r]
9500 set allcwait 1
9501 getcache $f
9502 }]} return
9505 if {$allcwait} {
9506 return
9508 set cmd [list | git rev-list --parents]
9509 set allcupdate [expr {$seeds ne {}}]
9510 if {!$allcupdate} {
9511 set ids "--all"
9512 } else {
9513 set refs [concat [array names idheads] [array names idtags] \
9514 [array names idotherrefs]]
9515 set ids {}
9516 set tagobjs {}
9517 foreach name [array names tagobjid] {
9518 lappend tagobjs $tagobjid($name)
9520 foreach id [lsort -unique $refs] {
9521 if {![info exists allparents($id)] &&
9522 [lsearch -exact $tagobjs $id] < 0} {
9523 lappend ids $id
9526 if {$ids ne {}} {
9527 foreach id $seeds {
9528 lappend ids "^$id"
9532 if {$ids ne {}} {
9533 set fd [open [concat $cmd $ids] r]
9534 fconfigure $fd -blocking 0
9535 incr allcommits
9536 nowbusy allcommits
9537 filerun $fd [list getallclines $fd]
9538 } else {
9539 dispneartags 0
9543 # Since most commits have 1 parent and 1 child, we group strings of
9544 # such commits into "arcs" joining branch/merge points (BMPs), which
9545 # are commits that either don't have 1 parent or don't have 1 child.
9547 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9548 # arcout(id) - outgoing arcs for BMP
9549 # arcids(a) - list of IDs on arc including end but not start
9550 # arcstart(a) - BMP ID at start of arc
9551 # arcend(a) - BMP ID at end of arc
9552 # growing(a) - arc a is still growing
9553 # arctags(a) - IDs out of arcids (excluding end) that have tags
9554 # archeads(a) - IDs out of arcids (excluding end) that have heads
9555 # The start of an arc is at the descendent end, so "incoming" means
9556 # coming from descendents, and "outgoing" means going towards ancestors.
9558 proc getallclines {fd} {
9559 global allparents allchildren idtags idheads nextarc
9560 global arcnos arcids arctags arcout arcend arcstart archeads growing
9561 global seeds allcommits cachedarcs allcupdate
9563 set nid 0
9564 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9565 set id [lindex $line 0]
9566 if {[info exists allparents($id)]} {
9567 # seen it already
9568 continue
9570 set cachedarcs 0
9571 set olds [lrange $line 1 end]
9572 set allparents($id) $olds
9573 if {![info exists allchildren($id)]} {
9574 set allchildren($id) {}
9575 set arcnos($id) {}
9576 lappend seeds $id
9577 } else {
9578 set a $arcnos($id)
9579 if {[llength $olds] == 1 && [llength $a] == 1} {
9580 lappend arcids($a) $id
9581 if {[info exists idtags($id)]} {
9582 lappend arctags($a) $id
9584 if {[info exists idheads($id)]} {
9585 lappend archeads($a) $id
9587 if {[info exists allparents($olds)]} {
9588 # seen parent already
9589 if {![info exists arcout($olds)]} {
9590 splitarc $olds
9592 lappend arcids($a) $olds
9593 set arcend($a) $olds
9594 unset growing($a)
9596 lappend allchildren($olds) $id
9597 lappend arcnos($olds) $a
9598 continue
9601 foreach a $arcnos($id) {
9602 lappend arcids($a) $id
9603 set arcend($a) $id
9604 unset growing($a)
9607 set ao {}
9608 foreach p $olds {
9609 lappend allchildren($p) $id
9610 set a [incr nextarc]
9611 set arcstart($a) $id
9612 set archeads($a) {}
9613 set arctags($a) {}
9614 set archeads($a) {}
9615 set arcids($a) {}
9616 lappend ao $a
9617 set growing($a) 1
9618 if {[info exists allparents($p)]} {
9619 # seen it already, may need to make a new branch
9620 if {![info exists arcout($p)]} {
9621 splitarc $p
9623 lappend arcids($a) $p
9624 set arcend($a) $p
9625 unset growing($a)
9627 lappend arcnos($p) $a
9629 set arcout($id) $ao
9631 if {$nid > 0} {
9632 global cached_dheads cached_dtags cached_atags
9633 catch {unset cached_dheads}
9634 catch {unset cached_dtags}
9635 catch {unset cached_atags}
9637 if {![eof $fd]} {
9638 return [expr {$nid >= 1000? 2: 1}]
9640 set cacheok 1
9641 if {[catch {
9642 fconfigure $fd -blocking 1
9643 close $fd
9644 } err]} {
9645 # got an error reading the list of commits
9646 # if we were updating, try rereading the whole thing again
9647 if {$allcupdate} {
9648 incr allcommits -1
9649 dropcache $err
9650 return
9652 error_popup "[mc "Error reading commit topology information;\
9653 branch and preceding/following tag information\
9654 will be incomplete."]\n($err)"
9655 set cacheok 0
9657 if {[incr allcommits -1] == 0} {
9658 notbusy allcommits
9659 if {$cacheok} {
9660 run savecache
9663 dispneartags 0
9664 return 0
9667 proc recalcarc {a} {
9668 global arctags archeads arcids idtags idheads
9670 set at {}
9671 set ah {}
9672 foreach id [lrange $arcids($a) 0 end-1] {
9673 if {[info exists idtags($id)]} {
9674 lappend at $id
9676 if {[info exists idheads($id)]} {
9677 lappend ah $id
9680 set arctags($a) $at
9681 set archeads($a) $ah
9684 proc splitarc {p} {
9685 global arcnos arcids nextarc arctags archeads idtags idheads
9686 global arcstart arcend arcout allparents growing
9688 set a $arcnos($p)
9689 if {[llength $a] != 1} {
9690 puts "oops splitarc called but [llength $a] arcs already"
9691 return
9693 set a [lindex $a 0]
9694 set i [lsearch -exact $arcids($a) $p]
9695 if {$i < 0} {
9696 puts "oops splitarc $p not in arc $a"
9697 return
9699 set na [incr nextarc]
9700 if {[info exists arcend($a)]} {
9701 set arcend($na) $arcend($a)
9702 } else {
9703 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9704 set j [lsearch -exact $arcnos($l) $a]
9705 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9707 set tail [lrange $arcids($a) [expr {$i+1}] end]
9708 set arcids($a) [lrange $arcids($a) 0 $i]
9709 set arcend($a) $p
9710 set arcstart($na) $p
9711 set arcout($p) $na
9712 set arcids($na) $tail
9713 if {[info exists growing($a)]} {
9714 set growing($na) 1
9715 unset growing($a)
9718 foreach id $tail {
9719 if {[llength $arcnos($id)] == 1} {
9720 set arcnos($id) $na
9721 } else {
9722 set j [lsearch -exact $arcnos($id) $a]
9723 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9727 # reconstruct tags and heads lists
9728 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9729 recalcarc $a
9730 recalcarc $na
9731 } else {
9732 set arctags($na) {}
9733 set archeads($na) {}
9737 # Update things for a new commit added that is a child of one
9738 # existing commit. Used when cherry-picking.
9739 proc addnewchild {id p} {
9740 global allparents allchildren idtags nextarc
9741 global arcnos arcids arctags arcout arcend arcstart archeads growing
9742 global seeds allcommits
9744 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9745 set allparents($id) [list $p]
9746 set allchildren($id) {}
9747 set arcnos($id) {}
9748 lappend seeds $id
9749 lappend allchildren($p) $id
9750 set a [incr nextarc]
9751 set arcstart($a) $id
9752 set archeads($a) {}
9753 set arctags($a) {}
9754 set arcids($a) [list $p]
9755 set arcend($a) $p
9756 if {![info exists arcout($p)]} {
9757 splitarc $p
9759 lappend arcnos($p) $a
9760 set arcout($id) [list $a]
9763 # This implements a cache for the topology information.
9764 # The cache saves, for each arc, the start and end of the arc,
9765 # the ids on the arc, and the outgoing arcs from the end.
9766 proc readcache {f} {
9767 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9768 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9769 global allcwait
9771 set a $nextarc
9772 set lim $cachedarcs
9773 if {$lim - $a > 500} {
9774 set lim [expr {$a + 500}]
9776 if {[catch {
9777 if {$a == $lim} {
9778 # finish reading the cache and setting up arctags, etc.
9779 set line [gets $f]
9780 if {$line ne "1"} {error "bad final version"}
9781 close $f
9782 foreach id [array names idtags] {
9783 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9784 [llength $allparents($id)] == 1} {
9785 set a [lindex $arcnos($id) 0]
9786 if {$arctags($a) eq {}} {
9787 recalcarc $a
9791 foreach id [array names idheads] {
9792 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9793 [llength $allparents($id)] == 1} {
9794 set a [lindex $arcnos($id) 0]
9795 if {$archeads($a) eq {}} {
9796 recalcarc $a
9800 foreach id [lsort -unique $possible_seeds] {
9801 if {$arcnos($id) eq {}} {
9802 lappend seeds $id
9805 set allcwait 0
9806 } else {
9807 while {[incr a] <= $lim} {
9808 set line [gets $f]
9809 if {[llength $line] != 3} {error "bad line"}
9810 set s [lindex $line 0]
9811 set arcstart($a) $s
9812 lappend arcout($s) $a
9813 if {![info exists arcnos($s)]} {
9814 lappend possible_seeds $s
9815 set arcnos($s) {}
9817 set e [lindex $line 1]
9818 if {$e eq {}} {
9819 set growing($a) 1
9820 } else {
9821 set arcend($a) $e
9822 if {![info exists arcout($e)]} {
9823 set arcout($e) {}
9826 set arcids($a) [lindex $line 2]
9827 foreach id $arcids($a) {
9828 lappend allparents($s) $id
9829 set s $id
9830 lappend arcnos($id) $a
9832 if {![info exists allparents($s)]} {
9833 set allparents($s) {}
9835 set arctags($a) {}
9836 set archeads($a) {}
9838 set nextarc [expr {$a - 1}]
9840 } err]} {
9841 dropcache $err
9842 return 0
9844 if {!$allcwait} {
9845 getallcommits
9847 return $allcwait
9850 proc getcache {f} {
9851 global nextarc cachedarcs possible_seeds
9853 if {[catch {
9854 set line [gets $f]
9855 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9856 # make sure it's an integer
9857 set cachedarcs [expr {int([lindex $line 1])}]
9858 if {$cachedarcs < 0} {error "bad number of arcs"}
9859 set nextarc 0
9860 set possible_seeds {}
9861 run readcache $f
9862 } err]} {
9863 dropcache $err
9865 return 0
9868 proc dropcache {err} {
9869 global allcwait nextarc cachedarcs seeds
9871 #puts "dropping cache ($err)"
9872 foreach v {arcnos arcout arcids arcstart arcend growing \
9873 arctags archeads allparents allchildren} {
9874 global $v
9875 catch {unset $v}
9877 set allcwait 0
9878 set nextarc 0
9879 set cachedarcs 0
9880 set seeds {}
9881 getallcommits
9884 proc writecache {f} {
9885 global cachearc cachedarcs allccache
9886 global arcstart arcend arcnos arcids arcout
9888 set a $cachearc
9889 set lim $cachedarcs
9890 if {$lim - $a > 1000} {
9891 set lim [expr {$a + 1000}]
9893 if {[catch {
9894 while {[incr a] <= $lim} {
9895 if {[info exists arcend($a)]} {
9896 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9897 } else {
9898 puts $f [list $arcstart($a) {} $arcids($a)]
9901 } err]} {
9902 catch {close $f}
9903 catch {file delete $allccache}
9904 #puts "writing cache failed ($err)"
9905 return 0
9907 set cachearc [expr {$a - 1}]
9908 if {$a > $cachedarcs} {
9909 puts $f "1"
9910 close $f
9911 return 0
9913 return 1
9916 proc savecache {} {
9917 global nextarc cachedarcs cachearc allccache
9919 if {$nextarc == $cachedarcs} return
9920 set cachearc 0
9921 set cachedarcs $nextarc
9922 catch {
9923 set f [open $allccache w]
9924 puts $f [list 1 $cachedarcs]
9925 run writecache $f
9929 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9930 # or 0 if neither is true.
9931 proc anc_or_desc {a b} {
9932 global arcout arcstart arcend arcnos cached_isanc
9934 if {$arcnos($a) eq $arcnos($b)} {
9935 # Both are on the same arc(s); either both are the same BMP,
9936 # or if one is not a BMP, the other is also not a BMP or is
9937 # the BMP at end of the arc (and it only has 1 incoming arc).
9938 # Or both can be BMPs with no incoming arcs.
9939 if {$a eq $b || $arcnos($a) eq {}} {
9940 return 0
9942 # assert {[llength $arcnos($a)] == 1}
9943 set arc [lindex $arcnos($a) 0]
9944 set i [lsearch -exact $arcids($arc) $a]
9945 set j [lsearch -exact $arcids($arc) $b]
9946 if {$i < 0 || $i > $j} {
9947 return 1
9948 } else {
9949 return -1
9953 if {![info exists arcout($a)]} {
9954 set arc [lindex $arcnos($a) 0]
9955 if {[info exists arcend($arc)]} {
9956 set aend $arcend($arc)
9957 } else {
9958 set aend {}
9960 set a $arcstart($arc)
9961 } else {
9962 set aend $a
9964 if {![info exists arcout($b)]} {
9965 set arc [lindex $arcnos($b) 0]
9966 if {[info exists arcend($arc)]} {
9967 set bend $arcend($arc)
9968 } else {
9969 set bend {}
9971 set b $arcstart($arc)
9972 } else {
9973 set bend $b
9975 if {$a eq $bend} {
9976 return 1
9978 if {$b eq $aend} {
9979 return -1
9981 if {[info exists cached_isanc($a,$bend)]} {
9982 if {$cached_isanc($a,$bend)} {
9983 return 1
9986 if {[info exists cached_isanc($b,$aend)]} {
9987 if {$cached_isanc($b,$aend)} {
9988 return -1
9990 if {[info exists cached_isanc($a,$bend)]} {
9991 return 0
9995 set todo [list $a $b]
9996 set anc($a) a
9997 set anc($b) b
9998 for {set i 0} {$i < [llength $todo]} {incr i} {
9999 set x [lindex $todo $i]
10000 if {$anc($x) eq {}} {
10001 continue
10003 foreach arc $arcnos($x) {
10004 set xd $arcstart($arc)
10005 if {$xd eq $bend} {
10006 set cached_isanc($a,$bend) 1
10007 set cached_isanc($b,$aend) 0
10008 return 1
10009 } elseif {$xd eq $aend} {
10010 set cached_isanc($b,$aend) 1
10011 set cached_isanc($a,$bend) 0
10012 return -1
10014 if {![info exists anc($xd)]} {
10015 set anc($xd) $anc($x)
10016 lappend todo $xd
10017 } elseif {$anc($xd) ne $anc($x)} {
10018 set anc($xd) {}
10022 set cached_isanc($a,$bend) 0
10023 set cached_isanc($b,$aend) 0
10024 return 0
10027 # This identifies whether $desc has an ancestor that is
10028 # a growing tip of the graph and which is not an ancestor of $anc
10029 # and returns 0 if so and 1 if not.
10030 # If we subsequently discover a tag on such a growing tip, and that
10031 # turns out to be a descendent of $anc (which it could, since we
10032 # don't necessarily see children before parents), then $desc
10033 # isn't a good choice to display as a descendent tag of
10034 # $anc (since it is the descendent of another tag which is
10035 # a descendent of $anc). Similarly, $anc isn't a good choice to
10036 # display as a ancestor tag of $desc.
10038 proc is_certain {desc anc} {
10039 global arcnos arcout arcstart arcend growing problems
10041 set certain {}
10042 if {[llength $arcnos($anc)] == 1} {
10043 # tags on the same arc are certain
10044 if {$arcnos($desc) eq $arcnos($anc)} {
10045 return 1
10047 if {![info exists arcout($anc)]} {
10048 # if $anc is partway along an arc, use the start of the arc instead
10049 set a [lindex $arcnos($anc) 0]
10050 set anc $arcstart($a)
10053 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10054 set x $desc
10055 } else {
10056 set a [lindex $arcnos($desc) 0]
10057 set x $arcend($a)
10059 if {$x == $anc} {
10060 return 1
10062 set anclist [list $x]
10063 set dl($x) 1
10064 set nnh 1
10065 set ngrowanc 0
10066 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10067 set x [lindex $anclist $i]
10068 if {$dl($x)} {
10069 incr nnh -1
10071 set done($x) 1
10072 foreach a $arcout($x) {
10073 if {[info exists growing($a)]} {
10074 if {![info exists growanc($x)] && $dl($x)} {
10075 set growanc($x) 1
10076 incr ngrowanc
10078 } else {
10079 set y $arcend($a)
10080 if {[info exists dl($y)]} {
10081 if {$dl($y)} {
10082 if {!$dl($x)} {
10083 set dl($y) 0
10084 if {![info exists done($y)]} {
10085 incr nnh -1
10087 if {[info exists growanc($x)]} {
10088 incr ngrowanc -1
10090 set xl [list $y]
10091 for {set k 0} {$k < [llength $xl]} {incr k} {
10092 set z [lindex $xl $k]
10093 foreach c $arcout($z) {
10094 if {[info exists arcend($c)]} {
10095 set v $arcend($c)
10096 if {[info exists dl($v)] && $dl($v)} {
10097 set dl($v) 0
10098 if {![info exists done($v)]} {
10099 incr nnh -1
10101 if {[info exists growanc($v)]} {
10102 incr ngrowanc -1
10104 lappend xl $v
10111 } elseif {$y eq $anc || !$dl($x)} {
10112 set dl($y) 0
10113 lappend anclist $y
10114 } else {
10115 set dl($y) 1
10116 lappend anclist $y
10117 incr nnh
10122 foreach x [array names growanc] {
10123 if {$dl($x)} {
10124 return 0
10126 return 0
10128 return 1
10131 proc validate_arctags {a} {
10132 global arctags idtags
10134 set i -1
10135 set na $arctags($a)
10136 foreach id $arctags($a) {
10137 incr i
10138 if {![info exists idtags($id)]} {
10139 set na [lreplace $na $i $i]
10140 incr i -1
10143 set arctags($a) $na
10146 proc validate_archeads {a} {
10147 global archeads idheads
10149 set i -1
10150 set na $archeads($a)
10151 foreach id $archeads($a) {
10152 incr i
10153 if {![info exists idheads($id)]} {
10154 set na [lreplace $na $i $i]
10155 incr i -1
10158 set archeads($a) $na
10161 # Return the list of IDs that have tags that are descendents of id,
10162 # ignoring IDs that are descendents of IDs already reported.
10163 proc desctags {id} {
10164 global arcnos arcstart arcids arctags idtags allparents
10165 global growing cached_dtags
10167 if {![info exists allparents($id)]} {
10168 return {}
10170 set t1 [clock clicks -milliseconds]
10171 set argid $id
10172 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10173 # part-way along an arc; check that arc first
10174 set a [lindex $arcnos($id) 0]
10175 if {$arctags($a) ne {}} {
10176 validate_arctags $a
10177 set i [lsearch -exact $arcids($a) $id]
10178 set tid {}
10179 foreach t $arctags($a) {
10180 set j [lsearch -exact $arcids($a) $t]
10181 if {$j >= $i} break
10182 set tid $t
10184 if {$tid ne {}} {
10185 return $tid
10188 set id $arcstart($a)
10189 if {[info exists idtags($id)]} {
10190 return $id
10193 if {[info exists cached_dtags($id)]} {
10194 return $cached_dtags($id)
10197 set origid $id
10198 set todo [list $id]
10199 set queued($id) 1
10200 set nc 1
10201 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10202 set id [lindex $todo $i]
10203 set done($id) 1
10204 set ta [info exists hastaggedancestor($id)]
10205 if {!$ta} {
10206 incr nc -1
10208 # ignore tags on starting node
10209 if {!$ta && $i > 0} {
10210 if {[info exists idtags($id)]} {
10211 set tagloc($id) $id
10212 set ta 1
10213 } elseif {[info exists cached_dtags($id)]} {
10214 set tagloc($id) $cached_dtags($id)
10215 set ta 1
10218 foreach a $arcnos($id) {
10219 set d $arcstart($a)
10220 if {!$ta && $arctags($a) ne {}} {
10221 validate_arctags $a
10222 if {$arctags($a) ne {}} {
10223 lappend tagloc($id) [lindex $arctags($a) end]
10226 if {$ta || $arctags($a) ne {}} {
10227 set tomark [list $d]
10228 for {set j 0} {$j < [llength $tomark]} {incr j} {
10229 set dd [lindex $tomark $j]
10230 if {![info exists hastaggedancestor($dd)]} {
10231 if {[info exists done($dd)]} {
10232 foreach b $arcnos($dd) {
10233 lappend tomark $arcstart($b)
10235 if {[info exists tagloc($dd)]} {
10236 unset tagloc($dd)
10238 } elseif {[info exists queued($dd)]} {
10239 incr nc -1
10241 set hastaggedancestor($dd) 1
10245 if {![info exists queued($d)]} {
10246 lappend todo $d
10247 set queued($d) 1
10248 if {![info exists hastaggedancestor($d)]} {
10249 incr nc
10254 set tags {}
10255 foreach id [array names tagloc] {
10256 if {![info exists hastaggedancestor($id)]} {
10257 foreach t $tagloc($id) {
10258 if {[lsearch -exact $tags $t] < 0} {
10259 lappend tags $t
10264 set t2 [clock clicks -milliseconds]
10265 set loopix $i
10267 # remove tags that are descendents of other tags
10268 for {set i 0} {$i < [llength $tags]} {incr i} {
10269 set a [lindex $tags $i]
10270 for {set j 0} {$j < $i} {incr j} {
10271 set b [lindex $tags $j]
10272 set r [anc_or_desc $a $b]
10273 if {$r == 1} {
10274 set tags [lreplace $tags $j $j]
10275 incr j -1
10276 incr i -1
10277 } elseif {$r == -1} {
10278 set tags [lreplace $tags $i $i]
10279 incr i -1
10280 break
10285 if {[array names growing] ne {}} {
10286 # graph isn't finished, need to check if any tag could get
10287 # eclipsed by another tag coming later. Simply ignore any
10288 # tags that could later get eclipsed.
10289 set ctags {}
10290 foreach t $tags {
10291 if {[is_certain $t $origid]} {
10292 lappend ctags $t
10295 if {$tags eq $ctags} {
10296 set cached_dtags($origid) $tags
10297 } else {
10298 set tags $ctags
10300 } else {
10301 set cached_dtags($origid) $tags
10303 set t3 [clock clicks -milliseconds]
10304 if {0 && $t3 - $t1 >= 100} {
10305 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10306 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10308 return $tags
10311 proc anctags {id} {
10312 global arcnos arcids arcout arcend arctags idtags allparents
10313 global growing cached_atags
10315 if {![info exists allparents($id)]} {
10316 return {}
10318 set t1 [clock clicks -milliseconds]
10319 set argid $id
10320 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10321 # part-way along an arc; check that arc first
10322 set a [lindex $arcnos($id) 0]
10323 if {$arctags($a) ne {}} {
10324 validate_arctags $a
10325 set i [lsearch -exact $arcids($a) $id]
10326 foreach t $arctags($a) {
10327 set j [lsearch -exact $arcids($a) $t]
10328 if {$j > $i} {
10329 return $t
10333 if {![info exists arcend($a)]} {
10334 return {}
10336 set id $arcend($a)
10337 if {[info exists idtags($id)]} {
10338 return $id
10341 if {[info exists cached_atags($id)]} {
10342 return $cached_atags($id)
10345 set origid $id
10346 set todo [list $id]
10347 set queued($id) 1
10348 set taglist {}
10349 set nc 1
10350 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10351 set id [lindex $todo $i]
10352 set done($id) 1
10353 set td [info exists hastaggeddescendent($id)]
10354 if {!$td} {
10355 incr nc -1
10357 # ignore tags on starting node
10358 if {!$td && $i > 0} {
10359 if {[info exists idtags($id)]} {
10360 set tagloc($id) $id
10361 set td 1
10362 } elseif {[info exists cached_atags($id)]} {
10363 set tagloc($id) $cached_atags($id)
10364 set td 1
10367 foreach a $arcout($id) {
10368 if {!$td && $arctags($a) ne {}} {
10369 validate_arctags $a
10370 if {$arctags($a) ne {}} {
10371 lappend tagloc($id) [lindex $arctags($a) 0]
10374 if {![info exists arcend($a)]} continue
10375 set d $arcend($a)
10376 if {$td || $arctags($a) ne {}} {
10377 set tomark [list $d]
10378 for {set j 0} {$j < [llength $tomark]} {incr j} {
10379 set dd [lindex $tomark $j]
10380 if {![info exists hastaggeddescendent($dd)]} {
10381 if {[info exists done($dd)]} {
10382 foreach b $arcout($dd) {
10383 if {[info exists arcend($b)]} {
10384 lappend tomark $arcend($b)
10387 if {[info exists tagloc($dd)]} {
10388 unset tagloc($dd)
10390 } elseif {[info exists queued($dd)]} {
10391 incr nc -1
10393 set hastaggeddescendent($dd) 1
10397 if {![info exists queued($d)]} {
10398 lappend todo $d
10399 set queued($d) 1
10400 if {![info exists hastaggeddescendent($d)]} {
10401 incr nc
10406 set t2 [clock clicks -milliseconds]
10407 set loopix $i
10408 set tags {}
10409 foreach id [array names tagloc] {
10410 if {![info exists hastaggeddescendent($id)]} {
10411 foreach t $tagloc($id) {
10412 if {[lsearch -exact $tags $t] < 0} {
10413 lappend tags $t
10419 # remove tags that are ancestors of other tags
10420 for {set i 0} {$i < [llength $tags]} {incr i} {
10421 set a [lindex $tags $i]
10422 for {set j 0} {$j < $i} {incr j} {
10423 set b [lindex $tags $j]
10424 set r [anc_or_desc $a $b]
10425 if {$r == -1} {
10426 set tags [lreplace $tags $j $j]
10427 incr j -1
10428 incr i -1
10429 } elseif {$r == 1} {
10430 set tags [lreplace $tags $i $i]
10431 incr i -1
10432 break
10437 if {[array names growing] ne {}} {
10438 # graph isn't finished, need to check if any tag could get
10439 # eclipsed by another tag coming later. Simply ignore any
10440 # tags that could later get eclipsed.
10441 set ctags {}
10442 foreach t $tags {
10443 if {[is_certain $origid $t]} {
10444 lappend ctags $t
10447 if {$tags eq $ctags} {
10448 set cached_atags($origid) $tags
10449 } else {
10450 set tags $ctags
10452 } else {
10453 set cached_atags($origid) $tags
10455 set t3 [clock clicks -milliseconds]
10456 if {0 && $t3 - $t1 >= 100} {
10457 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10458 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10460 return $tags
10463 # Return the list of IDs that have heads that are descendents of id,
10464 # including id itself if it has a head.
10465 proc descheads {id} {
10466 global arcnos arcstart arcids archeads idheads cached_dheads
10467 global allparents
10469 if {![info exists allparents($id)]} {
10470 return {}
10472 set aret {}
10473 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10474 # part-way along an arc; check it first
10475 set a [lindex $arcnos($id) 0]
10476 if {$archeads($a) ne {}} {
10477 validate_archeads $a
10478 set i [lsearch -exact $arcids($a) $id]
10479 foreach t $archeads($a) {
10480 set j [lsearch -exact $arcids($a) $t]
10481 if {$j > $i} break
10482 lappend aret $t
10485 set id $arcstart($a)
10487 set origid $id
10488 set todo [list $id]
10489 set seen($id) 1
10490 set ret {}
10491 for {set i 0} {$i < [llength $todo]} {incr i} {
10492 set id [lindex $todo $i]
10493 if {[info exists cached_dheads($id)]} {
10494 set ret [concat $ret $cached_dheads($id)]
10495 } else {
10496 if {[info exists idheads($id)]} {
10497 lappend ret $id
10499 foreach a $arcnos($id) {
10500 if {$archeads($a) ne {}} {
10501 validate_archeads $a
10502 if {$archeads($a) ne {}} {
10503 set ret [concat $ret $archeads($a)]
10506 set d $arcstart($a)
10507 if {![info exists seen($d)]} {
10508 lappend todo $d
10509 set seen($d) 1
10514 set ret [lsort -unique $ret]
10515 set cached_dheads($origid) $ret
10516 return [concat $ret $aret]
10519 proc addedtag {id} {
10520 global arcnos arcout cached_dtags cached_atags
10522 if {![info exists arcnos($id)]} return
10523 if {![info exists arcout($id)]} {
10524 recalcarc [lindex $arcnos($id) 0]
10526 catch {unset cached_dtags}
10527 catch {unset cached_atags}
10530 proc addedhead {hid head} {
10531 global arcnos arcout cached_dheads
10533 if {![info exists arcnos($hid)]} return
10534 if {![info exists arcout($hid)]} {
10535 recalcarc [lindex $arcnos($hid) 0]
10537 catch {unset cached_dheads}
10540 proc removedhead {hid head} {
10541 global cached_dheads
10543 catch {unset cached_dheads}
10546 proc movedhead {hid head} {
10547 global arcnos arcout cached_dheads
10549 if {![info exists arcnos($hid)]} return
10550 if {![info exists arcout($hid)]} {
10551 recalcarc [lindex $arcnos($hid) 0]
10553 catch {unset cached_dheads}
10556 proc changedrefs {} {
10557 global cached_dheads cached_dtags cached_atags
10558 global arctags archeads arcnos arcout idheads idtags
10560 foreach id [concat [array names idheads] [array names idtags]] {
10561 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10562 set a [lindex $arcnos($id) 0]
10563 if {![info exists donearc($a)]} {
10564 recalcarc $a
10565 set donearc($a) 1
10569 catch {unset cached_dtags}
10570 catch {unset cached_atags}
10571 catch {unset cached_dheads}
10574 proc rereadrefs {} {
10575 global idtags idheads idotherrefs mainheadid
10577 set refids [concat [array names idtags] \
10578 [array names idheads] [array names idotherrefs]]
10579 foreach id $refids {
10580 if {![info exists ref($id)]} {
10581 set ref($id) [listrefs $id]
10584 set oldmainhead $mainheadid
10585 readrefs
10586 changedrefs
10587 set refids [lsort -unique [concat $refids [array names idtags] \
10588 [array names idheads] [array names idotherrefs]]]
10589 foreach id $refids {
10590 set v [listrefs $id]
10591 if {![info exists ref($id)] || $ref($id) != $v} {
10592 redrawtags $id
10595 if {$oldmainhead ne $mainheadid} {
10596 redrawtags $oldmainhead
10597 redrawtags $mainheadid
10599 run refill_reflist
10602 proc listrefs {id} {
10603 global idtags idheads idotherrefs
10605 set x {}
10606 if {[info exists idtags($id)]} {
10607 set x $idtags($id)
10609 set y {}
10610 if {[info exists idheads($id)]} {
10611 set y $idheads($id)
10613 set z {}
10614 if {[info exists idotherrefs($id)]} {
10615 set z $idotherrefs($id)
10617 return [list $x $y $z]
10620 proc showtag {tag isnew} {
10621 global ctext tagcontents tagids linknum tagobjid
10623 if {$isnew} {
10624 addtohistory [list showtag $tag 0] savectextpos
10626 $ctext conf -state normal
10627 clear_ctext
10628 settabs 0
10629 set linknum 0
10630 if {![info exists tagcontents($tag)]} {
10631 catch {
10632 set tagcontents($tag) [exec git cat-file tag $tag]
10635 if {[info exists tagcontents($tag)]} {
10636 set text $tagcontents($tag)
10637 } else {
10638 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10640 appendwithlinks $text {}
10641 maybe_scroll_ctext 1
10642 $ctext conf -state disabled
10643 init_flist {}
10646 proc doquit {} {
10647 global stopped
10648 global gitktmpdir
10650 set stopped 100
10651 savestuff .
10652 destroy .
10654 if {[info exists gitktmpdir]} {
10655 catch {file delete -force $gitktmpdir}
10659 proc mkfontdisp {font top which} {
10660 global fontattr fontpref $font NS use_ttk
10662 set fontpref($font) [set $font]
10663 ${NS}::button $top.${font}but -text $which \
10664 -command [list choosefont $font $which]
10665 ${NS}::label $top.$font -relief flat -font $font \
10666 -text $fontattr($font,family) -justify left
10667 grid x $top.${font}but $top.$font -sticky w
10670 proc choosefont {font which} {
10671 global fontparam fontlist fonttop fontattr
10672 global prefstop NS
10674 set fontparam(which) $which
10675 set fontparam(font) $font
10676 set fontparam(family) [font actual $font -family]
10677 set fontparam(size) $fontattr($font,size)
10678 set fontparam(weight) $fontattr($font,weight)
10679 set fontparam(slant) $fontattr($font,slant)
10680 set top .gitkfont
10681 set fonttop $top
10682 if {![winfo exists $top]} {
10683 font create sample
10684 eval font config sample [font actual $font]
10685 ttk_toplevel $top
10686 make_transient $top $prefstop
10687 wm title $top [mc "Gitk font chooser"]
10688 ${NS}::label $top.l -textvariable fontparam(which)
10689 pack $top.l -side top
10690 set fontlist [lsort [font families]]
10691 ${NS}::frame $top.f
10692 listbox $top.f.fam -listvariable fontlist \
10693 -yscrollcommand [list $top.f.sb set]
10694 bind $top.f.fam <<ListboxSelect>> selfontfam
10695 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10696 pack $top.f.sb -side right -fill y
10697 pack $top.f.fam -side left -fill both -expand 1
10698 pack $top.f -side top -fill both -expand 1
10699 ${NS}::frame $top.g
10700 spinbox $top.g.size -from 4 -to 40 -width 4 \
10701 -textvariable fontparam(size) \
10702 -validatecommand {string is integer -strict %s}
10703 checkbutton $top.g.bold -padx 5 \
10704 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10705 -variable fontparam(weight) -onvalue bold -offvalue normal
10706 checkbutton $top.g.ital -padx 5 \
10707 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10708 -variable fontparam(slant) -onvalue italic -offvalue roman
10709 pack $top.g.size $top.g.bold $top.g.ital -side left
10710 pack $top.g -side top
10711 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10712 -background white
10713 $top.c create text 100 25 -anchor center -text $which -font sample \
10714 -fill black -tags text
10715 bind $top.c <Configure> [list centertext $top.c]
10716 pack $top.c -side top -fill x
10717 ${NS}::frame $top.buts
10718 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10719 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10720 bind $top <Key-Return> fontok
10721 bind $top <Key-Escape> fontcan
10722 grid $top.buts.ok $top.buts.can
10723 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10724 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10725 pack $top.buts -side bottom -fill x
10726 trace add variable fontparam write chg_fontparam
10727 } else {
10728 raise $top
10729 $top.c itemconf text -text $which
10731 set i [lsearch -exact $fontlist $fontparam(family)]
10732 if {$i >= 0} {
10733 $top.f.fam selection set $i
10734 $top.f.fam see $i
10738 proc centertext {w} {
10739 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10742 proc fontok {} {
10743 global fontparam fontpref prefstop
10745 set f $fontparam(font)
10746 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10747 if {$fontparam(weight) eq "bold"} {
10748 lappend fontpref($f) "bold"
10750 if {$fontparam(slant) eq "italic"} {
10751 lappend fontpref($f) "italic"
10753 set w $prefstop.$f
10754 $w conf -text $fontparam(family) -font $fontpref($f)
10756 fontcan
10759 proc fontcan {} {
10760 global fonttop fontparam
10762 if {[info exists fonttop]} {
10763 catch {destroy $fonttop}
10764 catch {font delete sample}
10765 unset fonttop
10766 unset fontparam
10770 if {[package vsatisfies [package provide Tk] 8.6]} {
10771 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10772 # function to make use of it.
10773 proc choosefont {font which} {
10774 tk fontchooser configure -title $which -font $font \
10775 -command [list on_choosefont $font $which]
10776 tk fontchooser show
10778 proc on_choosefont {font which newfont} {
10779 global fontparam
10780 puts stderr "$font $newfont"
10781 array set f [font actual $newfont]
10782 set fontparam(which) $which
10783 set fontparam(font) $font
10784 set fontparam(family) $f(-family)
10785 set fontparam(size) $f(-size)
10786 set fontparam(weight) $f(-weight)
10787 set fontparam(slant) $f(-slant)
10788 fontok
10792 proc selfontfam {} {
10793 global fonttop fontparam
10795 set i [$fonttop.f.fam curselection]
10796 if {$i ne {}} {
10797 set fontparam(family) [$fonttop.f.fam get $i]
10801 proc chg_fontparam {v sub op} {
10802 global fontparam
10804 font config sample -$sub $fontparam($sub)
10807 # Create a property sheet tab page
10808 proc create_prefs_page {w} {
10809 global NS
10810 set parent [join [lrange [split $w .] 0 end-1] .]
10811 if {[winfo class $parent] eq "TNotebook"} {
10812 ${NS}::frame $w
10813 } else {
10814 ${NS}::labelframe $w
10818 proc prefspage_general {notebook} {
10819 global NS maxwidth maxgraphpct showneartags showlocalchanges
10820 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
10821 global hideremotes want_ttk have_ttk
10823 set page [create_prefs_page $notebook.general]
10825 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
10826 grid $page.ldisp - -sticky w -pady 10
10827 ${NS}::label $page.spacer -text " "
10828 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
10829 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10830 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
10831 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
10832 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10833 grid x $page.maxpctl $page.maxpct -sticky w
10834 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
10835 -variable showlocalchanges
10836 grid x $page.showlocal -sticky w
10837 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
10838 -variable autoselect
10839 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
10840 grid x $page.autoselect $page.autosellen -sticky w
10841 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
10842 -variable hideremotes
10843 grid x $page.hideremotes -sticky w
10845 ${NS}::label $page.ddisp -text [mc "Diff display options"]
10846 grid $page.ddisp - -sticky w -pady 10
10847 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
10848 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10849 grid x $page.tabstopl $page.tabstop -sticky w
10850 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags"] \
10851 -variable showneartags
10852 grid x $page.ntag -sticky w
10853 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
10854 -variable limitdiffs
10855 grid x $page.ldiff -sticky w
10856 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
10857 -variable perfile_attrs
10858 grid x $page.lattr -sticky w
10860 ${NS}::entry $page.extdifft -textvariable extdifftool
10861 ${NS}::frame $page.extdifff
10862 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
10863 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10864 pack $page.extdifff.l $page.extdifff.b -side left
10865 pack configure $page.extdifff.l -padx 10
10866 grid x $page.extdifff $page.extdifft -sticky ew
10868 ${NS}::label $page.lgen -text [mc "General options"]
10869 grid $page.lgen - -sticky w -pady 10
10870 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
10871 -text [mc "Use themed widgets"]
10872 if {$have_ttk} {
10873 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
10874 } else {
10875 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
10877 grid x $page.want_ttk $page.ttk_note -sticky w
10878 return $page
10881 proc prefspage_colors {notebook} {
10882 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10884 set page [create_prefs_page $notebook.colors]
10886 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
10887 grid $page.cdisp - -sticky w -pady 10
10888 label $page.ui -padx 40 -relief sunk -background $uicolor
10889 ${NS}::button $page.uibut -text [mc "Interface"] \
10890 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
10891 grid x $page.uibut $page.ui -sticky w
10892 label $page.bg -padx 40 -relief sunk -background $bgcolor
10893 ${NS}::button $page.bgbut -text [mc "Background"] \
10894 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
10895 grid x $page.bgbut $page.bg -sticky w
10896 label $page.fg -padx 40 -relief sunk -background $fgcolor
10897 ${NS}::button $page.fgbut -text [mc "Foreground"] \
10898 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
10899 grid x $page.fgbut $page.fg -sticky w
10900 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10901 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
10902 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
10903 [list $ctext tag conf d0 -foreground]]
10904 grid x $page.diffoldbut $page.diffold -sticky w
10905 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10906 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
10907 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
10908 [list $ctext tag conf dresult -foreground]]
10909 grid x $page.diffnewbut $page.diffnew -sticky w
10910 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10911 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
10912 -command [list choosecolor diffcolors 2 $page.hunksep \
10913 [mc "diff hunk header"] \
10914 [list $ctext tag conf hunksep -foreground]]
10915 grid x $page.hunksepbut $page.hunksep -sticky w
10916 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
10917 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
10918 -command [list choosecolor markbgcolor {} $page.markbgsep \
10919 [mc "marked line background"] \
10920 [list $ctext tag conf omark -background]]
10921 grid x $page.markbgbut $page.markbgsep -sticky w
10922 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10923 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
10924 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
10925 grid x $page.selbgbut $page.selbgsep -sticky w
10926 return $page
10929 proc prefspage_fonts {notebook} {
10930 global NS
10931 set page [create_prefs_page $notebook.fonts]
10932 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
10933 grid $page.cfont - -sticky w -pady 10
10934 mkfontdisp mainfont $page [mc "Main font"]
10935 mkfontdisp textfont $page [mc "Diff display font"]
10936 mkfontdisp uifont $page [mc "User interface font"]
10937 return $page
10940 proc doprefs {} {
10941 global maxwidth maxgraphpct use_ttk NS
10942 global oldprefs prefstop showneartags showlocalchanges
10943 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10944 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
10945 global hideremotes want_ttk have_ttk
10947 set top .gitkprefs
10948 set prefstop $top
10949 if {[winfo exists $top]} {
10950 raise $top
10951 return
10953 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10954 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10955 set oldprefs($v) [set $v]
10957 ttk_toplevel $top
10958 wm title $top [mc "Gitk preferences"]
10959 make_transient $top .
10961 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
10962 set notebook [ttk::notebook $top.notebook]
10963 } else {
10964 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
10967 lappend pages [prefspage_general $notebook] [mc "General"]
10968 lappend pages [prefspage_colors $notebook] [mc "Colors"]
10969 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
10970 foreach {page title} $pages {
10971 if {$use_notebook} {
10972 $notebook add $page -text $title
10973 } else {
10974 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
10975 -text $title -command [list raise $page]]
10976 $page configure -text $title
10977 grid $btn -row 0 -column [incr col] -sticky w
10978 grid $page -row 1 -column 0 -sticky news -columnspan 100
10982 if {!$use_notebook} {
10983 grid columnconfigure $notebook 0 -weight 1
10984 grid rowconfigure $notebook 1 -weight 1
10985 raise [lindex $pages 0]
10988 grid $notebook -sticky news -padx 2 -pady 2
10989 grid rowconfigure $top 0 -weight 1
10990 grid columnconfigure $top 0 -weight 1
10992 ${NS}::frame $top.buts
10993 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10994 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10995 bind $top <Key-Return> prefsok
10996 bind $top <Key-Escape> prefscan
10997 grid $top.buts.ok $top.buts.can
10998 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10999 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11000 grid $top.buts - - -pady 10 -sticky ew
11001 grid columnconfigure $top 2 -weight 1
11002 bind $top <Visibility> [list focus $top.buts.ok]
11005 proc choose_extdiff {} {
11006 global extdifftool
11008 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11009 if {$prog ne {}} {
11010 set extdifftool $prog
11014 proc choosecolor {v vi w x cmd} {
11015 global $v
11017 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11018 -title [mc "Gitk: choose color for %s" $x]]
11019 if {$c eq {}} return
11020 $w conf -background $c
11021 lset $v $vi $c
11022 eval $cmd $c
11025 proc setselbg {c} {
11026 global bglist cflist
11027 foreach w $bglist {
11028 $w configure -selectbackground $c
11030 $cflist tag configure highlight \
11031 -background [$cflist cget -selectbackground]
11032 allcanvs itemconf secsel -fill $c
11035 # This sets the background color and the color scheme for the whole UI.
11036 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11037 # if we don't specify one ourselves, which makes the checkbuttons and
11038 # radiobuttons look bad. This chooses white for selectColor if the
11039 # background color is light, or black if it is dark.
11040 proc setui {c} {
11041 if {[tk windowingsystem] eq "win32"} { return }
11042 set bg [winfo rgb . $c]
11043 set selc black
11044 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11045 set selc white
11047 tk_setPalette background $c selectColor $selc
11050 proc setbg {c} {
11051 global bglist
11053 foreach w $bglist {
11054 $w conf -background $c
11058 proc setfg {c} {
11059 global fglist canv
11061 foreach w $fglist {
11062 $w conf -foreground $c
11064 allcanvs itemconf text -fill $c
11065 $canv itemconf circle -outline $c
11066 $canv itemconf markid -outline $c
11069 proc prefscan {} {
11070 global oldprefs prefstop
11072 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11073 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11074 global $v
11075 set $v $oldprefs($v)
11077 catch {destroy $prefstop}
11078 unset prefstop
11079 fontcan
11082 proc prefsok {} {
11083 global maxwidth maxgraphpct
11084 global oldprefs prefstop showneartags showlocalchanges
11085 global fontpref mainfont textfont uifont
11086 global limitdiffs treediffs perfile_attrs
11087 global hideremotes
11089 catch {destroy $prefstop}
11090 unset prefstop
11091 fontcan
11092 set fontchanged 0
11093 if {$mainfont ne $fontpref(mainfont)} {
11094 set mainfont $fontpref(mainfont)
11095 parsefont mainfont $mainfont
11096 eval font configure mainfont [fontflags mainfont]
11097 eval font configure mainfontbold [fontflags mainfont 1]
11098 setcoords
11099 set fontchanged 1
11101 if {$textfont ne $fontpref(textfont)} {
11102 set textfont $fontpref(textfont)
11103 parsefont textfont $textfont
11104 eval font configure textfont [fontflags textfont]
11105 eval font configure textfontbold [fontflags textfont 1]
11107 if {$uifont ne $fontpref(uifont)} {
11108 set uifont $fontpref(uifont)
11109 parsefont uifont $uifont
11110 eval font configure uifont [fontflags uifont]
11112 settabs
11113 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11114 if {$showlocalchanges} {
11115 doshowlocalchanges
11116 } else {
11117 dohidelocalchanges
11120 if {$limitdiffs != $oldprefs(limitdiffs) ||
11121 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11122 # treediffs elements are limited by path;
11123 # won't have encodings cached if perfile_attrs was just turned on
11124 catch {unset treediffs}
11126 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11127 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11128 redisplay
11129 } elseif {$showneartags != $oldprefs(showneartags) ||
11130 $limitdiffs != $oldprefs(limitdiffs)} {
11131 reselectline
11133 if {$hideremotes != $oldprefs(hideremotes)} {
11134 rereadrefs
11138 proc formatdate {d} {
11139 global datetimeformat
11140 if {$d ne {}} {
11141 set d [clock format [lindex $d 0] -format $datetimeformat]
11143 return $d
11146 # This list of encoding names and aliases is distilled from
11147 # http://www.iana.org/assignments/character-sets.
11148 # Not all of them are supported by Tcl.
11149 set encoding_aliases {
11150 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11151 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11152 { ISO-10646-UTF-1 csISO10646UTF1 }
11153 { ISO_646.basic:1983 ref csISO646basic1983 }
11154 { INVARIANT csINVARIANT }
11155 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11156 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11157 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11158 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11159 { NATS-DANO iso-ir-9-1 csNATSDANO }
11160 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11161 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11162 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11163 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11164 { ISO-2022-KR csISO2022KR }
11165 { EUC-KR csEUCKR }
11166 { ISO-2022-JP csISO2022JP }
11167 { ISO-2022-JP-2 csISO2022JP2 }
11168 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11169 csISO13JISC6220jp }
11170 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11171 { IT iso-ir-15 ISO646-IT csISO15Italian }
11172 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11173 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11174 { greek7-old iso-ir-18 csISO18Greek7Old }
11175 { latin-greek iso-ir-19 csISO19LatinGreek }
11176 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11177 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11178 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11179 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11180 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11181 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11182 { INIS iso-ir-49 csISO49INIS }
11183 { INIS-8 iso-ir-50 csISO50INIS8 }
11184 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11185 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11186 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11187 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11188 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11189 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11190 csISO60Norwegian1 }
11191 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11192 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11193 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11194 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11195 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11196 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11197 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11198 { greek7 iso-ir-88 csISO88Greek7 }
11199 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11200 { iso-ir-90 csISO90 }
11201 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11202 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11203 csISO92JISC62991984b }
11204 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11205 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11206 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11207 csISO95JIS62291984handadd }
11208 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11209 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11210 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11211 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11212 CP819 csISOLatin1 }
11213 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11214 { T.61-7bit iso-ir-102 csISO102T617bit }
11215 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11216 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11217 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11218 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11219 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11220 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11221 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11222 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11223 arabic csISOLatinArabic }
11224 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11225 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11226 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11227 greek greek8 csISOLatinGreek }
11228 { T.101-G2 iso-ir-128 csISO128T101G2 }
11229 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11230 csISOLatinHebrew }
11231 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11232 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11233 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11234 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11235 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11236 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11237 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11238 csISOLatinCyrillic }
11239 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11240 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11241 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11242 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11243 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11244 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11245 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11246 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11247 { ISO_10367-box iso-ir-155 csISO10367Box }
11248 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11249 { latin-lap lap iso-ir-158 csISO158Lap }
11250 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11251 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11252 { us-dk csUSDK }
11253 { dk-us csDKUS }
11254 { JIS_X0201 X0201 csHalfWidthKatakana }
11255 { KSC5636 ISO646-KR csKSC5636 }
11256 { ISO-10646-UCS-2 csUnicode }
11257 { ISO-10646-UCS-4 csUCS4 }
11258 { DEC-MCS dec csDECMCS }
11259 { hp-roman8 roman8 r8 csHPRoman8 }
11260 { macintosh mac csMacintosh }
11261 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11262 csIBM037 }
11263 { IBM038 EBCDIC-INT cp038 csIBM038 }
11264 { IBM273 CP273 csIBM273 }
11265 { IBM274 EBCDIC-BE CP274 csIBM274 }
11266 { IBM275 EBCDIC-BR cp275 csIBM275 }
11267 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11268 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11269 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11270 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11271 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11272 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11273 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11274 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11275 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11276 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11277 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11278 { IBM437 cp437 437 csPC8CodePage437 }
11279 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11280 { IBM775 cp775 csPC775Baltic }
11281 { IBM850 cp850 850 csPC850Multilingual }
11282 { IBM851 cp851 851 csIBM851 }
11283 { IBM852 cp852 852 csPCp852 }
11284 { IBM855 cp855 855 csIBM855 }
11285 { IBM857 cp857 857 csIBM857 }
11286 { IBM860 cp860 860 csIBM860 }
11287 { IBM861 cp861 861 cp-is csIBM861 }
11288 { IBM862 cp862 862 csPC862LatinHebrew }
11289 { IBM863 cp863 863 csIBM863 }
11290 { IBM864 cp864 csIBM864 }
11291 { IBM865 cp865 865 csIBM865 }
11292 { IBM866 cp866 866 csIBM866 }
11293 { IBM868 CP868 cp-ar csIBM868 }
11294 { IBM869 cp869 869 cp-gr csIBM869 }
11295 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11296 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11297 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11298 { IBM891 cp891 csIBM891 }
11299 { IBM903 cp903 csIBM903 }
11300 { IBM904 cp904 904 csIBBM904 }
11301 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11302 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11303 { IBM1026 CP1026 csIBM1026 }
11304 { EBCDIC-AT-DE csIBMEBCDICATDE }
11305 { EBCDIC-AT-DE-A csEBCDICATDEA }
11306 { EBCDIC-CA-FR csEBCDICCAFR }
11307 { EBCDIC-DK-NO csEBCDICDKNO }
11308 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11309 { EBCDIC-FI-SE csEBCDICFISE }
11310 { EBCDIC-FI-SE-A csEBCDICFISEA }
11311 { EBCDIC-FR csEBCDICFR }
11312 { EBCDIC-IT csEBCDICIT }
11313 { EBCDIC-PT csEBCDICPT }
11314 { EBCDIC-ES csEBCDICES }
11315 { EBCDIC-ES-A csEBCDICESA }
11316 { EBCDIC-ES-S csEBCDICESS }
11317 { EBCDIC-UK csEBCDICUK }
11318 { EBCDIC-US csEBCDICUS }
11319 { UNKNOWN-8BIT csUnknown8BiT }
11320 { MNEMONIC csMnemonic }
11321 { MNEM csMnem }
11322 { VISCII csVISCII }
11323 { VIQR csVIQR }
11324 { KOI8-R csKOI8R }
11325 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11326 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11327 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11328 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11329 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11330 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11331 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11332 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11333 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11334 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11335 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11336 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11337 { IBM1047 IBM-1047 }
11338 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11339 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11340 { UNICODE-1-1 csUnicode11 }
11341 { CESU-8 csCESU-8 }
11342 { BOCU-1 csBOCU-1 }
11343 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11344 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11345 l8 }
11346 { ISO-8859-15 ISO_8859-15 Latin-9 }
11347 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11348 { GBK CP936 MS936 windows-936 }
11349 { JIS_Encoding csJISEncoding }
11350 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11351 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11352 EUC-JP }
11353 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11354 { ISO-10646-UCS-Basic csUnicodeASCII }
11355 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11356 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11357 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11358 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11359 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11360 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11361 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11362 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11363 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11364 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11365 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11366 { Ventura-US csVenturaUS }
11367 { Ventura-International csVenturaInternational }
11368 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11369 { PC8-Turkish csPC8Turkish }
11370 { IBM-Symbols csIBMSymbols }
11371 { IBM-Thai csIBMThai }
11372 { HP-Legal csHPLegal }
11373 { HP-Pi-font csHPPiFont }
11374 { HP-Math8 csHPMath8 }
11375 { Adobe-Symbol-Encoding csHPPSMath }
11376 { HP-DeskTop csHPDesktop }
11377 { Ventura-Math csVenturaMath }
11378 { Microsoft-Publishing csMicrosoftPublishing }
11379 { Windows-31J csWindows31J }
11380 { GB2312 csGB2312 }
11381 { Big5 csBig5 }
11384 proc tcl_encoding {enc} {
11385 global encoding_aliases tcl_encoding_cache
11386 if {[info exists tcl_encoding_cache($enc)]} {
11387 return $tcl_encoding_cache($enc)
11389 set names [encoding names]
11390 set lcnames [string tolower $names]
11391 set enc [string tolower $enc]
11392 set i [lsearch -exact $lcnames $enc]
11393 if {$i < 0} {
11394 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11395 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11396 set i [lsearch -exact $lcnames $encx]
11399 if {$i < 0} {
11400 foreach l $encoding_aliases {
11401 set ll [string tolower $l]
11402 if {[lsearch -exact $ll $enc] < 0} continue
11403 # look through the aliases for one that tcl knows about
11404 foreach e $ll {
11405 set i [lsearch -exact $lcnames $e]
11406 if {$i < 0} {
11407 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11408 set i [lsearch -exact $lcnames $ex]
11411 if {$i >= 0} break
11413 break
11416 set tclenc {}
11417 if {$i >= 0} {
11418 set tclenc [lindex $names $i]
11420 set tcl_encoding_cache($enc) $tclenc
11421 return $tclenc
11424 proc gitattr {path attr default} {
11425 global path_attr_cache
11426 if {[info exists path_attr_cache($attr,$path)]} {
11427 set r $path_attr_cache($attr,$path)
11428 } else {
11429 set r "unspecified"
11430 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11431 regexp "(.*): $attr: (.*)" $line m f r
11433 set path_attr_cache($attr,$path) $r
11435 if {$r eq "unspecified"} {
11436 return $default
11438 return $r
11441 proc cache_gitattr {attr pathlist} {
11442 global path_attr_cache
11443 set newlist {}
11444 foreach path $pathlist {
11445 if {![info exists path_attr_cache($attr,$path)]} {
11446 lappend newlist $path
11449 set lim 1000
11450 if {[tk windowingsystem] == "win32"} {
11451 # windows has a 32k limit on the arguments to a command...
11452 set lim 30
11454 while {$newlist ne {}} {
11455 set head [lrange $newlist 0 [expr {$lim - 1}]]
11456 set newlist [lrange $newlist $lim end]
11457 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11458 foreach row [split $rlist "\n"] {
11459 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11460 if {[string index $path 0] eq "\""} {
11461 set path [encoding convertfrom [lindex $path 0]]
11463 set path_attr_cache($attr,$path) $value
11470 proc get_path_encoding {path} {
11471 global gui_encoding perfile_attrs
11472 set tcl_enc $gui_encoding
11473 if {$path ne {} && $perfile_attrs} {
11474 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11475 if {$enc2 ne {}} {
11476 set tcl_enc $enc2
11479 return $tcl_enc
11482 # First check that Tcl/Tk is recent enough
11483 if {[catch {package require Tk 8.4} err]} {
11484 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11485 Gitk requires at least Tcl/Tk 8.4." list
11486 exit 1
11489 # defaults...
11490 set wrcomcmd "git diff-tree --stdin -p --pretty"
11492 set gitencoding {}
11493 catch {
11494 set gitencoding [exec git config --get i18n.commitencoding]
11496 catch {
11497 set gitencoding [exec git config --get i18n.logoutputencoding]
11499 if {$gitencoding == ""} {
11500 set gitencoding "utf-8"
11502 set tclencoding [tcl_encoding $gitencoding]
11503 if {$tclencoding == {}} {
11504 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11507 set gui_encoding [encoding system]
11508 catch {
11509 set enc [exec git config --get gui.encoding]
11510 if {$enc ne {}} {
11511 set tclenc [tcl_encoding $enc]
11512 if {$tclenc ne {}} {
11513 set gui_encoding $tclenc
11514 } else {
11515 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11520 if {[tk windowingsystem] eq "aqua"} {
11521 set mainfont {{Lucida Grande} 9}
11522 set textfont {Monaco 9}
11523 set uifont {{Lucida Grande} 9 bold}
11524 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
11525 # fontconfig!
11526 set mainfont {sans 9}
11527 set textfont {monospace 9}
11528 set uifont {sans 9 bold}
11529 } else {
11530 set mainfont {Helvetica 9}
11531 set textfont {Courier 9}
11532 set uifont {Helvetica 9 bold}
11534 set tabstop 8
11535 set findmergefiles 0
11536 set maxgraphpct 50
11537 set maxwidth 16
11538 set revlistorder 0
11539 set fastdate 0
11540 set uparrowlen 5
11541 set downarrowlen 5
11542 set mingaplen 100
11543 set cmitmode "patch"
11544 set wrapcomment "none"
11545 set showneartags 1
11546 set hideremotes 0
11547 set maxrefs 20
11548 set maxlinelen 200
11549 set showlocalchanges 1
11550 set limitdiffs 1
11551 set datetimeformat "%Y-%m-%d %H:%M:%S"
11552 set autoselect 1
11553 set autosellen 40
11554 set perfile_attrs 0
11555 set want_ttk 1
11557 if {[tk windowingsystem] eq "aqua"} {
11558 set extdifftool "opendiff"
11559 } else {
11560 set extdifftool "meld"
11563 set colors {green red blue magenta darkgrey brown orange}
11564 if {[tk windowingsystem] eq "win32"} {
11565 set uicolor SystemButtonFace
11566 set bgcolor SystemWindow
11567 set fgcolor SystemButtonText
11568 set selectbgcolor SystemHighlight
11569 } else {
11570 set uicolor grey85
11571 set bgcolor white
11572 set fgcolor black
11573 set selectbgcolor gray85
11575 set diffcolors {red "#00a000" blue}
11576 set diffcontext 3
11577 set ignorespace 0
11578 set worddiff ""
11579 set markbgcolor "#e0e0ff"
11581 set circlecolors {white blue gray blue blue}
11583 # button for popping up context menus
11584 if {[tk windowingsystem] eq "aqua"} {
11585 set ctxbut <Button-2>
11586 } else {
11587 set ctxbut <Button-3>
11590 ## For msgcat loading, first locate the installation location.
11591 if { [info exists ::env(GITK_MSGSDIR)] } {
11592 ## Msgsdir was manually set in the environment.
11593 set gitk_msgsdir $::env(GITK_MSGSDIR)
11594 } else {
11595 ## Let's guess the prefix from argv0.
11596 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11597 set gitk_libdir [file join $gitk_prefix share gitk lib]
11598 set gitk_msgsdir [file join $gitk_libdir msgs]
11599 unset gitk_prefix
11602 ## Internationalization (i18n) through msgcat and gettext. See
11603 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11604 package require msgcat
11605 namespace import ::msgcat::mc
11606 ## And eventually load the actual message catalog
11607 ::msgcat::mcload $gitk_msgsdir
11609 catch {source ~/.gitk}
11611 parsefont mainfont $mainfont
11612 eval font create mainfont [fontflags mainfont]
11613 eval font create mainfontbold [fontflags mainfont 1]
11615 parsefont textfont $textfont
11616 eval font create textfont [fontflags textfont]
11617 eval font create textfontbold [fontflags textfont 1]
11619 parsefont uifont $uifont
11620 eval font create uifont [fontflags uifont]
11622 setui $uicolor
11624 setoptions
11626 # check that we can find a .git directory somewhere...
11627 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
11628 show_error {} . [mc "Cannot find a git repository here."]
11629 exit 1
11632 set selecthead {}
11633 set selectheadid {}
11635 set revtreeargs {}
11636 set cmdline_files {}
11637 set i 0
11638 set revtreeargscmd {}
11639 foreach arg $argv {
11640 switch -glob -- $arg {
11641 "" { }
11642 "--" {
11643 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11644 break
11646 "--select-commit=*" {
11647 set selecthead [string range $arg 16 end]
11649 "--argscmd=*" {
11650 set revtreeargscmd [string range $arg 10 end]
11652 default {
11653 lappend revtreeargs $arg
11656 incr i
11659 if {$selecthead eq "HEAD"} {
11660 set selecthead {}
11663 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11664 # no -- on command line, but some arguments (other than --argscmd)
11665 if {[catch {
11666 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11667 set cmdline_files [split $f "\n"]
11668 set n [llength $cmdline_files]
11669 set revtreeargs [lrange $revtreeargs 0 end-$n]
11670 # Unfortunately git rev-parse doesn't produce an error when
11671 # something is both a revision and a filename. To be consistent
11672 # with git log and git rev-list, check revtreeargs for filenames.
11673 foreach arg $revtreeargs {
11674 if {[file exists $arg]} {
11675 show_error {} . [mc "Ambiguous argument '%s': both revision\
11676 and filename" $arg]
11677 exit 1
11680 } err]} {
11681 # unfortunately we get both stdout and stderr in $err,
11682 # so look for "fatal:".
11683 set i [string first "fatal:" $err]
11684 if {$i > 0} {
11685 set err [string range $err [expr {$i + 6}] end]
11687 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11688 exit 1
11692 set nullid "0000000000000000000000000000000000000000"
11693 set nullid2 "0000000000000000000000000000000000000001"
11694 set nullfile "/dev/null"
11696 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11697 if {![info exists have_ttk]} {
11698 set have_ttk [llength [info commands ::ttk::style]]
11700 set use_ttk [expr {$have_ttk && $want_ttk}]
11701 set NS [expr {$use_ttk ? "ttk" : ""}]
11703 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
11705 set show_notes {}
11706 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
11707 set show_notes "--show-notes"
11710 set appname "gitk"
11712 set runq {}
11713 set history {}
11714 set historyindex 0
11715 set fh_serial 0
11716 set nhl_names {}
11717 set highlight_paths {}
11718 set findpattern {}
11719 set searchdirn -forwards
11720 set boldids {}
11721 set boldnameids {}
11722 set diffelide {0 0}
11723 set markingmatches 0
11724 set linkentercount 0
11725 set need_redisplay 0
11726 set nrows_drawn 0
11727 set firsttabstop 0
11729 set nextviewnum 1
11730 set curview 0
11731 set selectedview 0
11732 set selectedhlview [mc "None"]
11733 set highlight_related [mc "None"]
11734 set highlight_files {}
11735 set viewfiles(0) {}
11736 set viewperm(0) 0
11737 set viewargs(0) {}
11738 set viewargscmd(0) {}
11740 set selectedline {}
11741 set numcommits 0
11742 set loginstance 0
11743 set cmdlineok 0
11744 set stopped 0
11745 set stuffsaved 0
11746 set patchnum 0
11747 set lserial 0
11748 set hasworktree [hasworktree]
11749 set cdup {}
11750 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
11751 set cdup [exec git rev-parse --show-cdup]
11753 set worktree [exec git rev-parse --show-toplevel]
11754 setcoords
11755 makewindow
11756 catch {
11757 image create photo gitlogo -width 16 -height 16
11759 image create photo gitlogominus -width 4 -height 2
11760 gitlogominus put #C00000 -to 0 0 4 2
11761 gitlogo copy gitlogominus -to 1 5
11762 gitlogo copy gitlogominus -to 6 5
11763 gitlogo copy gitlogominus -to 11 5
11764 image delete gitlogominus
11766 image create photo gitlogoplus -width 4 -height 4
11767 gitlogoplus put #008000 -to 1 0 3 4
11768 gitlogoplus put #008000 -to 0 1 4 3
11769 gitlogo copy gitlogoplus -to 1 9
11770 gitlogo copy gitlogoplus -to 6 9
11771 gitlogo copy gitlogoplus -to 11 9
11772 image delete gitlogoplus
11774 image create photo gitlogo32 -width 32 -height 32
11775 gitlogo32 copy gitlogo -zoom 2 2
11777 wm iconphoto . -default gitlogo gitlogo32
11779 # wait for the window to become visible
11780 tkwait visibility .
11781 wm title . "$appname: [reponame]"
11782 update
11783 readrefs
11785 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11786 # create a view for the files/dirs specified on the command line
11787 set curview 1
11788 set selectedview 1
11789 set nextviewnum 2
11790 set viewname(1) [mc "Command line"]
11791 set viewfiles(1) $cmdline_files
11792 set viewargs(1) $revtreeargs
11793 set viewargscmd(1) $revtreeargscmd
11794 set viewperm(1) 0
11795 set vdatemode(1) 0
11796 addviewmenu 1
11797 .bar.view entryconf [mca "Edit view..."] -state normal
11798 .bar.view entryconf [mca "Delete view"] -state normal
11801 if {[info exists permviews]} {
11802 foreach v $permviews {
11803 set n $nextviewnum
11804 incr nextviewnum
11805 set viewname($n) [lindex $v 0]
11806 set viewfiles($n) [lindex $v 1]
11807 set viewargs($n) [lindex $v 2]
11808 set viewargscmd($n) [lindex $v 3]
11809 set viewperm($n) 1
11810 addviewmenu $n
11814 if {[tk windowingsystem] eq "win32"} {
11815 focus -force .
11818 getcommits {}
11820 # Local variables:
11821 # mode: tcl
11822 # indent-tabs-mode: t
11823 # tab-width: 8
11824 # End: