worktree: add --force option
[git.git] / gitk-git / gitk
blob78358a712ae764cb7eb9b4c5aac88031fd8fa1d3
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2014 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 package require Tk
12 proc hasworktree {} {
13 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
14 [exec git rev-parse --is-inside-git-dir] == "false"}]
17 proc reponame {} {
18 global gitdir
19 set n [file normalize $gitdir]
20 if {[string match "*/.git" $n]} {
21 set n [string range $n 0 end-5]
23 return [file tail $n]
26 proc gitworktree {} {
27 variable _gitworktree
28 if {[info exists _gitworktree]} {
29 return $_gitworktree
31 # v1.7.0 introduced --show-toplevel to return the canonical work-tree
32 if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
33 # try to set work tree from environment, core.worktree or use
34 # cdup to obtain a relative path to the top of the worktree. If
35 # run from the top, the ./ prefix ensures normalize expands pwd.
36 if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
37 catch {set _gitworktree [exec git config --get core.worktree]}
38 if {$_gitworktree eq ""} {
39 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
43 return $_gitworktree
46 # A simple scheduler for compute-intensive stuff.
47 # The aim is to make sure that event handlers for GUI actions can
48 # run at least every 50-100 ms. Unfortunately fileevent handlers are
49 # run before X event handlers, so reading from a fast source can
50 # make the GUI completely unresponsive.
51 proc run args {
52 global isonrunq runq currunq
54 set script $args
55 if {[info exists isonrunq($script)]} return
56 if {$runq eq {} && ![info exists currunq]} {
57 after idle dorunq
59 lappend runq [list {} $script]
60 set isonrunq($script) 1
63 proc filerun {fd script} {
64 fileevent $fd readable [list filereadable $fd $script]
67 proc filereadable {fd script} {
68 global runq currunq
70 fileevent $fd readable {}
71 if {$runq eq {} && ![info exists currunq]} {
72 after idle dorunq
74 lappend runq [list $fd $script]
77 proc nukefile {fd} {
78 global runq
80 for {set i 0} {$i < [llength $runq]} {} {
81 if {[lindex $runq $i 0] eq $fd} {
82 set runq [lreplace $runq $i $i]
83 } else {
84 incr i
89 proc dorunq {} {
90 global isonrunq runq currunq
92 set tstart [clock clicks -milliseconds]
93 set t0 $tstart
94 while {[llength $runq] > 0} {
95 set fd [lindex $runq 0 0]
96 set script [lindex $runq 0 1]
97 set currunq [lindex $runq 0]
98 set runq [lrange $runq 1 end]
99 set repeat [eval $script]
100 unset currunq
101 set t1 [clock clicks -milliseconds]
102 set t [expr {$t1 - $t0}]
103 if {$repeat ne {} && $repeat} {
104 if {$fd eq {} || $repeat == 2} {
105 # script returns 1 if it wants to be readded
106 # file readers return 2 if they could do more straight away
107 lappend runq [list $fd $script]
108 } else {
109 fileevent $fd readable [list filereadable $fd $script]
111 } elseif {$fd eq {}} {
112 unset isonrunq($script)
114 set t0 $t1
115 if {$t1 - $tstart >= 80} break
117 if {$runq ne {}} {
118 after idle dorunq
122 proc reg_instance {fd} {
123 global commfd leftover loginstance
125 set i [incr loginstance]
126 set commfd($i) $fd
127 set leftover($i) {}
128 return $i
131 proc unmerged_files {files} {
132 global nr_unmerged
134 # find the list of unmerged files
135 set mlist {}
136 set nr_unmerged 0
137 if {[catch {
138 set fd [open "| git ls-files -u" r]
139 } err]} {
140 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
141 exit 1
143 while {[gets $fd line] >= 0} {
144 set i [string first "\t" $line]
145 if {$i < 0} continue
146 set fname [string range $line [expr {$i+1}] end]
147 if {[lsearch -exact $mlist $fname] >= 0} continue
148 incr nr_unmerged
149 if {$files eq {} || [path_filter $files $fname]} {
150 lappend mlist $fname
153 catch {close $fd}
154 return $mlist
157 proc parseviewargs {n arglist} {
158 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
159 global vinlinediff
160 global worddiff git_version
162 set vdatemode($n) 0
163 set vmergeonly($n) 0
164 set vinlinediff($n) 0
165 set glflags {}
166 set diffargs {}
167 set nextisval 0
168 set revargs {}
169 set origargs $arglist
170 set allknown 1
171 set filtered 0
172 set i -1
173 foreach arg $arglist {
174 incr i
175 if {$nextisval} {
176 lappend glflags $arg
177 set nextisval 0
178 continue
180 switch -glob -- $arg {
181 "-d" -
182 "--date-order" {
183 set vdatemode($n) 1
184 # remove from origargs in case we hit an unknown option
185 set origargs [lreplace $origargs $i $i]
186 incr i -1
188 "-[puabwcrRBMC]" -
189 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
190 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
191 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
192 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
193 "--ignore-space-change" - "-U*" - "--unified=*" {
194 # These request or affect diff output, which we don't want.
195 # Some could be used to set our defaults for diff display.
196 lappend diffargs $arg
198 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
199 "--name-only" - "--name-status" - "--color" -
200 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
201 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
202 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
203 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
204 "--objects" - "--objects-edge" - "--reverse" {
205 # These cause our parsing of git log's output to fail, or else
206 # they're options we want to set ourselves, so ignore them.
208 "--color-words*" - "--word-diff=color" {
209 # These trigger a word diff in the console interface,
210 # so help the user by enabling our own support
211 if {[package vcompare $git_version "1.7.2"] >= 0} {
212 set worddiff [mc "Color words"]
215 "--word-diff*" {
216 if {[package vcompare $git_version "1.7.2"] >= 0} {
217 set worddiff [mc "Markup words"]
220 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
221 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
222 "--full-history" - "--dense" - "--sparse" -
223 "--follow" - "--left-right" - "--encoding=*" {
224 # These are harmless, and some are even useful
225 lappend glflags $arg
227 "--diff-filter=*" - "--no-merges" - "--unpacked" -
228 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
229 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
230 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
231 "--remove-empty" - "--first-parent" - "--cherry-pick" -
232 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
233 "--simplify-by-decoration" {
234 # These mean that we get a subset of the commits
235 set filtered 1
236 lappend glflags $arg
238 "-L*" {
239 # Line-log with 'stuck' argument (unstuck form is
240 # not supported)
241 set filtered 1
242 set vinlinediff($n) 1
243 set allknown 0
244 lappend glflags $arg
246 "-n" {
247 # This appears to be the only one that has a value as a
248 # separate word following it
249 set filtered 1
250 set nextisval 1
251 lappend glflags $arg
253 "--not" - "--all" {
254 lappend revargs $arg
256 "--merge" {
257 set vmergeonly($n) 1
258 # git rev-parse doesn't understand --merge
259 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
261 "--no-replace-objects" {
262 set env(GIT_NO_REPLACE_OBJECTS) "1"
264 "-*" {
265 # Other flag arguments including -<n>
266 if {[string is digit -strict [string range $arg 1 end]]} {
267 set filtered 1
268 } else {
269 # a flag argument that we don't recognize;
270 # that means we can't optimize
271 set allknown 0
273 lappend glflags $arg
275 default {
276 # Non-flag arguments specify commits or ranges of commits
277 if {[string match "*...*" $arg]} {
278 lappend revargs --gitk-symmetric-diff-marker
280 lappend revargs $arg
284 set vdflags($n) $diffargs
285 set vflags($n) $glflags
286 set vrevs($n) $revargs
287 set vfiltered($n) $filtered
288 set vorigargs($n) $origargs
289 return $allknown
292 proc parseviewrevs {view revs} {
293 global vposids vnegids
295 if {$revs eq {}} {
296 set revs HEAD
297 } elseif {[lsearch -exact $revs --all] >= 0} {
298 lappend revs HEAD
300 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
301 # we get stdout followed by stderr in $err
302 # for an unknown rev, git rev-parse echoes it and then errors out
303 set errlines [split $err "\n"]
304 set badrev {}
305 for {set l 0} {$l < [llength $errlines]} {incr l} {
306 set line [lindex $errlines $l]
307 if {!([string length $line] == 40 && [string is xdigit $line])} {
308 if {[string match "fatal:*" $line]} {
309 if {[string match "fatal: ambiguous argument*" $line]
310 && $badrev ne {}} {
311 if {[llength $badrev] == 1} {
312 set err "unknown revision $badrev"
313 } else {
314 set err "unknown revisions: [join $badrev ", "]"
316 } else {
317 set err [join [lrange $errlines $l end] "\n"]
319 break
321 lappend badrev $line
324 error_popup "[mc "Error parsing revisions:"] $err"
325 return {}
327 set ret {}
328 set pos {}
329 set neg {}
330 set sdm 0
331 foreach id [split $ids "\n"] {
332 if {$id eq "--gitk-symmetric-diff-marker"} {
333 set sdm 4
334 } elseif {[string match "^*" $id]} {
335 if {$sdm != 1} {
336 lappend ret $id
337 if {$sdm == 3} {
338 set sdm 0
341 lappend neg [string range $id 1 end]
342 } else {
343 if {$sdm != 2} {
344 lappend ret $id
345 } else {
346 lset ret end $id...[lindex $ret end]
348 lappend pos $id
350 incr sdm -1
352 set vposids($view) $pos
353 set vnegids($view) $neg
354 return $ret
357 # Start off a git log process and arrange to read its output
358 proc start_rev_list {view} {
359 global startmsecs commitidx viewcomplete curview
360 global tclencoding
361 global viewargs viewargscmd viewfiles vfilelimit
362 global showlocalchanges
363 global viewactive viewinstances vmergeonly
364 global mainheadid viewmainheadid viewmainheadid_orig
365 global vcanopt vflags vrevs vorigargs
366 global show_notes
368 set startmsecs [clock clicks -milliseconds]
369 set commitidx($view) 0
370 # these are set this way for the error exits
371 set viewcomplete($view) 1
372 set viewactive($view) 0
373 varcinit $view
375 set args $viewargs($view)
376 if {$viewargscmd($view) ne {}} {
377 if {[catch {
378 set str [exec sh -c $viewargscmd($view)]
379 } err]} {
380 error_popup "[mc "Error executing --argscmd command:"] $err"
381 return 0
383 set args [concat $args [split $str "\n"]]
385 set vcanopt($view) [parseviewargs $view $args]
387 set files $viewfiles($view)
388 if {$vmergeonly($view)} {
389 set files [unmerged_files $files]
390 if {$files eq {}} {
391 global nr_unmerged
392 if {$nr_unmerged == 0} {
393 error_popup [mc "No files selected: --merge specified but\
394 no files are unmerged."]
395 } else {
396 error_popup [mc "No files selected: --merge specified but\
397 no unmerged files are within file limit."]
399 return 0
402 set vfilelimit($view) $files
404 if {$vcanopt($view)} {
405 set revs [parseviewrevs $view $vrevs($view)]
406 if {$revs eq {}} {
407 return 0
409 set args [concat $vflags($view) $revs]
410 } else {
411 set args $vorigargs($view)
414 if {[catch {
415 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
416 --parents --boundary $args "--" $files] r]
417 } err]} {
418 error_popup "[mc "Error executing git log:"] $err"
419 return 0
421 set i [reg_instance $fd]
422 set viewinstances($view) [list $i]
423 set viewmainheadid($view) $mainheadid
424 set viewmainheadid_orig($view) $mainheadid
425 if {$files ne {} && $mainheadid ne {}} {
426 get_viewmainhead $view
428 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
429 interestedin $viewmainheadid($view) dodiffindex
431 fconfigure $fd -blocking 0 -translation lf -eofchar {}
432 if {$tclencoding != {}} {
433 fconfigure $fd -encoding $tclencoding
435 filerun $fd [list getcommitlines $fd $i $view 0]
436 nowbusy $view [mc "Reading"]
437 set viewcomplete($view) 0
438 set viewactive($view) 1
439 return 1
442 proc stop_instance {inst} {
443 global commfd leftover
445 set fd $commfd($inst)
446 catch {
447 set pid [pid $fd]
449 if {$::tcl_platform(platform) eq {windows}} {
450 exec taskkill /pid $pid
451 } else {
452 exec kill $pid
455 catch {close $fd}
456 nukefile $fd
457 unset commfd($inst)
458 unset leftover($inst)
461 proc stop_backends {} {
462 global commfd
464 foreach inst [array names commfd] {
465 stop_instance $inst
469 proc stop_rev_list {view} {
470 global viewinstances
472 foreach inst $viewinstances($view) {
473 stop_instance $inst
475 set viewinstances($view) {}
478 proc reset_pending_select {selid} {
479 global pending_select mainheadid selectheadid
481 if {$selid ne {}} {
482 set pending_select $selid
483 } elseif {$selectheadid ne {}} {
484 set pending_select $selectheadid
485 } else {
486 set pending_select $mainheadid
490 proc getcommits {selid} {
491 global canv curview need_redisplay viewactive
493 initlayout
494 if {[start_rev_list $curview]} {
495 reset_pending_select $selid
496 show_status [mc "Reading commits..."]
497 set need_redisplay 1
498 } else {
499 show_status [mc "No commits selected"]
503 proc updatecommits {} {
504 global curview vcanopt vorigargs vfilelimit viewinstances
505 global viewactive viewcomplete tclencoding
506 global startmsecs showneartags showlocalchanges
507 global mainheadid viewmainheadid viewmainheadid_orig pending_select
508 global hasworktree
509 global varcid vposids vnegids vflags vrevs
510 global show_notes
512 set hasworktree [hasworktree]
513 rereadrefs
514 set view $curview
515 if {$mainheadid ne $viewmainheadid_orig($view)} {
516 if {$showlocalchanges} {
517 dohidelocalchanges
519 set viewmainheadid($view) $mainheadid
520 set viewmainheadid_orig($view) $mainheadid
521 if {$vfilelimit($view) ne {}} {
522 get_viewmainhead $view
525 if {$showlocalchanges} {
526 doshowlocalchanges
528 if {$vcanopt($view)} {
529 set oldpos $vposids($view)
530 set oldneg $vnegids($view)
531 set revs [parseviewrevs $view $vrevs($view)]
532 if {$revs eq {}} {
533 return
535 # note: getting the delta when negative refs change is hard,
536 # and could require multiple git log invocations, so in that
537 # case we ask git log for all the commits (not just the delta)
538 if {$oldneg eq $vnegids($view)} {
539 set newrevs {}
540 set npos 0
541 # take out positive refs that we asked for before or
542 # that we have already seen
543 foreach rev $revs {
544 if {[string length $rev] == 40} {
545 if {[lsearch -exact $oldpos $rev] < 0
546 && ![info exists varcid($view,$rev)]} {
547 lappend newrevs $rev
548 incr npos
550 } else {
551 lappend $newrevs $rev
554 if {$npos == 0} return
555 set revs $newrevs
556 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
558 set args [concat $vflags($view) $revs --not $oldpos]
559 } else {
560 set args $vorigargs($view)
562 if {[catch {
563 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
564 --parents --boundary $args "--" $vfilelimit($view)] r]
565 } err]} {
566 error_popup "[mc "Error executing git log:"] $err"
567 return
569 if {$viewactive($view) == 0} {
570 set startmsecs [clock clicks -milliseconds]
572 set i [reg_instance $fd]
573 lappend viewinstances($view) $i
574 fconfigure $fd -blocking 0 -translation lf -eofchar {}
575 if {$tclencoding != {}} {
576 fconfigure $fd -encoding $tclencoding
578 filerun $fd [list getcommitlines $fd $i $view 1]
579 incr viewactive($view)
580 set viewcomplete($view) 0
581 reset_pending_select {}
582 nowbusy $view [mc "Reading"]
583 if {$showneartags} {
584 getallcommits
588 proc reloadcommits {} {
589 global curview viewcomplete selectedline currentid thickerline
590 global showneartags treediffs commitinterest cached_commitrow
591 global targetid
593 set selid {}
594 if {$selectedline ne {}} {
595 set selid $currentid
598 if {!$viewcomplete($curview)} {
599 stop_rev_list $curview
601 resetvarcs $curview
602 set selectedline {}
603 catch {unset currentid}
604 catch {unset thickerline}
605 catch {unset treediffs}
606 readrefs
607 changedrefs
608 if {$showneartags} {
609 getallcommits
611 clear_display
612 catch {unset commitinterest}
613 catch {unset cached_commitrow}
614 catch {unset targetid}
615 setcanvscroll
616 getcommits $selid
617 return 0
620 # This makes a string representation of a positive integer which
621 # sorts as a string in numerical order
622 proc strrep {n} {
623 if {$n < 16} {
624 return [format "%x" $n]
625 } elseif {$n < 256} {
626 return [format "x%.2x" $n]
627 } elseif {$n < 65536} {
628 return [format "y%.4x" $n]
630 return [format "z%.8x" $n]
633 # Procedures used in reordering commits from git log (without
634 # --topo-order) into the order for display.
636 proc varcinit {view} {
637 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
638 global vtokmod varcmod vrowmod varcix vlastins
640 set varcstart($view) {{}}
641 set vupptr($view) {0}
642 set vdownptr($view) {0}
643 set vleftptr($view) {0}
644 set vbackptr($view) {0}
645 set varctok($view) {{}}
646 set varcrow($view) {{}}
647 set vtokmod($view) {}
648 set varcmod($view) 0
649 set vrowmod($view) 0
650 set varcix($view) {{}}
651 set vlastins($view) {0}
654 proc resetvarcs {view} {
655 global varcid varccommits parents children vseedcount ordertok
656 global vshortids
658 foreach vid [array names varcid $view,*] {
659 unset varcid($vid)
660 unset children($vid)
661 unset parents($vid)
663 foreach vid [array names vshortids $view,*] {
664 unset vshortids($vid)
666 # some commits might have children but haven't been seen yet
667 foreach vid [array names children $view,*] {
668 unset children($vid)
670 foreach va [array names varccommits $view,*] {
671 unset varccommits($va)
673 foreach vd [array names vseedcount $view,*] {
674 unset vseedcount($vd)
676 catch {unset ordertok}
679 # returns a list of the commits with no children
680 proc seeds {v} {
681 global vdownptr vleftptr varcstart
683 set ret {}
684 set a [lindex $vdownptr($v) 0]
685 while {$a != 0} {
686 lappend ret [lindex $varcstart($v) $a]
687 set a [lindex $vleftptr($v) $a]
689 return $ret
692 proc newvarc {view id} {
693 global varcid varctok parents children vdatemode
694 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
695 global commitdata commitinfo vseedcount varccommits vlastins
697 set a [llength $varctok($view)]
698 set vid $view,$id
699 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
700 if {![info exists commitinfo($id)]} {
701 parsecommit $id $commitdata($id) 1
703 set cdate [lindex [lindex $commitinfo($id) 4] 0]
704 if {![string is integer -strict $cdate]} {
705 set cdate 0
707 if {![info exists vseedcount($view,$cdate)]} {
708 set vseedcount($view,$cdate) -1
710 set c [incr vseedcount($view,$cdate)]
711 set cdate [expr {$cdate ^ 0xffffffff}]
712 set tok "s[strrep $cdate][strrep $c]"
713 } else {
714 set tok {}
716 set ka 0
717 if {[llength $children($vid)] > 0} {
718 set kid [lindex $children($vid) end]
719 set k $varcid($view,$kid)
720 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
721 set ki $kid
722 set ka $k
723 set tok [lindex $varctok($view) $k]
726 if {$ka != 0} {
727 set i [lsearch -exact $parents($view,$ki) $id]
728 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
729 append tok [strrep $j]
731 set c [lindex $vlastins($view) $ka]
732 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
733 set c $ka
734 set b [lindex $vdownptr($view) $ka]
735 } else {
736 set b [lindex $vleftptr($view) $c]
738 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
739 set c $b
740 set b [lindex $vleftptr($view) $c]
742 if {$c == $ka} {
743 lset vdownptr($view) $ka $a
744 lappend vbackptr($view) 0
745 } else {
746 lset vleftptr($view) $c $a
747 lappend vbackptr($view) $c
749 lset vlastins($view) $ka $a
750 lappend vupptr($view) $ka
751 lappend vleftptr($view) $b
752 if {$b != 0} {
753 lset vbackptr($view) $b $a
755 lappend varctok($view) $tok
756 lappend varcstart($view) $id
757 lappend vdownptr($view) 0
758 lappend varcrow($view) {}
759 lappend varcix($view) {}
760 set varccommits($view,$a) {}
761 lappend vlastins($view) 0
762 return $a
765 proc splitvarc {p v} {
766 global varcid varcstart varccommits varctok vtokmod
767 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
769 set oa $varcid($v,$p)
770 set otok [lindex $varctok($v) $oa]
771 set ac $varccommits($v,$oa)
772 set i [lsearch -exact $varccommits($v,$oa) $p]
773 if {$i <= 0} return
774 set na [llength $varctok($v)]
775 # "%" sorts before "0"...
776 set tok "$otok%[strrep $i]"
777 lappend varctok($v) $tok
778 lappend varcrow($v) {}
779 lappend varcix($v) {}
780 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
781 set varccommits($v,$na) [lrange $ac $i end]
782 lappend varcstart($v) $p
783 foreach id $varccommits($v,$na) {
784 set varcid($v,$id) $na
786 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
787 lappend vlastins($v) [lindex $vlastins($v) $oa]
788 lset vdownptr($v) $oa $na
789 lset vlastins($v) $oa 0
790 lappend vupptr($v) $oa
791 lappend vleftptr($v) 0
792 lappend vbackptr($v) 0
793 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
794 lset vupptr($v) $b $na
796 if {[string compare $otok $vtokmod($v)] <= 0} {
797 modify_arc $v $oa
801 proc renumbervarc {a v} {
802 global parents children varctok varcstart varccommits
803 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
805 set t1 [clock clicks -milliseconds]
806 set todo {}
807 set isrelated($a) 1
808 set kidchanged($a) 1
809 set ntot 0
810 while {$a != 0} {
811 if {[info exists isrelated($a)]} {
812 lappend todo $a
813 set id [lindex $varccommits($v,$a) end]
814 foreach p $parents($v,$id) {
815 if {[info exists varcid($v,$p)]} {
816 set isrelated($varcid($v,$p)) 1
820 incr ntot
821 set b [lindex $vdownptr($v) $a]
822 if {$b == 0} {
823 while {$a != 0} {
824 set b [lindex $vleftptr($v) $a]
825 if {$b != 0} break
826 set a [lindex $vupptr($v) $a]
829 set a $b
831 foreach a $todo {
832 if {![info exists kidchanged($a)]} continue
833 set id [lindex $varcstart($v) $a]
834 if {[llength $children($v,$id)] > 1} {
835 set children($v,$id) [lsort -command [list vtokcmp $v] \
836 $children($v,$id)]
838 set oldtok [lindex $varctok($v) $a]
839 if {!$vdatemode($v)} {
840 set tok {}
841 } else {
842 set tok $oldtok
844 set ka 0
845 set kid [last_real_child $v,$id]
846 if {$kid ne {}} {
847 set k $varcid($v,$kid)
848 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
849 set ki $kid
850 set ka $k
851 set tok [lindex $varctok($v) $k]
854 if {$ka != 0} {
855 set i [lsearch -exact $parents($v,$ki) $id]
856 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
857 append tok [strrep $j]
859 if {$tok eq $oldtok} {
860 continue
862 set id [lindex $varccommits($v,$a) end]
863 foreach p $parents($v,$id) {
864 if {[info exists varcid($v,$p)]} {
865 set kidchanged($varcid($v,$p)) 1
866 } else {
867 set sortkids($p) 1
870 lset varctok($v) $a $tok
871 set b [lindex $vupptr($v) $a]
872 if {$b != $ka} {
873 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
874 modify_arc $v $ka
876 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
877 modify_arc $v $b
879 set c [lindex $vbackptr($v) $a]
880 set d [lindex $vleftptr($v) $a]
881 if {$c == 0} {
882 lset vdownptr($v) $b $d
883 } else {
884 lset vleftptr($v) $c $d
886 if {$d != 0} {
887 lset vbackptr($v) $d $c
889 if {[lindex $vlastins($v) $b] == $a} {
890 lset vlastins($v) $b $c
892 lset vupptr($v) $a $ka
893 set c [lindex $vlastins($v) $ka]
894 if {$c == 0 || \
895 [string compare $tok [lindex $varctok($v) $c]] < 0} {
896 set c $ka
897 set b [lindex $vdownptr($v) $ka]
898 } else {
899 set b [lindex $vleftptr($v) $c]
901 while {$b != 0 && \
902 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
903 set c $b
904 set b [lindex $vleftptr($v) $c]
906 if {$c == $ka} {
907 lset vdownptr($v) $ka $a
908 lset vbackptr($v) $a 0
909 } else {
910 lset vleftptr($v) $c $a
911 lset vbackptr($v) $a $c
913 lset vleftptr($v) $a $b
914 if {$b != 0} {
915 lset vbackptr($v) $b $a
917 lset vlastins($v) $ka $a
920 foreach id [array names sortkids] {
921 if {[llength $children($v,$id)] > 1} {
922 set children($v,$id) [lsort -command [list vtokcmp $v] \
923 $children($v,$id)]
926 set t2 [clock clicks -milliseconds]
927 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
930 # Fix up the graph after we have found out that in view $v,
931 # $p (a commit that we have already seen) is actually the parent
932 # of the last commit in arc $a.
933 proc fix_reversal {p a v} {
934 global varcid varcstart varctok vupptr
936 set pa $varcid($v,$p)
937 if {$p ne [lindex $varcstart($v) $pa]} {
938 splitvarc $p $v
939 set pa $varcid($v,$p)
941 # seeds always need to be renumbered
942 if {[lindex $vupptr($v) $pa] == 0 ||
943 [string compare [lindex $varctok($v) $a] \
944 [lindex $varctok($v) $pa]] > 0} {
945 renumbervarc $pa $v
949 proc insertrow {id p v} {
950 global cmitlisted children parents varcid varctok vtokmod
951 global varccommits ordertok commitidx numcommits curview
952 global targetid targetrow vshortids
954 readcommit $id
955 set vid $v,$id
956 set cmitlisted($vid) 1
957 set children($vid) {}
958 set parents($vid) [list $p]
959 set a [newvarc $v $id]
960 set varcid($vid) $a
961 lappend vshortids($v,[string range $id 0 3]) $id
962 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
963 modify_arc $v $a
965 lappend varccommits($v,$a) $id
966 set vp $v,$p
967 if {[llength [lappend children($vp) $id]] > 1} {
968 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
969 catch {unset ordertok}
971 fix_reversal $p $a $v
972 incr commitidx($v)
973 if {$v == $curview} {
974 set numcommits $commitidx($v)
975 setcanvscroll
976 if {[info exists targetid]} {
977 if {![comes_before $targetid $p]} {
978 incr targetrow
984 proc insertfakerow {id p} {
985 global varcid varccommits parents children cmitlisted
986 global commitidx varctok vtokmod targetid targetrow curview numcommits
988 set v $curview
989 set a $varcid($v,$p)
990 set i [lsearch -exact $varccommits($v,$a) $p]
991 if {$i < 0} {
992 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
993 return
995 set children($v,$id) {}
996 set parents($v,$id) [list $p]
997 set varcid($v,$id) $a
998 lappend children($v,$p) $id
999 set cmitlisted($v,$id) 1
1000 set numcommits [incr commitidx($v)]
1001 # note we deliberately don't update varcstart($v) even if $i == 0
1002 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1003 modify_arc $v $a $i
1004 if {[info exists targetid]} {
1005 if {![comes_before $targetid $p]} {
1006 incr targetrow
1009 setcanvscroll
1010 drawvisible
1013 proc removefakerow {id} {
1014 global varcid varccommits parents children commitidx
1015 global varctok vtokmod cmitlisted currentid selectedline
1016 global targetid curview numcommits
1018 set v $curview
1019 if {[llength $parents($v,$id)] != 1} {
1020 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1021 return
1023 set p [lindex $parents($v,$id) 0]
1024 set a $varcid($v,$id)
1025 set i [lsearch -exact $varccommits($v,$a) $id]
1026 if {$i < 0} {
1027 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1028 return
1030 unset varcid($v,$id)
1031 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1032 unset parents($v,$id)
1033 unset children($v,$id)
1034 unset cmitlisted($v,$id)
1035 set numcommits [incr commitidx($v) -1]
1036 set j [lsearch -exact $children($v,$p) $id]
1037 if {$j >= 0} {
1038 set children($v,$p) [lreplace $children($v,$p) $j $j]
1040 modify_arc $v $a $i
1041 if {[info exist currentid] && $id eq $currentid} {
1042 unset currentid
1043 set selectedline {}
1045 if {[info exists targetid] && $targetid eq $id} {
1046 set targetid $p
1048 setcanvscroll
1049 drawvisible
1052 proc real_children {vp} {
1053 global children nullid nullid2
1055 set kids {}
1056 foreach id $children($vp) {
1057 if {$id ne $nullid && $id ne $nullid2} {
1058 lappend kids $id
1061 return $kids
1064 proc first_real_child {vp} {
1065 global children nullid nullid2
1067 foreach id $children($vp) {
1068 if {$id ne $nullid && $id ne $nullid2} {
1069 return $id
1072 return {}
1075 proc last_real_child {vp} {
1076 global children nullid nullid2
1078 set kids $children($vp)
1079 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1080 set id [lindex $kids $i]
1081 if {$id ne $nullid && $id ne $nullid2} {
1082 return $id
1085 return {}
1088 proc vtokcmp {v a b} {
1089 global varctok varcid
1091 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1092 [lindex $varctok($v) $varcid($v,$b)]]
1095 # This assumes that if lim is not given, the caller has checked that
1096 # arc a's token is less than $vtokmod($v)
1097 proc modify_arc {v a {lim {}}} {
1098 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1100 if {$lim ne {}} {
1101 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1102 if {$c > 0} return
1103 if {$c == 0} {
1104 set r [lindex $varcrow($v) $a]
1105 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1108 set vtokmod($v) [lindex $varctok($v) $a]
1109 set varcmod($v) $a
1110 if {$v == $curview} {
1111 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1112 set a [lindex $vupptr($v) $a]
1113 set lim {}
1115 set r 0
1116 if {$a != 0} {
1117 if {$lim eq {}} {
1118 set lim [llength $varccommits($v,$a)]
1120 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1122 set vrowmod($v) $r
1123 undolayout $r
1127 proc update_arcrows {v} {
1128 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1129 global varcid vrownum varcorder varcix varccommits
1130 global vupptr vdownptr vleftptr varctok
1131 global displayorder parentlist curview cached_commitrow
1133 if {$vrowmod($v) == $commitidx($v)} return
1134 if {$v == $curview} {
1135 if {[llength $displayorder] > $vrowmod($v)} {
1136 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1137 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1139 catch {unset cached_commitrow}
1141 set narctot [expr {[llength $varctok($v)] - 1}]
1142 set a $varcmod($v)
1143 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1144 # go up the tree until we find something that has a row number,
1145 # or we get to a seed
1146 set a [lindex $vupptr($v) $a]
1148 if {$a == 0} {
1149 set a [lindex $vdownptr($v) 0]
1150 if {$a == 0} return
1151 set vrownum($v) {0}
1152 set varcorder($v) [list $a]
1153 lset varcix($v) $a 0
1154 lset varcrow($v) $a 0
1155 set arcn 0
1156 set row 0
1157 } else {
1158 set arcn [lindex $varcix($v) $a]
1159 if {[llength $vrownum($v)] > $arcn + 1} {
1160 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1161 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1163 set row [lindex $varcrow($v) $a]
1165 while {1} {
1166 set p $a
1167 incr row [llength $varccommits($v,$a)]
1168 # go down if possible
1169 set b [lindex $vdownptr($v) $a]
1170 if {$b == 0} {
1171 # if not, go left, or go up until we can go left
1172 while {$a != 0} {
1173 set b [lindex $vleftptr($v) $a]
1174 if {$b != 0} break
1175 set a [lindex $vupptr($v) $a]
1177 if {$a == 0} break
1179 set a $b
1180 incr arcn
1181 lappend vrownum($v) $row
1182 lappend varcorder($v) $a
1183 lset varcix($v) $a $arcn
1184 lset varcrow($v) $a $row
1186 set vtokmod($v) [lindex $varctok($v) $p]
1187 set varcmod($v) $p
1188 set vrowmod($v) $row
1189 if {[info exists currentid]} {
1190 set selectedline [rowofcommit $currentid]
1194 # Test whether view $v contains commit $id
1195 proc commitinview {id v} {
1196 global varcid
1198 return [info exists varcid($v,$id)]
1201 # Return the row number for commit $id in the current view
1202 proc rowofcommit {id} {
1203 global varcid varccommits varcrow curview cached_commitrow
1204 global varctok vtokmod
1206 set v $curview
1207 if {![info exists varcid($v,$id)]} {
1208 puts "oops rowofcommit no arc for [shortids $id]"
1209 return {}
1211 set a $varcid($v,$id)
1212 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1213 update_arcrows $v
1215 if {[info exists cached_commitrow($id)]} {
1216 return $cached_commitrow($id)
1218 set i [lsearch -exact $varccommits($v,$a) $id]
1219 if {$i < 0} {
1220 puts "oops didn't find commit [shortids $id] in arc $a"
1221 return {}
1223 incr i [lindex $varcrow($v) $a]
1224 set cached_commitrow($id) $i
1225 return $i
1228 # Returns 1 if a is on an earlier row than b, otherwise 0
1229 proc comes_before {a b} {
1230 global varcid varctok curview
1232 set v $curview
1233 if {$a eq $b || ![info exists varcid($v,$a)] || \
1234 ![info exists varcid($v,$b)]} {
1235 return 0
1237 if {$varcid($v,$a) != $varcid($v,$b)} {
1238 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1239 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1241 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1244 proc bsearch {l elt} {
1245 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1246 return 0
1248 set lo 0
1249 set hi [llength $l]
1250 while {$hi - $lo > 1} {
1251 set mid [expr {int(($lo + $hi) / 2)}]
1252 set t [lindex $l $mid]
1253 if {$elt < $t} {
1254 set hi $mid
1255 } elseif {$elt > $t} {
1256 set lo $mid
1257 } else {
1258 return $mid
1261 return $lo
1264 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1265 proc make_disporder {start end} {
1266 global vrownum curview commitidx displayorder parentlist
1267 global varccommits varcorder parents vrowmod varcrow
1268 global d_valid_start d_valid_end
1270 if {$end > $vrowmod($curview)} {
1271 update_arcrows $curview
1273 set ai [bsearch $vrownum($curview) $start]
1274 set start [lindex $vrownum($curview) $ai]
1275 set narc [llength $vrownum($curview)]
1276 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1277 set a [lindex $varcorder($curview) $ai]
1278 set l [llength $displayorder]
1279 set al [llength $varccommits($curview,$a)]
1280 if {$l < $r + $al} {
1281 if {$l < $r} {
1282 set pad [ntimes [expr {$r - $l}] {}]
1283 set displayorder [concat $displayorder $pad]
1284 set parentlist [concat $parentlist $pad]
1285 } elseif {$l > $r} {
1286 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1287 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1289 foreach id $varccommits($curview,$a) {
1290 lappend displayorder $id
1291 lappend parentlist $parents($curview,$id)
1293 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1294 set i $r
1295 foreach id $varccommits($curview,$a) {
1296 lset displayorder $i $id
1297 lset parentlist $i $parents($curview,$id)
1298 incr i
1301 incr r $al
1305 proc commitonrow {row} {
1306 global displayorder
1308 set id [lindex $displayorder $row]
1309 if {$id eq {}} {
1310 make_disporder $row [expr {$row + 1}]
1311 set id [lindex $displayorder $row]
1313 return $id
1316 proc closevarcs {v} {
1317 global varctok varccommits varcid parents children
1318 global cmitlisted commitidx vtokmod
1320 set missing_parents 0
1321 set scripts {}
1322 set narcs [llength $varctok($v)]
1323 for {set a 1} {$a < $narcs} {incr a} {
1324 set id [lindex $varccommits($v,$a) end]
1325 foreach p $parents($v,$id) {
1326 if {[info exists varcid($v,$p)]} continue
1327 # add p as a new commit
1328 incr missing_parents
1329 set cmitlisted($v,$p) 0
1330 set parents($v,$p) {}
1331 if {[llength $children($v,$p)] == 1 &&
1332 [llength $parents($v,$id)] == 1} {
1333 set b $a
1334 } else {
1335 set b [newvarc $v $p]
1337 set varcid($v,$p) $b
1338 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1339 modify_arc $v $b
1341 lappend varccommits($v,$b) $p
1342 incr commitidx($v)
1343 set scripts [check_interest $p $scripts]
1346 if {$missing_parents > 0} {
1347 foreach s $scripts {
1348 eval $s
1353 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1354 # Assumes we already have an arc for $rwid.
1355 proc rewrite_commit {v id rwid} {
1356 global children parents varcid varctok vtokmod varccommits
1358 foreach ch $children($v,$id) {
1359 # make $rwid be $ch's parent in place of $id
1360 set i [lsearch -exact $parents($v,$ch) $id]
1361 if {$i < 0} {
1362 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1364 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1365 # add $ch to $rwid's children and sort the list if necessary
1366 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1367 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1368 $children($v,$rwid)]
1370 # fix the graph after joining $id to $rwid
1371 set a $varcid($v,$ch)
1372 fix_reversal $rwid $a $v
1373 # parentlist is wrong for the last element of arc $a
1374 # even if displayorder is right, hence the 3rd arg here
1375 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1379 # Mechanism for registering a command to be executed when we come
1380 # across a particular commit. To handle the case when only the
1381 # prefix of the commit is known, the commitinterest array is now
1382 # indexed by the first 4 characters of the ID. Each element is a
1383 # list of id, cmd pairs.
1384 proc interestedin {id cmd} {
1385 global commitinterest
1387 lappend commitinterest([string range $id 0 3]) $id $cmd
1390 proc check_interest {id scripts} {
1391 global commitinterest
1393 set prefix [string range $id 0 3]
1394 if {[info exists commitinterest($prefix)]} {
1395 set newlist {}
1396 foreach {i script} $commitinterest($prefix) {
1397 if {[string match "$i*" $id]} {
1398 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1399 } else {
1400 lappend newlist $i $script
1403 if {$newlist ne {}} {
1404 set commitinterest($prefix) $newlist
1405 } else {
1406 unset commitinterest($prefix)
1409 return $scripts
1412 proc getcommitlines {fd inst view updating} {
1413 global cmitlisted leftover
1414 global commitidx commitdata vdatemode
1415 global parents children curview hlview
1416 global idpending ordertok
1417 global varccommits varcid varctok vtokmod vfilelimit vshortids
1419 set stuff [read $fd 500000]
1420 # git log doesn't terminate the last commit with a null...
1421 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1422 set stuff "\0"
1424 if {$stuff == {}} {
1425 if {![eof $fd]} {
1426 return 1
1428 global commfd viewcomplete viewactive viewname
1429 global viewinstances
1430 unset commfd($inst)
1431 set i [lsearch -exact $viewinstances($view) $inst]
1432 if {$i >= 0} {
1433 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1435 # set it blocking so we wait for the process to terminate
1436 fconfigure $fd -blocking 1
1437 if {[catch {close $fd} err]} {
1438 set fv {}
1439 if {$view != $curview} {
1440 set fv " for the \"$viewname($view)\" view"
1442 if {[string range $err 0 4] == "usage"} {
1443 set err "Gitk: error reading commits$fv:\
1444 bad arguments to git log."
1445 if {$viewname($view) eq "Command line"} {
1446 append err \
1447 " (Note: arguments to gitk are passed to git log\
1448 to allow selection of commits to be displayed.)"
1450 } else {
1451 set err "Error reading commits$fv: $err"
1453 error_popup $err
1455 if {[incr viewactive($view) -1] <= 0} {
1456 set viewcomplete($view) 1
1457 # Check if we have seen any ids listed as parents that haven't
1458 # appeared in the list
1459 closevarcs $view
1460 notbusy $view
1462 if {$view == $curview} {
1463 run chewcommits
1465 return 0
1467 set start 0
1468 set gotsome 0
1469 set scripts {}
1470 while 1 {
1471 set i [string first "\0" $stuff $start]
1472 if {$i < 0} {
1473 append leftover($inst) [string range $stuff $start end]
1474 break
1476 if {$start == 0} {
1477 set cmit $leftover($inst)
1478 append cmit [string range $stuff 0 [expr {$i - 1}]]
1479 set leftover($inst) {}
1480 } else {
1481 set cmit [string range $stuff $start [expr {$i - 1}]]
1483 set start [expr {$i + 1}]
1484 set j [string first "\n" $cmit]
1485 set ok 0
1486 set listed 1
1487 if {$j >= 0 && [string match "commit *" $cmit]} {
1488 set ids [string range $cmit 7 [expr {$j - 1}]]
1489 if {[string match {[-^<>]*} $ids]} {
1490 switch -- [string index $ids 0] {
1491 "-" {set listed 0}
1492 "^" {set listed 2}
1493 "<" {set listed 3}
1494 ">" {set listed 4}
1496 set ids [string range $ids 1 end]
1498 set ok 1
1499 foreach id $ids {
1500 if {[string length $id] != 40} {
1501 set ok 0
1502 break
1506 if {!$ok} {
1507 set shortcmit $cmit
1508 if {[string length $shortcmit] > 80} {
1509 set shortcmit "[string range $shortcmit 0 80]..."
1511 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1512 exit 1
1514 set id [lindex $ids 0]
1515 set vid $view,$id
1517 lappend vshortids($view,[string range $id 0 3]) $id
1519 if {!$listed && $updating && ![info exists varcid($vid)] &&
1520 $vfilelimit($view) ne {}} {
1521 # git log doesn't rewrite parents for unlisted commits
1522 # when doing path limiting, so work around that here
1523 # by working out the rewritten parent with git rev-list
1524 # and if we already know about it, using the rewritten
1525 # parent as a substitute parent for $id's children.
1526 if {![catch {
1527 set rwid [exec git rev-list --first-parent --max-count=1 \
1528 $id -- $vfilelimit($view)]
1529 }]} {
1530 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1531 # use $rwid in place of $id
1532 rewrite_commit $view $id $rwid
1533 continue
1538 set a 0
1539 if {[info exists varcid($vid)]} {
1540 if {$cmitlisted($vid) || !$listed} continue
1541 set a $varcid($vid)
1543 if {$listed} {
1544 set olds [lrange $ids 1 end]
1545 } else {
1546 set olds {}
1548 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1549 set cmitlisted($vid) $listed
1550 set parents($vid) $olds
1551 if {![info exists children($vid)]} {
1552 set children($vid) {}
1553 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1554 set k [lindex $children($vid) 0]
1555 if {[llength $parents($view,$k)] == 1 &&
1556 (!$vdatemode($view) ||
1557 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1558 set a $varcid($view,$k)
1561 if {$a == 0} {
1562 # new arc
1563 set a [newvarc $view $id]
1565 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1566 modify_arc $view $a
1568 if {![info exists varcid($vid)]} {
1569 set varcid($vid) $a
1570 lappend varccommits($view,$a) $id
1571 incr commitidx($view)
1574 set i 0
1575 foreach p $olds {
1576 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1577 set vp $view,$p
1578 if {[llength [lappend children($vp) $id]] > 1 &&
1579 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1580 set children($vp) [lsort -command [list vtokcmp $view] \
1581 $children($vp)]
1582 catch {unset ordertok}
1584 if {[info exists varcid($view,$p)]} {
1585 fix_reversal $p $a $view
1588 incr i
1591 set scripts [check_interest $id $scripts]
1592 set gotsome 1
1594 if {$gotsome} {
1595 global numcommits hlview
1597 if {$view == $curview} {
1598 set numcommits $commitidx($view)
1599 run chewcommits
1601 if {[info exists hlview] && $view == $hlview} {
1602 # we never actually get here...
1603 run vhighlightmore
1605 foreach s $scripts {
1606 eval $s
1609 return 2
1612 proc chewcommits {} {
1613 global curview hlview viewcomplete
1614 global pending_select
1616 layoutmore
1617 if {$viewcomplete($curview)} {
1618 global commitidx varctok
1619 global numcommits startmsecs
1621 if {[info exists pending_select]} {
1622 update
1623 reset_pending_select {}
1625 if {[commitinview $pending_select $curview]} {
1626 selectline [rowofcommit $pending_select] 1
1627 } else {
1628 set row [first_real_row]
1629 selectline $row 1
1632 if {$commitidx($curview) > 0} {
1633 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1634 #puts "overall $ms ms for $numcommits commits"
1635 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1636 } else {
1637 show_status [mc "No commits selected"]
1639 notbusy layout
1641 return 0
1644 proc do_readcommit {id} {
1645 global tclencoding
1647 # Invoke git-log to handle automatic encoding conversion
1648 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1649 # Read the results using i18n.logoutputencoding
1650 fconfigure $fd -translation lf -eofchar {}
1651 if {$tclencoding != {}} {
1652 fconfigure $fd -encoding $tclencoding
1654 set contents [read $fd]
1655 close $fd
1656 # Remove the heading line
1657 regsub {^commit [0-9a-f]+\n} $contents {} contents
1659 return $contents
1662 proc readcommit {id} {
1663 if {[catch {set contents [do_readcommit $id]}]} return
1664 parsecommit $id $contents 1
1667 proc parsecommit {id contents listed} {
1668 global commitinfo
1670 set inhdr 1
1671 set comment {}
1672 set headline {}
1673 set auname {}
1674 set audate {}
1675 set comname {}
1676 set comdate {}
1677 set hdrend [string first "\n\n" $contents]
1678 if {$hdrend < 0} {
1679 # should never happen...
1680 set hdrend [string length $contents]
1682 set header [string range $contents 0 [expr {$hdrend - 1}]]
1683 set comment [string range $contents [expr {$hdrend + 2}] end]
1684 foreach line [split $header "\n"] {
1685 set line [split $line " "]
1686 set tag [lindex $line 0]
1687 if {$tag == "author"} {
1688 set audate [lrange $line end-1 end]
1689 set auname [join [lrange $line 1 end-2] " "]
1690 } elseif {$tag == "committer"} {
1691 set comdate [lrange $line end-1 end]
1692 set comname [join [lrange $line 1 end-2] " "]
1695 set headline {}
1696 # take the first non-blank line of the comment as the headline
1697 set headline [string trimleft $comment]
1698 set i [string first "\n" $headline]
1699 if {$i >= 0} {
1700 set headline [string range $headline 0 $i]
1702 set headline [string trimright $headline]
1703 set i [string first "\r" $headline]
1704 if {$i >= 0} {
1705 set headline [string trimright [string range $headline 0 $i]]
1707 if {!$listed} {
1708 # git log indents the comment by 4 spaces;
1709 # if we got this via git cat-file, add the indentation
1710 set newcomment {}
1711 foreach line [split $comment "\n"] {
1712 append newcomment " "
1713 append newcomment $line
1714 append newcomment "\n"
1716 set comment $newcomment
1718 set hasnote [string first "\nNotes:\n" $contents]
1719 set diff ""
1720 # If there is diff output shown in the git-log stream, split it
1721 # out. But get rid of the empty line that always precedes the
1722 # diff.
1723 set i [string first "\n\ndiff" $comment]
1724 if {$i >= 0} {
1725 set diff [string range $comment $i+1 end]
1726 set comment [string range $comment 0 $i-1]
1728 set commitinfo($id) [list $headline $auname $audate \
1729 $comname $comdate $comment $hasnote $diff]
1732 proc getcommit {id} {
1733 global commitdata commitinfo
1735 if {[info exists commitdata($id)]} {
1736 parsecommit $id $commitdata($id) 1
1737 } else {
1738 readcommit $id
1739 if {![info exists commitinfo($id)]} {
1740 set commitinfo($id) [list [mc "No commit information available"]]
1743 return 1
1746 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1747 # and are present in the current view.
1748 # This is fairly slow...
1749 proc longid {prefix} {
1750 global varcid curview vshortids
1752 set ids {}
1753 if {[string length $prefix] >= 4} {
1754 set vshortid $curview,[string range $prefix 0 3]
1755 if {[info exists vshortids($vshortid)]} {
1756 foreach id $vshortids($vshortid) {
1757 if {[string match "$prefix*" $id]} {
1758 if {[lsearch -exact $ids $id] < 0} {
1759 lappend ids $id
1760 if {[llength $ids] >= 2} break
1765 } else {
1766 foreach match [array names varcid "$curview,$prefix*"] {
1767 lappend ids [lindex [split $match ","] 1]
1768 if {[llength $ids] >= 2} break
1771 return $ids
1774 proc readrefs {} {
1775 global tagids idtags headids idheads tagobjid
1776 global otherrefids idotherrefs mainhead mainheadid
1777 global selecthead selectheadid
1778 global hideremotes
1780 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1781 catch {unset $v}
1783 set refd [open [list | git show-ref -d] r]
1784 while {[gets $refd line] >= 0} {
1785 if {[string index $line 40] ne " "} continue
1786 set id [string range $line 0 39]
1787 set ref [string range $line 41 end]
1788 if {![string match "refs/*" $ref]} continue
1789 set name [string range $ref 5 end]
1790 if {[string match "remotes/*" $name]} {
1791 if {![string match "*/HEAD" $name] && !$hideremotes} {
1792 set headids($name) $id
1793 lappend idheads($id) $name
1795 } elseif {[string match "heads/*" $name]} {
1796 set name [string range $name 6 end]
1797 set headids($name) $id
1798 lappend idheads($id) $name
1799 } elseif {[string match "tags/*" $name]} {
1800 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1801 # which is what we want since the former is the commit ID
1802 set name [string range $name 5 end]
1803 if {[string match "*^{}" $name]} {
1804 set name [string range $name 0 end-3]
1805 } else {
1806 set tagobjid($name) $id
1808 set tagids($name) $id
1809 lappend idtags($id) $name
1810 } else {
1811 set otherrefids($name) $id
1812 lappend idotherrefs($id) $name
1815 catch {close $refd}
1816 set mainhead {}
1817 set mainheadid {}
1818 catch {
1819 set mainheadid [exec git rev-parse HEAD]
1820 set thehead [exec git symbolic-ref HEAD]
1821 if {[string match "refs/heads/*" $thehead]} {
1822 set mainhead [string range $thehead 11 end]
1825 set selectheadid {}
1826 if {$selecthead ne {}} {
1827 catch {
1828 set selectheadid [exec git rev-parse --verify $selecthead]
1833 # skip over fake commits
1834 proc first_real_row {} {
1835 global nullid nullid2 numcommits
1837 for {set row 0} {$row < $numcommits} {incr row} {
1838 set id [commitonrow $row]
1839 if {$id ne $nullid && $id ne $nullid2} {
1840 break
1843 return $row
1846 # update things for a head moved to a child of its previous location
1847 proc movehead {id name} {
1848 global headids idheads
1850 removehead $headids($name) $name
1851 set headids($name) $id
1852 lappend idheads($id) $name
1855 # update things when a head has been removed
1856 proc removehead {id name} {
1857 global headids idheads
1859 if {$idheads($id) eq $name} {
1860 unset idheads($id)
1861 } else {
1862 set i [lsearch -exact $idheads($id) $name]
1863 if {$i >= 0} {
1864 set idheads($id) [lreplace $idheads($id) $i $i]
1867 unset headids($name)
1870 proc ttk_toplevel {w args} {
1871 global use_ttk
1872 eval [linsert $args 0 ::toplevel $w]
1873 if {$use_ttk} {
1874 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1876 return $w
1879 proc make_transient {window origin} {
1880 global have_tk85
1882 # In MacOS Tk 8.4 transient appears to work by setting
1883 # overrideredirect, which is utterly useless, since the
1884 # windows get no border, and are not even kept above
1885 # the parent.
1886 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1888 wm transient $window $origin
1890 # Windows fails to place transient windows normally, so
1891 # schedule a callback to center them on the parent.
1892 if {[tk windowingsystem] eq {win32}} {
1893 after idle [list tk::PlaceWindow $window widget $origin]
1897 proc show_error {w top msg {mc mc}} {
1898 global NS
1899 if {![info exists NS]} {set NS ""}
1900 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1901 message $w.m -text $msg -justify center -aspect 400
1902 pack $w.m -side top -fill x -padx 20 -pady 20
1903 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1904 pack $w.ok -side bottom -fill x
1905 bind $top <Visibility> "grab $top; focus $top"
1906 bind $top <Key-Return> "destroy $top"
1907 bind $top <Key-space> "destroy $top"
1908 bind $top <Key-Escape> "destroy $top"
1909 tkwait window $top
1912 proc error_popup {msg {owner .}} {
1913 if {[tk windowingsystem] eq "win32"} {
1914 tk_messageBox -icon error -type ok -title [wm title .] \
1915 -parent $owner -message $msg
1916 } else {
1917 set w .error
1918 ttk_toplevel $w
1919 make_transient $w $owner
1920 show_error $w $w $msg
1924 proc confirm_popup {msg {owner .}} {
1925 global confirm_ok NS
1926 set confirm_ok 0
1927 set w .confirm
1928 ttk_toplevel $w
1929 make_transient $w $owner
1930 message $w.m -text $msg -justify center -aspect 400
1931 pack $w.m -side top -fill x -padx 20 -pady 20
1932 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1933 pack $w.ok -side left -fill x
1934 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1935 pack $w.cancel -side right -fill x
1936 bind $w <Visibility> "grab $w; focus $w"
1937 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1938 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1939 bind $w <Key-Escape> "destroy $w"
1940 tk::PlaceWindow $w widget $owner
1941 tkwait window $w
1942 return $confirm_ok
1945 proc setoptions {} {
1946 if {[tk windowingsystem] ne "win32"} {
1947 option add *Panedwindow.showHandle 1 startupFile
1948 option add *Panedwindow.sashRelief raised startupFile
1949 if {[tk windowingsystem] ne "aqua"} {
1950 option add *Menu.font uifont startupFile
1952 } else {
1953 option add *Menu.TearOff 0 startupFile
1955 option add *Button.font uifont startupFile
1956 option add *Checkbutton.font uifont startupFile
1957 option add *Radiobutton.font uifont startupFile
1958 option add *Menubutton.font uifont startupFile
1959 option add *Label.font uifont startupFile
1960 option add *Message.font uifont startupFile
1961 option add *Entry.font textfont startupFile
1962 option add *Text.font textfont startupFile
1963 option add *Labelframe.font uifont startupFile
1964 option add *Spinbox.font textfont startupFile
1965 option add *Listbox.font mainfont startupFile
1968 # Make a menu and submenus.
1969 # m is the window name for the menu, items is the list of menu items to add.
1970 # Each item is a list {mc label type description options...}
1971 # mc is ignored; it's so we can put mc there to alert xgettext
1972 # label is the string that appears in the menu
1973 # type is cascade, command or radiobutton (should add checkbutton)
1974 # description depends on type; it's the sublist for cascade, the
1975 # command to invoke for command, or {variable value} for radiobutton
1976 proc makemenu {m items} {
1977 menu $m
1978 if {[tk windowingsystem] eq {aqua}} {
1979 set Meta1 Cmd
1980 } else {
1981 set Meta1 Ctrl
1983 foreach i $items {
1984 set name [mc [lindex $i 1]]
1985 set type [lindex $i 2]
1986 set thing [lindex $i 3]
1987 set params [list $type]
1988 if {$name ne {}} {
1989 set u [string first "&" [string map {&& x} $name]]
1990 lappend params -label [string map {&& & & {}} $name]
1991 if {$u >= 0} {
1992 lappend params -underline $u
1995 switch -- $type {
1996 "cascade" {
1997 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1998 lappend params -menu $m.$submenu
2000 "command" {
2001 lappend params -command $thing
2003 "radiobutton" {
2004 lappend params -variable [lindex $thing 0] \
2005 -value [lindex $thing 1]
2008 set tail [lrange $i 4 end]
2009 regsub -all {\yMeta1\y} $tail $Meta1 tail
2010 eval $m add $params $tail
2011 if {$type eq "cascade"} {
2012 makemenu $m.$submenu $thing
2017 # translate string and remove ampersands
2018 proc mca {str} {
2019 return [string map {&& & & {}} [mc $str]]
2022 proc cleardropsel {w} {
2023 $w selection clear
2025 proc makedroplist {w varname args} {
2026 global use_ttk
2027 if {$use_ttk} {
2028 set width 0
2029 foreach label $args {
2030 set cx [string length $label]
2031 if {$cx > $width} {set width $cx}
2033 set gm [ttk::combobox $w -width $width -state readonly\
2034 -textvariable $varname -values $args \
2035 -exportselection false]
2036 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2037 } else {
2038 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2040 return $gm
2043 proc makewindow {} {
2044 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2045 global tabstop
2046 global findtype findtypemenu findloc findstring fstring geometry
2047 global entries sha1entry sha1string sha1but
2048 global diffcontextstring diffcontext
2049 global ignorespace
2050 global maincursor textcursor curtextcursor
2051 global rowctxmenu fakerowmenu mergemax wrapcomment
2052 global highlight_files gdttype
2053 global searchstring sstring
2054 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2055 global uifgcolor uifgdisabledcolor
2056 global filesepbgcolor filesepfgcolor
2057 global mergecolors foundbgcolor currentsearchhitbgcolor
2058 global headctxmenu progresscanv progressitem progresscoords statusw
2059 global fprogitem fprogcoord lastprogupdate progupdatepending
2060 global rprogitem rprogcoord rownumsel numcommits
2061 global have_tk85 use_ttk NS
2062 global git_version
2063 global worddiff
2065 # The "mc" arguments here are purely so that xgettext
2066 # sees the following string as needing to be translated
2067 set file {
2068 mc "File" cascade {
2069 {mc "Update" command updatecommits -accelerator F5}
2070 {mc "Reload" command reloadcommits -accelerator Shift-F5}
2071 {mc "Reread references" command rereadrefs}
2072 {mc "List references" command showrefs -accelerator F2}
2073 {xx "" separator}
2074 {mc "Start git gui" command {exec git gui &}}
2075 {xx "" separator}
2076 {mc "Quit" command doquit -accelerator Meta1-Q}
2078 set edit {
2079 mc "Edit" cascade {
2080 {mc "Preferences" command doprefs}
2082 set view {
2083 mc "View" cascade {
2084 {mc "New view..." command {newview 0} -accelerator Shift-F4}
2085 {mc "Edit view..." command editview -state disabled -accelerator F4}
2086 {mc "Delete view" command delview -state disabled}
2087 {xx "" separator}
2088 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2090 if {[tk windowingsystem] ne "aqua"} {
2091 set help {
2092 mc "Help" cascade {
2093 {mc "About gitk" command about}
2094 {mc "Key bindings" command keys}
2096 set bar [list $file $edit $view $help]
2097 } else {
2098 proc ::tk::mac::ShowPreferences {} {doprefs}
2099 proc ::tk::mac::Quit {} {doquit}
2100 lset file end [lreplace [lindex $file end] end-1 end]
2101 set apple {
2102 xx "Apple" cascade {
2103 {mc "About gitk" command about}
2104 {xx "" separator}
2106 set help {
2107 mc "Help" cascade {
2108 {mc "Key bindings" command keys}
2110 set bar [list $apple $file $view $help]
2112 makemenu .bar $bar
2113 . configure -menu .bar
2115 if {$use_ttk} {
2116 # cover the non-themed toplevel with a themed frame.
2117 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2120 # the gui has upper and lower half, parts of a paned window.
2121 ${NS}::panedwindow .ctop -orient vertical
2123 # possibly use assumed geometry
2124 if {![info exists geometry(pwsash0)]} {
2125 set geometry(topheight) [expr {15 * $linespc}]
2126 set geometry(topwidth) [expr {80 * $charspc}]
2127 set geometry(botheight) [expr {15 * $linespc}]
2128 set geometry(botwidth) [expr {50 * $charspc}]
2129 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2130 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2133 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2134 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2135 ${NS}::frame .tf.histframe
2136 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2137 if {!$use_ttk} {
2138 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2141 # create three canvases
2142 set cscroll .tf.histframe.csb
2143 set canv .tf.histframe.pwclist.canv
2144 canvas $canv \
2145 -selectbackground $selectbgcolor \
2146 -background $bgcolor -bd 0 \
2147 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2148 .tf.histframe.pwclist add $canv
2149 set canv2 .tf.histframe.pwclist.canv2
2150 canvas $canv2 \
2151 -selectbackground $selectbgcolor \
2152 -background $bgcolor -bd 0 -yscrollincr $linespc
2153 .tf.histframe.pwclist add $canv2
2154 set canv3 .tf.histframe.pwclist.canv3
2155 canvas $canv3 \
2156 -selectbackground $selectbgcolor \
2157 -background $bgcolor -bd 0 -yscrollincr $linespc
2158 .tf.histframe.pwclist add $canv3
2159 if {$use_ttk} {
2160 bind .tf.histframe.pwclist <Map> {
2161 bind %W <Map> {}
2162 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2163 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2165 } else {
2166 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2167 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2170 # a scroll bar to rule them
2171 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2172 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2173 pack $cscroll -side right -fill y
2174 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2175 lappend bglist $canv $canv2 $canv3
2176 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2178 # we have two button bars at bottom of top frame. Bar 1
2179 ${NS}::frame .tf.bar
2180 ${NS}::frame .tf.lbar -height 15
2182 set sha1entry .tf.bar.sha1
2183 set entries $sha1entry
2184 set sha1but .tf.bar.sha1label
2185 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2186 -command gotocommit -width 8
2187 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2188 pack .tf.bar.sha1label -side left
2189 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2190 trace add variable sha1string write sha1change
2191 pack $sha1entry -side left -pady 2
2193 set bm_left_data {
2194 #define left_width 16
2195 #define left_height 16
2196 static unsigned char left_bits[] = {
2197 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2198 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2199 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2201 set bm_right_data {
2202 #define right_width 16
2203 #define right_height 16
2204 static unsigned char right_bits[] = {
2205 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2206 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2207 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2209 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2210 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2211 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2212 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2214 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2215 if {$use_ttk} {
2216 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2217 } else {
2218 .tf.bar.leftbut configure -image bm-left
2220 pack .tf.bar.leftbut -side left -fill y
2221 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2222 if {$use_ttk} {
2223 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2224 } else {
2225 .tf.bar.rightbut configure -image bm-right
2227 pack .tf.bar.rightbut -side left -fill y
2229 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2230 set rownumsel {}
2231 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2232 -relief sunken -anchor e
2233 ${NS}::label .tf.bar.rowlabel2 -text "/"
2234 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2235 -relief sunken -anchor e
2236 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2237 -side left
2238 if {!$use_ttk} {
2239 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2241 global selectedline
2242 trace add variable selectedline write selectedline_change
2244 # Status label and progress bar
2245 set statusw .tf.bar.status
2246 ${NS}::label $statusw -width 15 -relief sunken
2247 pack $statusw -side left -padx 5
2248 if {$use_ttk} {
2249 set progresscanv [ttk::progressbar .tf.bar.progress]
2250 } else {
2251 set h [expr {[font metrics uifont -linespace] + 2}]
2252 set progresscanv .tf.bar.progress
2253 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2254 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2255 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2256 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2258 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2259 set progresscoords {0 0}
2260 set fprogcoord 0
2261 set rprogcoord 0
2262 bind $progresscanv <Configure> adjustprogress
2263 set lastprogupdate [clock clicks -milliseconds]
2264 set progupdatepending 0
2266 # build up the bottom bar of upper window
2267 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2269 set bm_down_data {
2270 #define down_width 16
2271 #define down_height 16
2272 static unsigned char down_bits[] = {
2273 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2274 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2275 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2276 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2278 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2279 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2280 .tf.lbar.fnext configure -image bm-down
2282 set bm_up_data {
2283 #define up_width 16
2284 #define up_height 16
2285 static unsigned char up_bits[] = {
2286 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2287 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2288 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2289 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2291 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2292 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2293 .tf.lbar.fprev configure -image bm-up
2295 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2297 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2298 -side left -fill y
2299 set gdttype [mc "containing:"]
2300 set gm [makedroplist .tf.lbar.gdttype gdttype \
2301 [mc "containing:"] \
2302 [mc "touching paths:"] \
2303 [mc "adding/removing string:"] \
2304 [mc "changing lines matching:"]]
2305 trace add variable gdttype write gdttype_change
2306 pack .tf.lbar.gdttype -side left -fill y
2308 set findstring {}
2309 set fstring .tf.lbar.findstring
2310 lappend entries $fstring
2311 ${NS}::entry $fstring -width 30 -textvariable findstring
2312 trace add variable findstring write find_change
2313 set findtype [mc "Exact"]
2314 set findtypemenu [makedroplist .tf.lbar.findtype \
2315 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2316 trace add variable findtype write findcom_change
2317 set findloc [mc "All fields"]
2318 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2319 [mc "Comments"] [mc "Author"] [mc "Committer"]
2320 trace add variable findloc write find_change
2321 pack .tf.lbar.findloc -side right
2322 pack .tf.lbar.findtype -side right
2323 pack $fstring -side left -expand 1 -fill x
2325 # Finish putting the upper half of the viewer together
2326 pack .tf.lbar -in .tf -side bottom -fill x
2327 pack .tf.bar -in .tf -side bottom -fill x
2328 pack .tf.histframe -fill both -side top -expand 1
2329 .ctop add .tf
2330 if {!$use_ttk} {
2331 .ctop paneconfigure .tf -height $geometry(topheight)
2332 .ctop paneconfigure .tf -width $geometry(topwidth)
2335 # now build up the bottom
2336 ${NS}::panedwindow .pwbottom -orient horizontal
2338 # lower left, a text box over search bar, scroll bar to the right
2339 # if we know window height, then that will set the lower text height, otherwise
2340 # we set lower text height which will drive window height
2341 if {[info exists geometry(main)]} {
2342 ${NS}::frame .bleft -width $geometry(botwidth)
2343 } else {
2344 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2346 ${NS}::frame .bleft.top
2347 ${NS}::frame .bleft.mid
2348 ${NS}::frame .bleft.bottom
2350 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2351 pack .bleft.top.search -side left -padx 5
2352 set sstring .bleft.top.sstring
2353 set searchstring ""
2354 ${NS}::entry $sstring -width 20 -textvariable searchstring
2355 lappend entries $sstring
2356 trace add variable searchstring write incrsearch
2357 pack $sstring -side left -expand 1 -fill x
2358 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2359 -command changediffdisp -variable diffelide -value {0 0}
2360 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2361 -command changediffdisp -variable diffelide -value {0 1}
2362 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2363 -command changediffdisp -variable diffelide -value {1 0}
2364 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2365 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2366 spinbox .bleft.mid.diffcontext -width 5 \
2367 -from 0 -increment 1 -to 10000000 \
2368 -validate all -validatecommand "diffcontextvalidate %P" \
2369 -textvariable diffcontextstring
2370 .bleft.mid.diffcontext set $diffcontext
2371 trace add variable diffcontextstring write diffcontextchange
2372 lappend entries .bleft.mid.diffcontext
2373 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2374 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2375 -command changeignorespace -variable ignorespace
2376 pack .bleft.mid.ignspace -side left -padx 5
2378 set worddiff [mc "Line diff"]
2379 if {[package vcompare $git_version "1.7.2"] >= 0} {
2380 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2381 [mc "Markup words"] [mc "Color words"]
2382 trace add variable worddiff write changeworddiff
2383 pack .bleft.mid.worddiff -side left -padx 5
2386 set ctext .bleft.bottom.ctext
2387 text $ctext -background $bgcolor -foreground $fgcolor \
2388 -state disabled -font textfont \
2389 -yscrollcommand scrolltext -wrap none \
2390 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2391 if {$have_tk85} {
2392 $ctext conf -tabstyle wordprocessor
2394 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2395 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2396 pack .bleft.top -side top -fill x
2397 pack .bleft.mid -side top -fill x
2398 grid $ctext .bleft.bottom.sb -sticky nsew
2399 grid .bleft.bottom.sbhorizontal -sticky ew
2400 grid columnconfigure .bleft.bottom 0 -weight 1
2401 grid rowconfigure .bleft.bottom 0 -weight 1
2402 grid rowconfigure .bleft.bottom 1 -weight 0
2403 pack .bleft.bottom -side top -fill both -expand 1
2404 lappend bglist $ctext
2405 lappend fglist $ctext
2407 $ctext tag conf comment -wrap $wrapcomment
2408 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2409 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2410 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2411 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2412 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2413 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2414 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2415 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2416 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2417 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2418 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2419 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2420 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2421 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2422 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2423 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2424 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2425 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2426 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2427 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2428 $ctext tag conf mmax -fore darkgrey
2429 set mergemax 16
2430 $ctext tag conf mresult -font textfontbold
2431 $ctext tag conf msep -font textfontbold
2432 $ctext tag conf found -back $foundbgcolor
2433 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2434 $ctext tag conf wwrap -wrap word -lmargin2 1c
2435 $ctext tag conf bold -font textfontbold
2437 .pwbottom add .bleft
2438 if {!$use_ttk} {
2439 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2442 # lower right
2443 ${NS}::frame .bright
2444 ${NS}::frame .bright.mode
2445 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2446 -command reselectline -variable cmitmode -value "patch"
2447 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2448 -command reselectline -variable cmitmode -value "tree"
2449 grid .bright.mode.patch .bright.mode.tree -sticky ew
2450 pack .bright.mode -side top -fill x
2451 set cflist .bright.cfiles
2452 set indent [font measure mainfont "nn"]
2453 text $cflist \
2454 -selectbackground $selectbgcolor \
2455 -background $bgcolor -foreground $fgcolor \
2456 -font mainfont \
2457 -tabs [list $indent [expr {2 * $indent}]] \
2458 -yscrollcommand ".bright.sb set" \
2459 -cursor [. cget -cursor] \
2460 -spacing1 1 -spacing3 1
2461 lappend bglist $cflist
2462 lappend fglist $cflist
2463 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2464 pack .bright.sb -side right -fill y
2465 pack $cflist -side left -fill both -expand 1
2466 $cflist tag configure highlight \
2467 -background [$cflist cget -selectbackground]
2468 $cflist tag configure bold -font mainfontbold
2470 .pwbottom add .bright
2471 .ctop add .pwbottom
2473 # restore window width & height if known
2474 if {[info exists geometry(main)]} {
2475 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2476 if {$w > [winfo screenwidth .]} {
2477 set w [winfo screenwidth .]
2479 if {$h > [winfo screenheight .]} {
2480 set h [winfo screenheight .]
2482 wm geometry . "${w}x$h"
2486 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2487 wm state . $geometry(state)
2490 if {[tk windowingsystem] eq {aqua}} {
2491 set M1B M1
2492 set ::BM "3"
2493 } else {
2494 set M1B Control
2495 set ::BM "2"
2498 if {$use_ttk} {
2499 bind .ctop <Map> {
2500 bind %W <Map> {}
2501 %W sashpos 0 $::geometry(topheight)
2503 bind .pwbottom <Map> {
2504 bind %W <Map> {}
2505 %W sashpos 0 $::geometry(botwidth)
2509 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2510 pack .ctop -fill both -expand 1
2511 bindall <1> {selcanvline %W %x %y}
2512 #bindall <B1-Motion> {selcanvline %W %x %y}
2513 if {[tk windowingsystem] == "win32"} {
2514 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2515 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2516 } else {
2517 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2518 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2519 if {[tk windowingsystem] eq "aqua"} {
2520 bindall <MouseWheel> {
2521 set delta [expr {- (%D)}]
2522 allcanvs yview scroll $delta units
2524 bindall <Shift-MouseWheel> {
2525 set delta [expr {- (%D)}]
2526 $canv xview scroll $delta units
2530 bindall <$::BM> "canvscan mark %W %x %y"
2531 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2532 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2533 bind . <$M1B-Key-w> doquit
2534 bindkey <Home> selfirstline
2535 bindkey <End> sellastline
2536 bind . <Key-Up> "selnextline -1"
2537 bind . <Key-Down> "selnextline 1"
2538 bind . <Shift-Key-Up> "dofind -1 0"
2539 bind . <Shift-Key-Down> "dofind 1 0"
2540 bindkey <Key-Right> "goforw"
2541 bindkey <Key-Left> "goback"
2542 bind . <Key-Prior> "selnextpage -1"
2543 bind . <Key-Next> "selnextpage 1"
2544 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2545 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2546 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2547 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2548 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2549 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2550 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2551 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2552 bindkey <Key-space> "$ctext yview scroll 1 pages"
2553 bindkey p "selnextline -1"
2554 bindkey n "selnextline 1"
2555 bindkey z "goback"
2556 bindkey x "goforw"
2557 bindkey k "selnextline -1"
2558 bindkey j "selnextline 1"
2559 bindkey h "goback"
2560 bindkey l "goforw"
2561 bindkey b prevfile
2562 bindkey d "$ctext yview scroll 18 units"
2563 bindkey u "$ctext yview scroll -18 units"
2564 bindkey / {focus $fstring}
2565 bindkey <Key-KP_Divide> {focus $fstring}
2566 bindkey <Key-Return> {dofind 1 1}
2567 bindkey ? {dofind -1 1}
2568 bindkey f nextfile
2569 bind . <F5> updatecommits
2570 bindmodfunctionkey Shift 5 reloadcommits
2571 bind . <F2> showrefs
2572 bindmodfunctionkey Shift 4 {newview 0}
2573 bind . <F4> edit_or_newview
2574 bind . <$M1B-q> doquit
2575 bind . <$M1B-f> {dofind 1 1}
2576 bind . <$M1B-g> {dofind 1 0}
2577 bind . <$M1B-r> dosearchback
2578 bind . <$M1B-s> dosearch
2579 bind . <$M1B-equal> {incrfont 1}
2580 bind . <$M1B-plus> {incrfont 1}
2581 bind . <$M1B-KP_Add> {incrfont 1}
2582 bind . <$M1B-minus> {incrfont -1}
2583 bind . <$M1B-KP_Subtract> {incrfont -1}
2584 wm protocol . WM_DELETE_WINDOW doquit
2585 bind . <Destroy> {stop_backends}
2586 bind . <Button-1> "click %W"
2587 bind $fstring <Key-Return> {dofind 1 1}
2588 bind $sha1entry <Key-Return> {gotocommit; break}
2589 bind $sha1entry <<PasteSelection>> clearsha1
2590 bind $sha1entry <<Paste>> clearsha1
2591 bind $cflist <1> {sel_flist %W %x %y; break}
2592 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2593 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2594 global ctxbut
2595 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2596 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2597 bind $ctext <Button-1> {focus %W}
2598 bind $ctext <<Selection>> rehighlight_search_results
2599 for {set i 1} {$i < 10} {incr i} {
2600 bind . <$M1B-Key-$i> [list go_to_parent $i]
2603 set maincursor [. cget -cursor]
2604 set textcursor [$ctext cget -cursor]
2605 set curtextcursor $textcursor
2607 set rowctxmenu .rowctxmenu
2608 makemenu $rowctxmenu {
2609 {mc "Diff this -> selected" command {diffvssel 0}}
2610 {mc "Diff selected -> this" command {diffvssel 1}}
2611 {mc "Make patch" command mkpatch}
2612 {mc "Create tag" command mktag}
2613 {mc "Write commit to file" command writecommit}
2614 {mc "Create new branch" command mkbranch}
2615 {mc "Cherry-pick this commit" command cherrypick}
2616 {mc "Reset HEAD branch to here" command resethead}
2617 {mc "Mark this commit" command markhere}
2618 {mc "Return to mark" command gotomark}
2619 {mc "Find descendant of this and mark" command find_common_desc}
2620 {mc "Compare with marked commit" command compare_commits}
2621 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2622 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2623 {mc "Revert this commit" command revert}
2625 $rowctxmenu configure -tearoff 0
2627 set fakerowmenu .fakerowmenu
2628 makemenu $fakerowmenu {
2629 {mc "Diff this -> selected" command {diffvssel 0}}
2630 {mc "Diff selected -> this" command {diffvssel 1}}
2631 {mc "Make patch" command mkpatch}
2632 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2633 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2635 $fakerowmenu configure -tearoff 0
2637 set headctxmenu .headctxmenu
2638 makemenu $headctxmenu {
2639 {mc "Check out this branch" command cobranch}
2640 {mc "Remove this branch" command rmbranch}
2642 $headctxmenu configure -tearoff 0
2644 global flist_menu
2645 set flist_menu .flistctxmenu
2646 makemenu $flist_menu {
2647 {mc "Highlight this too" command {flist_hl 0}}
2648 {mc "Highlight this only" command {flist_hl 1}}
2649 {mc "External diff" command {external_diff}}
2650 {mc "Blame parent commit" command {external_blame 1}}
2652 $flist_menu configure -tearoff 0
2654 global diff_menu
2655 set diff_menu .diffctxmenu
2656 makemenu $diff_menu {
2657 {mc "Show origin of this line" command show_line_source}
2658 {mc "Run git gui blame on this line" command {external_blame_diff}}
2660 $diff_menu configure -tearoff 0
2663 # Windows sends all mouse wheel events to the current focused window, not
2664 # the one where the mouse hovers, so bind those events here and redirect
2665 # to the correct window
2666 proc windows_mousewheel_redirector {W X Y D} {
2667 global canv canv2 canv3
2668 set w [winfo containing -displayof $W $X $Y]
2669 if {$w ne ""} {
2670 set u [expr {$D < 0 ? 5 : -5}]
2671 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2672 allcanvs yview scroll $u units
2673 } else {
2674 catch {
2675 $w yview scroll $u units
2681 # Update row number label when selectedline changes
2682 proc selectedline_change {n1 n2 op} {
2683 global selectedline rownumsel
2685 if {$selectedline eq {}} {
2686 set rownumsel {}
2687 } else {
2688 set rownumsel [expr {$selectedline + 1}]
2692 # mouse-2 makes all windows scan vertically, but only the one
2693 # the cursor is in scans horizontally
2694 proc canvscan {op w x y} {
2695 global canv canv2 canv3
2696 foreach c [list $canv $canv2 $canv3] {
2697 if {$c == $w} {
2698 $c scan $op $x $y
2699 } else {
2700 $c scan $op 0 $y
2705 proc scrollcanv {cscroll f0 f1} {
2706 $cscroll set $f0 $f1
2707 drawvisible
2708 flushhighlights
2711 # when we make a key binding for the toplevel, make sure
2712 # it doesn't get triggered when that key is pressed in the
2713 # find string entry widget.
2714 proc bindkey {ev script} {
2715 global entries
2716 bind . $ev $script
2717 set escript [bind Entry $ev]
2718 if {$escript == {}} {
2719 set escript [bind Entry <Key>]
2721 foreach e $entries {
2722 bind $e $ev "$escript; break"
2726 proc bindmodfunctionkey {mod n script} {
2727 bind . <$mod-F$n> $script
2728 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2731 # set the focus back to the toplevel for any click outside
2732 # the entry widgets
2733 proc click {w} {
2734 global ctext entries
2735 foreach e [concat $entries $ctext] {
2736 if {$w == $e} return
2738 focus .
2741 # Adjust the progress bar for a change in requested extent or canvas size
2742 proc adjustprogress {} {
2743 global progresscanv progressitem progresscoords
2744 global fprogitem fprogcoord lastprogupdate progupdatepending
2745 global rprogitem rprogcoord use_ttk
2747 if {$use_ttk} {
2748 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2749 return
2752 set w [expr {[winfo width $progresscanv] - 4}]
2753 set x0 [expr {$w * [lindex $progresscoords 0]}]
2754 set x1 [expr {$w * [lindex $progresscoords 1]}]
2755 set h [winfo height $progresscanv]
2756 $progresscanv coords $progressitem $x0 0 $x1 $h
2757 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2758 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2759 set now [clock clicks -milliseconds]
2760 if {$now >= $lastprogupdate + 100} {
2761 set progupdatepending 0
2762 update
2763 } elseif {!$progupdatepending} {
2764 set progupdatepending 1
2765 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2769 proc doprogupdate {} {
2770 global lastprogupdate progupdatepending
2772 if {$progupdatepending} {
2773 set progupdatepending 0
2774 set lastprogupdate [clock clicks -milliseconds]
2775 update
2779 proc savestuff {w} {
2780 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2781 global use_ttk
2782 global stuffsaved
2783 global config_file config_file_tmp
2784 global config_variables
2786 if {$stuffsaved} return
2787 if {![winfo viewable .]} return
2788 catch {
2789 if {[file exists $config_file_tmp]} {
2790 file delete -force $config_file_tmp
2792 set f [open $config_file_tmp w]
2793 if {$::tcl_platform(platform) eq {windows}} {
2794 file attributes $config_file_tmp -hidden true
2796 foreach var_name $config_variables {
2797 upvar #0 $var_name var
2798 puts $f [list set $var_name $var]
2801 puts $f "set geometry(main) [wm geometry .]"
2802 puts $f "set geometry(state) [wm state .]"
2803 puts $f "set geometry(topwidth) [winfo width .tf]"
2804 puts $f "set geometry(topheight) [winfo height .tf]"
2805 if {$use_ttk} {
2806 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2807 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2808 } else {
2809 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2810 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2812 puts $f "set geometry(botwidth) [winfo width .bleft]"
2813 puts $f "set geometry(botheight) [winfo height .bleft]"
2815 puts -nonewline $f "set permviews {"
2816 for {set v 0} {$v < $nextviewnum} {incr v} {
2817 if {$viewperm($v)} {
2818 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2821 puts $f "}"
2822 close $f
2823 file rename -force $config_file_tmp $config_file
2825 set stuffsaved 1
2828 proc resizeclistpanes {win w} {
2829 global oldwidth use_ttk
2830 if {[info exists oldwidth($win)]} {
2831 if {$use_ttk} {
2832 set s0 [$win sashpos 0]
2833 set s1 [$win sashpos 1]
2834 } else {
2835 set s0 [$win sash coord 0]
2836 set s1 [$win sash coord 1]
2838 if {$w < 60} {
2839 set sash0 [expr {int($w/2 - 2)}]
2840 set sash1 [expr {int($w*5/6 - 2)}]
2841 } else {
2842 set factor [expr {1.0 * $w / $oldwidth($win)}]
2843 set sash0 [expr {int($factor * [lindex $s0 0])}]
2844 set sash1 [expr {int($factor * [lindex $s1 0])}]
2845 if {$sash0 < 30} {
2846 set sash0 30
2848 if {$sash1 < $sash0 + 20} {
2849 set sash1 [expr {$sash0 + 20}]
2851 if {$sash1 > $w - 10} {
2852 set sash1 [expr {$w - 10}]
2853 if {$sash0 > $sash1 - 20} {
2854 set sash0 [expr {$sash1 - 20}]
2858 if {$use_ttk} {
2859 $win sashpos 0 $sash0
2860 $win sashpos 1 $sash1
2861 } else {
2862 $win sash place 0 $sash0 [lindex $s0 1]
2863 $win sash place 1 $sash1 [lindex $s1 1]
2866 set oldwidth($win) $w
2869 proc resizecdetpanes {win w} {
2870 global oldwidth use_ttk
2871 if {[info exists oldwidth($win)]} {
2872 if {$use_ttk} {
2873 set s0 [$win sashpos 0]
2874 } else {
2875 set s0 [$win sash coord 0]
2877 if {$w < 60} {
2878 set sash0 [expr {int($w*3/4 - 2)}]
2879 } else {
2880 set factor [expr {1.0 * $w / $oldwidth($win)}]
2881 set sash0 [expr {int($factor * [lindex $s0 0])}]
2882 if {$sash0 < 45} {
2883 set sash0 45
2885 if {$sash0 > $w - 15} {
2886 set sash0 [expr {$w - 15}]
2889 if {$use_ttk} {
2890 $win sashpos 0 $sash0
2891 } else {
2892 $win sash place 0 $sash0 [lindex $s0 1]
2895 set oldwidth($win) $w
2898 proc allcanvs args {
2899 global canv canv2 canv3
2900 eval $canv $args
2901 eval $canv2 $args
2902 eval $canv3 $args
2905 proc bindall {event action} {
2906 global canv canv2 canv3
2907 bind $canv $event $action
2908 bind $canv2 $event $action
2909 bind $canv3 $event $action
2912 proc about {} {
2913 global uifont NS
2914 set w .about
2915 if {[winfo exists $w]} {
2916 raise $w
2917 return
2919 ttk_toplevel $w
2920 wm title $w [mc "About gitk"]
2921 make_transient $w .
2922 message $w.m -text [mc "
2923 Gitk - a commit viewer for git
2925 Copyright \u00a9 2005-2014 Paul Mackerras
2927 Use and redistribute under the terms of the GNU General Public License"] \
2928 -justify center -aspect 400 -border 2 -bg white -relief groove
2929 pack $w.m -side top -fill x -padx 2 -pady 2
2930 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2931 pack $w.ok -side bottom
2932 bind $w <Visibility> "focus $w.ok"
2933 bind $w <Key-Escape> "destroy $w"
2934 bind $w <Key-Return> "destroy $w"
2935 tk::PlaceWindow $w widget .
2938 proc keys {} {
2939 global NS
2940 set w .keys
2941 if {[winfo exists $w]} {
2942 raise $w
2943 return
2945 if {[tk windowingsystem] eq {aqua}} {
2946 set M1T Cmd
2947 } else {
2948 set M1T Ctrl
2950 ttk_toplevel $w
2951 wm title $w [mc "Gitk key bindings"]
2952 make_transient $w .
2953 message $w.m -text "
2954 [mc "Gitk key bindings:"]
2956 [mc "<%s-Q> Quit" $M1T]
2957 [mc "<%s-W> Close window" $M1T]
2958 [mc "<Home> Move to first commit"]
2959 [mc "<End> Move to last commit"]
2960 [mc "<Up>, p, k Move up one commit"]
2961 [mc "<Down>, n, j Move down one commit"]
2962 [mc "<Left>, z, h Go back in history list"]
2963 [mc "<Right>, x, l Go forward in history list"]
2964 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
2965 [mc "<PageUp> Move up one page in commit list"]
2966 [mc "<PageDown> Move down one page in commit list"]
2967 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2968 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2969 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2970 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2971 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2972 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2973 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2974 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2975 [mc "<Delete>, b Scroll diff view up one page"]
2976 [mc "<Backspace> Scroll diff view up one page"]
2977 [mc "<Space> Scroll diff view down one page"]
2978 [mc "u Scroll diff view up 18 lines"]
2979 [mc "d Scroll diff view down 18 lines"]
2980 [mc "<%s-F> Find" $M1T]
2981 [mc "<%s-G> Move to next find hit" $M1T]
2982 [mc "<Return> Move to next find hit"]
2983 [mc "/ Focus the search box"]
2984 [mc "? Move to previous find hit"]
2985 [mc "f Scroll diff view to next file"]
2986 [mc "<%s-S> Search for next hit in diff view" $M1T]
2987 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2988 [mc "<%s-KP+> Increase font size" $M1T]
2989 [mc "<%s-plus> Increase font size" $M1T]
2990 [mc "<%s-KP-> Decrease font size" $M1T]
2991 [mc "<%s-minus> Decrease font size" $M1T]
2992 [mc "<F5> Update"]
2994 -justify left -bg white -border 2 -relief groove
2995 pack $w.m -side top -fill both -padx 2 -pady 2
2996 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2997 bind $w <Key-Escape> [list destroy $w]
2998 pack $w.ok -side bottom
2999 bind $w <Visibility> "focus $w.ok"
3000 bind $w <Key-Escape> "destroy $w"
3001 bind $w <Key-Return> "destroy $w"
3004 # Procedures for manipulating the file list window at the
3005 # bottom right of the overall window.
3007 proc treeview {w l openlevs} {
3008 global treecontents treediropen treeheight treeparent treeindex
3010 set ix 0
3011 set treeindex() 0
3012 set lev 0
3013 set prefix {}
3014 set prefixend -1
3015 set prefendstack {}
3016 set htstack {}
3017 set ht 0
3018 set treecontents() {}
3019 $w conf -state normal
3020 foreach f $l {
3021 while {[string range $f 0 $prefixend] ne $prefix} {
3022 if {$lev <= $openlevs} {
3023 $w mark set e:$treeindex($prefix) "end -1c"
3024 $w mark gravity e:$treeindex($prefix) left
3026 set treeheight($prefix) $ht
3027 incr ht [lindex $htstack end]
3028 set htstack [lreplace $htstack end end]
3029 set prefixend [lindex $prefendstack end]
3030 set prefendstack [lreplace $prefendstack end end]
3031 set prefix [string range $prefix 0 $prefixend]
3032 incr lev -1
3034 set tail [string range $f [expr {$prefixend+1}] end]
3035 while {[set slash [string first "/" $tail]] >= 0} {
3036 lappend htstack $ht
3037 set ht 0
3038 lappend prefendstack $prefixend
3039 incr prefixend [expr {$slash + 1}]
3040 set d [string range $tail 0 $slash]
3041 lappend treecontents($prefix) $d
3042 set oldprefix $prefix
3043 append prefix $d
3044 set treecontents($prefix) {}
3045 set treeindex($prefix) [incr ix]
3046 set treeparent($prefix) $oldprefix
3047 set tail [string range $tail [expr {$slash+1}] end]
3048 if {$lev <= $openlevs} {
3049 set ht 1
3050 set treediropen($prefix) [expr {$lev < $openlevs}]
3051 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3052 $w mark set d:$ix "end -1c"
3053 $w mark gravity d:$ix left
3054 set str "\n"
3055 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3056 $w insert end $str
3057 $w image create end -align center -image $bm -padx 1 \
3058 -name a:$ix
3059 $w insert end $d [highlight_tag $prefix]
3060 $w mark set s:$ix "end -1c"
3061 $w mark gravity s:$ix left
3063 incr lev
3065 if {$tail ne {}} {
3066 if {$lev <= $openlevs} {
3067 incr ht
3068 set str "\n"
3069 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3070 $w insert end $str
3071 $w insert end $tail [highlight_tag $f]
3073 lappend treecontents($prefix) $tail
3076 while {$htstack ne {}} {
3077 set treeheight($prefix) $ht
3078 incr ht [lindex $htstack end]
3079 set htstack [lreplace $htstack end end]
3080 set prefixend [lindex $prefendstack end]
3081 set prefendstack [lreplace $prefendstack end end]
3082 set prefix [string range $prefix 0 $prefixend]
3084 $w conf -state disabled
3087 proc linetoelt {l} {
3088 global treeheight treecontents
3090 set y 2
3091 set prefix {}
3092 while {1} {
3093 foreach e $treecontents($prefix) {
3094 if {$y == $l} {
3095 return "$prefix$e"
3097 set n 1
3098 if {[string index $e end] eq "/"} {
3099 set n $treeheight($prefix$e)
3100 if {$y + $n > $l} {
3101 append prefix $e
3102 incr y
3103 break
3106 incr y $n
3111 proc highlight_tree {y prefix} {
3112 global treeheight treecontents cflist
3114 foreach e $treecontents($prefix) {
3115 set path $prefix$e
3116 if {[highlight_tag $path] ne {}} {
3117 $cflist tag add bold $y.0 "$y.0 lineend"
3119 incr y
3120 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3121 set y [highlight_tree $y $path]
3124 return $y
3127 proc treeclosedir {w dir} {
3128 global treediropen treeheight treeparent treeindex
3130 set ix $treeindex($dir)
3131 $w conf -state normal
3132 $w delete s:$ix e:$ix
3133 set treediropen($dir) 0
3134 $w image configure a:$ix -image tri-rt
3135 $w conf -state disabled
3136 set n [expr {1 - $treeheight($dir)}]
3137 while {$dir ne {}} {
3138 incr treeheight($dir) $n
3139 set dir $treeparent($dir)
3143 proc treeopendir {w dir} {
3144 global treediropen treeheight treeparent treecontents treeindex
3146 set ix $treeindex($dir)
3147 $w conf -state normal
3148 $w image configure a:$ix -image tri-dn
3149 $w mark set e:$ix s:$ix
3150 $w mark gravity e:$ix right
3151 set lev 0
3152 set str "\n"
3153 set n [llength $treecontents($dir)]
3154 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3155 incr lev
3156 append str "\t"
3157 incr treeheight($x) $n
3159 foreach e $treecontents($dir) {
3160 set de $dir$e
3161 if {[string index $e end] eq "/"} {
3162 set iy $treeindex($de)
3163 $w mark set d:$iy e:$ix
3164 $w mark gravity d:$iy left
3165 $w insert e:$ix $str
3166 set treediropen($de) 0
3167 $w image create e:$ix -align center -image tri-rt -padx 1 \
3168 -name a:$iy
3169 $w insert e:$ix $e [highlight_tag $de]
3170 $w mark set s:$iy e:$ix
3171 $w mark gravity s:$iy left
3172 set treeheight($de) 1
3173 } else {
3174 $w insert e:$ix $str
3175 $w insert e:$ix $e [highlight_tag $de]
3178 $w mark gravity e:$ix right
3179 $w conf -state disabled
3180 set treediropen($dir) 1
3181 set top [lindex [split [$w index @0,0] .] 0]
3182 set ht [$w cget -height]
3183 set l [lindex [split [$w index s:$ix] .] 0]
3184 if {$l < $top} {
3185 $w yview $l.0
3186 } elseif {$l + $n + 1 > $top + $ht} {
3187 set top [expr {$l + $n + 2 - $ht}]
3188 if {$l < $top} {
3189 set top $l
3191 $w yview $top.0
3195 proc treeclick {w x y} {
3196 global treediropen cmitmode ctext cflist cflist_top
3198 if {$cmitmode ne "tree"} return
3199 if {![info exists cflist_top]} return
3200 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3201 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3202 $cflist tag add highlight $l.0 "$l.0 lineend"
3203 set cflist_top $l
3204 if {$l == 1} {
3205 $ctext yview 1.0
3206 return
3208 set e [linetoelt $l]
3209 if {[string index $e end] ne "/"} {
3210 showfile $e
3211 } elseif {$treediropen($e)} {
3212 treeclosedir $w $e
3213 } else {
3214 treeopendir $w $e
3218 proc setfilelist {id} {
3219 global treefilelist cflist jump_to_here
3221 treeview $cflist $treefilelist($id) 0
3222 if {$jump_to_here ne {}} {
3223 set f [lindex $jump_to_here 0]
3224 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3225 showfile $f
3230 image create bitmap tri-rt -background black -foreground blue -data {
3231 #define tri-rt_width 13
3232 #define tri-rt_height 13
3233 static unsigned char tri-rt_bits[] = {
3234 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3235 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3236 0x00, 0x00};
3237 } -maskdata {
3238 #define tri-rt-mask_width 13
3239 #define tri-rt-mask_height 13
3240 static unsigned char tri-rt-mask_bits[] = {
3241 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3242 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3243 0x08, 0x00};
3245 image create bitmap tri-dn -background black -foreground blue -data {
3246 #define tri-dn_width 13
3247 #define tri-dn_height 13
3248 static unsigned char tri-dn_bits[] = {
3249 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3250 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3251 0x00, 0x00};
3252 } -maskdata {
3253 #define tri-dn-mask_width 13
3254 #define tri-dn-mask_height 13
3255 static unsigned char tri-dn-mask_bits[] = {
3256 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3257 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3258 0x00, 0x00};
3261 image create bitmap reficon-T -background black -foreground yellow -data {
3262 #define tagicon_width 13
3263 #define tagicon_height 9
3264 static unsigned char tagicon_bits[] = {
3265 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3266 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3267 } -maskdata {
3268 #define tagicon-mask_width 13
3269 #define tagicon-mask_height 9
3270 static unsigned char tagicon-mask_bits[] = {
3271 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3272 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3274 set rectdata {
3275 #define headicon_width 13
3276 #define headicon_height 9
3277 static unsigned char headicon_bits[] = {
3278 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3279 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3281 set rectmask {
3282 #define headicon-mask_width 13
3283 #define headicon-mask_height 9
3284 static unsigned char headicon-mask_bits[] = {
3285 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3286 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3288 image create bitmap reficon-H -background black -foreground green \
3289 -data $rectdata -maskdata $rectmask
3290 image create bitmap reficon-o -background black -foreground "#ddddff" \
3291 -data $rectdata -maskdata $rectmask
3293 proc init_flist {first} {
3294 global cflist cflist_top difffilestart
3296 $cflist conf -state normal
3297 $cflist delete 0.0 end
3298 if {$first ne {}} {
3299 $cflist insert end $first
3300 set cflist_top 1
3301 $cflist tag add highlight 1.0 "1.0 lineend"
3302 } else {
3303 catch {unset cflist_top}
3305 $cflist conf -state disabled
3306 set difffilestart {}
3309 proc highlight_tag {f} {
3310 global highlight_paths
3312 foreach p $highlight_paths {
3313 if {[string match $p $f]} {
3314 return "bold"
3317 return {}
3320 proc highlight_filelist {} {
3321 global cmitmode cflist
3323 $cflist conf -state normal
3324 if {$cmitmode ne "tree"} {
3325 set end [lindex [split [$cflist index end] .] 0]
3326 for {set l 2} {$l < $end} {incr l} {
3327 set line [$cflist get $l.0 "$l.0 lineend"]
3328 if {[highlight_tag $line] ne {}} {
3329 $cflist tag add bold $l.0 "$l.0 lineend"
3332 } else {
3333 highlight_tree 2 {}
3335 $cflist conf -state disabled
3338 proc unhighlight_filelist {} {
3339 global cflist
3341 $cflist conf -state normal
3342 $cflist tag remove bold 1.0 end
3343 $cflist conf -state disabled
3346 proc add_flist {fl} {
3347 global cflist
3349 $cflist conf -state normal
3350 foreach f $fl {
3351 $cflist insert end "\n"
3352 $cflist insert end $f [highlight_tag $f]
3354 $cflist conf -state disabled
3357 proc sel_flist {w x y} {
3358 global ctext difffilestart cflist cflist_top cmitmode
3360 if {$cmitmode eq "tree"} return
3361 if {![info exists cflist_top]} return
3362 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3363 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3364 $cflist tag add highlight $l.0 "$l.0 lineend"
3365 set cflist_top $l
3366 if {$l == 1} {
3367 $ctext yview 1.0
3368 } else {
3369 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3371 suppress_highlighting_file_for_current_scrollpos
3374 proc pop_flist_menu {w X Y x y} {
3375 global ctext cflist cmitmode flist_menu flist_menu_file
3376 global treediffs diffids
3378 stopfinding
3379 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3380 if {$l <= 1} return
3381 if {$cmitmode eq "tree"} {
3382 set e [linetoelt $l]
3383 if {[string index $e end] eq "/"} return
3384 } else {
3385 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3387 set flist_menu_file $e
3388 set xdiffstate "normal"
3389 if {$cmitmode eq "tree"} {
3390 set xdiffstate "disabled"
3392 # Disable "External diff" item in tree mode
3393 $flist_menu entryconf 2 -state $xdiffstate
3394 tk_popup $flist_menu $X $Y
3397 proc find_ctext_fileinfo {line} {
3398 global ctext_file_names ctext_file_lines
3400 set ok [bsearch $ctext_file_lines $line]
3401 set tline [lindex $ctext_file_lines $ok]
3403 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3404 return {}
3405 } else {
3406 return [list [lindex $ctext_file_names $ok] $tline]
3410 proc pop_diff_menu {w X Y x y} {
3411 global ctext diff_menu flist_menu_file
3412 global diff_menu_txtpos diff_menu_line
3413 global diff_menu_filebase
3415 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3416 set diff_menu_line [lindex $diff_menu_txtpos 0]
3417 # don't pop up the menu on hunk-separator or file-separator lines
3418 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3419 return
3421 stopfinding
3422 set f [find_ctext_fileinfo $diff_menu_line]
3423 if {$f eq {}} return
3424 set flist_menu_file [lindex $f 0]
3425 set diff_menu_filebase [lindex $f 1]
3426 tk_popup $diff_menu $X $Y
3429 proc flist_hl {only} {
3430 global flist_menu_file findstring gdttype
3432 set x [shellquote $flist_menu_file]
3433 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3434 set findstring $x
3435 } else {
3436 append findstring " " $x
3438 set gdttype [mc "touching paths:"]
3441 proc gitknewtmpdir {} {
3442 global diffnum gitktmpdir gitdir env
3444 if {![info exists gitktmpdir]} {
3445 if {[info exists env(GITK_TMPDIR)]} {
3446 set tmpdir $env(GITK_TMPDIR)
3447 } elseif {[info exists env(TMPDIR)]} {
3448 set tmpdir $env(TMPDIR)
3449 } else {
3450 set tmpdir $gitdir
3452 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3453 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3454 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3456 if {[catch {file mkdir $gitktmpdir} err]} {
3457 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3458 unset gitktmpdir
3459 return {}
3461 set diffnum 0
3463 incr diffnum
3464 set diffdir [file join $gitktmpdir $diffnum]
3465 if {[catch {file mkdir $diffdir} err]} {
3466 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3467 return {}
3469 return $diffdir
3472 proc save_file_from_commit {filename output what} {
3473 global nullfile
3475 if {[catch {exec git show $filename -- > $output} err]} {
3476 if {[string match "fatal: bad revision *" $err]} {
3477 return $nullfile
3479 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3480 return {}
3482 return $output
3485 proc external_diff_get_one_file {diffid filename diffdir} {
3486 global nullid nullid2 nullfile
3487 global worktree
3489 if {$diffid == $nullid} {
3490 set difffile [file join $worktree $filename]
3491 if {[file exists $difffile]} {
3492 return $difffile
3494 return $nullfile
3496 if {$diffid == $nullid2} {
3497 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3498 return [save_file_from_commit :$filename $difffile index]
3500 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3501 return [save_file_from_commit $diffid:$filename $difffile \
3502 "revision $diffid"]
3505 proc external_diff {} {
3506 global nullid nullid2
3507 global flist_menu_file
3508 global diffids
3509 global extdifftool
3511 if {[llength $diffids] == 1} {
3512 # no reference commit given
3513 set diffidto [lindex $diffids 0]
3514 if {$diffidto eq $nullid} {
3515 # diffing working copy with index
3516 set diffidfrom $nullid2
3517 } elseif {$diffidto eq $nullid2} {
3518 # diffing index with HEAD
3519 set diffidfrom "HEAD"
3520 } else {
3521 # use first parent commit
3522 global parentlist selectedline
3523 set diffidfrom [lindex $parentlist $selectedline 0]
3525 } else {
3526 set diffidfrom [lindex $diffids 0]
3527 set diffidto [lindex $diffids 1]
3530 # make sure that several diffs wont collide
3531 set diffdir [gitknewtmpdir]
3532 if {$diffdir eq {}} return
3534 # gather files to diff
3535 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3536 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3538 if {$difffromfile ne {} && $difftofile ne {}} {
3539 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3540 if {[catch {set fl [open |$cmd r]} err]} {
3541 file delete -force $diffdir
3542 error_popup "$extdifftool: [mc "command failed:"] $err"
3543 } else {
3544 fconfigure $fl -blocking 0
3545 filerun $fl [list delete_at_eof $fl $diffdir]
3550 proc find_hunk_blamespec {base line} {
3551 global ctext
3553 # Find and parse the hunk header
3554 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3555 if {$s_lix eq {}} return
3557 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3558 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3559 s_line old_specs osz osz1 new_line nsz]} {
3560 return
3563 # base lines for the parents
3564 set base_lines [list $new_line]
3565 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3566 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3567 old_spec old_line osz]} {
3568 return
3570 lappend base_lines $old_line
3573 # Now scan the lines to determine offset within the hunk
3574 set max_parent [expr {[llength $base_lines]-2}]
3575 set dline 0
3576 set s_lno [lindex [split $s_lix "."] 0]
3578 # Determine if the line is removed
3579 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3580 if {[string match {[-+ ]*} $chunk]} {
3581 set removed_idx [string first "-" $chunk]
3582 # Choose a parent index
3583 if {$removed_idx >= 0} {
3584 set parent $removed_idx
3585 } else {
3586 set unchanged_idx [string first " " $chunk]
3587 if {$unchanged_idx >= 0} {
3588 set parent $unchanged_idx
3589 } else {
3590 # blame the current commit
3591 set parent -1
3594 # then count other lines that belong to it
3595 for {set i $line} {[incr i -1] > $s_lno} {} {
3596 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3597 # Determine if the line is removed
3598 set removed_idx [string first "-" $chunk]
3599 if {$parent >= 0} {
3600 set code [string index $chunk $parent]
3601 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3602 incr dline
3604 } else {
3605 if {$removed_idx < 0} {
3606 incr dline
3610 incr parent
3611 } else {
3612 set parent 0
3615 incr dline [lindex $base_lines $parent]
3616 return [list $parent $dline]
3619 proc external_blame_diff {} {
3620 global currentid cmitmode
3621 global diff_menu_txtpos diff_menu_line
3622 global diff_menu_filebase flist_menu_file
3624 if {$cmitmode eq "tree"} {
3625 set parent_idx 0
3626 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3627 } else {
3628 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3629 if {$hinfo ne {}} {
3630 set parent_idx [lindex $hinfo 0]
3631 set line [lindex $hinfo 1]
3632 } else {
3633 set parent_idx 0
3634 set line 0
3638 external_blame $parent_idx $line
3641 # Find the SHA1 ID of the blob for file $fname in the index
3642 # at stage 0 or 2
3643 proc index_sha1 {fname} {
3644 set f [open [list | git ls-files -s $fname] r]
3645 while {[gets $f line] >= 0} {
3646 set info [lindex [split $line "\t"] 0]
3647 set stage [lindex $info 2]
3648 if {$stage eq "0" || $stage eq "2"} {
3649 close $f
3650 return [lindex $info 1]
3653 close $f
3654 return {}
3657 # Turn an absolute path into one relative to the current directory
3658 proc make_relative {f} {
3659 if {[file pathtype $f] eq "relative"} {
3660 return $f
3662 set elts [file split $f]
3663 set here [file split [pwd]]
3664 set ei 0
3665 set hi 0
3666 set res {}
3667 foreach d $here {
3668 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3669 lappend res ".."
3670 } else {
3671 incr ei
3673 incr hi
3675 set elts [concat $res [lrange $elts $ei end]]
3676 return [eval file join $elts]
3679 proc external_blame {parent_idx {line {}}} {
3680 global flist_menu_file cdup
3681 global nullid nullid2
3682 global parentlist selectedline currentid
3684 if {$parent_idx > 0} {
3685 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3686 } else {
3687 set base_commit $currentid
3690 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3691 error_popup [mc "No such commit"]
3692 return
3695 set cmdline [list git gui blame]
3696 if {$line ne {} && $line > 1} {
3697 lappend cmdline "--line=$line"
3699 set f [file join $cdup $flist_menu_file]
3700 # Unfortunately it seems git gui blame doesn't like
3701 # being given an absolute path...
3702 set f [make_relative $f]
3703 lappend cmdline $base_commit $f
3704 if {[catch {eval exec $cmdline &} err]} {
3705 error_popup "[mc "git gui blame: command failed:"] $err"
3709 proc show_line_source {} {
3710 global cmitmode currentid parents curview blamestuff blameinst
3711 global diff_menu_line diff_menu_filebase flist_menu_file
3712 global nullid nullid2 gitdir cdup
3714 set from_index {}
3715 if {$cmitmode eq "tree"} {
3716 set id $currentid
3717 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3718 } else {
3719 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3720 if {$h eq {}} return
3721 set pi [lindex $h 0]
3722 if {$pi == 0} {
3723 mark_ctext_line $diff_menu_line
3724 return
3726 incr pi -1
3727 if {$currentid eq $nullid} {
3728 if {$pi > 0} {
3729 # must be a merge in progress...
3730 if {[catch {
3731 # get the last line from .git/MERGE_HEAD
3732 set f [open [file join $gitdir MERGE_HEAD] r]
3733 set id [lindex [split [read $f] "\n"] end-1]
3734 close $f
3735 } err]} {
3736 error_popup [mc "Couldn't read merge head: %s" $err]
3737 return
3739 } elseif {$parents($curview,$currentid) eq $nullid2} {
3740 # need to do the blame from the index
3741 if {[catch {
3742 set from_index [index_sha1 $flist_menu_file]
3743 } err]} {
3744 error_popup [mc "Error reading index: %s" $err]
3745 return
3747 } else {
3748 set id $parents($curview,$currentid)
3750 } else {
3751 set id [lindex $parents($curview,$currentid) $pi]
3753 set line [lindex $h 1]
3755 set blameargs {}
3756 if {$from_index ne {}} {
3757 lappend blameargs | git cat-file blob $from_index
3759 lappend blameargs | git blame -p -L$line,+1
3760 if {$from_index ne {}} {
3761 lappend blameargs --contents -
3762 } else {
3763 lappend blameargs $id
3765 lappend blameargs -- [file join $cdup $flist_menu_file]
3766 if {[catch {
3767 set f [open $blameargs r]
3768 } err]} {
3769 error_popup [mc "Couldn't start git blame: %s" $err]
3770 return
3772 nowbusy blaming [mc "Searching"]
3773 fconfigure $f -blocking 0
3774 set i [reg_instance $f]
3775 set blamestuff($i) {}
3776 set blameinst $i
3777 filerun $f [list read_line_source $f $i]
3780 proc stopblaming {} {
3781 global blameinst
3783 if {[info exists blameinst]} {
3784 stop_instance $blameinst
3785 unset blameinst
3786 notbusy blaming
3790 proc read_line_source {fd inst} {
3791 global blamestuff curview commfd blameinst nullid nullid2
3793 while {[gets $fd line] >= 0} {
3794 lappend blamestuff($inst) $line
3796 if {![eof $fd]} {
3797 return 1
3799 unset commfd($inst)
3800 unset blameinst
3801 notbusy blaming
3802 fconfigure $fd -blocking 1
3803 if {[catch {close $fd} err]} {
3804 error_popup [mc "Error running git blame: %s" $err]
3805 return 0
3808 set fname {}
3809 set line [split [lindex $blamestuff($inst) 0] " "]
3810 set id [lindex $line 0]
3811 set lnum [lindex $line 1]
3812 if {[string length $id] == 40 && [string is xdigit $id] &&
3813 [string is digit -strict $lnum]} {
3814 # look for "filename" line
3815 foreach l $blamestuff($inst) {
3816 if {[string match "filename *" $l]} {
3817 set fname [string range $l 9 end]
3818 break
3822 if {$fname ne {}} {
3823 # all looks good, select it
3824 if {$id eq $nullid} {
3825 # blame uses all-zeroes to mean not committed,
3826 # which would mean a change in the index
3827 set id $nullid2
3829 if {[commitinview $id $curview]} {
3830 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3831 } else {
3832 error_popup [mc "That line comes from commit %s, \
3833 which is not in this view" [shortids $id]]
3835 } else {
3836 puts "oops couldn't parse git blame output"
3838 return 0
3841 # delete $dir when we see eof on $f (presumably because the child has exited)
3842 proc delete_at_eof {f dir} {
3843 while {[gets $f line] >= 0} {}
3844 if {[eof $f]} {
3845 if {[catch {close $f} err]} {
3846 error_popup "[mc "External diff viewer failed:"] $err"
3848 file delete -force $dir
3849 return 0
3851 return 1
3854 # Functions for adding and removing shell-type quoting
3856 proc shellquote {str} {
3857 if {![string match "*\['\"\\ \t]*" $str]} {
3858 return $str
3860 if {![string match "*\['\"\\]*" $str]} {
3861 return "\"$str\""
3863 if {![string match "*'*" $str]} {
3864 return "'$str'"
3866 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3869 proc shellarglist {l} {
3870 set str {}
3871 foreach a $l {
3872 if {$str ne {}} {
3873 append str " "
3875 append str [shellquote $a]
3877 return $str
3880 proc shelldequote {str} {
3881 set ret {}
3882 set used -1
3883 while {1} {
3884 incr used
3885 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3886 append ret [string range $str $used end]
3887 set used [string length $str]
3888 break
3890 set first [lindex $first 0]
3891 set ch [string index $str $first]
3892 if {$first > $used} {
3893 append ret [string range $str $used [expr {$first - 1}]]
3894 set used $first
3896 if {$ch eq " " || $ch eq "\t"} break
3897 incr used
3898 if {$ch eq "'"} {
3899 set first [string first "'" $str $used]
3900 if {$first < 0} {
3901 error "unmatched single-quote"
3903 append ret [string range $str $used [expr {$first - 1}]]
3904 set used $first
3905 continue
3907 if {$ch eq "\\"} {
3908 if {$used >= [string length $str]} {
3909 error "trailing backslash"
3911 append ret [string index $str $used]
3912 continue
3914 # here ch == "\""
3915 while {1} {
3916 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3917 error "unmatched double-quote"
3919 set first [lindex $first 0]
3920 set ch [string index $str $first]
3921 if {$first > $used} {
3922 append ret [string range $str $used [expr {$first - 1}]]
3923 set used $first
3925 if {$ch eq "\""} break
3926 incr used
3927 append ret [string index $str $used]
3928 incr used
3931 return [list $used $ret]
3934 proc shellsplit {str} {
3935 set l {}
3936 while {1} {
3937 set str [string trimleft $str]
3938 if {$str eq {}} break
3939 set dq [shelldequote $str]
3940 set n [lindex $dq 0]
3941 set word [lindex $dq 1]
3942 set str [string range $str $n end]
3943 lappend l $word
3945 return $l
3948 # Code to implement multiple views
3950 proc newview {ishighlight} {
3951 global nextviewnum newviewname newishighlight
3952 global revtreeargs viewargscmd newviewopts curview
3954 set newishighlight $ishighlight
3955 set top .gitkview
3956 if {[winfo exists $top]} {
3957 raise $top
3958 return
3960 decode_view_opts $nextviewnum $revtreeargs
3961 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3962 set newviewopts($nextviewnum,perm) 0
3963 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3964 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3967 set known_view_options {
3968 {perm b . {} {mc "Remember this view"}}
3969 {reflabel l + {} {mc "References (space separated list):"}}
3970 {refs t15 .. {} {mc "Branches & tags:"}}
3971 {allrefs b *. "--all" {mc "All refs"}}
3972 {branches b . "--branches" {mc "All (local) branches"}}
3973 {tags b . "--tags" {mc "All tags"}}
3974 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3975 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3976 {author t15 .. "--author=*" {mc "Author:"}}
3977 {committer t15 . "--committer=*" {mc "Committer:"}}
3978 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3979 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3980 {changes_l l + {} {mc "Changes to Files:"}}
3981 {pickaxe_s r0 . {} {mc "Fixed String"}}
3982 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3983 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3984 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3985 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3986 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3987 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3988 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3989 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3990 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3991 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3992 {lright b . "--left-right" {mc "Mark branch sides"}}
3993 {first b . "--first-parent" {mc "Limit to first parent"}}
3994 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3995 {args t50 *. {} {mc "Additional arguments to git log:"}}
3996 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3997 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4000 # Convert $newviewopts($n, ...) into args for git log.
4001 proc encode_view_opts {n} {
4002 global known_view_options newviewopts
4004 set rargs [list]
4005 foreach opt $known_view_options {
4006 set patterns [lindex $opt 3]
4007 if {$patterns eq {}} continue
4008 set pattern [lindex $patterns 0]
4010 if {[lindex $opt 1] eq "b"} {
4011 set val $newviewopts($n,[lindex $opt 0])
4012 if {$val} {
4013 lappend rargs $pattern
4015 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4016 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4017 set val $newviewopts($n,$button_id)
4018 if {$val eq $value} {
4019 lappend rargs $pattern
4021 } else {
4022 set val $newviewopts($n,[lindex $opt 0])
4023 set val [string trim $val]
4024 if {$val ne {}} {
4025 set pfix [string range $pattern 0 end-1]
4026 lappend rargs $pfix$val
4030 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4031 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4034 # Fill $newviewopts($n, ...) based on args for git log.
4035 proc decode_view_opts {n view_args} {
4036 global known_view_options newviewopts
4038 foreach opt $known_view_options {
4039 set id [lindex $opt 0]
4040 if {[lindex $opt 1] eq "b"} {
4041 # Checkboxes
4042 set val 0
4043 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4044 # Radiobuttons
4045 regexp {^(.*_)} $id uselessvar id
4046 set val 0
4047 } else {
4048 # Text fields
4049 set val {}
4051 set newviewopts($n,$id) $val
4053 set oargs [list]
4054 set refargs [list]
4055 foreach arg $view_args {
4056 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4057 && ![info exists found(limit)]} {
4058 set newviewopts($n,limit) $cnt
4059 set found(limit) 1
4060 continue
4062 catch { unset val }
4063 foreach opt $known_view_options {
4064 set id [lindex $opt 0]
4065 if {[info exists found($id)]} continue
4066 foreach pattern [lindex $opt 3] {
4067 if {![string match $pattern $arg]} continue
4068 if {[lindex $opt 1] eq "b"} {
4069 # Check buttons
4070 set val 1
4071 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4072 # Radio buttons
4073 regexp {^(.*_)} $id uselessvar id
4074 set val $num
4075 } else {
4076 # Text input fields
4077 set size [string length $pattern]
4078 set val [string range $arg [expr {$size-1}] end]
4080 set newviewopts($n,$id) $val
4081 set found($id) 1
4082 break
4084 if {[info exists val]} break
4086 if {[info exists val]} continue
4087 if {[regexp {^-} $arg]} {
4088 lappend oargs $arg
4089 } else {
4090 lappend refargs $arg
4093 set newviewopts($n,refs) [shellarglist $refargs]
4094 set newviewopts($n,args) [shellarglist $oargs]
4097 proc edit_or_newview {} {
4098 global curview
4100 if {$curview > 0} {
4101 editview
4102 } else {
4103 newview 0
4107 proc editview {} {
4108 global curview
4109 global viewname viewperm newviewname newviewopts
4110 global viewargs viewargscmd
4112 set top .gitkvedit-$curview
4113 if {[winfo exists $top]} {
4114 raise $top
4115 return
4117 decode_view_opts $curview $viewargs($curview)
4118 set newviewname($curview) $viewname($curview)
4119 set newviewopts($curview,perm) $viewperm($curview)
4120 set newviewopts($curview,cmd) $viewargscmd($curview)
4121 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4124 proc vieweditor {top n title} {
4125 global newviewname newviewopts viewfiles bgcolor
4126 global known_view_options NS
4128 ttk_toplevel $top
4129 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4130 make_transient $top .
4132 # View name
4133 ${NS}::frame $top.nfr
4134 ${NS}::label $top.nl -text [mc "View Name"]
4135 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4136 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4137 pack $top.nl -in $top.nfr -side left -padx {0 5}
4138 pack $top.name -in $top.nfr -side left -padx {0 25}
4140 # View options
4141 set cframe $top.nfr
4142 set cexpand 0
4143 set cnt 0
4144 foreach opt $known_view_options {
4145 set id [lindex $opt 0]
4146 set type [lindex $opt 1]
4147 set flags [lindex $opt 2]
4148 set title [eval [lindex $opt 4]]
4149 set lxpad 0
4151 if {$flags eq "+" || $flags eq "*"} {
4152 set cframe $top.fr$cnt
4153 incr cnt
4154 ${NS}::frame $cframe
4155 pack $cframe -in $top -fill x -pady 3 -padx 3
4156 set cexpand [expr {$flags eq "*"}]
4157 } elseif {$flags eq ".." || $flags eq "*."} {
4158 set cframe $top.fr$cnt
4159 incr cnt
4160 ${NS}::frame $cframe
4161 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4162 set cexpand [expr {$flags eq "*."}]
4163 } else {
4164 set lxpad 5
4167 if {$type eq "l"} {
4168 ${NS}::label $cframe.l_$id -text $title
4169 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4170 } elseif {$type eq "b"} {
4171 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4172 pack $cframe.c_$id -in $cframe -side left \
4173 -padx [list $lxpad 0] -expand $cexpand -anchor w
4174 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4175 regexp {^(.*_)} $id uselessvar button_id
4176 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4177 pack $cframe.c_$id -in $cframe -side left \
4178 -padx [list $lxpad 0] -expand $cexpand -anchor w
4179 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4180 ${NS}::label $cframe.l_$id -text $title
4181 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4182 -textvariable newviewopts($n,$id)
4183 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4184 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4185 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4186 ${NS}::label $cframe.l_$id -text $title
4187 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4188 -textvariable newviewopts($n,$id)
4189 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4190 pack $cframe.e_$id -in $cframe -side top -fill x
4191 } elseif {$type eq "path"} {
4192 ${NS}::label $top.l -text $title
4193 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4194 text $top.t -width 40 -height 5 -background $bgcolor
4195 if {[info exists viewfiles($n)]} {
4196 foreach f $viewfiles($n) {
4197 $top.t insert end $f
4198 $top.t insert end "\n"
4200 $top.t delete {end - 1c} end
4201 $top.t mark set insert 0.0
4203 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4207 ${NS}::frame $top.buts
4208 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4209 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4210 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4211 bind $top <Control-Return> [list newviewok $top $n]
4212 bind $top <F5> [list newviewok $top $n 1]
4213 bind $top <Escape> [list destroy $top]
4214 grid $top.buts.ok $top.buts.apply $top.buts.can
4215 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4216 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4217 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4218 pack $top.buts -in $top -side top -fill x
4219 focus $top.t
4222 proc doviewmenu {m first cmd op argv} {
4223 set nmenu [$m index end]
4224 for {set i $first} {$i <= $nmenu} {incr i} {
4225 if {[$m entrycget $i -command] eq $cmd} {
4226 eval $m $op $i $argv
4227 break
4232 proc allviewmenus {n op args} {
4233 # global viewhlmenu
4235 doviewmenu .bar.view 5 [list showview $n] $op $args
4236 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4239 proc newviewok {top n {apply 0}} {
4240 global nextviewnum newviewperm newviewname newishighlight
4241 global viewname viewfiles viewperm selectedview curview
4242 global viewargs viewargscmd newviewopts viewhlmenu
4244 if {[catch {
4245 set newargs [encode_view_opts $n]
4246 } err]} {
4247 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4248 return
4250 set files {}
4251 foreach f [split [$top.t get 0.0 end] "\n"] {
4252 set ft [string trim $f]
4253 if {$ft ne {}} {
4254 lappend files $ft
4257 if {![info exists viewfiles($n)]} {
4258 # creating a new view
4259 incr nextviewnum
4260 set viewname($n) $newviewname($n)
4261 set viewperm($n) $newviewopts($n,perm)
4262 set viewfiles($n) $files
4263 set viewargs($n) $newargs
4264 set viewargscmd($n) $newviewopts($n,cmd)
4265 addviewmenu $n
4266 if {!$newishighlight} {
4267 run showview $n
4268 } else {
4269 run addvhighlight $n
4271 } else {
4272 # editing an existing view
4273 set viewperm($n) $newviewopts($n,perm)
4274 if {$newviewname($n) ne $viewname($n)} {
4275 set viewname($n) $newviewname($n)
4276 doviewmenu .bar.view 5 [list showview $n] \
4277 entryconf [list -label $viewname($n)]
4278 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4279 # entryconf [list -label $viewname($n) -value $viewname($n)]
4281 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4282 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4283 set viewfiles($n) $files
4284 set viewargs($n) $newargs
4285 set viewargscmd($n) $newviewopts($n,cmd)
4286 if {$curview == $n} {
4287 run reloadcommits
4291 if {$apply} return
4292 catch {destroy $top}
4295 proc delview {} {
4296 global curview viewperm hlview selectedhlview
4298 if {$curview == 0} return
4299 if {[info exists hlview] && $hlview == $curview} {
4300 set selectedhlview [mc "None"]
4301 unset hlview
4303 allviewmenus $curview delete
4304 set viewperm($curview) 0
4305 showview 0
4308 proc addviewmenu {n} {
4309 global viewname viewhlmenu
4311 .bar.view add radiobutton -label $viewname($n) \
4312 -command [list showview $n] -variable selectedview -value $n
4313 #$viewhlmenu add radiobutton -label $viewname($n) \
4314 # -command [list addvhighlight $n] -variable selectedhlview
4317 proc showview {n} {
4318 global curview cached_commitrow ordertok
4319 global displayorder parentlist rowidlist rowisopt rowfinal
4320 global colormap rowtextx nextcolor canvxmax
4321 global numcommits viewcomplete
4322 global selectedline currentid canv canvy0
4323 global treediffs
4324 global pending_select mainheadid
4325 global commitidx
4326 global selectedview
4327 global hlview selectedhlview commitinterest
4329 if {$n == $curview} return
4330 set selid {}
4331 set ymax [lindex [$canv cget -scrollregion] 3]
4332 set span [$canv yview]
4333 set ytop [expr {[lindex $span 0] * $ymax}]
4334 set ybot [expr {[lindex $span 1] * $ymax}]
4335 set yscreen [expr {($ybot - $ytop) / 2}]
4336 if {$selectedline ne {}} {
4337 set selid $currentid
4338 set y [yc $selectedline]
4339 if {$ytop < $y && $y < $ybot} {
4340 set yscreen [expr {$y - $ytop}]
4342 } elseif {[info exists pending_select]} {
4343 set selid $pending_select
4344 unset pending_select
4346 unselectline
4347 normalline
4348 catch {unset treediffs}
4349 clear_display
4350 if {[info exists hlview] && $hlview == $n} {
4351 unset hlview
4352 set selectedhlview [mc "None"]
4354 catch {unset commitinterest}
4355 catch {unset cached_commitrow}
4356 catch {unset ordertok}
4358 set curview $n
4359 set selectedview $n
4360 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4361 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4363 run refill_reflist
4364 if {![info exists viewcomplete($n)]} {
4365 getcommits $selid
4366 return
4369 set displayorder {}
4370 set parentlist {}
4371 set rowidlist {}
4372 set rowisopt {}
4373 set rowfinal {}
4374 set numcommits $commitidx($n)
4376 catch {unset colormap}
4377 catch {unset rowtextx}
4378 set nextcolor 0
4379 set canvxmax [$canv cget -width]
4380 set curview $n
4381 set row 0
4382 setcanvscroll
4383 set yf 0
4384 set row {}
4385 if {$selid ne {} && [commitinview $selid $n]} {
4386 set row [rowofcommit $selid]
4387 # try to get the selected row in the same position on the screen
4388 set ymax [lindex [$canv cget -scrollregion] 3]
4389 set ytop [expr {[yc $row] - $yscreen}]
4390 if {$ytop < 0} {
4391 set ytop 0
4393 set yf [expr {$ytop * 1.0 / $ymax}]
4395 allcanvs yview moveto $yf
4396 drawvisible
4397 if {$row ne {}} {
4398 selectline $row 0
4399 } elseif {!$viewcomplete($n)} {
4400 reset_pending_select $selid
4401 } else {
4402 reset_pending_select {}
4404 if {[commitinview $pending_select $curview]} {
4405 selectline [rowofcommit $pending_select] 1
4406 } else {
4407 set row [first_real_row]
4408 if {$row < $numcommits} {
4409 selectline $row 0
4413 if {!$viewcomplete($n)} {
4414 if {$numcommits == 0} {
4415 show_status [mc "Reading commits..."]
4417 } elseif {$numcommits == 0} {
4418 show_status [mc "No commits selected"]
4422 # Stuff relating to the highlighting facility
4424 proc ishighlighted {id} {
4425 global vhighlights fhighlights nhighlights rhighlights
4427 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4428 return $nhighlights($id)
4430 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4431 return $vhighlights($id)
4433 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4434 return $fhighlights($id)
4436 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4437 return $rhighlights($id)
4439 return 0
4442 proc bolden {id font} {
4443 global canv linehtag currentid boldids need_redisplay markedid
4445 # need_redisplay = 1 means the display is stale and about to be redrawn
4446 if {$need_redisplay} return
4447 lappend boldids $id
4448 $canv itemconf $linehtag($id) -font $font
4449 if {[info exists currentid] && $id eq $currentid} {
4450 $canv delete secsel
4451 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4452 -outline {{}} -tags secsel \
4453 -fill [$canv cget -selectbackground]]
4454 $canv lower $t
4456 if {[info exists markedid] && $id eq $markedid} {
4457 make_idmark $id
4461 proc bolden_name {id font} {
4462 global canv2 linentag currentid boldnameids need_redisplay
4464 if {$need_redisplay} return
4465 lappend boldnameids $id
4466 $canv2 itemconf $linentag($id) -font $font
4467 if {[info exists currentid] && $id eq $currentid} {
4468 $canv2 delete secsel
4469 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4470 -outline {{}} -tags secsel \
4471 -fill [$canv2 cget -selectbackground]]
4472 $canv2 lower $t
4476 proc unbolden {} {
4477 global boldids
4479 set stillbold {}
4480 foreach id $boldids {
4481 if {![ishighlighted $id]} {
4482 bolden $id mainfont
4483 } else {
4484 lappend stillbold $id
4487 set boldids $stillbold
4490 proc addvhighlight {n} {
4491 global hlview viewcomplete curview vhl_done commitidx
4493 if {[info exists hlview]} {
4494 delvhighlight
4496 set hlview $n
4497 if {$n != $curview && ![info exists viewcomplete($n)]} {
4498 start_rev_list $n
4500 set vhl_done $commitidx($hlview)
4501 if {$vhl_done > 0} {
4502 drawvisible
4506 proc delvhighlight {} {
4507 global hlview vhighlights
4509 if {![info exists hlview]} return
4510 unset hlview
4511 catch {unset vhighlights}
4512 unbolden
4515 proc vhighlightmore {} {
4516 global hlview vhl_done commitidx vhighlights curview
4518 set max $commitidx($hlview)
4519 set vr [visiblerows]
4520 set r0 [lindex $vr 0]
4521 set r1 [lindex $vr 1]
4522 for {set i $vhl_done} {$i < $max} {incr i} {
4523 set id [commitonrow $i $hlview]
4524 if {[commitinview $id $curview]} {
4525 set row [rowofcommit $id]
4526 if {$r0 <= $row && $row <= $r1} {
4527 if {![highlighted $row]} {
4528 bolden $id mainfontbold
4530 set vhighlights($id) 1
4534 set vhl_done $max
4535 return 0
4538 proc askvhighlight {row id} {
4539 global hlview vhighlights iddrawn
4541 if {[commitinview $id $hlview]} {
4542 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4543 bolden $id mainfontbold
4545 set vhighlights($id) 1
4546 } else {
4547 set vhighlights($id) 0
4551 proc hfiles_change {} {
4552 global highlight_files filehighlight fhighlights fh_serial
4553 global highlight_paths
4555 if {[info exists filehighlight]} {
4556 # delete previous highlights
4557 catch {close $filehighlight}
4558 unset filehighlight
4559 catch {unset fhighlights}
4560 unbolden
4561 unhighlight_filelist
4563 set highlight_paths {}
4564 after cancel do_file_hl $fh_serial
4565 incr fh_serial
4566 if {$highlight_files ne {}} {
4567 after 300 do_file_hl $fh_serial
4571 proc gdttype_change {name ix op} {
4572 global gdttype highlight_files findstring findpattern
4574 stopfinding
4575 if {$findstring ne {}} {
4576 if {$gdttype eq [mc "containing:"]} {
4577 if {$highlight_files ne {}} {
4578 set highlight_files {}
4579 hfiles_change
4581 findcom_change
4582 } else {
4583 if {$findpattern ne {}} {
4584 set findpattern {}
4585 findcom_change
4587 set highlight_files $findstring
4588 hfiles_change
4590 drawvisible
4592 # enable/disable findtype/findloc menus too
4595 proc find_change {name ix op} {
4596 global gdttype findstring highlight_files
4598 stopfinding
4599 if {$gdttype eq [mc "containing:"]} {
4600 findcom_change
4601 } else {
4602 if {$highlight_files ne $findstring} {
4603 set highlight_files $findstring
4604 hfiles_change
4607 drawvisible
4610 proc findcom_change args {
4611 global nhighlights boldnameids
4612 global findpattern findtype findstring gdttype
4614 stopfinding
4615 # delete previous highlights, if any
4616 foreach id $boldnameids {
4617 bolden_name $id mainfont
4619 set boldnameids {}
4620 catch {unset nhighlights}
4621 unbolden
4622 unmarkmatches
4623 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4624 set findpattern {}
4625 } elseif {$findtype eq [mc "Regexp"]} {
4626 set findpattern $findstring
4627 } else {
4628 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4629 $findstring]
4630 set findpattern "*$e*"
4634 proc makepatterns {l} {
4635 set ret {}
4636 foreach e $l {
4637 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4638 if {[string index $ee end] eq "/"} {
4639 lappend ret "$ee*"
4640 } else {
4641 lappend ret $ee
4642 lappend ret "$ee/*"
4645 return $ret
4648 proc do_file_hl {serial} {
4649 global highlight_files filehighlight highlight_paths gdttype fhl_list
4650 global cdup findtype
4652 if {$gdttype eq [mc "touching paths:"]} {
4653 # If "exact" match then convert backslashes to forward slashes.
4654 # Most useful to support Windows-flavoured file paths.
4655 if {$findtype eq [mc "Exact"]} {
4656 set highlight_files [string map {"\\" "/"} $highlight_files]
4658 if {[catch {set paths [shellsplit $highlight_files]}]} return
4659 set highlight_paths [makepatterns $paths]
4660 highlight_filelist
4661 set relative_paths {}
4662 foreach path $paths {
4663 lappend relative_paths [file join $cdup $path]
4665 set gdtargs [concat -- $relative_paths]
4666 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4667 set gdtargs [list "-S$highlight_files"]
4668 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4669 set gdtargs [list "-G$highlight_files"]
4670 } else {
4671 # must be "containing:", i.e. we're searching commit info
4672 return
4674 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4675 set filehighlight [open $cmd r+]
4676 fconfigure $filehighlight -blocking 0
4677 filerun $filehighlight readfhighlight
4678 set fhl_list {}
4679 drawvisible
4680 flushhighlights
4683 proc flushhighlights {} {
4684 global filehighlight fhl_list
4686 if {[info exists filehighlight]} {
4687 lappend fhl_list {}
4688 puts $filehighlight ""
4689 flush $filehighlight
4693 proc askfilehighlight {row id} {
4694 global filehighlight fhighlights fhl_list
4696 lappend fhl_list $id
4697 set fhighlights($id) -1
4698 puts $filehighlight $id
4701 proc readfhighlight {} {
4702 global filehighlight fhighlights curview iddrawn
4703 global fhl_list find_dirn
4705 if {![info exists filehighlight]} {
4706 return 0
4708 set nr 0
4709 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4710 set line [string trim $line]
4711 set i [lsearch -exact $fhl_list $line]
4712 if {$i < 0} continue
4713 for {set j 0} {$j < $i} {incr j} {
4714 set id [lindex $fhl_list $j]
4715 set fhighlights($id) 0
4717 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4718 if {$line eq {}} continue
4719 if {![commitinview $line $curview]} continue
4720 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4721 bolden $line mainfontbold
4723 set fhighlights($line) 1
4725 if {[eof $filehighlight]} {
4726 # strange...
4727 puts "oops, git diff-tree died"
4728 catch {close $filehighlight}
4729 unset filehighlight
4730 return 0
4732 if {[info exists find_dirn]} {
4733 run findmore
4735 return 1
4738 proc doesmatch {f} {
4739 global findtype findpattern
4741 if {$findtype eq [mc "Regexp"]} {
4742 return [regexp $findpattern $f]
4743 } elseif {$findtype eq [mc "IgnCase"]} {
4744 return [string match -nocase $findpattern $f]
4745 } else {
4746 return [string match $findpattern $f]
4750 proc askfindhighlight {row id} {
4751 global nhighlights commitinfo iddrawn
4752 global findloc
4753 global markingmatches
4755 if {![info exists commitinfo($id)]} {
4756 getcommit $id
4758 set info $commitinfo($id)
4759 set isbold 0
4760 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4761 foreach f $info ty $fldtypes {
4762 if {$ty eq ""} continue
4763 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4764 [doesmatch $f]} {
4765 if {$ty eq [mc "Author"]} {
4766 set isbold 2
4767 break
4769 set isbold 1
4772 if {$isbold && [info exists iddrawn($id)]} {
4773 if {![ishighlighted $id]} {
4774 bolden $id mainfontbold
4775 if {$isbold > 1} {
4776 bolden_name $id mainfontbold
4779 if {$markingmatches} {
4780 markrowmatches $row $id
4783 set nhighlights($id) $isbold
4786 proc markrowmatches {row id} {
4787 global canv canv2 linehtag linentag commitinfo findloc
4789 set headline [lindex $commitinfo($id) 0]
4790 set author [lindex $commitinfo($id) 1]
4791 $canv delete match$row
4792 $canv2 delete match$row
4793 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4794 set m [findmatches $headline]
4795 if {$m ne {}} {
4796 markmatches $canv $row $headline $linehtag($id) $m \
4797 [$canv itemcget $linehtag($id) -font] $row
4800 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4801 set m [findmatches $author]
4802 if {$m ne {}} {
4803 markmatches $canv2 $row $author $linentag($id) $m \
4804 [$canv2 itemcget $linentag($id) -font] $row
4809 proc vrel_change {name ix op} {
4810 global highlight_related
4812 rhighlight_none
4813 if {$highlight_related ne [mc "None"]} {
4814 run drawvisible
4818 # prepare for testing whether commits are descendents or ancestors of a
4819 proc rhighlight_sel {a} {
4820 global descendent desc_todo ancestor anc_todo
4821 global highlight_related
4823 catch {unset descendent}
4824 set desc_todo [list $a]
4825 catch {unset ancestor}
4826 set anc_todo [list $a]
4827 if {$highlight_related ne [mc "None"]} {
4828 rhighlight_none
4829 run drawvisible
4833 proc rhighlight_none {} {
4834 global rhighlights
4836 catch {unset rhighlights}
4837 unbolden
4840 proc is_descendent {a} {
4841 global curview children descendent desc_todo
4843 set v $curview
4844 set la [rowofcommit $a]
4845 set todo $desc_todo
4846 set leftover {}
4847 set done 0
4848 for {set i 0} {$i < [llength $todo]} {incr i} {
4849 set do [lindex $todo $i]
4850 if {[rowofcommit $do] < $la} {
4851 lappend leftover $do
4852 continue
4854 foreach nk $children($v,$do) {
4855 if {![info exists descendent($nk)]} {
4856 set descendent($nk) 1
4857 lappend todo $nk
4858 if {$nk eq $a} {
4859 set done 1
4863 if {$done} {
4864 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4865 return
4868 set descendent($a) 0
4869 set desc_todo $leftover
4872 proc is_ancestor {a} {
4873 global curview parents ancestor anc_todo
4875 set v $curview
4876 set la [rowofcommit $a]
4877 set todo $anc_todo
4878 set leftover {}
4879 set done 0
4880 for {set i 0} {$i < [llength $todo]} {incr i} {
4881 set do [lindex $todo $i]
4882 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4883 lappend leftover $do
4884 continue
4886 foreach np $parents($v,$do) {
4887 if {![info exists ancestor($np)]} {
4888 set ancestor($np) 1
4889 lappend todo $np
4890 if {$np eq $a} {
4891 set done 1
4895 if {$done} {
4896 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4897 return
4900 set ancestor($a) 0
4901 set anc_todo $leftover
4904 proc askrelhighlight {row id} {
4905 global descendent highlight_related iddrawn rhighlights
4906 global selectedline ancestor
4908 if {$selectedline eq {}} return
4909 set isbold 0
4910 if {$highlight_related eq [mc "Descendant"] ||
4911 $highlight_related eq [mc "Not descendant"]} {
4912 if {![info exists descendent($id)]} {
4913 is_descendent $id
4915 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4916 set isbold 1
4918 } elseif {$highlight_related eq [mc "Ancestor"] ||
4919 $highlight_related eq [mc "Not ancestor"]} {
4920 if {![info exists ancestor($id)]} {
4921 is_ancestor $id
4923 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4924 set isbold 1
4927 if {[info exists iddrawn($id)]} {
4928 if {$isbold && ![ishighlighted $id]} {
4929 bolden $id mainfontbold
4932 set rhighlights($id) $isbold
4935 # Graph layout functions
4937 proc shortids {ids} {
4938 set res {}
4939 foreach id $ids {
4940 if {[llength $id] > 1} {
4941 lappend res [shortids $id]
4942 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4943 lappend res [string range $id 0 7]
4944 } else {
4945 lappend res $id
4948 return $res
4951 proc ntimes {n o} {
4952 set ret {}
4953 set o [list $o]
4954 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4955 if {($n & $mask) != 0} {
4956 set ret [concat $ret $o]
4958 set o [concat $o $o]
4960 return $ret
4963 proc ordertoken {id} {
4964 global ordertok curview varcid varcstart varctok curview parents children
4965 global nullid nullid2
4967 if {[info exists ordertok($id)]} {
4968 return $ordertok($id)
4970 set origid $id
4971 set todo {}
4972 while {1} {
4973 if {[info exists varcid($curview,$id)]} {
4974 set a $varcid($curview,$id)
4975 set p [lindex $varcstart($curview) $a]
4976 } else {
4977 set p [lindex $children($curview,$id) 0]
4979 if {[info exists ordertok($p)]} {
4980 set tok $ordertok($p)
4981 break
4983 set id [first_real_child $curview,$p]
4984 if {$id eq {}} {
4985 # it's a root
4986 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4987 break
4989 if {[llength $parents($curview,$id)] == 1} {
4990 lappend todo [list $p {}]
4991 } else {
4992 set j [lsearch -exact $parents($curview,$id) $p]
4993 if {$j < 0} {
4994 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4996 lappend todo [list $p [strrep $j]]
4999 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5000 set p [lindex $todo $i 0]
5001 append tok [lindex $todo $i 1]
5002 set ordertok($p) $tok
5004 set ordertok($origid) $tok
5005 return $tok
5008 # Work out where id should go in idlist so that order-token
5009 # values increase from left to right
5010 proc idcol {idlist id {i 0}} {
5011 set t [ordertoken $id]
5012 if {$i < 0} {
5013 set i 0
5015 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5016 if {$i > [llength $idlist]} {
5017 set i [llength $idlist]
5019 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5020 incr i
5021 } else {
5022 if {$t > [ordertoken [lindex $idlist $i]]} {
5023 while {[incr i] < [llength $idlist] &&
5024 $t >= [ordertoken [lindex $idlist $i]]} {}
5027 return $i
5030 proc initlayout {} {
5031 global rowidlist rowisopt rowfinal displayorder parentlist
5032 global numcommits canvxmax canv
5033 global nextcolor
5034 global colormap rowtextx
5036 set numcommits 0
5037 set displayorder {}
5038 set parentlist {}
5039 set nextcolor 0
5040 set rowidlist {}
5041 set rowisopt {}
5042 set rowfinal {}
5043 set canvxmax [$canv cget -width]
5044 catch {unset colormap}
5045 catch {unset rowtextx}
5046 setcanvscroll
5049 proc setcanvscroll {} {
5050 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5051 global lastscrollset lastscrollrows
5053 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5054 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5055 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5056 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5057 set lastscrollset [clock clicks -milliseconds]
5058 set lastscrollrows $numcommits
5061 proc visiblerows {} {
5062 global canv numcommits linespc
5064 set ymax [lindex [$canv cget -scrollregion] 3]
5065 if {$ymax eq {} || $ymax == 0} return
5066 set f [$canv yview]
5067 set y0 [expr {int([lindex $f 0] * $ymax)}]
5068 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5069 if {$r0 < 0} {
5070 set r0 0
5072 set y1 [expr {int([lindex $f 1] * $ymax)}]
5073 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5074 if {$r1 >= $numcommits} {
5075 set r1 [expr {$numcommits - 1}]
5077 return [list $r0 $r1]
5080 proc layoutmore {} {
5081 global commitidx viewcomplete curview
5082 global numcommits pending_select curview
5083 global lastscrollset lastscrollrows
5085 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5086 [clock clicks -milliseconds] - $lastscrollset > 500} {
5087 setcanvscroll
5089 if {[info exists pending_select] &&
5090 [commitinview $pending_select $curview]} {
5091 update
5092 selectline [rowofcommit $pending_select] 1
5094 drawvisible
5097 # With path limiting, we mightn't get the actual HEAD commit,
5098 # so ask git rev-list what is the first ancestor of HEAD that
5099 # touches a file in the path limit.
5100 proc get_viewmainhead {view} {
5101 global viewmainheadid vfilelimit viewinstances mainheadid
5103 catch {
5104 set rfd [open [concat | git rev-list -1 $mainheadid \
5105 -- $vfilelimit($view)] r]
5106 set j [reg_instance $rfd]
5107 lappend viewinstances($view) $j
5108 fconfigure $rfd -blocking 0
5109 filerun $rfd [list getviewhead $rfd $j $view]
5110 set viewmainheadid($curview) {}
5114 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5115 proc getviewhead {fd inst view} {
5116 global viewmainheadid commfd curview viewinstances showlocalchanges
5118 set id {}
5119 if {[gets $fd line] < 0} {
5120 if {![eof $fd]} {
5121 return 1
5123 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5124 set id $line
5126 set viewmainheadid($view) $id
5127 close $fd
5128 unset commfd($inst)
5129 set i [lsearch -exact $viewinstances($view) $inst]
5130 if {$i >= 0} {
5131 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5133 if {$showlocalchanges && $id ne {} && $view == $curview} {
5134 doshowlocalchanges
5136 return 0
5139 proc doshowlocalchanges {} {
5140 global curview viewmainheadid
5142 if {$viewmainheadid($curview) eq {}} return
5143 if {[commitinview $viewmainheadid($curview) $curview]} {
5144 dodiffindex
5145 } else {
5146 interestedin $viewmainheadid($curview) dodiffindex
5150 proc dohidelocalchanges {} {
5151 global nullid nullid2 lserial curview
5153 if {[commitinview $nullid $curview]} {
5154 removefakerow $nullid
5156 if {[commitinview $nullid2 $curview]} {
5157 removefakerow $nullid2
5159 incr lserial
5162 # spawn off a process to do git diff-index --cached HEAD
5163 proc dodiffindex {} {
5164 global lserial showlocalchanges vfilelimit curview
5165 global hasworktree git_version
5167 if {!$showlocalchanges || !$hasworktree} return
5168 incr lserial
5169 if {[package vcompare $git_version "1.7.2"] >= 0} {
5170 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5171 } else {
5172 set cmd "|git diff-index --cached HEAD"
5174 if {$vfilelimit($curview) ne {}} {
5175 set cmd [concat $cmd -- $vfilelimit($curview)]
5177 set fd [open $cmd r]
5178 fconfigure $fd -blocking 0
5179 set i [reg_instance $fd]
5180 filerun $fd [list readdiffindex $fd $lserial $i]
5183 proc readdiffindex {fd serial inst} {
5184 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5185 global vfilelimit
5187 set isdiff 1
5188 if {[gets $fd line] < 0} {
5189 if {![eof $fd]} {
5190 return 1
5192 set isdiff 0
5194 # we only need to see one line and we don't really care what it says...
5195 stop_instance $inst
5197 if {$serial != $lserial} {
5198 return 0
5201 # now see if there are any local changes not checked in to the index
5202 set cmd "|git diff-files"
5203 if {$vfilelimit($curview) ne {}} {
5204 set cmd [concat $cmd -- $vfilelimit($curview)]
5206 set fd [open $cmd r]
5207 fconfigure $fd -blocking 0
5208 set i [reg_instance $fd]
5209 filerun $fd [list readdifffiles $fd $serial $i]
5211 if {$isdiff && ![commitinview $nullid2 $curview]} {
5212 # add the line for the changes in the index to the graph
5213 set hl [mc "Local changes checked in to index but not committed"]
5214 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5215 set commitdata($nullid2) "\n $hl\n"
5216 if {[commitinview $nullid $curview]} {
5217 removefakerow $nullid
5219 insertfakerow $nullid2 $viewmainheadid($curview)
5220 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5221 if {[commitinview $nullid $curview]} {
5222 removefakerow $nullid
5224 removefakerow $nullid2
5226 return 0
5229 proc readdifffiles {fd serial inst} {
5230 global viewmainheadid nullid nullid2 curview
5231 global commitinfo commitdata lserial
5233 set isdiff 1
5234 if {[gets $fd line] < 0} {
5235 if {![eof $fd]} {
5236 return 1
5238 set isdiff 0
5240 # we only need to see one line and we don't really care what it says...
5241 stop_instance $inst
5243 if {$serial != $lserial} {
5244 return 0
5247 if {$isdiff && ![commitinview $nullid $curview]} {
5248 # add the line for the local diff to the graph
5249 set hl [mc "Local uncommitted changes, not checked in to index"]
5250 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5251 set commitdata($nullid) "\n $hl\n"
5252 if {[commitinview $nullid2 $curview]} {
5253 set p $nullid2
5254 } else {
5255 set p $viewmainheadid($curview)
5257 insertfakerow $nullid $p
5258 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5259 removefakerow $nullid
5261 return 0
5264 proc nextuse {id row} {
5265 global curview children
5267 if {[info exists children($curview,$id)]} {
5268 foreach kid $children($curview,$id) {
5269 if {![commitinview $kid $curview]} {
5270 return -1
5272 if {[rowofcommit $kid] > $row} {
5273 return [rowofcommit $kid]
5277 if {[commitinview $id $curview]} {
5278 return [rowofcommit $id]
5280 return -1
5283 proc prevuse {id row} {
5284 global curview children
5286 set ret -1
5287 if {[info exists children($curview,$id)]} {
5288 foreach kid $children($curview,$id) {
5289 if {![commitinview $kid $curview]} break
5290 if {[rowofcommit $kid] < $row} {
5291 set ret [rowofcommit $kid]
5295 return $ret
5298 proc make_idlist {row} {
5299 global displayorder parentlist uparrowlen downarrowlen mingaplen
5300 global commitidx curview children
5302 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5303 if {$r < 0} {
5304 set r 0
5306 set ra [expr {$row - $downarrowlen}]
5307 if {$ra < 0} {
5308 set ra 0
5310 set rb [expr {$row + $uparrowlen}]
5311 if {$rb > $commitidx($curview)} {
5312 set rb $commitidx($curview)
5314 make_disporder $r [expr {$rb + 1}]
5315 set ids {}
5316 for {} {$r < $ra} {incr r} {
5317 set nextid [lindex $displayorder [expr {$r + 1}]]
5318 foreach p [lindex $parentlist $r] {
5319 if {$p eq $nextid} continue
5320 set rn [nextuse $p $r]
5321 if {$rn >= $row &&
5322 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5323 lappend ids [list [ordertoken $p] $p]
5327 for {} {$r < $row} {incr r} {
5328 set nextid [lindex $displayorder [expr {$r + 1}]]
5329 foreach p [lindex $parentlist $r] {
5330 if {$p eq $nextid} continue
5331 set rn [nextuse $p $r]
5332 if {$rn < 0 || $rn >= $row} {
5333 lappend ids [list [ordertoken $p] $p]
5337 set id [lindex $displayorder $row]
5338 lappend ids [list [ordertoken $id] $id]
5339 while {$r < $rb} {
5340 foreach p [lindex $parentlist $r] {
5341 set firstkid [lindex $children($curview,$p) 0]
5342 if {[rowofcommit $firstkid] < $row} {
5343 lappend ids [list [ordertoken $p] $p]
5346 incr r
5347 set id [lindex $displayorder $r]
5348 if {$id ne {}} {
5349 set firstkid [lindex $children($curview,$id) 0]
5350 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5351 lappend ids [list [ordertoken $id] $id]
5355 set idlist {}
5356 foreach idx [lsort -unique $ids] {
5357 lappend idlist [lindex $idx 1]
5359 return $idlist
5362 proc rowsequal {a b} {
5363 while {[set i [lsearch -exact $a {}]] >= 0} {
5364 set a [lreplace $a $i $i]
5366 while {[set i [lsearch -exact $b {}]] >= 0} {
5367 set b [lreplace $b $i $i]
5369 return [expr {$a eq $b}]
5372 proc makeupline {id row rend col} {
5373 global rowidlist uparrowlen downarrowlen mingaplen
5375 for {set r $rend} {1} {set r $rstart} {
5376 set rstart [prevuse $id $r]
5377 if {$rstart < 0} return
5378 if {$rstart < $row} break
5380 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5381 set rstart [expr {$rend - $uparrowlen - 1}]
5383 for {set r $rstart} {[incr r] <= $row} {} {
5384 set idlist [lindex $rowidlist $r]
5385 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5386 set col [idcol $idlist $id $col]
5387 lset rowidlist $r [linsert $idlist $col $id]
5388 changedrow $r
5393 proc layoutrows {row endrow} {
5394 global rowidlist rowisopt rowfinal displayorder
5395 global uparrowlen downarrowlen maxwidth mingaplen
5396 global children parentlist
5397 global commitidx viewcomplete curview
5399 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5400 set idlist {}
5401 if {$row > 0} {
5402 set rm1 [expr {$row - 1}]
5403 foreach id [lindex $rowidlist $rm1] {
5404 if {$id ne {}} {
5405 lappend idlist $id
5408 set final [lindex $rowfinal $rm1]
5410 for {} {$row < $endrow} {incr row} {
5411 set rm1 [expr {$row - 1}]
5412 if {$rm1 < 0 || $idlist eq {}} {
5413 set idlist [make_idlist $row]
5414 set final 1
5415 } else {
5416 set id [lindex $displayorder $rm1]
5417 set col [lsearch -exact $idlist $id]
5418 set idlist [lreplace $idlist $col $col]
5419 foreach p [lindex $parentlist $rm1] {
5420 if {[lsearch -exact $idlist $p] < 0} {
5421 set col [idcol $idlist $p $col]
5422 set idlist [linsert $idlist $col $p]
5423 # if not the first child, we have to insert a line going up
5424 if {$id ne [lindex $children($curview,$p) 0]} {
5425 makeupline $p $rm1 $row $col
5429 set id [lindex $displayorder $row]
5430 if {$row > $downarrowlen} {
5431 set termrow [expr {$row - $downarrowlen - 1}]
5432 foreach p [lindex $parentlist $termrow] {
5433 set i [lsearch -exact $idlist $p]
5434 if {$i < 0} continue
5435 set nr [nextuse $p $termrow]
5436 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5437 set idlist [lreplace $idlist $i $i]
5441 set col [lsearch -exact $idlist $id]
5442 if {$col < 0} {
5443 set col [idcol $idlist $id]
5444 set idlist [linsert $idlist $col $id]
5445 if {$children($curview,$id) ne {}} {
5446 makeupline $id $rm1 $row $col
5449 set r [expr {$row + $uparrowlen - 1}]
5450 if {$r < $commitidx($curview)} {
5451 set x $col
5452 foreach p [lindex $parentlist $r] {
5453 if {[lsearch -exact $idlist $p] >= 0} continue
5454 set fk [lindex $children($curview,$p) 0]
5455 if {[rowofcommit $fk] < $row} {
5456 set x [idcol $idlist $p $x]
5457 set idlist [linsert $idlist $x $p]
5460 if {[incr r] < $commitidx($curview)} {
5461 set p [lindex $displayorder $r]
5462 if {[lsearch -exact $idlist $p] < 0} {
5463 set fk [lindex $children($curview,$p) 0]
5464 if {$fk ne {} && [rowofcommit $fk] < $row} {
5465 set x [idcol $idlist $p $x]
5466 set idlist [linsert $idlist $x $p]
5472 if {$final && !$viewcomplete($curview) &&
5473 $row + $uparrowlen + $mingaplen + $downarrowlen
5474 >= $commitidx($curview)} {
5475 set final 0
5477 set l [llength $rowidlist]
5478 if {$row == $l} {
5479 lappend rowidlist $idlist
5480 lappend rowisopt 0
5481 lappend rowfinal $final
5482 } elseif {$row < $l} {
5483 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5484 lset rowidlist $row $idlist
5485 changedrow $row
5487 lset rowfinal $row $final
5488 } else {
5489 set pad [ntimes [expr {$row - $l}] {}]
5490 set rowidlist [concat $rowidlist $pad]
5491 lappend rowidlist $idlist
5492 set rowfinal [concat $rowfinal $pad]
5493 lappend rowfinal $final
5494 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5497 return $row
5500 proc changedrow {row} {
5501 global displayorder iddrawn rowisopt need_redisplay
5503 set l [llength $rowisopt]
5504 if {$row < $l} {
5505 lset rowisopt $row 0
5506 if {$row + 1 < $l} {
5507 lset rowisopt [expr {$row + 1}] 0
5508 if {$row + 2 < $l} {
5509 lset rowisopt [expr {$row + 2}] 0
5513 set id [lindex $displayorder $row]
5514 if {[info exists iddrawn($id)]} {
5515 set need_redisplay 1
5519 proc insert_pad {row col npad} {
5520 global rowidlist
5522 set pad [ntimes $npad {}]
5523 set idlist [lindex $rowidlist $row]
5524 set bef [lrange $idlist 0 [expr {$col - 1}]]
5525 set aft [lrange $idlist $col end]
5526 set i [lsearch -exact $aft {}]
5527 if {$i > 0} {
5528 set aft [lreplace $aft $i $i]
5530 lset rowidlist $row [concat $bef $pad $aft]
5531 changedrow $row
5534 proc optimize_rows {row col endrow} {
5535 global rowidlist rowisopt displayorder curview children
5537 if {$row < 1} {
5538 set row 1
5540 for {} {$row < $endrow} {incr row; set col 0} {
5541 if {[lindex $rowisopt $row]} continue
5542 set haspad 0
5543 set y0 [expr {$row - 1}]
5544 set ym [expr {$row - 2}]
5545 set idlist [lindex $rowidlist $row]
5546 set previdlist [lindex $rowidlist $y0]
5547 if {$idlist eq {} || $previdlist eq {}} continue
5548 if {$ym >= 0} {
5549 set pprevidlist [lindex $rowidlist $ym]
5550 if {$pprevidlist eq {}} continue
5551 } else {
5552 set pprevidlist {}
5554 set x0 -1
5555 set xm -1
5556 for {} {$col < [llength $idlist]} {incr col} {
5557 set id [lindex $idlist $col]
5558 if {[lindex $previdlist $col] eq $id} continue
5559 if {$id eq {}} {
5560 set haspad 1
5561 continue
5563 set x0 [lsearch -exact $previdlist $id]
5564 if {$x0 < 0} continue
5565 set z [expr {$x0 - $col}]
5566 set isarrow 0
5567 set z0 {}
5568 if {$ym >= 0} {
5569 set xm [lsearch -exact $pprevidlist $id]
5570 if {$xm >= 0} {
5571 set z0 [expr {$xm - $x0}]
5574 if {$z0 eq {}} {
5575 # if row y0 is the first child of $id then it's not an arrow
5576 if {[lindex $children($curview,$id) 0] ne
5577 [lindex $displayorder $y0]} {
5578 set isarrow 1
5581 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5582 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5583 set isarrow 1
5585 # Looking at lines from this row to the previous row,
5586 # make them go straight up if they end in an arrow on
5587 # the previous row; otherwise make them go straight up
5588 # or at 45 degrees.
5589 if {$z < -1 || ($z < 0 && $isarrow)} {
5590 # Line currently goes left too much;
5591 # insert pads in the previous row, then optimize it
5592 set npad [expr {-1 - $z + $isarrow}]
5593 insert_pad $y0 $x0 $npad
5594 if {$y0 > 0} {
5595 optimize_rows $y0 $x0 $row
5597 set previdlist [lindex $rowidlist $y0]
5598 set x0 [lsearch -exact $previdlist $id]
5599 set z [expr {$x0 - $col}]
5600 if {$z0 ne {}} {
5601 set pprevidlist [lindex $rowidlist $ym]
5602 set xm [lsearch -exact $pprevidlist $id]
5603 set z0 [expr {$xm - $x0}]
5605 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5606 # Line currently goes right too much;
5607 # insert pads in this line
5608 set npad [expr {$z - 1 + $isarrow}]
5609 insert_pad $row $col $npad
5610 set idlist [lindex $rowidlist $row]
5611 incr col $npad
5612 set z [expr {$x0 - $col}]
5613 set haspad 1
5615 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5616 # this line links to its first child on row $row-2
5617 set id [lindex $displayorder $ym]
5618 set xc [lsearch -exact $pprevidlist $id]
5619 if {$xc >= 0} {
5620 set z0 [expr {$xc - $x0}]
5623 # avoid lines jigging left then immediately right
5624 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5625 insert_pad $y0 $x0 1
5626 incr x0
5627 optimize_rows $y0 $x0 $row
5628 set previdlist [lindex $rowidlist $y0]
5631 if {!$haspad} {
5632 # Find the first column that doesn't have a line going right
5633 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5634 set id [lindex $idlist $col]
5635 if {$id eq {}} break
5636 set x0 [lsearch -exact $previdlist $id]
5637 if {$x0 < 0} {
5638 # check if this is the link to the first child
5639 set kid [lindex $displayorder $y0]
5640 if {[lindex $children($curview,$id) 0] eq $kid} {
5641 # it is, work out offset to child
5642 set x0 [lsearch -exact $previdlist $kid]
5645 if {$x0 <= $col} break
5647 # Insert a pad at that column as long as it has a line and
5648 # isn't the last column
5649 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5650 set idlist [linsert $idlist $col {}]
5651 lset rowidlist $row $idlist
5652 changedrow $row
5658 proc xc {row col} {
5659 global canvx0 linespc
5660 return [expr {$canvx0 + $col * $linespc}]
5663 proc yc {row} {
5664 global canvy0 linespc
5665 return [expr {$canvy0 + $row * $linespc}]
5668 proc linewidth {id} {
5669 global thickerline lthickness
5671 set wid $lthickness
5672 if {[info exists thickerline] && $id eq $thickerline} {
5673 set wid [expr {2 * $lthickness}]
5675 return $wid
5678 proc rowranges {id} {
5679 global curview children uparrowlen downarrowlen
5680 global rowidlist
5682 set kids $children($curview,$id)
5683 if {$kids eq {}} {
5684 return {}
5686 set ret {}
5687 lappend kids $id
5688 foreach child $kids {
5689 if {![commitinview $child $curview]} break
5690 set row [rowofcommit $child]
5691 if {![info exists prev]} {
5692 lappend ret [expr {$row + 1}]
5693 } else {
5694 if {$row <= $prevrow} {
5695 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5697 # see if the line extends the whole way from prevrow to row
5698 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5699 [lsearch -exact [lindex $rowidlist \
5700 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5701 # it doesn't, see where it ends
5702 set r [expr {$prevrow + $downarrowlen}]
5703 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5704 while {[incr r -1] > $prevrow &&
5705 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5706 } else {
5707 while {[incr r] <= $row &&
5708 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5709 incr r -1
5711 lappend ret $r
5712 # see where it starts up again
5713 set r [expr {$row - $uparrowlen}]
5714 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5715 while {[incr r] < $row &&
5716 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5717 } else {
5718 while {[incr r -1] >= $prevrow &&
5719 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5720 incr r
5722 lappend ret $r
5725 if {$child eq $id} {
5726 lappend ret $row
5728 set prev $child
5729 set prevrow $row
5731 return $ret
5734 proc drawlineseg {id row endrow arrowlow} {
5735 global rowidlist displayorder iddrawn linesegs
5736 global canv colormap linespc curview maxlinelen parentlist
5738 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5739 set le [expr {$row + 1}]
5740 set arrowhigh 1
5741 while {1} {
5742 set c [lsearch -exact [lindex $rowidlist $le] $id]
5743 if {$c < 0} {
5744 incr le -1
5745 break
5747 lappend cols $c
5748 set x [lindex $displayorder $le]
5749 if {$x eq $id} {
5750 set arrowhigh 0
5751 break
5753 if {[info exists iddrawn($x)] || $le == $endrow} {
5754 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5755 if {$c >= 0} {
5756 lappend cols $c
5757 set arrowhigh 0
5759 break
5761 incr le
5763 if {$le <= $row} {
5764 return $row
5767 set lines {}
5768 set i 0
5769 set joinhigh 0
5770 if {[info exists linesegs($id)]} {
5771 set lines $linesegs($id)
5772 foreach li $lines {
5773 set r0 [lindex $li 0]
5774 if {$r0 > $row} {
5775 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5776 set joinhigh 1
5778 break
5780 incr i
5783 set joinlow 0
5784 if {$i > 0} {
5785 set li [lindex $lines [expr {$i-1}]]
5786 set r1 [lindex $li 1]
5787 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5788 set joinlow 1
5792 set x [lindex $cols [expr {$le - $row}]]
5793 set xp [lindex $cols [expr {$le - 1 - $row}]]
5794 set dir [expr {$xp - $x}]
5795 if {$joinhigh} {
5796 set ith [lindex $lines $i 2]
5797 set coords [$canv coords $ith]
5798 set ah [$canv itemcget $ith -arrow]
5799 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5800 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5801 if {$x2 ne {} && $x - $x2 == $dir} {
5802 set coords [lrange $coords 0 end-2]
5804 } else {
5805 set coords [list [xc $le $x] [yc $le]]
5807 if {$joinlow} {
5808 set itl [lindex $lines [expr {$i-1}] 2]
5809 set al [$canv itemcget $itl -arrow]
5810 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5811 } elseif {$arrowlow} {
5812 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5813 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5814 set arrowlow 0
5817 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5818 for {set y $le} {[incr y -1] > $row} {} {
5819 set x $xp
5820 set xp [lindex $cols [expr {$y - 1 - $row}]]
5821 set ndir [expr {$xp - $x}]
5822 if {$dir != $ndir || $xp < 0} {
5823 lappend coords [xc $y $x] [yc $y]
5825 set dir $ndir
5827 if {!$joinlow} {
5828 if {$xp < 0} {
5829 # join parent line to first child
5830 set ch [lindex $displayorder $row]
5831 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5832 if {$xc < 0} {
5833 puts "oops: drawlineseg: child $ch not on row $row"
5834 } elseif {$xc != $x} {
5835 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5836 set d [expr {int(0.5 * $linespc)}]
5837 set x1 [xc $row $x]
5838 if {$xc < $x} {
5839 set x2 [expr {$x1 - $d}]
5840 } else {
5841 set x2 [expr {$x1 + $d}]
5843 set y2 [yc $row]
5844 set y1 [expr {$y2 + $d}]
5845 lappend coords $x1 $y1 $x2 $y2
5846 } elseif {$xc < $x - 1} {
5847 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5848 } elseif {$xc > $x + 1} {
5849 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5851 set x $xc
5853 lappend coords [xc $row $x] [yc $row]
5854 } else {
5855 set xn [xc $row $xp]
5856 set yn [yc $row]
5857 lappend coords $xn $yn
5859 if {!$joinhigh} {
5860 assigncolor $id
5861 set t [$canv create line $coords -width [linewidth $id] \
5862 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5863 $canv lower $t
5864 bindline $t $id
5865 set lines [linsert $lines $i [list $row $le $t]]
5866 } else {
5867 $canv coords $ith $coords
5868 if {$arrow ne $ah} {
5869 $canv itemconf $ith -arrow $arrow
5871 lset lines $i 0 $row
5873 } else {
5874 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5875 set ndir [expr {$xo - $xp}]
5876 set clow [$canv coords $itl]
5877 if {$dir == $ndir} {
5878 set clow [lrange $clow 2 end]
5880 set coords [concat $coords $clow]
5881 if {!$joinhigh} {
5882 lset lines [expr {$i-1}] 1 $le
5883 } else {
5884 # coalesce two pieces
5885 $canv delete $ith
5886 set b [lindex $lines [expr {$i-1}] 0]
5887 set e [lindex $lines $i 1]
5888 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5890 $canv coords $itl $coords
5891 if {$arrow ne $al} {
5892 $canv itemconf $itl -arrow $arrow
5896 set linesegs($id) $lines
5897 return $le
5900 proc drawparentlinks {id row} {
5901 global rowidlist canv colormap curview parentlist
5902 global idpos linespc
5904 set rowids [lindex $rowidlist $row]
5905 set col [lsearch -exact $rowids $id]
5906 if {$col < 0} return
5907 set olds [lindex $parentlist $row]
5908 set row2 [expr {$row + 1}]
5909 set x [xc $row $col]
5910 set y [yc $row]
5911 set y2 [yc $row2]
5912 set d [expr {int(0.5 * $linespc)}]
5913 set ymid [expr {$y + $d}]
5914 set ids [lindex $rowidlist $row2]
5915 # rmx = right-most X coord used
5916 set rmx 0
5917 foreach p $olds {
5918 set i [lsearch -exact $ids $p]
5919 if {$i < 0} {
5920 puts "oops, parent $p of $id not in list"
5921 continue
5923 set x2 [xc $row2 $i]
5924 if {$x2 > $rmx} {
5925 set rmx $x2
5927 set j [lsearch -exact $rowids $p]
5928 if {$j < 0} {
5929 # drawlineseg will do this one for us
5930 continue
5932 assigncolor $p
5933 # should handle duplicated parents here...
5934 set coords [list $x $y]
5935 if {$i != $col} {
5936 # if attaching to a vertical segment, draw a smaller
5937 # slant for visual distinctness
5938 if {$i == $j} {
5939 if {$i < $col} {
5940 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5941 } else {
5942 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5944 } elseif {$i < $col && $i < $j} {
5945 # segment slants towards us already
5946 lappend coords [xc $row $j] $y
5947 } else {
5948 if {$i < $col - 1} {
5949 lappend coords [expr {$x2 + $linespc}] $y
5950 } elseif {$i > $col + 1} {
5951 lappend coords [expr {$x2 - $linespc}] $y
5953 lappend coords $x2 $y2
5955 } else {
5956 lappend coords $x2 $y2
5958 set t [$canv create line $coords -width [linewidth $p] \
5959 -fill $colormap($p) -tags lines.$p]
5960 $canv lower $t
5961 bindline $t $p
5963 if {$rmx > [lindex $idpos($id) 1]} {
5964 lset idpos($id) 1 $rmx
5965 redrawtags $id
5969 proc drawlines {id} {
5970 global canv
5972 $canv itemconf lines.$id -width [linewidth $id]
5975 proc drawcmittext {id row col} {
5976 global linespc canv canv2 canv3 fgcolor curview
5977 global cmitlisted commitinfo rowidlist parentlist
5978 global rowtextx idpos idtags idheads idotherrefs
5979 global linehtag linentag linedtag selectedline
5980 global canvxmax boldids boldnameids fgcolor markedid
5981 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5982 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
5983 global circleoutlinecolor
5985 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5986 set listed $cmitlisted($curview,$id)
5987 if {$id eq $nullid} {
5988 set ofill $workingfilescirclecolor
5989 } elseif {$id eq $nullid2} {
5990 set ofill $indexcirclecolor
5991 } elseif {$id eq $mainheadid} {
5992 set ofill $mainheadcirclecolor
5993 } else {
5994 set ofill [lindex $circlecolors $listed]
5996 set x [xc $row $col]
5997 set y [yc $row]
5998 set orad [expr {$linespc / 3}]
5999 if {$listed <= 2} {
6000 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6001 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6002 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6003 } elseif {$listed == 3} {
6004 # triangle pointing left for left-side commits
6005 set t [$canv create polygon \
6006 [expr {$x - $orad}] $y \
6007 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6008 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6009 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6010 } else {
6011 # triangle pointing right for right-side commits
6012 set t [$canv create polygon \
6013 [expr {$x + $orad - 1}] $y \
6014 [expr {$x - $orad}] [expr {$y - $orad}] \
6015 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6016 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6018 set circleitem($row) $t
6019 $canv raise $t
6020 $canv bind $t <1> {selcanvline {} %x %y}
6021 set rmx [llength [lindex $rowidlist $row]]
6022 set olds [lindex $parentlist $row]
6023 if {$olds ne {}} {
6024 set nextids [lindex $rowidlist [expr {$row + 1}]]
6025 foreach p $olds {
6026 set i [lsearch -exact $nextids $p]
6027 if {$i > $rmx} {
6028 set rmx $i
6032 set xt [xc $row $rmx]
6033 set rowtextx($row) $xt
6034 set idpos($id) [list $x $xt $y]
6035 if {[info exists idtags($id)] || [info exists idheads($id)]
6036 || [info exists idotherrefs($id)]} {
6037 set xt [drawtags $id $x $xt $y]
6039 if {[lindex $commitinfo($id) 6] > 0} {
6040 set xt [drawnotesign $xt $y]
6042 set headline [lindex $commitinfo($id) 0]
6043 set name [lindex $commitinfo($id) 1]
6044 set date [lindex $commitinfo($id) 2]
6045 set date [formatdate $date]
6046 set font mainfont
6047 set nfont mainfont
6048 set isbold [ishighlighted $id]
6049 if {$isbold > 0} {
6050 lappend boldids $id
6051 set font mainfontbold
6052 if {$isbold > 1} {
6053 lappend boldnameids $id
6054 set nfont mainfontbold
6057 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6058 -text $headline -font $font -tags text]
6059 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6060 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6061 -text $name -font $nfont -tags text]
6062 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6063 -text $date -font mainfont -tags text]
6064 if {$selectedline == $row} {
6065 make_secsel $id
6067 if {[info exists markedid] && $markedid eq $id} {
6068 make_idmark $id
6070 set xr [expr {$xt + [font measure $font $headline]}]
6071 if {$xr > $canvxmax} {
6072 set canvxmax $xr
6073 setcanvscroll
6077 proc drawcmitrow {row} {
6078 global displayorder rowidlist nrows_drawn
6079 global iddrawn markingmatches
6080 global commitinfo numcommits
6081 global filehighlight fhighlights findpattern nhighlights
6082 global hlview vhighlights
6083 global highlight_related rhighlights
6085 if {$row >= $numcommits} return
6087 set id [lindex $displayorder $row]
6088 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6089 askvhighlight $row $id
6091 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6092 askfilehighlight $row $id
6094 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6095 askfindhighlight $row $id
6097 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6098 askrelhighlight $row $id
6100 if {![info exists iddrawn($id)]} {
6101 set col [lsearch -exact [lindex $rowidlist $row] $id]
6102 if {$col < 0} {
6103 puts "oops, row $row id $id not in list"
6104 return
6106 if {![info exists commitinfo($id)]} {
6107 getcommit $id
6109 assigncolor $id
6110 drawcmittext $id $row $col
6111 set iddrawn($id) 1
6112 incr nrows_drawn
6114 if {$markingmatches} {
6115 markrowmatches $row $id
6119 proc drawcommits {row {endrow {}}} {
6120 global numcommits iddrawn displayorder curview need_redisplay
6121 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6123 if {$row < 0} {
6124 set row 0
6126 if {$endrow eq {}} {
6127 set endrow $row
6129 if {$endrow >= $numcommits} {
6130 set endrow [expr {$numcommits - 1}]
6133 set rl1 [expr {$row - $downarrowlen - 3}]
6134 if {$rl1 < 0} {
6135 set rl1 0
6137 set ro1 [expr {$row - 3}]
6138 if {$ro1 < 0} {
6139 set ro1 0
6141 set r2 [expr {$endrow + $uparrowlen + 3}]
6142 if {$r2 > $numcommits} {
6143 set r2 $numcommits
6145 for {set r $rl1} {$r < $r2} {incr r} {
6146 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6147 if {$rl1 < $r} {
6148 layoutrows $rl1 $r
6150 set rl1 [expr {$r + 1}]
6153 if {$rl1 < $r} {
6154 layoutrows $rl1 $r
6156 optimize_rows $ro1 0 $r2
6157 if {$need_redisplay || $nrows_drawn > 2000} {
6158 clear_display
6161 # make the lines join to already-drawn rows either side
6162 set r [expr {$row - 1}]
6163 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6164 set r $row
6166 set er [expr {$endrow + 1}]
6167 if {$er >= $numcommits ||
6168 ![info exists iddrawn([lindex $displayorder $er])]} {
6169 set er $endrow
6171 for {} {$r <= $er} {incr r} {
6172 set id [lindex $displayorder $r]
6173 set wasdrawn [info exists iddrawn($id)]
6174 drawcmitrow $r
6175 if {$r == $er} break
6176 set nextid [lindex $displayorder [expr {$r + 1}]]
6177 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6178 drawparentlinks $id $r
6180 set rowids [lindex $rowidlist $r]
6181 foreach lid $rowids {
6182 if {$lid eq {}} continue
6183 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6184 if {$lid eq $id} {
6185 # see if this is the first child of any of its parents
6186 foreach p [lindex $parentlist $r] {
6187 if {[lsearch -exact $rowids $p] < 0} {
6188 # make this line extend up to the child
6189 set lineend($p) [drawlineseg $p $r $er 0]
6192 } else {
6193 set lineend($lid) [drawlineseg $lid $r $er 1]
6199 proc undolayout {row} {
6200 global uparrowlen mingaplen downarrowlen
6201 global rowidlist rowisopt rowfinal need_redisplay
6203 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6204 if {$r < 0} {
6205 set r 0
6207 if {[llength $rowidlist] > $r} {
6208 incr r -1
6209 set rowidlist [lrange $rowidlist 0 $r]
6210 set rowfinal [lrange $rowfinal 0 $r]
6211 set rowisopt [lrange $rowisopt 0 $r]
6212 set need_redisplay 1
6213 run drawvisible
6217 proc drawvisible {} {
6218 global canv linespc curview vrowmod selectedline targetrow targetid
6219 global need_redisplay cscroll numcommits
6221 set fs [$canv yview]
6222 set ymax [lindex [$canv cget -scrollregion] 3]
6223 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6224 set f0 [lindex $fs 0]
6225 set f1 [lindex $fs 1]
6226 set y0 [expr {int($f0 * $ymax)}]
6227 set y1 [expr {int($f1 * $ymax)}]
6229 if {[info exists targetid]} {
6230 if {[commitinview $targetid $curview]} {
6231 set r [rowofcommit $targetid]
6232 if {$r != $targetrow} {
6233 # Fix up the scrollregion and change the scrolling position
6234 # now that our target row has moved.
6235 set diff [expr {($r - $targetrow) * $linespc}]
6236 set targetrow $r
6237 setcanvscroll
6238 set ymax [lindex [$canv cget -scrollregion] 3]
6239 incr y0 $diff
6240 incr y1 $diff
6241 set f0 [expr {$y0 / $ymax}]
6242 set f1 [expr {$y1 / $ymax}]
6243 allcanvs yview moveto $f0
6244 $cscroll set $f0 $f1
6245 set need_redisplay 1
6247 } else {
6248 unset targetid
6252 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6253 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6254 if {$endrow >= $vrowmod($curview)} {
6255 update_arcrows $curview
6257 if {$selectedline ne {} &&
6258 $row <= $selectedline && $selectedline <= $endrow} {
6259 set targetrow $selectedline
6260 } elseif {[info exists targetid]} {
6261 set targetrow [expr {int(($row + $endrow) / 2)}]
6263 if {[info exists targetrow]} {
6264 if {$targetrow >= $numcommits} {
6265 set targetrow [expr {$numcommits - 1}]
6267 set targetid [commitonrow $targetrow]
6269 drawcommits $row $endrow
6272 proc clear_display {} {
6273 global iddrawn linesegs need_redisplay nrows_drawn
6274 global vhighlights fhighlights nhighlights rhighlights
6275 global linehtag linentag linedtag boldids boldnameids
6277 allcanvs delete all
6278 catch {unset iddrawn}
6279 catch {unset linesegs}
6280 catch {unset linehtag}
6281 catch {unset linentag}
6282 catch {unset linedtag}
6283 set boldids {}
6284 set boldnameids {}
6285 catch {unset vhighlights}
6286 catch {unset fhighlights}
6287 catch {unset nhighlights}
6288 catch {unset rhighlights}
6289 set need_redisplay 0
6290 set nrows_drawn 0
6293 proc findcrossings {id} {
6294 global rowidlist parentlist numcommits displayorder
6296 set cross {}
6297 set ccross {}
6298 foreach {s e} [rowranges $id] {
6299 if {$e >= $numcommits} {
6300 set e [expr {$numcommits - 1}]
6302 if {$e <= $s} continue
6303 for {set row $e} {[incr row -1] >= $s} {} {
6304 set x [lsearch -exact [lindex $rowidlist $row] $id]
6305 if {$x < 0} break
6306 set olds [lindex $parentlist $row]
6307 set kid [lindex $displayorder $row]
6308 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6309 if {$kidx < 0} continue
6310 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6311 foreach p $olds {
6312 set px [lsearch -exact $nextrow $p]
6313 if {$px < 0} continue
6314 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6315 if {[lsearch -exact $ccross $p] >= 0} continue
6316 if {$x == $px + ($kidx < $px? -1: 1)} {
6317 lappend ccross $p
6318 } elseif {[lsearch -exact $cross $p] < 0} {
6319 lappend cross $p
6325 return [concat $ccross {{}} $cross]
6328 proc assigncolor {id} {
6329 global colormap colors nextcolor
6330 global parents children children curview
6332 if {[info exists colormap($id)]} return
6333 set ncolors [llength $colors]
6334 if {[info exists children($curview,$id)]} {
6335 set kids $children($curview,$id)
6336 } else {
6337 set kids {}
6339 if {[llength $kids] == 1} {
6340 set child [lindex $kids 0]
6341 if {[info exists colormap($child)]
6342 && [llength $parents($curview,$child)] == 1} {
6343 set colormap($id) $colormap($child)
6344 return
6347 set badcolors {}
6348 set origbad {}
6349 foreach x [findcrossings $id] {
6350 if {$x eq {}} {
6351 # delimiter between corner crossings and other crossings
6352 if {[llength $badcolors] >= $ncolors - 1} break
6353 set origbad $badcolors
6355 if {[info exists colormap($x)]
6356 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6357 lappend badcolors $colormap($x)
6360 if {[llength $badcolors] >= $ncolors} {
6361 set badcolors $origbad
6363 set origbad $badcolors
6364 if {[llength $badcolors] < $ncolors - 1} {
6365 foreach child $kids {
6366 if {[info exists colormap($child)]
6367 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6368 lappend badcolors $colormap($child)
6370 foreach p $parents($curview,$child) {
6371 if {[info exists colormap($p)]
6372 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6373 lappend badcolors $colormap($p)
6377 if {[llength $badcolors] >= $ncolors} {
6378 set badcolors $origbad
6381 for {set i 0} {$i <= $ncolors} {incr i} {
6382 set c [lindex $colors $nextcolor]
6383 if {[incr nextcolor] >= $ncolors} {
6384 set nextcolor 0
6386 if {[lsearch -exact $badcolors $c]} break
6388 set colormap($id) $c
6391 proc bindline {t id} {
6392 global canv
6394 $canv bind $t <Enter> "lineenter %x %y $id"
6395 $canv bind $t <Motion> "linemotion %x %y $id"
6396 $canv bind $t <Leave> "lineleave $id"
6397 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6400 proc graph_pane_width {} {
6401 global use_ttk
6403 if {$use_ttk} {
6404 set g [.tf.histframe.pwclist sashpos 0]
6405 } else {
6406 set g [.tf.histframe.pwclist sash coord 0]
6408 return [lindex $g 0]
6411 proc totalwidth {l font extra} {
6412 set tot 0
6413 foreach str $l {
6414 set tot [expr {$tot + [font measure $font $str] + $extra}]
6416 return $tot
6419 proc drawtags {id x xt y1} {
6420 global idtags idheads idotherrefs mainhead
6421 global linespc lthickness
6422 global canv rowtextx curview fgcolor bgcolor ctxbut
6423 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6424 global tagbgcolor tagfgcolor tagoutlinecolor
6425 global reflinecolor
6427 set marks {}
6428 set ntags 0
6429 set nheads 0
6430 set singletag 0
6431 set maxtags 3
6432 set maxtagpct 25
6433 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6434 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6435 set extra [expr {$delta + $lthickness + $linespc}]
6437 if {[info exists idtags($id)]} {
6438 set marks $idtags($id)
6439 set ntags [llength $marks]
6440 if {$ntags > $maxtags ||
6441 [totalwidth $marks mainfont $extra] > $maxwidth} {
6442 # show just a single "n tags..." tag
6443 set singletag 1
6444 if {$ntags == 1} {
6445 set marks [list "tag..."]
6446 } else {
6447 set marks [list [format "%d tags..." $ntags]]
6449 set ntags 1
6452 if {[info exists idheads($id)]} {
6453 set marks [concat $marks $idheads($id)]
6454 set nheads [llength $idheads($id)]
6456 if {[info exists idotherrefs($id)]} {
6457 set marks [concat $marks $idotherrefs($id)]
6459 if {$marks eq {}} {
6460 return $xt
6463 set yt [expr {$y1 - 0.5 * $linespc}]
6464 set yb [expr {$yt + $linespc - 1}]
6465 set xvals {}
6466 set wvals {}
6467 set i -1
6468 foreach tag $marks {
6469 incr i
6470 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6471 set wid [font measure mainfontbold $tag]
6472 } else {
6473 set wid [font measure mainfont $tag]
6475 lappend xvals $xt
6476 lappend wvals $wid
6477 set xt [expr {$xt + $wid + $extra}]
6479 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6480 -width $lthickness -fill $reflinecolor -tags tag.$id]
6481 $canv lower $t
6482 foreach tag $marks x $xvals wid $wvals {
6483 set tag_quoted [string map {% %%} $tag]
6484 set xl [expr {$x + $delta}]
6485 set xr [expr {$x + $delta + $wid + $lthickness}]
6486 set font mainfont
6487 if {[incr ntags -1] >= 0} {
6488 # draw a tag
6489 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6490 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6491 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6492 -tags tag.$id]
6493 if {$singletag} {
6494 set tagclick [list showtags $id 1]
6495 } else {
6496 set tagclick [list showtag $tag_quoted 1]
6498 $canv bind $t <1> $tagclick
6499 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6500 } else {
6501 # draw a head or other ref
6502 if {[incr nheads -1] >= 0} {
6503 set col $headbgcolor
6504 if {$tag eq $mainhead} {
6505 set font mainfontbold
6507 } else {
6508 set col "#ddddff"
6510 set xl [expr {$xl - $delta/2}]
6511 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6512 -width 1 -outline black -fill $col -tags tag.$id
6513 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6514 set rwid [font measure mainfont $remoteprefix]
6515 set xi [expr {$x + 1}]
6516 set yti [expr {$yt + 1}]
6517 set xri [expr {$x + $rwid}]
6518 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6519 -width 0 -fill $remotebgcolor -tags tag.$id
6522 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6523 -font $font -tags [list tag.$id text]]
6524 if {$ntags >= 0} {
6525 $canv bind $t <1> $tagclick
6526 } elseif {$nheads >= 0} {
6527 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6530 return $xt
6533 proc drawnotesign {xt y} {
6534 global linespc canv fgcolor
6536 set orad [expr {$linespc / 3}]
6537 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6538 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6539 -fill yellow -outline $fgcolor -width 1 -tags circle]
6540 set xt [expr {$xt + $orad * 3}]
6541 return $xt
6544 proc xcoord {i level ln} {
6545 global canvx0 xspc1 xspc2
6547 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6548 if {$i > 0 && $i == $level} {
6549 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6550 } elseif {$i > $level} {
6551 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6553 return $x
6556 proc show_status {msg} {
6557 global canv fgcolor
6559 clear_display
6560 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6561 -tags text -fill $fgcolor
6564 # Don't change the text pane cursor if it is currently the hand cursor,
6565 # showing that we are over a sha1 ID link.
6566 proc settextcursor {c} {
6567 global ctext curtextcursor
6569 if {[$ctext cget -cursor] == $curtextcursor} {
6570 $ctext config -cursor $c
6572 set curtextcursor $c
6575 proc nowbusy {what {name {}}} {
6576 global isbusy busyname statusw
6578 if {[array names isbusy] eq {}} {
6579 . config -cursor watch
6580 settextcursor watch
6582 set isbusy($what) 1
6583 set busyname($what) $name
6584 if {$name ne {}} {
6585 $statusw conf -text $name
6589 proc notbusy {what} {
6590 global isbusy maincursor textcursor busyname statusw
6592 catch {
6593 unset isbusy($what)
6594 if {$busyname($what) ne {} &&
6595 [$statusw cget -text] eq $busyname($what)} {
6596 $statusw conf -text {}
6599 if {[array names isbusy] eq {}} {
6600 . config -cursor $maincursor
6601 settextcursor $textcursor
6605 proc findmatches {f} {
6606 global findtype findstring
6607 if {$findtype == [mc "Regexp"]} {
6608 set matches [regexp -indices -all -inline $findstring $f]
6609 } else {
6610 set fs $findstring
6611 if {$findtype == [mc "IgnCase"]} {
6612 set f [string tolower $f]
6613 set fs [string tolower $fs]
6615 set matches {}
6616 set i 0
6617 set l [string length $fs]
6618 while {[set j [string first $fs $f $i]] >= 0} {
6619 lappend matches [list $j [expr {$j+$l-1}]]
6620 set i [expr {$j + $l}]
6623 return $matches
6626 proc dofind {{dirn 1} {wrap 1}} {
6627 global findstring findstartline findcurline selectedline numcommits
6628 global gdttype filehighlight fh_serial find_dirn findallowwrap
6630 if {[info exists find_dirn]} {
6631 if {$find_dirn == $dirn} return
6632 stopfinding
6634 focus .
6635 if {$findstring eq {} || $numcommits == 0} return
6636 if {$selectedline eq {}} {
6637 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6638 } else {
6639 set findstartline $selectedline
6641 set findcurline $findstartline
6642 nowbusy finding [mc "Searching"]
6643 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6644 after cancel do_file_hl $fh_serial
6645 do_file_hl $fh_serial
6647 set find_dirn $dirn
6648 set findallowwrap $wrap
6649 run findmore
6652 proc stopfinding {} {
6653 global find_dirn findcurline fprogcoord
6655 if {[info exists find_dirn]} {
6656 unset find_dirn
6657 unset findcurline
6658 notbusy finding
6659 set fprogcoord 0
6660 adjustprogress
6662 stopblaming
6665 proc findmore {} {
6666 global commitdata commitinfo numcommits findpattern findloc
6667 global findstartline findcurline findallowwrap
6668 global find_dirn gdttype fhighlights fprogcoord
6669 global curview varcorder vrownum varccommits vrowmod
6671 if {![info exists find_dirn]} {
6672 return 0
6674 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6675 set l $findcurline
6676 set moretodo 0
6677 if {$find_dirn > 0} {
6678 incr l
6679 if {$l >= $numcommits} {
6680 set l 0
6682 if {$l <= $findstartline} {
6683 set lim [expr {$findstartline + 1}]
6684 } else {
6685 set lim $numcommits
6686 set moretodo $findallowwrap
6688 } else {
6689 if {$l == 0} {
6690 set l $numcommits
6692 incr l -1
6693 if {$l >= $findstartline} {
6694 set lim [expr {$findstartline - 1}]
6695 } else {
6696 set lim -1
6697 set moretodo $findallowwrap
6700 set n [expr {($lim - $l) * $find_dirn}]
6701 if {$n > 500} {
6702 set n 500
6703 set moretodo 1
6705 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6706 update_arcrows $curview
6708 set found 0
6709 set domore 1
6710 set ai [bsearch $vrownum($curview) $l]
6711 set a [lindex $varcorder($curview) $ai]
6712 set arow [lindex $vrownum($curview) $ai]
6713 set ids [lindex $varccommits($curview,$a)]
6714 set arowend [expr {$arow + [llength $ids]}]
6715 if {$gdttype eq [mc "containing:"]} {
6716 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6717 if {$l < $arow || $l >= $arowend} {
6718 incr ai $find_dirn
6719 set a [lindex $varcorder($curview) $ai]
6720 set arow [lindex $vrownum($curview) $ai]
6721 set ids [lindex $varccommits($curview,$a)]
6722 set arowend [expr {$arow + [llength $ids]}]
6724 set id [lindex $ids [expr {$l - $arow}]]
6725 # shouldn't happen unless git log doesn't give all the commits...
6726 if {![info exists commitdata($id)] ||
6727 ![doesmatch $commitdata($id)]} {
6728 continue
6730 if {![info exists commitinfo($id)]} {
6731 getcommit $id
6733 set info $commitinfo($id)
6734 foreach f $info ty $fldtypes {
6735 if {$ty eq ""} continue
6736 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6737 [doesmatch $f]} {
6738 set found 1
6739 break
6742 if {$found} break
6744 } else {
6745 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6746 if {$l < $arow || $l >= $arowend} {
6747 incr ai $find_dirn
6748 set a [lindex $varcorder($curview) $ai]
6749 set arow [lindex $vrownum($curview) $ai]
6750 set ids [lindex $varccommits($curview,$a)]
6751 set arowend [expr {$arow + [llength $ids]}]
6753 set id [lindex $ids [expr {$l - $arow}]]
6754 if {![info exists fhighlights($id)]} {
6755 # this sets fhighlights($id) to -1
6756 askfilehighlight $l $id
6758 if {$fhighlights($id) > 0} {
6759 set found $domore
6760 break
6762 if {$fhighlights($id) < 0} {
6763 if {$domore} {
6764 set domore 0
6765 set findcurline [expr {$l - $find_dirn}]
6770 if {$found || ($domore && !$moretodo)} {
6771 unset findcurline
6772 unset find_dirn
6773 notbusy finding
6774 set fprogcoord 0
6775 adjustprogress
6776 if {$found} {
6777 findselectline $l
6778 } else {
6779 bell
6781 return 0
6783 if {!$domore} {
6784 flushhighlights
6785 } else {
6786 set findcurline [expr {$l - $find_dirn}]
6788 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6789 if {$n < 0} {
6790 incr n $numcommits
6792 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6793 adjustprogress
6794 return $domore
6797 proc findselectline {l} {
6798 global findloc commentend ctext findcurline markingmatches gdttype
6800 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6801 set findcurline $l
6802 selectline $l 1
6803 if {$markingmatches &&
6804 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6805 # highlight the matches in the comments
6806 set f [$ctext get 1.0 $commentend]
6807 set matches [findmatches $f]
6808 foreach match $matches {
6809 set start [lindex $match 0]
6810 set end [expr {[lindex $match 1] + 1}]
6811 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6814 drawvisible
6817 # mark the bits of a headline or author that match a find string
6818 proc markmatches {canv l str tag matches font row} {
6819 global selectedline
6821 set bbox [$canv bbox $tag]
6822 set x0 [lindex $bbox 0]
6823 set y0 [lindex $bbox 1]
6824 set y1 [lindex $bbox 3]
6825 foreach match $matches {
6826 set start [lindex $match 0]
6827 set end [lindex $match 1]
6828 if {$start > $end} continue
6829 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6830 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6831 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6832 [expr {$x0+$xlen+2}] $y1 \
6833 -outline {} -tags [list match$l matches] -fill yellow]
6834 $canv lower $t
6835 if {$row == $selectedline} {
6836 $canv raise $t secsel
6841 proc unmarkmatches {} {
6842 global markingmatches
6844 allcanvs delete matches
6845 set markingmatches 0
6846 stopfinding
6849 proc selcanvline {w x y} {
6850 global canv canvy0 ctext linespc
6851 global rowtextx
6852 set ymax [lindex [$canv cget -scrollregion] 3]
6853 if {$ymax == {}} return
6854 set yfrac [lindex [$canv yview] 0]
6855 set y [expr {$y + $yfrac * $ymax}]
6856 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6857 if {$l < 0} {
6858 set l 0
6860 if {$w eq $canv} {
6861 set xmax [lindex [$canv cget -scrollregion] 2]
6862 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6863 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6865 unmarkmatches
6866 selectline $l 1
6869 proc commit_descriptor {p} {
6870 global commitinfo
6871 if {![info exists commitinfo($p)]} {
6872 getcommit $p
6874 set l "..."
6875 if {[llength $commitinfo($p)] > 1} {
6876 set l [lindex $commitinfo($p) 0]
6878 return "$p ($l)\n"
6881 # append some text to the ctext widget, and make any SHA1 ID
6882 # that we know about be a clickable link.
6883 proc appendwithlinks {text tags} {
6884 global ctext linknum curview
6886 set start [$ctext index "end - 1c"]
6887 $ctext insert end $text $tags
6888 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6889 foreach l $links {
6890 set s [lindex $l 0]
6891 set e [lindex $l 1]
6892 set linkid [string range $text $s $e]
6893 incr e
6894 $ctext tag delete link$linknum
6895 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6896 setlink $linkid link$linknum
6897 incr linknum
6901 proc setlink {id lk} {
6902 global curview ctext pendinglinks
6903 global linkfgcolor
6905 if {[string range $id 0 1] eq "-g"} {
6906 set id [string range $id 2 end]
6909 set known 0
6910 if {[string length $id] < 40} {
6911 set matches [longid $id]
6912 if {[llength $matches] > 0} {
6913 if {[llength $matches] > 1} return
6914 set known 1
6915 set id [lindex $matches 0]
6917 } else {
6918 set known [commitinview $id $curview]
6920 if {$known} {
6921 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
6922 $ctext tag bind $lk <1> [list selbyid $id]
6923 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6924 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6925 } else {
6926 lappend pendinglinks($id) $lk
6927 interestedin $id {makelink %P}
6931 proc appendshortlink {id {pre {}} {post {}}} {
6932 global ctext linknum
6934 $ctext insert end $pre
6935 $ctext tag delete link$linknum
6936 $ctext insert end [string range $id 0 7] link$linknum
6937 $ctext insert end $post
6938 setlink $id link$linknum
6939 incr linknum
6942 proc makelink {id} {
6943 global pendinglinks
6945 if {![info exists pendinglinks($id)]} return
6946 foreach lk $pendinglinks($id) {
6947 setlink $id $lk
6949 unset pendinglinks($id)
6952 proc linkcursor {w inc} {
6953 global linkentercount curtextcursor
6955 if {[incr linkentercount $inc] > 0} {
6956 $w configure -cursor hand2
6957 } else {
6958 $w configure -cursor $curtextcursor
6959 if {$linkentercount < 0} {
6960 set linkentercount 0
6965 proc viewnextline {dir} {
6966 global canv linespc
6968 $canv delete hover
6969 set ymax [lindex [$canv cget -scrollregion] 3]
6970 set wnow [$canv yview]
6971 set wtop [expr {[lindex $wnow 0] * $ymax}]
6972 set newtop [expr {$wtop + $dir * $linespc}]
6973 if {$newtop < 0} {
6974 set newtop 0
6975 } elseif {$newtop > $ymax} {
6976 set newtop $ymax
6978 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6981 # add a list of tag or branch names at position pos
6982 # returns the number of names inserted
6983 proc appendrefs {pos ids var} {
6984 global ctext linknum curview $var maxrefs visiblerefs mainheadid
6986 if {[catch {$ctext index $pos}]} {
6987 return 0
6989 $ctext conf -state normal
6990 $ctext delete $pos "$pos lineend"
6991 set tags {}
6992 foreach id $ids {
6993 foreach tag [set $var\($id\)] {
6994 lappend tags [list $tag $id]
6998 set sep {}
6999 set tags [lsort -index 0 -decreasing $tags]
7000 set nutags 0
7002 if {[llength $tags] > $maxrefs} {
7003 # If we are displaying heads, and there are too many,
7004 # see if there are some important heads to display.
7005 # Currently that are the current head and heads listed in $visiblerefs option
7006 set itags {}
7007 if {$var eq "idheads"} {
7008 set utags {}
7009 foreach ti $tags {
7010 set hname [lindex $ti 0]
7011 set id [lindex $ti 1]
7012 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7013 [llength $itags] < $maxrefs} {
7014 lappend itags $ti
7015 } else {
7016 lappend utags $ti
7019 set tags $utags
7021 if {$itags ne {}} {
7022 set str [mc "and many more"]
7023 set sep " "
7024 } else {
7025 set str [mc "many"]
7027 $ctext insert $pos "$str ([llength $tags])"
7028 set nutags [llength $tags]
7029 set tags $itags
7032 foreach ti $tags {
7033 set id [lindex $ti 1]
7034 set lk link$linknum
7035 incr linknum
7036 $ctext tag delete $lk
7037 $ctext insert $pos $sep
7038 $ctext insert $pos [lindex $ti 0] $lk
7039 setlink $id $lk
7040 set sep ", "
7042 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7043 $ctext conf -state disabled
7044 return [expr {[llength $tags] + $nutags}]
7047 # called when we have finished computing the nearby tags
7048 proc dispneartags {delay} {
7049 global selectedline currentid showneartags tagphase
7051 if {$selectedline eq {} || !$showneartags} return
7052 after cancel dispnexttag
7053 if {$delay} {
7054 after 200 dispnexttag
7055 set tagphase -1
7056 } else {
7057 after idle dispnexttag
7058 set tagphase 0
7062 proc dispnexttag {} {
7063 global selectedline currentid showneartags tagphase ctext
7065 if {$selectedline eq {} || !$showneartags} return
7066 switch -- $tagphase {
7068 set dtags [desctags $currentid]
7069 if {$dtags ne {}} {
7070 appendrefs precedes $dtags idtags
7074 set atags [anctags $currentid]
7075 if {$atags ne {}} {
7076 appendrefs follows $atags idtags
7080 set dheads [descheads $currentid]
7081 if {$dheads ne {}} {
7082 if {[appendrefs branch $dheads idheads] > 1
7083 && [$ctext get "branch -3c"] eq "h"} {
7084 # turn "Branch" into "Branches"
7085 $ctext conf -state normal
7086 $ctext insert "branch -2c" "es"
7087 $ctext conf -state disabled
7092 if {[incr tagphase] <= 2} {
7093 after idle dispnexttag
7097 proc make_secsel {id} {
7098 global linehtag linentag linedtag canv canv2 canv3
7100 if {![info exists linehtag($id)]} return
7101 $canv delete secsel
7102 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7103 -tags secsel -fill [$canv cget -selectbackground]]
7104 $canv lower $t
7105 $canv2 delete secsel
7106 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7107 -tags secsel -fill [$canv2 cget -selectbackground]]
7108 $canv2 lower $t
7109 $canv3 delete secsel
7110 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7111 -tags secsel -fill [$canv3 cget -selectbackground]]
7112 $canv3 lower $t
7115 proc make_idmark {id} {
7116 global linehtag canv fgcolor
7118 if {![info exists linehtag($id)]} return
7119 $canv delete markid
7120 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7121 -tags markid -outline $fgcolor]
7122 $canv raise $t
7125 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7126 global canv ctext commitinfo selectedline
7127 global canvy0 linespc parents children curview
7128 global currentid sha1entry
7129 global commentend idtags linknum
7130 global mergemax numcommits pending_select
7131 global cmitmode showneartags allcommits
7132 global targetrow targetid lastscrollrows
7133 global autoselect autosellen jump_to_here
7134 global vinlinediff
7136 catch {unset pending_select}
7137 $canv delete hover
7138 normalline
7139 unsel_reflist
7140 stopfinding
7141 if {$l < 0 || $l >= $numcommits} return
7142 set id [commitonrow $l]
7143 set targetid $id
7144 set targetrow $l
7145 set selectedline $l
7146 set currentid $id
7147 if {$lastscrollrows < $numcommits} {
7148 setcanvscroll
7151 if {$cmitmode ne "patch" && $switch_to_patch} {
7152 set cmitmode "patch"
7155 set y [expr {$canvy0 + $l * $linespc}]
7156 set ymax [lindex [$canv cget -scrollregion] 3]
7157 set ytop [expr {$y - $linespc - 1}]
7158 set ybot [expr {$y + $linespc + 1}]
7159 set wnow [$canv yview]
7160 set wtop [expr {[lindex $wnow 0] * $ymax}]
7161 set wbot [expr {[lindex $wnow 1] * $ymax}]
7162 set wh [expr {$wbot - $wtop}]
7163 set newtop $wtop
7164 if {$ytop < $wtop} {
7165 if {$ybot < $wtop} {
7166 set newtop [expr {$y - $wh / 2.0}]
7167 } else {
7168 set newtop $ytop
7169 if {$newtop > $wtop - $linespc} {
7170 set newtop [expr {$wtop - $linespc}]
7173 } elseif {$ybot > $wbot} {
7174 if {$ytop > $wbot} {
7175 set newtop [expr {$y - $wh / 2.0}]
7176 } else {
7177 set newtop [expr {$ybot - $wh}]
7178 if {$newtop < $wtop + $linespc} {
7179 set newtop [expr {$wtop + $linespc}]
7183 if {$newtop != $wtop} {
7184 if {$newtop < 0} {
7185 set newtop 0
7187 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7188 drawvisible
7191 make_secsel $id
7193 if {$isnew} {
7194 addtohistory [list selbyid $id 0] savecmitpos
7197 $sha1entry delete 0 end
7198 $sha1entry insert 0 $id
7199 if {$autoselect} {
7200 $sha1entry selection range 0 $autosellen
7202 rhighlight_sel $id
7204 $ctext conf -state normal
7205 clear_ctext
7206 set linknum 0
7207 if {![info exists commitinfo($id)]} {
7208 getcommit $id
7210 set info $commitinfo($id)
7211 set date [formatdate [lindex $info 2]]
7212 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7213 set date [formatdate [lindex $info 4]]
7214 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7215 if {[info exists idtags($id)]} {
7216 $ctext insert end [mc "Tags:"]
7217 foreach tag $idtags($id) {
7218 $ctext insert end " $tag"
7220 $ctext insert end "\n"
7223 set headers {}
7224 set olds $parents($curview,$id)
7225 if {[llength $olds] > 1} {
7226 set np 0
7227 foreach p $olds {
7228 if {$np >= $mergemax} {
7229 set tag mmax
7230 } else {
7231 set tag m$np
7233 $ctext insert end "[mc "Parent"]: " $tag
7234 appendwithlinks [commit_descriptor $p] {}
7235 incr np
7237 } else {
7238 foreach p $olds {
7239 append headers "[mc "Parent"]: [commit_descriptor $p]"
7243 foreach c $children($curview,$id) {
7244 append headers "[mc "Child"]: [commit_descriptor $c]"
7247 # make anything that looks like a SHA1 ID be a clickable link
7248 appendwithlinks $headers {}
7249 if {$showneartags} {
7250 if {![info exists allcommits]} {
7251 getallcommits
7253 $ctext insert end "[mc "Branch"]: "
7254 $ctext mark set branch "end -1c"
7255 $ctext mark gravity branch left
7256 $ctext insert end "\n[mc "Follows"]: "
7257 $ctext mark set follows "end -1c"
7258 $ctext mark gravity follows left
7259 $ctext insert end "\n[mc "Precedes"]: "
7260 $ctext mark set precedes "end -1c"
7261 $ctext mark gravity precedes left
7262 $ctext insert end "\n"
7263 dispneartags 1
7265 $ctext insert end "\n"
7266 set comment [lindex $info 5]
7267 if {[string first "\r" $comment] >= 0} {
7268 set comment [string map {"\r" "\n "} $comment]
7270 appendwithlinks $comment {comment}
7272 $ctext tag remove found 1.0 end
7273 $ctext conf -state disabled
7274 set commentend [$ctext index "end - 1c"]
7276 set jump_to_here $desired_loc
7277 init_flist [mc "Comments"]
7278 if {$cmitmode eq "tree"} {
7279 gettree $id
7280 } elseif {$vinlinediff($curview) == 1} {
7281 showinlinediff $id
7282 } elseif {[llength $olds] <= 1} {
7283 startdiff $id
7284 } else {
7285 mergediff $id
7289 proc selfirstline {} {
7290 unmarkmatches
7291 selectline 0 1
7294 proc sellastline {} {
7295 global numcommits
7296 unmarkmatches
7297 set l [expr {$numcommits - 1}]
7298 selectline $l 1
7301 proc selnextline {dir} {
7302 global selectedline
7303 focus .
7304 if {$selectedline eq {}} return
7305 set l [expr {$selectedline + $dir}]
7306 unmarkmatches
7307 selectline $l 1
7310 proc selnextpage {dir} {
7311 global canv linespc selectedline numcommits
7313 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7314 if {$lpp < 1} {
7315 set lpp 1
7317 allcanvs yview scroll [expr {$dir * $lpp}] units
7318 drawvisible
7319 if {$selectedline eq {}} return
7320 set l [expr {$selectedline + $dir * $lpp}]
7321 if {$l < 0} {
7322 set l 0
7323 } elseif {$l >= $numcommits} {
7324 set l [expr $numcommits - 1]
7326 unmarkmatches
7327 selectline $l 1
7330 proc unselectline {} {
7331 global selectedline currentid
7333 set selectedline {}
7334 catch {unset currentid}
7335 allcanvs delete secsel
7336 rhighlight_none
7339 proc reselectline {} {
7340 global selectedline
7342 if {$selectedline ne {}} {
7343 selectline $selectedline 0
7347 proc addtohistory {cmd {saveproc {}}} {
7348 global history historyindex curview
7350 unset_posvars
7351 save_position
7352 set elt [list $curview $cmd $saveproc {}]
7353 if {$historyindex > 0
7354 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7355 return
7358 if {$historyindex < [llength $history]} {
7359 set history [lreplace $history $historyindex end $elt]
7360 } else {
7361 lappend history $elt
7363 incr historyindex
7364 if {$historyindex > 1} {
7365 .tf.bar.leftbut conf -state normal
7366 } else {
7367 .tf.bar.leftbut conf -state disabled
7369 .tf.bar.rightbut conf -state disabled
7372 # save the scrolling position of the diff display pane
7373 proc save_position {} {
7374 global historyindex history
7376 if {$historyindex < 1} return
7377 set hi [expr {$historyindex - 1}]
7378 set fn [lindex $history $hi 2]
7379 if {$fn ne {}} {
7380 lset history $hi 3 [eval $fn]
7384 proc unset_posvars {} {
7385 global last_posvars
7387 if {[info exists last_posvars]} {
7388 foreach {var val} $last_posvars {
7389 global $var
7390 catch {unset $var}
7392 unset last_posvars
7396 proc godo {elt} {
7397 global curview last_posvars
7399 set view [lindex $elt 0]
7400 set cmd [lindex $elt 1]
7401 set pv [lindex $elt 3]
7402 if {$curview != $view} {
7403 showview $view
7405 unset_posvars
7406 foreach {var val} $pv {
7407 global $var
7408 set $var $val
7410 set last_posvars $pv
7411 eval $cmd
7414 proc goback {} {
7415 global history historyindex
7416 focus .
7418 if {$historyindex > 1} {
7419 save_position
7420 incr historyindex -1
7421 godo [lindex $history [expr {$historyindex - 1}]]
7422 .tf.bar.rightbut conf -state normal
7424 if {$historyindex <= 1} {
7425 .tf.bar.leftbut conf -state disabled
7429 proc goforw {} {
7430 global history historyindex
7431 focus .
7433 if {$historyindex < [llength $history]} {
7434 save_position
7435 set cmd [lindex $history $historyindex]
7436 incr historyindex
7437 godo $cmd
7438 .tf.bar.leftbut conf -state normal
7440 if {$historyindex >= [llength $history]} {
7441 .tf.bar.rightbut conf -state disabled
7445 proc go_to_parent {i} {
7446 global parents curview targetid
7447 set ps $parents($curview,$targetid)
7448 if {[llength $ps] >= $i} {
7449 selbyid [lindex $ps [expr $i - 1]]
7453 proc gettree {id} {
7454 global treefilelist treeidlist diffids diffmergeid treepending
7455 global nullid nullid2
7457 set diffids $id
7458 catch {unset diffmergeid}
7459 if {![info exists treefilelist($id)]} {
7460 if {![info exists treepending]} {
7461 if {$id eq $nullid} {
7462 set cmd [list | git ls-files]
7463 } elseif {$id eq $nullid2} {
7464 set cmd [list | git ls-files --stage -t]
7465 } else {
7466 set cmd [list | git ls-tree -r $id]
7468 if {[catch {set gtf [open $cmd r]}]} {
7469 return
7471 set treepending $id
7472 set treefilelist($id) {}
7473 set treeidlist($id) {}
7474 fconfigure $gtf -blocking 0 -encoding binary
7475 filerun $gtf [list gettreeline $gtf $id]
7477 } else {
7478 setfilelist $id
7482 proc gettreeline {gtf id} {
7483 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7485 set nl 0
7486 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7487 if {$diffids eq $nullid} {
7488 set fname $line
7489 } else {
7490 set i [string first "\t" $line]
7491 if {$i < 0} continue
7492 set fname [string range $line [expr {$i+1}] end]
7493 set line [string range $line 0 [expr {$i-1}]]
7494 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7495 set sha1 [lindex $line 2]
7496 lappend treeidlist($id) $sha1
7498 if {[string index $fname 0] eq "\""} {
7499 set fname [lindex $fname 0]
7501 set fname [encoding convertfrom $fname]
7502 lappend treefilelist($id) $fname
7504 if {![eof $gtf]} {
7505 return [expr {$nl >= 1000? 2: 1}]
7507 close $gtf
7508 unset treepending
7509 if {$cmitmode ne "tree"} {
7510 if {![info exists diffmergeid]} {
7511 gettreediffs $diffids
7513 } elseif {$id ne $diffids} {
7514 gettree $diffids
7515 } else {
7516 setfilelist $id
7518 return 0
7521 proc showfile {f} {
7522 global treefilelist treeidlist diffids nullid nullid2
7523 global ctext_file_names ctext_file_lines
7524 global ctext commentend
7526 set i [lsearch -exact $treefilelist($diffids) $f]
7527 if {$i < 0} {
7528 puts "oops, $f not in list for id $diffids"
7529 return
7531 if {$diffids eq $nullid} {
7532 if {[catch {set bf [open $f r]} err]} {
7533 puts "oops, can't read $f: $err"
7534 return
7536 } else {
7537 set blob [lindex $treeidlist($diffids) $i]
7538 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7539 puts "oops, error reading blob $blob: $err"
7540 return
7543 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7544 filerun $bf [list getblobline $bf $diffids]
7545 $ctext config -state normal
7546 clear_ctext $commentend
7547 lappend ctext_file_names $f
7548 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7549 $ctext insert end "\n"
7550 $ctext insert end "$f\n" filesep
7551 $ctext config -state disabled
7552 $ctext yview $commentend
7553 settabs 0
7556 proc getblobline {bf id} {
7557 global diffids cmitmode ctext
7559 if {$id ne $diffids || $cmitmode ne "tree"} {
7560 catch {close $bf}
7561 return 0
7563 $ctext config -state normal
7564 set nl 0
7565 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7566 $ctext insert end "$line\n"
7568 if {[eof $bf]} {
7569 global jump_to_here ctext_file_names commentend
7571 # delete last newline
7572 $ctext delete "end - 2c" "end - 1c"
7573 close $bf
7574 if {$jump_to_here ne {} &&
7575 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7576 set lnum [expr {[lindex $jump_to_here 1] +
7577 [lindex [split $commentend .] 0]}]
7578 mark_ctext_line $lnum
7580 $ctext config -state disabled
7581 return 0
7583 $ctext config -state disabled
7584 return [expr {$nl >= 1000? 2: 1}]
7587 proc mark_ctext_line {lnum} {
7588 global ctext markbgcolor
7590 $ctext tag delete omark
7591 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7592 $ctext tag conf omark -background $markbgcolor
7593 $ctext see $lnum.0
7596 proc mergediff {id} {
7597 global diffmergeid
7598 global diffids treediffs
7599 global parents curview
7601 set diffmergeid $id
7602 set diffids $id
7603 set treediffs($id) {}
7604 set np [llength $parents($curview,$id)]
7605 settabs $np
7606 getblobdiffs $id
7609 proc startdiff {ids} {
7610 global treediffs diffids treepending diffmergeid nullid nullid2
7612 settabs 1
7613 set diffids $ids
7614 catch {unset diffmergeid}
7615 if {![info exists treediffs($ids)] ||
7616 [lsearch -exact $ids $nullid] >= 0 ||
7617 [lsearch -exact $ids $nullid2] >= 0} {
7618 if {![info exists treepending]} {
7619 gettreediffs $ids
7621 } else {
7622 addtocflist $ids
7626 proc showinlinediff {ids} {
7627 global commitinfo commitdata ctext
7628 global treediffs
7630 set info $commitinfo($ids)
7631 set diff [lindex $info 7]
7632 set difflines [split $diff "\n"]
7634 initblobdiffvars
7635 set treediff {}
7637 set inhdr 0
7638 foreach line $difflines {
7639 if {![string compare -length 5 "diff " $line]} {
7640 set inhdr 1
7641 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7642 # offset also accounts for the b/ prefix
7643 lappend treediff [string range $line 6 end]
7644 set inhdr 0
7648 set treediffs($ids) $treediff
7649 add_flist $treediff
7651 $ctext conf -state normal
7652 foreach line $difflines {
7653 parseblobdiffline $ids $line
7655 maybe_scroll_ctext 1
7656 $ctext conf -state disabled
7659 # If the filename (name) is under any of the passed filter paths
7660 # then return true to include the file in the listing.
7661 proc path_filter {filter name} {
7662 set worktree [gitworktree]
7663 foreach p $filter {
7664 set fq_p [file normalize $p]
7665 set fq_n [file normalize [file join $worktree $name]]
7666 if {[string match [file normalize $fq_p]* $fq_n]} {
7667 return 1
7670 return 0
7673 proc addtocflist {ids} {
7674 global treediffs
7676 add_flist $treediffs($ids)
7677 getblobdiffs $ids
7680 proc diffcmd {ids flags} {
7681 global log_showroot nullid nullid2 git_version
7683 set i [lsearch -exact $ids $nullid]
7684 set j [lsearch -exact $ids $nullid2]
7685 if {$i >= 0} {
7686 if {[llength $ids] > 1 && $j < 0} {
7687 # comparing working directory with some specific revision
7688 set cmd [concat | git diff-index $flags]
7689 if {$i == 0} {
7690 lappend cmd -R [lindex $ids 1]
7691 } else {
7692 lappend cmd [lindex $ids 0]
7694 } else {
7695 # comparing working directory with index
7696 set cmd [concat | git diff-files $flags]
7697 if {$j == 1} {
7698 lappend cmd -R
7701 } elseif {$j >= 0} {
7702 if {[package vcompare $git_version "1.7.2"] >= 0} {
7703 set flags "$flags --ignore-submodules=dirty"
7705 set cmd [concat | git diff-index --cached $flags]
7706 if {[llength $ids] > 1} {
7707 # comparing index with specific revision
7708 if {$j == 0} {
7709 lappend cmd -R [lindex $ids 1]
7710 } else {
7711 lappend cmd [lindex $ids 0]
7713 } else {
7714 # comparing index with HEAD
7715 lappend cmd HEAD
7717 } else {
7718 if {$log_showroot} {
7719 lappend flags --root
7721 set cmd [concat | git diff-tree -r $flags $ids]
7723 return $cmd
7726 proc gettreediffs {ids} {
7727 global treediff treepending limitdiffs vfilelimit curview
7729 set cmd [diffcmd $ids {--no-commit-id}]
7730 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7731 set cmd [concat $cmd -- $vfilelimit($curview)]
7733 if {[catch {set gdtf [open $cmd r]}]} return
7735 set treepending $ids
7736 set treediff {}
7737 fconfigure $gdtf -blocking 0 -encoding binary
7738 filerun $gdtf [list gettreediffline $gdtf $ids]
7741 proc gettreediffline {gdtf ids} {
7742 global treediff treediffs treepending diffids diffmergeid
7743 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7745 set nr 0
7746 set sublist {}
7747 set max 1000
7748 if {$perfile_attrs} {
7749 # cache_gitattr is slow, and even slower on win32 where we
7750 # have to invoke it for only about 30 paths at a time
7751 set max 500
7752 if {[tk windowingsystem] == "win32"} {
7753 set max 120
7756 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7757 set i [string first "\t" $line]
7758 if {$i >= 0} {
7759 set file [string range $line [expr {$i+1}] end]
7760 if {[string index $file 0] eq "\""} {
7761 set file [lindex $file 0]
7763 set file [encoding convertfrom $file]
7764 if {$file ne [lindex $treediff end]} {
7765 lappend treediff $file
7766 lappend sublist $file
7770 if {$perfile_attrs} {
7771 cache_gitattr encoding $sublist
7773 if {![eof $gdtf]} {
7774 return [expr {$nr >= $max? 2: 1}]
7776 close $gdtf
7777 set treediffs($ids) $treediff
7778 unset treepending
7779 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7780 gettree $diffids
7781 } elseif {$ids != $diffids} {
7782 if {![info exists diffmergeid]} {
7783 gettreediffs $diffids
7785 } else {
7786 addtocflist $ids
7788 return 0
7791 # empty string or positive integer
7792 proc diffcontextvalidate {v} {
7793 return [regexp {^(|[1-9][0-9]*)$} $v]
7796 proc diffcontextchange {n1 n2 op} {
7797 global diffcontextstring diffcontext
7799 if {[string is integer -strict $diffcontextstring]} {
7800 if {$diffcontextstring >= 0} {
7801 set diffcontext $diffcontextstring
7802 reselectline
7807 proc changeignorespace {} {
7808 reselectline
7811 proc changeworddiff {name ix op} {
7812 reselectline
7815 proc initblobdiffvars {} {
7816 global diffencoding targetline diffnparents
7817 global diffinhdr currdiffsubmod diffseehere
7818 set targetline {}
7819 set diffnparents 0
7820 set diffinhdr 0
7821 set diffencoding [get_path_encoding {}]
7822 set currdiffsubmod ""
7823 set diffseehere -1
7826 proc getblobdiffs {ids} {
7827 global blobdifffd diffids env
7828 global treediffs
7829 global diffcontext
7830 global ignorespace
7831 global worddiff
7832 global limitdiffs vfilelimit curview
7833 global git_version
7835 set textconv {}
7836 if {[package vcompare $git_version "1.6.1"] >= 0} {
7837 set textconv "--textconv"
7839 set submodule {}
7840 if {[package vcompare $git_version "1.6.6"] >= 0} {
7841 set submodule "--submodule"
7843 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7844 if {$ignorespace} {
7845 append cmd " -w"
7847 if {$worddiff ne [mc "Line diff"]} {
7848 append cmd " --word-diff=porcelain"
7850 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7851 set cmd [concat $cmd -- $vfilelimit($curview)]
7853 if {[catch {set bdf [open $cmd r]} err]} {
7854 error_popup [mc "Error getting diffs: %s" $err]
7855 return
7857 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7858 set blobdifffd($ids) $bdf
7859 initblobdiffvars
7860 filerun $bdf [list getblobdiffline $bdf $diffids]
7863 proc savecmitpos {} {
7864 global ctext cmitmode
7866 if {$cmitmode eq "tree"} {
7867 return {}
7869 return [list target_scrollpos [$ctext index @0,0]]
7872 proc savectextpos {} {
7873 global ctext
7875 return [list target_scrollpos [$ctext index @0,0]]
7878 proc maybe_scroll_ctext {ateof} {
7879 global ctext target_scrollpos
7881 if {![info exists target_scrollpos]} return
7882 if {!$ateof} {
7883 set nlines [expr {[winfo height $ctext]
7884 / [font metrics textfont -linespace]}]
7885 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7887 $ctext yview $target_scrollpos
7888 unset target_scrollpos
7891 proc setinlist {var i val} {
7892 global $var
7894 while {[llength [set $var]] < $i} {
7895 lappend $var {}
7897 if {[llength [set $var]] == $i} {
7898 lappend $var $val
7899 } else {
7900 lset $var $i $val
7904 proc makediffhdr {fname ids} {
7905 global ctext curdiffstart treediffs diffencoding
7906 global ctext_file_names jump_to_here targetline diffline
7908 set fname [encoding convertfrom $fname]
7909 set diffencoding [get_path_encoding $fname]
7910 set i [lsearch -exact $treediffs($ids) $fname]
7911 if {$i >= 0} {
7912 setinlist difffilestart $i $curdiffstart
7914 lset ctext_file_names end $fname
7915 set l [expr {(78 - [string length $fname]) / 2}]
7916 set pad [string range "----------------------------------------" 1 $l]
7917 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7918 set targetline {}
7919 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7920 set targetline [lindex $jump_to_here 1]
7922 set diffline 0
7925 proc blobdiffmaybeseehere {ateof} {
7926 global diffseehere
7927 if {$diffseehere >= 0} {
7928 mark_ctext_line [lindex [split $diffseehere .] 0]
7930 maybe_scroll_ctext $ateof
7933 proc getblobdiffline {bdf ids} {
7934 global diffids blobdifffd
7935 global ctext
7937 set nr 0
7938 $ctext conf -state normal
7939 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7940 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7941 catch {close $bdf}
7942 return 0
7944 parseblobdiffline $ids $line
7946 $ctext conf -state disabled
7947 blobdiffmaybeseehere [eof $bdf]
7948 if {[eof $bdf]} {
7949 catch {close $bdf}
7950 return 0
7952 return [expr {$nr >= 1000? 2: 1}]
7955 proc parseblobdiffline {ids line} {
7956 global ctext curdiffstart
7957 global diffnexthead diffnextnote difffilestart
7958 global ctext_file_names ctext_file_lines
7959 global diffinhdr treediffs mergemax diffnparents
7960 global diffencoding jump_to_here targetline diffline currdiffsubmod
7961 global worddiff diffseehere
7963 if {![string compare -length 5 "diff " $line]} {
7964 if {![regexp {^diff (--cc|--git) } $line m type]} {
7965 set line [encoding convertfrom $line]
7966 $ctext insert end "$line\n" hunksep
7967 continue
7969 # start of a new file
7970 set diffinhdr 1
7971 $ctext insert end "\n"
7972 set curdiffstart [$ctext index "end - 1c"]
7973 lappend ctext_file_names ""
7974 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7975 $ctext insert end "\n" filesep
7977 if {$type eq "--cc"} {
7978 # start of a new file in a merge diff
7979 set fname [string range $line 10 end]
7980 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7981 lappend treediffs($ids) $fname
7982 add_flist [list $fname]
7985 } else {
7986 set line [string range $line 11 end]
7987 # If the name hasn't changed the length will be odd,
7988 # the middle char will be a space, and the two bits either
7989 # side will be a/name and b/name, or "a/name" and "b/name".
7990 # If the name has changed we'll get "rename from" and
7991 # "rename to" or "copy from" and "copy to" lines following
7992 # this, and we'll use them to get the filenames.
7993 # This complexity is necessary because spaces in the
7994 # filename(s) don't get escaped.
7995 set l [string length $line]
7996 set i [expr {$l / 2}]
7997 if {!(($l & 1) && [string index $line $i] eq " " &&
7998 [string range $line 2 [expr {$i - 1}]] eq \
7999 [string range $line [expr {$i + 3}] end])} {
8000 return
8002 # unescape if quoted and chop off the a/ from the front
8003 if {[string index $line 0] eq "\""} {
8004 set fname [string range [lindex $line 0] 2 end]
8005 } else {
8006 set fname [string range $line 2 [expr {$i - 1}]]
8009 makediffhdr $fname $ids
8011 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8012 set fname [encoding convertfrom [string range $line 16 end]]
8013 $ctext insert end "\n"
8014 set curdiffstart [$ctext index "end - 1c"]
8015 lappend ctext_file_names $fname
8016 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8017 $ctext insert end "$line\n" filesep
8018 set i [lsearch -exact $treediffs($ids) $fname]
8019 if {$i >= 0} {
8020 setinlist difffilestart $i $curdiffstart
8023 } elseif {![string compare -length 2 "@@" $line]} {
8024 regexp {^@@+} $line ats
8025 set line [encoding convertfrom $diffencoding $line]
8026 $ctext insert end "$line\n" hunksep
8027 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8028 set diffline $nl
8030 set diffnparents [expr {[string length $ats] - 1}]
8031 set diffinhdr 0
8033 } elseif {![string compare -length 10 "Submodule " $line]} {
8034 # start of a new submodule
8035 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8036 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8037 } else {
8038 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8040 if {$currdiffsubmod != $fname} {
8041 $ctext insert end "\n"; # Add newline after commit message
8043 set curdiffstart [$ctext index "end - 1c"]
8044 lappend ctext_file_names ""
8045 if {$currdiffsubmod != $fname} {
8046 lappend ctext_file_lines $fname
8047 makediffhdr $fname $ids
8048 set currdiffsubmod $fname
8049 $ctext insert end "\n$line\n" filesep
8050 } else {
8051 $ctext insert end "$line\n" filesep
8053 } elseif {![string compare -length 3 " >" $line]} {
8054 set $currdiffsubmod ""
8055 set line [encoding convertfrom $diffencoding $line]
8056 $ctext insert end "$line\n" dresult
8057 } elseif {![string compare -length 3 " <" $line]} {
8058 set $currdiffsubmod ""
8059 set line [encoding convertfrom $diffencoding $line]
8060 $ctext insert end "$line\n" d0
8061 } elseif {$diffinhdr} {
8062 if {![string compare -length 12 "rename from " $line]} {
8063 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8064 if {[string index $fname 0] eq "\""} {
8065 set fname [lindex $fname 0]
8067 set fname [encoding convertfrom $fname]
8068 set i [lsearch -exact $treediffs($ids) $fname]
8069 if {$i >= 0} {
8070 setinlist difffilestart $i $curdiffstart
8072 } elseif {![string compare -length 10 $line "rename to "] ||
8073 ![string compare -length 8 $line "copy to "]} {
8074 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8075 if {[string index $fname 0] eq "\""} {
8076 set fname [lindex $fname 0]
8078 makediffhdr $fname $ids
8079 } elseif {[string compare -length 3 $line "---"] == 0} {
8080 # do nothing
8081 return
8082 } elseif {[string compare -length 3 $line "+++"] == 0} {
8083 set diffinhdr 0
8084 return
8086 $ctext insert end "$line\n" filesep
8088 } else {
8089 set line [string map {\x1A ^Z} \
8090 [encoding convertfrom $diffencoding $line]]
8091 # parse the prefix - one ' ', '-' or '+' for each parent
8092 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8093 set tag [expr {$diffnparents > 1? "m": "d"}]
8094 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8095 set words_pre_markup ""
8096 set words_post_markup ""
8097 if {[string trim $prefix " -+"] eq {}} {
8098 # prefix only has " ", "-" and "+" in it: normal diff line
8099 set num [string first "-" $prefix]
8100 if {$dowords} {
8101 set line [string range $line 1 end]
8103 if {$num >= 0} {
8104 # removed line, first parent with line is $num
8105 if {$num >= $mergemax} {
8106 set num "max"
8108 if {$dowords && $worddiff eq [mc "Markup words"]} {
8109 $ctext insert end "\[-$line-\]" $tag$num
8110 } else {
8111 $ctext insert end "$line" $tag$num
8113 if {!$dowords} {
8114 $ctext insert end "\n" $tag$num
8116 } else {
8117 set tags {}
8118 if {[string first "+" $prefix] >= 0} {
8119 # added line
8120 lappend tags ${tag}result
8121 if {$diffnparents > 1} {
8122 set num [string first " " $prefix]
8123 if {$num >= 0} {
8124 if {$num >= $mergemax} {
8125 set num "max"
8127 lappend tags m$num
8130 set words_pre_markup "{+"
8131 set words_post_markup "+}"
8133 if {$targetline ne {}} {
8134 if {$diffline == $targetline} {
8135 set diffseehere [$ctext index "end - 1 chars"]
8136 set targetline {}
8137 } else {
8138 incr diffline
8141 if {$dowords && $worddiff eq [mc "Markup words"]} {
8142 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8143 } else {
8144 $ctext insert end "$line" $tags
8146 if {!$dowords} {
8147 $ctext insert end "\n" $tags
8150 } elseif {$dowords && $prefix eq "~"} {
8151 $ctext insert end "\n" {}
8152 } else {
8153 # "\ No newline at end of file",
8154 # or something else we don't recognize
8155 $ctext insert end "$line\n" hunksep
8160 proc changediffdisp {} {
8161 global ctext diffelide
8163 $ctext tag conf d0 -elide [lindex $diffelide 0]
8164 $ctext tag conf dresult -elide [lindex $diffelide 1]
8167 proc highlightfile {cline} {
8168 global cflist cflist_top
8170 if {![info exists cflist_top]} return
8172 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8173 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8174 $cflist see $cline.0
8175 set cflist_top $cline
8178 proc highlightfile_for_scrollpos {topidx} {
8179 global cmitmode difffilestart
8181 if {$cmitmode eq "tree"} return
8182 if {![info exists difffilestart]} return
8184 set top [lindex [split $topidx .] 0]
8185 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8186 highlightfile 0
8187 } else {
8188 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8192 proc prevfile {} {
8193 global difffilestart ctext cmitmode
8195 if {$cmitmode eq "tree"} return
8196 set prev 0.0
8197 set here [$ctext index @0,0]
8198 foreach loc $difffilestart {
8199 if {[$ctext compare $loc >= $here]} {
8200 $ctext yview $prev
8201 return
8203 set prev $loc
8205 $ctext yview $prev
8208 proc nextfile {} {
8209 global difffilestart ctext cmitmode
8211 if {$cmitmode eq "tree"} return
8212 set here [$ctext index @0,0]
8213 foreach loc $difffilestart {
8214 if {[$ctext compare $loc > $here]} {
8215 $ctext yview $loc
8216 return
8221 proc clear_ctext {{first 1.0}} {
8222 global ctext smarktop smarkbot
8223 global ctext_file_names ctext_file_lines
8224 global pendinglinks
8226 set l [lindex [split $first .] 0]
8227 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8228 set smarktop $l
8230 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8231 set smarkbot $l
8233 $ctext delete $first end
8234 if {$first eq "1.0"} {
8235 catch {unset pendinglinks}
8237 set ctext_file_names {}
8238 set ctext_file_lines {}
8241 proc settabs {{firstab {}}} {
8242 global firsttabstop tabstop ctext have_tk85
8244 if {$firstab ne {} && $have_tk85} {
8245 set firsttabstop $firstab
8247 set w [font measure textfont "0"]
8248 if {$firsttabstop != 0} {
8249 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8250 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8251 } elseif {$have_tk85 || $tabstop != 8} {
8252 $ctext conf -tabs [expr {$tabstop * $w}]
8253 } else {
8254 $ctext conf -tabs {}
8258 proc incrsearch {name ix op} {
8259 global ctext searchstring searchdirn
8261 if {[catch {$ctext index anchor}]} {
8262 # no anchor set, use start of selection, or of visible area
8263 set sel [$ctext tag ranges sel]
8264 if {$sel ne {}} {
8265 $ctext mark set anchor [lindex $sel 0]
8266 } elseif {$searchdirn eq "-forwards"} {
8267 $ctext mark set anchor @0,0
8268 } else {
8269 $ctext mark set anchor @0,[winfo height $ctext]
8272 if {$searchstring ne {}} {
8273 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8274 if {$here ne {}} {
8275 $ctext see $here
8276 set mend "$here + $mlen c"
8277 $ctext tag remove sel 1.0 end
8278 $ctext tag add sel $here $mend
8279 suppress_highlighting_file_for_current_scrollpos
8280 highlightfile_for_scrollpos $here
8283 rehighlight_search_results
8286 proc dosearch {} {
8287 global sstring ctext searchstring searchdirn
8289 focus $sstring
8290 $sstring icursor end
8291 set searchdirn -forwards
8292 if {$searchstring ne {}} {
8293 set sel [$ctext tag ranges sel]
8294 if {$sel ne {}} {
8295 set start "[lindex $sel 0] + 1c"
8296 } elseif {[catch {set start [$ctext index anchor]}]} {
8297 set start "@0,0"
8299 set match [$ctext search -count mlen -- $searchstring $start]
8300 $ctext tag remove sel 1.0 end
8301 if {$match eq {}} {
8302 bell
8303 return
8305 $ctext see $match
8306 suppress_highlighting_file_for_current_scrollpos
8307 highlightfile_for_scrollpos $match
8308 set mend "$match + $mlen c"
8309 $ctext tag add sel $match $mend
8310 $ctext mark unset anchor
8311 rehighlight_search_results
8315 proc dosearchback {} {
8316 global sstring ctext searchstring searchdirn
8318 focus $sstring
8319 $sstring icursor end
8320 set searchdirn -backwards
8321 if {$searchstring ne {}} {
8322 set sel [$ctext tag ranges sel]
8323 if {$sel ne {}} {
8324 set start [lindex $sel 0]
8325 } elseif {[catch {set start [$ctext index anchor]}]} {
8326 set start @0,[winfo height $ctext]
8328 set match [$ctext search -backwards -count ml -- $searchstring $start]
8329 $ctext tag remove sel 1.0 end
8330 if {$match eq {}} {
8331 bell
8332 return
8334 $ctext see $match
8335 suppress_highlighting_file_for_current_scrollpos
8336 highlightfile_for_scrollpos $match
8337 set mend "$match + $ml c"
8338 $ctext tag add sel $match $mend
8339 $ctext mark unset anchor
8340 rehighlight_search_results
8344 proc rehighlight_search_results {} {
8345 global ctext searchstring
8347 $ctext tag remove found 1.0 end
8348 $ctext tag remove currentsearchhit 1.0 end
8350 if {$searchstring ne {}} {
8351 searchmarkvisible 1
8355 proc searchmark {first last} {
8356 global ctext searchstring
8358 set sel [$ctext tag ranges sel]
8360 set mend $first.0
8361 while {1} {
8362 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8363 if {$match eq {}} break
8364 set mend "$match + $mlen c"
8365 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8366 $ctext tag add currentsearchhit $match $mend
8367 } else {
8368 $ctext tag add found $match $mend
8373 proc searchmarkvisible {doall} {
8374 global ctext smarktop smarkbot
8376 set topline [lindex [split [$ctext index @0,0] .] 0]
8377 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8378 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8379 # no overlap with previous
8380 searchmark $topline $botline
8381 set smarktop $topline
8382 set smarkbot $botline
8383 } else {
8384 if {$topline < $smarktop} {
8385 searchmark $topline [expr {$smarktop-1}]
8386 set smarktop $topline
8388 if {$botline > $smarkbot} {
8389 searchmark [expr {$smarkbot+1}] $botline
8390 set smarkbot $botline
8395 proc suppress_highlighting_file_for_current_scrollpos {} {
8396 global ctext suppress_highlighting_file_for_this_scrollpos
8398 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8401 proc scrolltext {f0 f1} {
8402 global searchstring cmitmode ctext
8403 global suppress_highlighting_file_for_this_scrollpos
8405 set topidx [$ctext index @0,0]
8406 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8407 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8408 highlightfile_for_scrollpos $topidx
8411 catch {unset suppress_highlighting_file_for_this_scrollpos}
8413 .bleft.bottom.sb set $f0 $f1
8414 if {$searchstring ne {}} {
8415 searchmarkvisible 0
8419 proc setcoords {} {
8420 global linespc charspc canvx0 canvy0
8421 global xspc1 xspc2 lthickness
8423 set linespc [font metrics mainfont -linespace]
8424 set charspc [font measure mainfont "m"]
8425 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8426 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8427 set lthickness [expr {int($linespc / 9) + 1}]
8428 set xspc1(0) $linespc
8429 set xspc2 $linespc
8432 proc redisplay {} {
8433 global canv
8434 global selectedline
8436 set ymax [lindex [$canv cget -scrollregion] 3]
8437 if {$ymax eq {} || $ymax == 0} return
8438 set span [$canv yview]
8439 clear_display
8440 setcanvscroll
8441 allcanvs yview moveto [lindex $span 0]
8442 drawvisible
8443 if {$selectedline ne {}} {
8444 selectline $selectedline 0
8445 allcanvs yview moveto [lindex $span 0]
8449 proc parsefont {f n} {
8450 global fontattr
8452 set fontattr($f,family) [lindex $n 0]
8453 set s [lindex $n 1]
8454 if {$s eq {} || $s == 0} {
8455 set s 10
8456 } elseif {$s < 0} {
8457 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8459 set fontattr($f,size) $s
8460 set fontattr($f,weight) normal
8461 set fontattr($f,slant) roman
8462 foreach style [lrange $n 2 end] {
8463 switch -- $style {
8464 "normal" -
8465 "bold" {set fontattr($f,weight) $style}
8466 "roman" -
8467 "italic" {set fontattr($f,slant) $style}
8472 proc fontflags {f {isbold 0}} {
8473 global fontattr
8475 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8476 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8477 -slant $fontattr($f,slant)]
8480 proc fontname {f} {
8481 global fontattr
8483 set n [list $fontattr($f,family) $fontattr($f,size)]
8484 if {$fontattr($f,weight) eq "bold"} {
8485 lappend n "bold"
8487 if {$fontattr($f,slant) eq "italic"} {
8488 lappend n "italic"
8490 return $n
8493 proc incrfont {inc} {
8494 global mainfont textfont ctext canv cflist showrefstop
8495 global stopped entries fontattr
8497 unmarkmatches
8498 set s $fontattr(mainfont,size)
8499 incr s $inc
8500 if {$s < 1} {
8501 set s 1
8503 set fontattr(mainfont,size) $s
8504 font config mainfont -size $s
8505 font config mainfontbold -size $s
8506 set mainfont [fontname mainfont]
8507 set s $fontattr(textfont,size)
8508 incr s $inc
8509 if {$s < 1} {
8510 set s 1
8512 set fontattr(textfont,size) $s
8513 font config textfont -size $s
8514 font config textfontbold -size $s
8515 set textfont [fontname textfont]
8516 setcoords
8517 settabs
8518 redisplay
8521 proc clearsha1 {} {
8522 global sha1entry sha1string
8523 if {[string length $sha1string] == 40} {
8524 $sha1entry delete 0 end
8528 proc sha1change {n1 n2 op} {
8529 global sha1string currentid sha1but
8530 if {$sha1string == {}
8531 || ([info exists currentid] && $sha1string == $currentid)} {
8532 set state disabled
8533 } else {
8534 set state normal
8536 if {[$sha1but cget -state] == $state} return
8537 if {$state == "normal"} {
8538 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8539 } else {
8540 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8544 proc gotocommit {} {
8545 global sha1string tagids headids curview varcid
8547 if {$sha1string == {}
8548 || ([info exists currentid] && $sha1string == $currentid)} return
8549 if {[info exists tagids($sha1string)]} {
8550 set id $tagids($sha1string)
8551 } elseif {[info exists headids($sha1string)]} {
8552 set id $headids($sha1string)
8553 } else {
8554 set id [string tolower $sha1string]
8555 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8556 set matches [longid $id]
8557 if {$matches ne {}} {
8558 if {[llength $matches] > 1} {
8559 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8560 return
8562 set id [lindex $matches 0]
8564 } else {
8565 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8566 error_popup [mc "Revision %s is not known" $sha1string]
8567 return
8571 if {[commitinview $id $curview]} {
8572 selectline [rowofcommit $id] 1
8573 return
8575 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8576 set msg [mc "SHA1 id %s is not known" $sha1string]
8577 } else {
8578 set msg [mc "Revision %s is not in the current view" $sha1string]
8580 error_popup $msg
8583 proc lineenter {x y id} {
8584 global hoverx hovery hoverid hovertimer
8585 global commitinfo canv
8587 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8588 set hoverx $x
8589 set hovery $y
8590 set hoverid $id
8591 if {[info exists hovertimer]} {
8592 after cancel $hovertimer
8594 set hovertimer [after 500 linehover]
8595 $canv delete hover
8598 proc linemotion {x y id} {
8599 global hoverx hovery hoverid hovertimer
8601 if {[info exists hoverid] && $id == $hoverid} {
8602 set hoverx $x
8603 set hovery $y
8604 if {[info exists hovertimer]} {
8605 after cancel $hovertimer
8607 set hovertimer [after 500 linehover]
8611 proc lineleave {id} {
8612 global hoverid hovertimer canv
8614 if {[info exists hoverid] && $id == $hoverid} {
8615 $canv delete hover
8616 if {[info exists hovertimer]} {
8617 after cancel $hovertimer
8618 unset hovertimer
8620 unset hoverid
8624 proc linehover {} {
8625 global hoverx hovery hoverid hovertimer
8626 global canv linespc lthickness
8627 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8629 global commitinfo
8631 set text [lindex $commitinfo($hoverid) 0]
8632 set ymax [lindex [$canv cget -scrollregion] 3]
8633 if {$ymax == {}} return
8634 set yfrac [lindex [$canv yview] 0]
8635 set x [expr {$hoverx + 2 * $linespc}]
8636 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8637 set x0 [expr {$x - 2 * $lthickness}]
8638 set y0 [expr {$y - 2 * $lthickness}]
8639 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8640 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8641 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8642 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8643 -width 1 -tags hover]
8644 $canv raise $t
8645 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8646 -font mainfont -fill $linehoverfgcolor]
8647 $canv raise $t
8650 proc clickisonarrow {id y} {
8651 global lthickness
8653 set ranges [rowranges $id]
8654 set thresh [expr {2 * $lthickness + 6}]
8655 set n [expr {[llength $ranges] - 1}]
8656 for {set i 1} {$i < $n} {incr i} {
8657 set row [lindex $ranges $i]
8658 if {abs([yc $row] - $y) < $thresh} {
8659 return $i
8662 return {}
8665 proc arrowjump {id n y} {
8666 global canv
8668 # 1 <-> 2, 3 <-> 4, etc...
8669 set n [expr {(($n - 1) ^ 1) + 1}]
8670 set row [lindex [rowranges $id] $n]
8671 set yt [yc $row]
8672 set ymax [lindex [$canv cget -scrollregion] 3]
8673 if {$ymax eq {} || $ymax <= 0} return
8674 set view [$canv yview]
8675 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8676 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8677 if {$yfrac < 0} {
8678 set yfrac 0
8680 allcanvs yview moveto $yfrac
8683 proc lineclick {x y id isnew} {
8684 global ctext commitinfo children canv thickerline curview
8686 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8687 unmarkmatches
8688 unselectline
8689 normalline
8690 $canv delete hover
8691 # draw this line thicker than normal
8692 set thickerline $id
8693 drawlines $id
8694 if {$isnew} {
8695 set ymax [lindex [$canv cget -scrollregion] 3]
8696 if {$ymax eq {}} return
8697 set yfrac [lindex [$canv yview] 0]
8698 set y [expr {$y + $yfrac * $ymax}]
8700 set dirn [clickisonarrow $id $y]
8701 if {$dirn ne {}} {
8702 arrowjump $id $dirn $y
8703 return
8706 if {$isnew} {
8707 addtohistory [list lineclick $x $y $id 0] savectextpos
8709 # fill the details pane with info about this line
8710 $ctext conf -state normal
8711 clear_ctext
8712 settabs 0
8713 $ctext insert end "[mc "Parent"]:\t"
8714 $ctext insert end $id link0
8715 setlink $id link0
8716 set info $commitinfo($id)
8717 $ctext insert end "\n\t[lindex $info 0]\n"
8718 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8719 set date [formatdate [lindex $info 2]]
8720 $ctext insert end "\t[mc "Date"]:\t$date\n"
8721 set kids $children($curview,$id)
8722 if {$kids ne {}} {
8723 $ctext insert end "\n[mc "Children"]:"
8724 set i 0
8725 foreach child $kids {
8726 incr i
8727 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8728 set info $commitinfo($child)
8729 $ctext insert end "\n\t"
8730 $ctext insert end $child link$i
8731 setlink $child link$i
8732 $ctext insert end "\n\t[lindex $info 0]"
8733 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8734 set date [formatdate [lindex $info 2]]
8735 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8738 maybe_scroll_ctext 1
8739 $ctext conf -state disabled
8740 init_flist {}
8743 proc normalline {} {
8744 global thickerline
8745 if {[info exists thickerline]} {
8746 set id $thickerline
8747 unset thickerline
8748 drawlines $id
8752 proc selbyid {id {isnew 1}} {
8753 global curview
8754 if {[commitinview $id $curview]} {
8755 selectline [rowofcommit $id] $isnew
8759 proc mstime {} {
8760 global startmstime
8761 if {![info exists startmstime]} {
8762 set startmstime [clock clicks -milliseconds]
8764 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8767 proc rowmenu {x y id} {
8768 global rowctxmenu selectedline rowmenuid curview
8769 global nullid nullid2 fakerowmenu mainhead markedid
8771 stopfinding
8772 set rowmenuid $id
8773 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8774 set state disabled
8775 } else {
8776 set state normal
8778 if {[info exists markedid] && $markedid ne $id} {
8779 set mstate normal
8780 } else {
8781 set mstate disabled
8783 if {$id ne $nullid && $id ne $nullid2} {
8784 set menu $rowctxmenu
8785 if {$mainhead ne {}} {
8786 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8787 } else {
8788 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8790 $menu entryconfigure 9 -state $mstate
8791 $menu entryconfigure 10 -state $mstate
8792 $menu entryconfigure 11 -state $mstate
8793 } else {
8794 set menu $fakerowmenu
8796 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8797 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8798 $menu entryconfigure [mca "Make patch"] -state $state
8799 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8800 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8801 tk_popup $menu $x $y
8804 proc markhere {} {
8805 global rowmenuid markedid canv
8807 set markedid $rowmenuid
8808 make_idmark $markedid
8811 proc gotomark {} {
8812 global markedid
8814 if {[info exists markedid]} {
8815 selbyid $markedid
8819 proc replace_by_kids {l r} {
8820 global curview children
8822 set id [commitonrow $r]
8823 set l [lreplace $l 0 0]
8824 foreach kid $children($curview,$id) {
8825 lappend l [rowofcommit $kid]
8827 return [lsort -integer -decreasing -unique $l]
8830 proc find_common_desc {} {
8831 global markedid rowmenuid curview children
8833 if {![info exists markedid]} return
8834 if {![commitinview $markedid $curview] ||
8835 ![commitinview $rowmenuid $curview]} return
8836 #set t1 [clock clicks -milliseconds]
8837 set l1 [list [rowofcommit $markedid]]
8838 set l2 [list [rowofcommit $rowmenuid]]
8839 while 1 {
8840 set r1 [lindex $l1 0]
8841 set r2 [lindex $l2 0]
8842 if {$r1 eq {} || $r2 eq {}} break
8843 if {$r1 == $r2} {
8844 selectline $r1 1
8845 break
8847 if {$r1 > $r2} {
8848 set l1 [replace_by_kids $l1 $r1]
8849 } else {
8850 set l2 [replace_by_kids $l2 $r2]
8853 #set t2 [clock clicks -milliseconds]
8854 #puts "took [expr {$t2-$t1}]ms"
8857 proc compare_commits {} {
8858 global markedid rowmenuid curview children
8860 if {![info exists markedid]} return
8861 if {![commitinview $markedid $curview]} return
8862 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8863 do_cmp_commits $markedid $rowmenuid
8866 proc getpatchid {id} {
8867 global patchids
8869 if {![info exists patchids($id)]} {
8870 set cmd [diffcmd [list $id] {-p --root}]
8871 # trim off the initial "|"
8872 set cmd [lrange $cmd 1 end]
8873 if {[catch {
8874 set x [eval exec $cmd | git patch-id]
8875 set patchids($id) [lindex $x 0]
8876 }]} {
8877 set patchids($id) "error"
8880 return $patchids($id)
8883 proc do_cmp_commits {a b} {
8884 global ctext curview parents children patchids commitinfo
8886 $ctext conf -state normal
8887 clear_ctext
8888 init_flist {}
8889 for {set i 0} {$i < 100} {incr i} {
8890 set skipa 0
8891 set skipb 0
8892 if {[llength $parents($curview,$a)] > 1} {
8893 appendshortlink $a [mc "Skipping merge commit "] "\n"
8894 set skipa 1
8895 } else {
8896 set patcha [getpatchid $a]
8898 if {[llength $parents($curview,$b)] > 1} {
8899 appendshortlink $b [mc "Skipping merge commit "] "\n"
8900 set skipb 1
8901 } else {
8902 set patchb [getpatchid $b]
8904 if {!$skipa && !$skipb} {
8905 set heada [lindex $commitinfo($a) 0]
8906 set headb [lindex $commitinfo($b) 0]
8907 if {$patcha eq "error"} {
8908 appendshortlink $a [mc "Error getting patch ID for "] \
8909 [mc " - stopping\n"]
8910 break
8912 if {$patchb eq "error"} {
8913 appendshortlink $b [mc "Error getting patch ID for "] \
8914 [mc " - stopping\n"]
8915 break
8917 if {$patcha eq $patchb} {
8918 if {$heada eq $headb} {
8919 appendshortlink $a [mc "Commit "]
8920 appendshortlink $b " == " " $heada\n"
8921 } else {
8922 appendshortlink $a [mc "Commit "] " $heada\n"
8923 appendshortlink $b [mc " is the same patch as\n "] \
8924 " $headb\n"
8926 set skipa 1
8927 set skipb 1
8928 } else {
8929 $ctext insert end "\n"
8930 appendshortlink $a [mc "Commit "] " $heada\n"
8931 appendshortlink $b [mc " differs from\n "] \
8932 " $headb\n"
8933 $ctext insert end [mc "Diff of commits:\n\n"]
8934 $ctext conf -state disabled
8935 update
8936 diffcommits $a $b
8937 return
8940 if {$skipa} {
8941 set kids [real_children $curview,$a]
8942 if {[llength $kids] != 1} {
8943 $ctext insert end "\n"
8944 appendshortlink $a [mc "Commit "] \
8945 [mc " has %s children - stopping\n" [llength $kids]]
8946 break
8948 set a [lindex $kids 0]
8950 if {$skipb} {
8951 set kids [real_children $curview,$b]
8952 if {[llength $kids] != 1} {
8953 appendshortlink $b [mc "Commit "] \
8954 [mc " has %s children - stopping\n" [llength $kids]]
8955 break
8957 set b [lindex $kids 0]
8960 $ctext conf -state disabled
8963 proc diffcommits {a b} {
8964 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
8966 set tmpdir [gitknewtmpdir]
8967 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8968 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8969 if {[catch {
8970 exec git diff-tree -p --pretty $a >$fna
8971 exec git diff-tree -p --pretty $b >$fnb
8972 } err]} {
8973 error_popup [mc "Error writing commit to file: %s" $err]
8974 return
8976 if {[catch {
8977 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8978 } err]} {
8979 error_popup [mc "Error diffing commits: %s" $err]
8980 return
8982 set diffids [list commits $a $b]
8983 set blobdifffd($diffids) $fd
8984 set diffinhdr 0
8985 set currdiffsubmod ""
8986 filerun $fd [list getblobdiffline $fd $diffids]
8989 proc diffvssel {dirn} {
8990 global rowmenuid selectedline
8992 if {$selectedline eq {}} return
8993 if {$dirn} {
8994 set oldid [commitonrow $selectedline]
8995 set newid $rowmenuid
8996 } else {
8997 set oldid $rowmenuid
8998 set newid [commitonrow $selectedline]
9000 addtohistory [list doseldiff $oldid $newid] savectextpos
9001 doseldiff $oldid $newid
9004 proc diffvsmark {dirn} {
9005 global rowmenuid markedid
9007 if {![info exists markedid]} return
9008 if {$dirn} {
9009 set oldid $markedid
9010 set newid $rowmenuid
9011 } else {
9012 set oldid $rowmenuid
9013 set newid $markedid
9015 addtohistory [list doseldiff $oldid $newid] savectextpos
9016 doseldiff $oldid $newid
9019 proc doseldiff {oldid newid} {
9020 global ctext
9021 global commitinfo
9023 $ctext conf -state normal
9024 clear_ctext
9025 init_flist [mc "Top"]
9026 $ctext insert end "[mc "From"] "
9027 $ctext insert end $oldid link0
9028 setlink $oldid link0
9029 $ctext insert end "\n "
9030 $ctext insert end [lindex $commitinfo($oldid) 0]
9031 $ctext insert end "\n\n[mc "To"] "
9032 $ctext insert end $newid link1
9033 setlink $newid link1
9034 $ctext insert end "\n "
9035 $ctext insert end [lindex $commitinfo($newid) 0]
9036 $ctext insert end "\n"
9037 $ctext conf -state disabled
9038 $ctext tag remove found 1.0 end
9039 startdiff [list $oldid $newid]
9042 proc mkpatch {} {
9043 global rowmenuid currentid commitinfo patchtop patchnum NS
9045 if {![info exists currentid]} return
9046 set oldid $currentid
9047 set oldhead [lindex $commitinfo($oldid) 0]
9048 set newid $rowmenuid
9049 set newhead [lindex $commitinfo($newid) 0]
9050 set top .patch
9051 set patchtop $top
9052 catch {destroy $top}
9053 ttk_toplevel $top
9054 make_transient $top .
9055 ${NS}::label $top.title -text [mc "Generate patch"]
9056 grid $top.title - -pady 10
9057 ${NS}::label $top.from -text [mc "From:"]
9058 ${NS}::entry $top.fromsha1 -width 40
9059 $top.fromsha1 insert 0 $oldid
9060 $top.fromsha1 conf -state readonly
9061 grid $top.from $top.fromsha1 -sticky w
9062 ${NS}::entry $top.fromhead -width 60
9063 $top.fromhead insert 0 $oldhead
9064 $top.fromhead conf -state readonly
9065 grid x $top.fromhead -sticky w
9066 ${NS}::label $top.to -text [mc "To:"]
9067 ${NS}::entry $top.tosha1 -width 40
9068 $top.tosha1 insert 0 $newid
9069 $top.tosha1 conf -state readonly
9070 grid $top.to $top.tosha1 -sticky w
9071 ${NS}::entry $top.tohead -width 60
9072 $top.tohead insert 0 $newhead
9073 $top.tohead conf -state readonly
9074 grid x $top.tohead -sticky w
9075 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9076 grid $top.rev x -pady 10 -padx 5
9077 ${NS}::label $top.flab -text [mc "Output file:"]
9078 ${NS}::entry $top.fname -width 60
9079 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9080 incr patchnum
9081 grid $top.flab $top.fname -sticky w
9082 ${NS}::frame $top.buts
9083 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9084 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9085 bind $top <Key-Return> mkpatchgo
9086 bind $top <Key-Escape> mkpatchcan
9087 grid $top.buts.gen $top.buts.can
9088 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9089 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9090 grid $top.buts - -pady 10 -sticky ew
9091 focus $top.fname
9094 proc mkpatchrev {} {
9095 global patchtop
9097 set oldid [$patchtop.fromsha1 get]
9098 set oldhead [$patchtop.fromhead get]
9099 set newid [$patchtop.tosha1 get]
9100 set newhead [$patchtop.tohead get]
9101 foreach e [list fromsha1 fromhead tosha1 tohead] \
9102 v [list $newid $newhead $oldid $oldhead] {
9103 $patchtop.$e conf -state normal
9104 $patchtop.$e delete 0 end
9105 $patchtop.$e insert 0 $v
9106 $patchtop.$e conf -state readonly
9110 proc mkpatchgo {} {
9111 global patchtop nullid nullid2
9113 set oldid [$patchtop.fromsha1 get]
9114 set newid [$patchtop.tosha1 get]
9115 set fname [$patchtop.fname get]
9116 set cmd [diffcmd [list $oldid $newid] -p]
9117 # trim off the initial "|"
9118 set cmd [lrange $cmd 1 end]
9119 lappend cmd >$fname &
9120 if {[catch {eval exec $cmd} err]} {
9121 error_popup "[mc "Error creating patch:"] $err" $patchtop
9123 catch {destroy $patchtop}
9124 unset patchtop
9127 proc mkpatchcan {} {
9128 global patchtop
9130 catch {destroy $patchtop}
9131 unset patchtop
9134 proc mktag {} {
9135 global rowmenuid mktagtop commitinfo NS
9137 set top .maketag
9138 set mktagtop $top
9139 catch {destroy $top}
9140 ttk_toplevel $top
9141 make_transient $top .
9142 ${NS}::label $top.title -text [mc "Create tag"]
9143 grid $top.title - -pady 10
9144 ${NS}::label $top.id -text [mc "ID:"]
9145 ${NS}::entry $top.sha1 -width 40
9146 $top.sha1 insert 0 $rowmenuid
9147 $top.sha1 conf -state readonly
9148 grid $top.id $top.sha1 -sticky w
9149 ${NS}::entry $top.head -width 60
9150 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9151 $top.head conf -state readonly
9152 grid x $top.head -sticky w
9153 ${NS}::label $top.tlab -text [mc "Tag name:"]
9154 ${NS}::entry $top.tag -width 60
9155 grid $top.tlab $top.tag -sticky w
9156 ${NS}::label $top.op -text [mc "Tag message is optional"]
9157 grid $top.op -columnspan 2 -sticky we
9158 ${NS}::label $top.mlab -text [mc "Tag message:"]
9159 ${NS}::entry $top.msg -width 60
9160 grid $top.mlab $top.msg -sticky w
9161 ${NS}::frame $top.buts
9162 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9163 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9164 bind $top <Key-Return> mktaggo
9165 bind $top <Key-Escape> mktagcan
9166 grid $top.buts.gen $top.buts.can
9167 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9168 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9169 grid $top.buts - -pady 10 -sticky ew
9170 focus $top.tag
9173 proc domktag {} {
9174 global mktagtop env tagids idtags
9176 set id [$mktagtop.sha1 get]
9177 set tag [$mktagtop.tag get]
9178 set msg [$mktagtop.msg get]
9179 if {$tag == {}} {
9180 error_popup [mc "No tag name specified"] $mktagtop
9181 return 0
9183 if {[info exists tagids($tag)]} {
9184 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9185 return 0
9187 if {[catch {
9188 if {$msg != {}} {
9189 exec git tag -a -m $msg $tag $id
9190 } else {
9191 exec git tag $tag $id
9193 } err]} {
9194 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9195 return 0
9198 set tagids($tag) $id
9199 lappend idtags($id) $tag
9200 redrawtags $id
9201 addedtag $id
9202 dispneartags 0
9203 run refill_reflist
9204 return 1
9207 proc redrawtags {id} {
9208 global canv linehtag idpos currentid curview cmitlisted markedid
9209 global canvxmax iddrawn circleitem mainheadid circlecolors
9210 global mainheadcirclecolor
9212 if {![commitinview $id $curview]} return
9213 if {![info exists iddrawn($id)]} return
9214 set row [rowofcommit $id]
9215 if {$id eq $mainheadid} {
9216 set ofill $mainheadcirclecolor
9217 } else {
9218 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9220 $canv itemconf $circleitem($row) -fill $ofill
9221 $canv delete tag.$id
9222 set xt [eval drawtags $id $idpos($id)]
9223 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9224 set text [$canv itemcget $linehtag($id) -text]
9225 set font [$canv itemcget $linehtag($id) -font]
9226 set xr [expr {$xt + [font measure $font $text]}]
9227 if {$xr > $canvxmax} {
9228 set canvxmax $xr
9229 setcanvscroll
9231 if {[info exists currentid] && $currentid == $id} {
9232 make_secsel $id
9234 if {[info exists markedid] && $markedid eq $id} {
9235 make_idmark $id
9239 proc mktagcan {} {
9240 global mktagtop
9242 catch {destroy $mktagtop}
9243 unset mktagtop
9246 proc mktaggo {} {
9247 if {![domktag]} return
9248 mktagcan
9251 proc writecommit {} {
9252 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9254 set top .writecommit
9255 set wrcomtop $top
9256 catch {destroy $top}
9257 ttk_toplevel $top
9258 make_transient $top .
9259 ${NS}::label $top.title -text [mc "Write commit to file"]
9260 grid $top.title - -pady 10
9261 ${NS}::label $top.id -text [mc "ID:"]
9262 ${NS}::entry $top.sha1 -width 40
9263 $top.sha1 insert 0 $rowmenuid
9264 $top.sha1 conf -state readonly
9265 grid $top.id $top.sha1 -sticky w
9266 ${NS}::entry $top.head -width 60
9267 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9268 $top.head conf -state readonly
9269 grid x $top.head -sticky w
9270 ${NS}::label $top.clab -text [mc "Command:"]
9271 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9272 grid $top.clab $top.cmd -sticky w -pady 10
9273 ${NS}::label $top.flab -text [mc "Output file:"]
9274 ${NS}::entry $top.fname -width 60
9275 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9276 grid $top.flab $top.fname -sticky w
9277 ${NS}::frame $top.buts
9278 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9279 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9280 bind $top <Key-Return> wrcomgo
9281 bind $top <Key-Escape> wrcomcan
9282 grid $top.buts.gen $top.buts.can
9283 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9284 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9285 grid $top.buts - -pady 10 -sticky ew
9286 focus $top.fname
9289 proc wrcomgo {} {
9290 global wrcomtop
9292 set id [$wrcomtop.sha1 get]
9293 set cmd "echo $id | [$wrcomtop.cmd get]"
9294 set fname [$wrcomtop.fname get]
9295 if {[catch {exec sh -c $cmd >$fname &} err]} {
9296 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9298 catch {destroy $wrcomtop}
9299 unset wrcomtop
9302 proc wrcomcan {} {
9303 global wrcomtop
9305 catch {destroy $wrcomtop}
9306 unset wrcomtop
9309 proc mkbranch {} {
9310 global rowmenuid mkbrtop NS
9312 set top .makebranch
9313 catch {destroy $top}
9314 ttk_toplevel $top
9315 make_transient $top .
9316 ${NS}::label $top.title -text [mc "Create new branch"]
9317 grid $top.title - -pady 10
9318 ${NS}::label $top.id -text [mc "ID:"]
9319 ${NS}::entry $top.sha1 -width 40
9320 $top.sha1 insert 0 $rowmenuid
9321 $top.sha1 conf -state readonly
9322 grid $top.id $top.sha1 -sticky w
9323 ${NS}::label $top.nlab -text [mc "Name:"]
9324 ${NS}::entry $top.name -width 40
9325 grid $top.nlab $top.name -sticky w
9326 ${NS}::frame $top.buts
9327 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9328 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9329 bind $top <Key-Return> [list mkbrgo $top]
9330 bind $top <Key-Escape> "catch {destroy $top}"
9331 grid $top.buts.go $top.buts.can
9332 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9333 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9334 grid $top.buts - -pady 10 -sticky ew
9335 focus $top.name
9338 proc mkbrgo {top} {
9339 global headids idheads
9341 set name [$top.name get]
9342 set id [$top.sha1 get]
9343 set cmdargs {}
9344 set old_id {}
9345 if {$name eq {}} {
9346 error_popup [mc "Please specify a name for the new branch"] $top
9347 return
9349 if {[info exists headids($name)]} {
9350 if {![confirm_popup [mc \
9351 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9352 return
9354 set old_id $headids($name)
9355 lappend cmdargs -f
9357 catch {destroy $top}
9358 lappend cmdargs $name $id
9359 nowbusy newbranch
9360 update
9361 if {[catch {
9362 eval exec git branch $cmdargs
9363 } err]} {
9364 notbusy newbranch
9365 error_popup $err
9366 } else {
9367 notbusy newbranch
9368 if {$old_id ne {}} {
9369 movehead $id $name
9370 movedhead $id $name
9371 redrawtags $old_id
9372 redrawtags $id
9373 } else {
9374 set headids($name) $id
9375 lappend idheads($id) $name
9376 addedhead $id $name
9377 redrawtags $id
9379 dispneartags 0
9380 run refill_reflist
9384 proc exec_citool {tool_args {baseid {}}} {
9385 global commitinfo env
9387 set save_env [array get env GIT_AUTHOR_*]
9389 if {$baseid ne {}} {
9390 if {![info exists commitinfo($baseid)]} {
9391 getcommit $baseid
9393 set author [lindex $commitinfo($baseid) 1]
9394 set date [lindex $commitinfo($baseid) 2]
9395 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9396 $author author name email]
9397 && $date ne {}} {
9398 set env(GIT_AUTHOR_NAME) $name
9399 set env(GIT_AUTHOR_EMAIL) $email
9400 set env(GIT_AUTHOR_DATE) $date
9404 eval exec git citool $tool_args &
9406 array unset env GIT_AUTHOR_*
9407 array set env $save_env
9410 proc cherrypick {} {
9411 global rowmenuid curview
9412 global mainhead mainheadid
9413 global gitdir
9415 set oldhead [exec git rev-parse HEAD]
9416 set dheads [descheads $rowmenuid]
9417 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9418 set ok [confirm_popup [mc "Commit %s is already\
9419 included in branch %s -- really re-apply it?" \
9420 [string range $rowmenuid 0 7] $mainhead]]
9421 if {!$ok} return
9423 nowbusy cherrypick [mc "Cherry-picking"]
9424 update
9425 # Unfortunately git-cherry-pick writes stuff to stderr even when
9426 # no error occurs, and exec takes that as an indication of error...
9427 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9428 notbusy cherrypick
9429 if {[regexp -line \
9430 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9431 $err msg fname]} {
9432 error_popup [mc "Cherry-pick failed because of local changes\
9433 to file '%s'.\nPlease commit, reset or stash\
9434 your changes and try again." $fname]
9435 } elseif {[regexp -line \
9436 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9437 $err]} {
9438 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9439 conflict.\nDo you wish to run git citool to\
9440 resolve it?"]]} {
9441 # Force citool to read MERGE_MSG
9442 file delete [file join $gitdir "GITGUI_MSG"]
9443 exec_citool {} $rowmenuid
9445 } else {
9446 error_popup $err
9448 run updatecommits
9449 return
9451 set newhead [exec git rev-parse HEAD]
9452 if {$newhead eq $oldhead} {
9453 notbusy cherrypick
9454 error_popup [mc "No changes committed"]
9455 return
9457 addnewchild $newhead $oldhead
9458 if {[commitinview $oldhead $curview]} {
9459 # XXX this isn't right if we have a path limit...
9460 insertrow $newhead $oldhead $curview
9461 if {$mainhead ne {}} {
9462 movehead $newhead $mainhead
9463 movedhead $newhead $mainhead
9465 set mainheadid $newhead
9466 redrawtags $oldhead
9467 redrawtags $newhead
9468 selbyid $newhead
9470 notbusy cherrypick
9473 proc revert {} {
9474 global rowmenuid curview
9475 global mainhead mainheadid
9476 global gitdir
9478 set oldhead [exec git rev-parse HEAD]
9479 set dheads [descheads $rowmenuid]
9480 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9481 set ok [confirm_popup [mc "Commit %s is not\
9482 included in branch %s -- really revert it?" \
9483 [string range $rowmenuid 0 7] $mainhead]]
9484 if {!$ok} return
9486 nowbusy revert [mc "Reverting"]
9487 update
9489 if [catch {exec git revert --no-edit $rowmenuid} err] {
9490 notbusy revert
9491 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9492 $err match files] {
9493 regsub {\n( |\t)+} $files "\n" files
9494 error_popup [mc "Revert failed because of local changes to\
9495 the following files:%s Please commit, reset or stash \
9496 your changes and try again." $files]
9497 } elseif [regexp {error: could not revert} $err] {
9498 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9499 Do you wish to run git citool to resolve it?"]] {
9500 # Force citool to read MERGE_MSG
9501 file delete [file join $gitdir "GITGUI_MSG"]
9502 exec_citool {} $rowmenuid
9504 } else { error_popup $err }
9505 run updatecommits
9506 return
9509 set newhead [exec git rev-parse HEAD]
9510 if { $newhead eq $oldhead } {
9511 notbusy revert
9512 error_popup [mc "No changes committed"]
9513 return
9516 addnewchild $newhead $oldhead
9518 if [commitinview $oldhead $curview] {
9519 # XXX this isn't right if we have a path limit...
9520 insertrow $newhead $oldhead $curview
9521 if {$mainhead ne {}} {
9522 movehead $newhead $mainhead
9523 movedhead $newhead $mainhead
9525 set mainheadid $newhead
9526 redrawtags $oldhead
9527 redrawtags $newhead
9528 selbyid $newhead
9531 notbusy revert
9534 proc resethead {} {
9535 global mainhead rowmenuid confirm_ok resettype NS
9537 set confirm_ok 0
9538 set w ".confirmreset"
9539 ttk_toplevel $w
9540 make_transient $w .
9541 wm title $w [mc "Confirm reset"]
9542 ${NS}::label $w.m -text \
9543 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9544 pack $w.m -side top -fill x -padx 20 -pady 20
9545 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9546 set resettype mixed
9547 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9548 -text [mc "Soft: Leave working tree and index untouched"]
9549 grid $w.f.soft -sticky w
9550 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9551 -text [mc "Mixed: Leave working tree untouched, reset index"]
9552 grid $w.f.mixed -sticky w
9553 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9554 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9555 grid $w.f.hard -sticky w
9556 pack $w.f -side top -fill x -padx 4
9557 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9558 pack $w.ok -side left -fill x -padx 20 -pady 20
9559 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9560 bind $w <Key-Escape> [list destroy $w]
9561 pack $w.cancel -side right -fill x -padx 20 -pady 20
9562 bind $w <Visibility> "grab $w; focus $w"
9563 tkwait window $w
9564 if {!$confirm_ok} return
9565 if {[catch {set fd [open \
9566 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9567 error_popup $err
9568 } else {
9569 dohidelocalchanges
9570 filerun $fd [list readresetstat $fd]
9571 nowbusy reset [mc "Resetting"]
9572 selbyid $rowmenuid
9576 proc readresetstat {fd} {
9577 global mainhead mainheadid showlocalchanges rprogcoord
9579 if {[gets $fd line] >= 0} {
9580 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9581 set rprogcoord [expr {1.0 * $m / $n}]
9582 adjustprogress
9584 return 1
9586 set rprogcoord 0
9587 adjustprogress
9588 notbusy reset
9589 if {[catch {close $fd} err]} {
9590 error_popup $err
9592 set oldhead $mainheadid
9593 set newhead [exec git rev-parse HEAD]
9594 if {$newhead ne $oldhead} {
9595 movehead $newhead $mainhead
9596 movedhead $newhead $mainhead
9597 set mainheadid $newhead
9598 redrawtags $oldhead
9599 redrawtags $newhead
9601 if {$showlocalchanges} {
9602 doshowlocalchanges
9604 return 0
9607 # context menu for a head
9608 proc headmenu {x y id head} {
9609 global headmenuid headmenuhead headctxmenu mainhead
9611 stopfinding
9612 set headmenuid $id
9613 set headmenuhead $head
9614 set state normal
9615 if {[string match "remotes/*" $head]} {
9616 set state disabled
9618 if {$head eq $mainhead} {
9619 set state disabled
9621 $headctxmenu entryconfigure 0 -state $state
9622 $headctxmenu entryconfigure 1 -state $state
9623 tk_popup $headctxmenu $x $y
9626 proc cobranch {} {
9627 global headmenuid headmenuhead headids
9628 global showlocalchanges
9630 # check the tree is clean first??
9631 nowbusy checkout [mc "Checking out"]
9632 update
9633 dohidelocalchanges
9634 if {[catch {
9635 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9636 } err]} {
9637 notbusy checkout
9638 error_popup $err
9639 if {$showlocalchanges} {
9640 dodiffindex
9642 } else {
9643 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9647 proc readcheckoutstat {fd newhead newheadid} {
9648 global mainhead mainheadid headids showlocalchanges progresscoords
9649 global viewmainheadid curview
9651 if {[gets $fd line] >= 0} {
9652 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9653 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9654 adjustprogress
9656 return 1
9658 set progresscoords {0 0}
9659 adjustprogress
9660 notbusy checkout
9661 if {[catch {close $fd} err]} {
9662 error_popup $err
9664 set oldmainid $mainheadid
9665 set mainhead $newhead
9666 set mainheadid $newheadid
9667 set viewmainheadid($curview) $newheadid
9668 redrawtags $oldmainid
9669 redrawtags $newheadid
9670 selbyid $newheadid
9671 if {$showlocalchanges} {
9672 dodiffindex
9676 proc rmbranch {} {
9677 global headmenuid headmenuhead mainhead
9678 global idheads
9680 set head $headmenuhead
9681 set id $headmenuid
9682 # this check shouldn't be needed any more...
9683 if {$head eq $mainhead} {
9684 error_popup [mc "Cannot delete the currently checked-out branch"]
9685 return
9687 set dheads [descheads $id]
9688 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9689 # the stuff on this branch isn't on any other branch
9690 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9691 branch.\nReally delete branch %s?" $head $head]]} return
9693 nowbusy rmbranch
9694 update
9695 if {[catch {exec git branch -D $head} err]} {
9696 notbusy rmbranch
9697 error_popup $err
9698 return
9700 removehead $id $head
9701 removedhead $id $head
9702 redrawtags $id
9703 notbusy rmbranch
9704 dispneartags 0
9705 run refill_reflist
9708 # Display a list of tags and heads
9709 proc showrefs {} {
9710 global showrefstop bgcolor fgcolor selectbgcolor NS
9711 global bglist fglist reflistfilter reflist maincursor
9713 set top .showrefs
9714 set showrefstop $top
9715 if {[winfo exists $top]} {
9716 raise $top
9717 refill_reflist
9718 return
9720 ttk_toplevel $top
9721 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9722 make_transient $top .
9723 text $top.list -background $bgcolor -foreground $fgcolor \
9724 -selectbackground $selectbgcolor -font mainfont \
9725 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9726 -width 30 -height 20 -cursor $maincursor \
9727 -spacing1 1 -spacing3 1 -state disabled
9728 $top.list tag configure highlight -background $selectbgcolor
9729 lappend bglist $top.list
9730 lappend fglist $top.list
9731 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9732 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9733 grid $top.list $top.ysb -sticky nsew
9734 grid $top.xsb x -sticky ew
9735 ${NS}::frame $top.f
9736 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9737 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9738 set reflistfilter "*"
9739 trace add variable reflistfilter write reflistfilter_change
9740 pack $top.f.e -side right -fill x -expand 1
9741 pack $top.f.l -side left
9742 grid $top.f - -sticky ew -pady 2
9743 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9744 bind $top <Key-Escape> [list destroy $top]
9745 grid $top.close -
9746 grid columnconfigure $top 0 -weight 1
9747 grid rowconfigure $top 0 -weight 1
9748 bind $top.list <1> {break}
9749 bind $top.list <B1-Motion> {break}
9750 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9751 set reflist {}
9752 refill_reflist
9755 proc sel_reflist {w x y} {
9756 global showrefstop reflist headids tagids otherrefids
9758 if {![winfo exists $showrefstop]} return
9759 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9760 set ref [lindex $reflist [expr {$l-1}]]
9761 set n [lindex $ref 0]
9762 switch -- [lindex $ref 1] {
9763 "H" {selbyid $headids($n)}
9764 "T" {selbyid $tagids($n)}
9765 "o" {selbyid $otherrefids($n)}
9767 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9770 proc unsel_reflist {} {
9771 global showrefstop
9773 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9774 $showrefstop.list tag remove highlight 0.0 end
9777 proc reflistfilter_change {n1 n2 op} {
9778 global reflistfilter
9780 after cancel refill_reflist
9781 after 200 refill_reflist
9784 proc refill_reflist {} {
9785 global reflist reflistfilter showrefstop headids tagids otherrefids
9786 global curview
9788 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9789 set refs {}
9790 foreach n [array names headids] {
9791 if {[string match $reflistfilter $n]} {
9792 if {[commitinview $headids($n) $curview]} {
9793 lappend refs [list $n H]
9794 } else {
9795 interestedin $headids($n) {run refill_reflist}
9799 foreach n [array names tagids] {
9800 if {[string match $reflistfilter $n]} {
9801 if {[commitinview $tagids($n) $curview]} {
9802 lappend refs [list $n T]
9803 } else {
9804 interestedin $tagids($n) {run refill_reflist}
9808 foreach n [array names otherrefids] {
9809 if {[string match $reflistfilter $n]} {
9810 if {[commitinview $otherrefids($n) $curview]} {
9811 lappend refs [list $n o]
9812 } else {
9813 interestedin $otherrefids($n) {run refill_reflist}
9817 set refs [lsort -index 0 $refs]
9818 if {$refs eq $reflist} return
9820 # Update the contents of $showrefstop.list according to the
9821 # differences between $reflist (old) and $refs (new)
9822 $showrefstop.list conf -state normal
9823 $showrefstop.list insert end "\n"
9824 set i 0
9825 set j 0
9826 while {$i < [llength $reflist] || $j < [llength $refs]} {
9827 if {$i < [llength $reflist]} {
9828 if {$j < [llength $refs]} {
9829 set cmp [string compare [lindex $reflist $i 0] \
9830 [lindex $refs $j 0]]
9831 if {$cmp == 0} {
9832 set cmp [string compare [lindex $reflist $i 1] \
9833 [lindex $refs $j 1]]
9835 } else {
9836 set cmp -1
9838 } else {
9839 set cmp 1
9841 switch -- $cmp {
9842 -1 {
9843 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9844 incr i
9847 incr i
9848 incr j
9851 set l [expr {$j + 1}]
9852 $showrefstop.list image create $l.0 -align baseline \
9853 -image reficon-[lindex $refs $j 1] -padx 2
9854 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9855 incr j
9859 set reflist $refs
9860 # delete last newline
9861 $showrefstop.list delete end-2c end-1c
9862 $showrefstop.list conf -state disabled
9865 # Stuff for finding nearby tags
9866 proc getallcommits {} {
9867 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9868 global idheads idtags idotherrefs allparents tagobjid
9869 global gitdir
9871 if {![info exists allcommits]} {
9872 set nextarc 0
9873 set allcommits 0
9874 set seeds {}
9875 set allcwait 0
9876 set cachedarcs 0
9877 set allccache [file join $gitdir "gitk.cache"]
9878 if {![catch {
9879 set f [open $allccache r]
9880 set allcwait 1
9881 getcache $f
9882 }]} return
9885 if {$allcwait} {
9886 return
9888 set cmd [list | git rev-list --parents]
9889 set allcupdate [expr {$seeds ne {}}]
9890 if {!$allcupdate} {
9891 set ids "--all"
9892 } else {
9893 set refs [concat [array names idheads] [array names idtags] \
9894 [array names idotherrefs]]
9895 set ids {}
9896 set tagobjs {}
9897 foreach name [array names tagobjid] {
9898 lappend tagobjs $tagobjid($name)
9900 foreach id [lsort -unique $refs] {
9901 if {![info exists allparents($id)] &&
9902 [lsearch -exact $tagobjs $id] < 0} {
9903 lappend ids $id
9906 if {$ids ne {}} {
9907 foreach id $seeds {
9908 lappend ids "^$id"
9912 if {$ids ne {}} {
9913 set fd [open [concat $cmd $ids] r]
9914 fconfigure $fd -blocking 0
9915 incr allcommits
9916 nowbusy allcommits
9917 filerun $fd [list getallclines $fd]
9918 } else {
9919 dispneartags 0
9923 # Since most commits have 1 parent and 1 child, we group strings of
9924 # such commits into "arcs" joining branch/merge points (BMPs), which
9925 # are commits that either don't have 1 parent or don't have 1 child.
9927 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9928 # arcout(id) - outgoing arcs for BMP
9929 # arcids(a) - list of IDs on arc including end but not start
9930 # arcstart(a) - BMP ID at start of arc
9931 # arcend(a) - BMP ID at end of arc
9932 # growing(a) - arc a is still growing
9933 # arctags(a) - IDs out of arcids (excluding end) that have tags
9934 # archeads(a) - IDs out of arcids (excluding end) that have heads
9935 # The start of an arc is at the descendent end, so "incoming" means
9936 # coming from descendents, and "outgoing" means going towards ancestors.
9938 proc getallclines {fd} {
9939 global allparents allchildren idtags idheads nextarc
9940 global arcnos arcids arctags arcout arcend arcstart archeads growing
9941 global seeds allcommits cachedarcs allcupdate
9943 set nid 0
9944 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9945 set id [lindex $line 0]
9946 if {[info exists allparents($id)]} {
9947 # seen it already
9948 continue
9950 set cachedarcs 0
9951 set olds [lrange $line 1 end]
9952 set allparents($id) $olds
9953 if {![info exists allchildren($id)]} {
9954 set allchildren($id) {}
9955 set arcnos($id) {}
9956 lappend seeds $id
9957 } else {
9958 set a $arcnos($id)
9959 if {[llength $olds] == 1 && [llength $a] == 1} {
9960 lappend arcids($a) $id
9961 if {[info exists idtags($id)]} {
9962 lappend arctags($a) $id
9964 if {[info exists idheads($id)]} {
9965 lappend archeads($a) $id
9967 if {[info exists allparents($olds)]} {
9968 # seen parent already
9969 if {![info exists arcout($olds)]} {
9970 splitarc $olds
9972 lappend arcids($a) $olds
9973 set arcend($a) $olds
9974 unset growing($a)
9976 lappend allchildren($olds) $id
9977 lappend arcnos($olds) $a
9978 continue
9981 foreach a $arcnos($id) {
9982 lappend arcids($a) $id
9983 set arcend($a) $id
9984 unset growing($a)
9987 set ao {}
9988 foreach p $olds {
9989 lappend allchildren($p) $id
9990 set a [incr nextarc]
9991 set arcstart($a) $id
9992 set archeads($a) {}
9993 set arctags($a) {}
9994 set archeads($a) {}
9995 set arcids($a) {}
9996 lappend ao $a
9997 set growing($a) 1
9998 if {[info exists allparents($p)]} {
9999 # seen it already, may need to make a new branch
10000 if {![info exists arcout($p)]} {
10001 splitarc $p
10003 lappend arcids($a) $p
10004 set arcend($a) $p
10005 unset growing($a)
10007 lappend arcnos($p) $a
10009 set arcout($id) $ao
10011 if {$nid > 0} {
10012 global cached_dheads cached_dtags cached_atags
10013 catch {unset cached_dheads}
10014 catch {unset cached_dtags}
10015 catch {unset cached_atags}
10017 if {![eof $fd]} {
10018 return [expr {$nid >= 1000? 2: 1}]
10020 set cacheok 1
10021 if {[catch {
10022 fconfigure $fd -blocking 1
10023 close $fd
10024 } err]} {
10025 # got an error reading the list of commits
10026 # if we were updating, try rereading the whole thing again
10027 if {$allcupdate} {
10028 incr allcommits -1
10029 dropcache $err
10030 return
10032 error_popup "[mc "Error reading commit topology information;\
10033 branch and preceding/following tag information\
10034 will be incomplete."]\n($err)"
10035 set cacheok 0
10037 if {[incr allcommits -1] == 0} {
10038 notbusy allcommits
10039 if {$cacheok} {
10040 run savecache
10043 dispneartags 0
10044 return 0
10047 proc recalcarc {a} {
10048 global arctags archeads arcids idtags idheads
10050 set at {}
10051 set ah {}
10052 foreach id [lrange $arcids($a) 0 end-1] {
10053 if {[info exists idtags($id)]} {
10054 lappend at $id
10056 if {[info exists idheads($id)]} {
10057 lappend ah $id
10060 set arctags($a) $at
10061 set archeads($a) $ah
10064 proc splitarc {p} {
10065 global arcnos arcids nextarc arctags archeads idtags idheads
10066 global arcstart arcend arcout allparents growing
10068 set a $arcnos($p)
10069 if {[llength $a] != 1} {
10070 puts "oops splitarc called but [llength $a] arcs already"
10071 return
10073 set a [lindex $a 0]
10074 set i [lsearch -exact $arcids($a) $p]
10075 if {$i < 0} {
10076 puts "oops splitarc $p not in arc $a"
10077 return
10079 set na [incr nextarc]
10080 if {[info exists arcend($a)]} {
10081 set arcend($na) $arcend($a)
10082 } else {
10083 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10084 set j [lsearch -exact $arcnos($l) $a]
10085 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10087 set tail [lrange $arcids($a) [expr {$i+1}] end]
10088 set arcids($a) [lrange $arcids($a) 0 $i]
10089 set arcend($a) $p
10090 set arcstart($na) $p
10091 set arcout($p) $na
10092 set arcids($na) $tail
10093 if {[info exists growing($a)]} {
10094 set growing($na) 1
10095 unset growing($a)
10098 foreach id $tail {
10099 if {[llength $arcnos($id)] == 1} {
10100 set arcnos($id) $na
10101 } else {
10102 set j [lsearch -exact $arcnos($id) $a]
10103 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10107 # reconstruct tags and heads lists
10108 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10109 recalcarc $a
10110 recalcarc $na
10111 } else {
10112 set arctags($na) {}
10113 set archeads($na) {}
10117 # Update things for a new commit added that is a child of one
10118 # existing commit. Used when cherry-picking.
10119 proc addnewchild {id p} {
10120 global allparents allchildren idtags nextarc
10121 global arcnos arcids arctags arcout arcend arcstart archeads growing
10122 global seeds allcommits
10124 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10125 set allparents($id) [list $p]
10126 set allchildren($id) {}
10127 set arcnos($id) {}
10128 lappend seeds $id
10129 lappend allchildren($p) $id
10130 set a [incr nextarc]
10131 set arcstart($a) $id
10132 set archeads($a) {}
10133 set arctags($a) {}
10134 set arcids($a) [list $p]
10135 set arcend($a) $p
10136 if {![info exists arcout($p)]} {
10137 splitarc $p
10139 lappend arcnos($p) $a
10140 set arcout($id) [list $a]
10143 # This implements a cache for the topology information.
10144 # The cache saves, for each arc, the start and end of the arc,
10145 # the ids on the arc, and the outgoing arcs from the end.
10146 proc readcache {f} {
10147 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10148 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10149 global allcwait
10151 set a $nextarc
10152 set lim $cachedarcs
10153 if {$lim - $a > 500} {
10154 set lim [expr {$a + 500}]
10156 if {[catch {
10157 if {$a == $lim} {
10158 # finish reading the cache and setting up arctags, etc.
10159 set line [gets $f]
10160 if {$line ne "1"} {error "bad final version"}
10161 close $f
10162 foreach id [array names idtags] {
10163 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10164 [llength $allparents($id)] == 1} {
10165 set a [lindex $arcnos($id) 0]
10166 if {$arctags($a) eq {}} {
10167 recalcarc $a
10171 foreach id [array names idheads] {
10172 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10173 [llength $allparents($id)] == 1} {
10174 set a [lindex $arcnos($id) 0]
10175 if {$archeads($a) eq {}} {
10176 recalcarc $a
10180 foreach id [lsort -unique $possible_seeds] {
10181 if {$arcnos($id) eq {}} {
10182 lappend seeds $id
10185 set allcwait 0
10186 } else {
10187 while {[incr a] <= $lim} {
10188 set line [gets $f]
10189 if {[llength $line] != 3} {error "bad line"}
10190 set s [lindex $line 0]
10191 set arcstart($a) $s
10192 lappend arcout($s) $a
10193 if {![info exists arcnos($s)]} {
10194 lappend possible_seeds $s
10195 set arcnos($s) {}
10197 set e [lindex $line 1]
10198 if {$e eq {}} {
10199 set growing($a) 1
10200 } else {
10201 set arcend($a) $e
10202 if {![info exists arcout($e)]} {
10203 set arcout($e) {}
10206 set arcids($a) [lindex $line 2]
10207 foreach id $arcids($a) {
10208 lappend allparents($s) $id
10209 set s $id
10210 lappend arcnos($id) $a
10212 if {![info exists allparents($s)]} {
10213 set allparents($s) {}
10215 set arctags($a) {}
10216 set archeads($a) {}
10218 set nextarc [expr {$a - 1}]
10220 } err]} {
10221 dropcache $err
10222 return 0
10224 if {!$allcwait} {
10225 getallcommits
10227 return $allcwait
10230 proc getcache {f} {
10231 global nextarc cachedarcs possible_seeds
10233 if {[catch {
10234 set line [gets $f]
10235 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10236 # make sure it's an integer
10237 set cachedarcs [expr {int([lindex $line 1])}]
10238 if {$cachedarcs < 0} {error "bad number of arcs"}
10239 set nextarc 0
10240 set possible_seeds {}
10241 run readcache $f
10242 } err]} {
10243 dropcache $err
10245 return 0
10248 proc dropcache {err} {
10249 global allcwait nextarc cachedarcs seeds
10251 #puts "dropping cache ($err)"
10252 foreach v {arcnos arcout arcids arcstart arcend growing \
10253 arctags archeads allparents allchildren} {
10254 global $v
10255 catch {unset $v}
10257 set allcwait 0
10258 set nextarc 0
10259 set cachedarcs 0
10260 set seeds {}
10261 getallcommits
10264 proc writecache {f} {
10265 global cachearc cachedarcs allccache
10266 global arcstart arcend arcnos arcids arcout
10268 set a $cachearc
10269 set lim $cachedarcs
10270 if {$lim - $a > 1000} {
10271 set lim [expr {$a + 1000}]
10273 if {[catch {
10274 while {[incr a] <= $lim} {
10275 if {[info exists arcend($a)]} {
10276 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10277 } else {
10278 puts $f [list $arcstart($a) {} $arcids($a)]
10281 } err]} {
10282 catch {close $f}
10283 catch {file delete $allccache}
10284 #puts "writing cache failed ($err)"
10285 return 0
10287 set cachearc [expr {$a - 1}]
10288 if {$a > $cachedarcs} {
10289 puts $f "1"
10290 close $f
10291 return 0
10293 return 1
10296 proc savecache {} {
10297 global nextarc cachedarcs cachearc allccache
10299 if {$nextarc == $cachedarcs} return
10300 set cachearc 0
10301 set cachedarcs $nextarc
10302 catch {
10303 set f [open $allccache w]
10304 puts $f [list 1 $cachedarcs]
10305 run writecache $f
10309 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10310 # or 0 if neither is true.
10311 proc anc_or_desc {a b} {
10312 global arcout arcstart arcend arcnos cached_isanc
10314 if {$arcnos($a) eq $arcnos($b)} {
10315 # Both are on the same arc(s); either both are the same BMP,
10316 # or if one is not a BMP, the other is also not a BMP or is
10317 # the BMP at end of the arc (and it only has 1 incoming arc).
10318 # Or both can be BMPs with no incoming arcs.
10319 if {$a eq $b || $arcnos($a) eq {}} {
10320 return 0
10322 # assert {[llength $arcnos($a)] == 1}
10323 set arc [lindex $arcnos($a) 0]
10324 set i [lsearch -exact $arcids($arc) $a]
10325 set j [lsearch -exact $arcids($arc) $b]
10326 if {$i < 0 || $i > $j} {
10327 return 1
10328 } else {
10329 return -1
10333 if {![info exists arcout($a)]} {
10334 set arc [lindex $arcnos($a) 0]
10335 if {[info exists arcend($arc)]} {
10336 set aend $arcend($arc)
10337 } else {
10338 set aend {}
10340 set a $arcstart($arc)
10341 } else {
10342 set aend $a
10344 if {![info exists arcout($b)]} {
10345 set arc [lindex $arcnos($b) 0]
10346 if {[info exists arcend($arc)]} {
10347 set bend $arcend($arc)
10348 } else {
10349 set bend {}
10351 set b $arcstart($arc)
10352 } else {
10353 set bend $b
10355 if {$a eq $bend} {
10356 return 1
10358 if {$b eq $aend} {
10359 return -1
10361 if {[info exists cached_isanc($a,$bend)]} {
10362 if {$cached_isanc($a,$bend)} {
10363 return 1
10366 if {[info exists cached_isanc($b,$aend)]} {
10367 if {$cached_isanc($b,$aend)} {
10368 return -1
10370 if {[info exists cached_isanc($a,$bend)]} {
10371 return 0
10375 set todo [list $a $b]
10376 set anc($a) a
10377 set anc($b) b
10378 for {set i 0} {$i < [llength $todo]} {incr i} {
10379 set x [lindex $todo $i]
10380 if {$anc($x) eq {}} {
10381 continue
10383 foreach arc $arcnos($x) {
10384 set xd $arcstart($arc)
10385 if {$xd eq $bend} {
10386 set cached_isanc($a,$bend) 1
10387 set cached_isanc($b,$aend) 0
10388 return 1
10389 } elseif {$xd eq $aend} {
10390 set cached_isanc($b,$aend) 1
10391 set cached_isanc($a,$bend) 0
10392 return -1
10394 if {![info exists anc($xd)]} {
10395 set anc($xd) $anc($x)
10396 lappend todo $xd
10397 } elseif {$anc($xd) ne $anc($x)} {
10398 set anc($xd) {}
10402 set cached_isanc($a,$bend) 0
10403 set cached_isanc($b,$aend) 0
10404 return 0
10407 # This identifies whether $desc has an ancestor that is
10408 # a growing tip of the graph and which is not an ancestor of $anc
10409 # and returns 0 if so and 1 if not.
10410 # If we subsequently discover a tag on such a growing tip, and that
10411 # turns out to be a descendent of $anc (which it could, since we
10412 # don't necessarily see children before parents), then $desc
10413 # isn't a good choice to display as a descendent tag of
10414 # $anc (since it is the descendent of another tag which is
10415 # a descendent of $anc). Similarly, $anc isn't a good choice to
10416 # display as a ancestor tag of $desc.
10418 proc is_certain {desc anc} {
10419 global arcnos arcout arcstart arcend growing problems
10421 set certain {}
10422 if {[llength $arcnos($anc)] == 1} {
10423 # tags on the same arc are certain
10424 if {$arcnos($desc) eq $arcnos($anc)} {
10425 return 1
10427 if {![info exists arcout($anc)]} {
10428 # if $anc is partway along an arc, use the start of the arc instead
10429 set a [lindex $arcnos($anc) 0]
10430 set anc $arcstart($a)
10433 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10434 set x $desc
10435 } else {
10436 set a [lindex $arcnos($desc) 0]
10437 set x $arcend($a)
10439 if {$x == $anc} {
10440 return 1
10442 set anclist [list $x]
10443 set dl($x) 1
10444 set nnh 1
10445 set ngrowanc 0
10446 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10447 set x [lindex $anclist $i]
10448 if {$dl($x)} {
10449 incr nnh -1
10451 set done($x) 1
10452 foreach a $arcout($x) {
10453 if {[info exists growing($a)]} {
10454 if {![info exists growanc($x)] && $dl($x)} {
10455 set growanc($x) 1
10456 incr ngrowanc
10458 } else {
10459 set y $arcend($a)
10460 if {[info exists dl($y)]} {
10461 if {$dl($y)} {
10462 if {!$dl($x)} {
10463 set dl($y) 0
10464 if {![info exists done($y)]} {
10465 incr nnh -1
10467 if {[info exists growanc($x)]} {
10468 incr ngrowanc -1
10470 set xl [list $y]
10471 for {set k 0} {$k < [llength $xl]} {incr k} {
10472 set z [lindex $xl $k]
10473 foreach c $arcout($z) {
10474 if {[info exists arcend($c)]} {
10475 set v $arcend($c)
10476 if {[info exists dl($v)] && $dl($v)} {
10477 set dl($v) 0
10478 if {![info exists done($v)]} {
10479 incr nnh -1
10481 if {[info exists growanc($v)]} {
10482 incr ngrowanc -1
10484 lappend xl $v
10491 } elseif {$y eq $anc || !$dl($x)} {
10492 set dl($y) 0
10493 lappend anclist $y
10494 } else {
10495 set dl($y) 1
10496 lappend anclist $y
10497 incr nnh
10502 foreach x [array names growanc] {
10503 if {$dl($x)} {
10504 return 0
10506 return 0
10508 return 1
10511 proc validate_arctags {a} {
10512 global arctags idtags
10514 set i -1
10515 set na $arctags($a)
10516 foreach id $arctags($a) {
10517 incr i
10518 if {![info exists idtags($id)]} {
10519 set na [lreplace $na $i $i]
10520 incr i -1
10523 set arctags($a) $na
10526 proc validate_archeads {a} {
10527 global archeads idheads
10529 set i -1
10530 set na $archeads($a)
10531 foreach id $archeads($a) {
10532 incr i
10533 if {![info exists idheads($id)]} {
10534 set na [lreplace $na $i $i]
10535 incr i -1
10538 set archeads($a) $na
10541 # Return the list of IDs that have tags that are descendents of id,
10542 # ignoring IDs that are descendents of IDs already reported.
10543 proc desctags {id} {
10544 global arcnos arcstart arcids arctags idtags allparents
10545 global growing cached_dtags
10547 if {![info exists allparents($id)]} {
10548 return {}
10550 set t1 [clock clicks -milliseconds]
10551 set argid $id
10552 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10553 # part-way along an arc; check that arc first
10554 set a [lindex $arcnos($id) 0]
10555 if {$arctags($a) ne {}} {
10556 validate_arctags $a
10557 set i [lsearch -exact $arcids($a) $id]
10558 set tid {}
10559 foreach t $arctags($a) {
10560 set j [lsearch -exact $arcids($a) $t]
10561 if {$j >= $i} break
10562 set tid $t
10564 if {$tid ne {}} {
10565 return $tid
10568 set id $arcstart($a)
10569 if {[info exists idtags($id)]} {
10570 return $id
10573 if {[info exists cached_dtags($id)]} {
10574 return $cached_dtags($id)
10577 set origid $id
10578 set todo [list $id]
10579 set queued($id) 1
10580 set nc 1
10581 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10582 set id [lindex $todo $i]
10583 set done($id) 1
10584 set ta [info exists hastaggedancestor($id)]
10585 if {!$ta} {
10586 incr nc -1
10588 # ignore tags on starting node
10589 if {!$ta && $i > 0} {
10590 if {[info exists idtags($id)]} {
10591 set tagloc($id) $id
10592 set ta 1
10593 } elseif {[info exists cached_dtags($id)]} {
10594 set tagloc($id) $cached_dtags($id)
10595 set ta 1
10598 foreach a $arcnos($id) {
10599 set d $arcstart($a)
10600 if {!$ta && $arctags($a) ne {}} {
10601 validate_arctags $a
10602 if {$arctags($a) ne {}} {
10603 lappend tagloc($id) [lindex $arctags($a) end]
10606 if {$ta || $arctags($a) ne {}} {
10607 set tomark [list $d]
10608 for {set j 0} {$j < [llength $tomark]} {incr j} {
10609 set dd [lindex $tomark $j]
10610 if {![info exists hastaggedancestor($dd)]} {
10611 if {[info exists done($dd)]} {
10612 foreach b $arcnos($dd) {
10613 lappend tomark $arcstart($b)
10615 if {[info exists tagloc($dd)]} {
10616 unset tagloc($dd)
10618 } elseif {[info exists queued($dd)]} {
10619 incr nc -1
10621 set hastaggedancestor($dd) 1
10625 if {![info exists queued($d)]} {
10626 lappend todo $d
10627 set queued($d) 1
10628 if {![info exists hastaggedancestor($d)]} {
10629 incr nc
10634 set tags {}
10635 foreach id [array names tagloc] {
10636 if {![info exists hastaggedancestor($id)]} {
10637 foreach t $tagloc($id) {
10638 if {[lsearch -exact $tags $t] < 0} {
10639 lappend tags $t
10644 set t2 [clock clicks -milliseconds]
10645 set loopix $i
10647 # remove tags that are descendents of other tags
10648 for {set i 0} {$i < [llength $tags]} {incr i} {
10649 set a [lindex $tags $i]
10650 for {set j 0} {$j < $i} {incr j} {
10651 set b [lindex $tags $j]
10652 set r [anc_or_desc $a $b]
10653 if {$r == 1} {
10654 set tags [lreplace $tags $j $j]
10655 incr j -1
10656 incr i -1
10657 } elseif {$r == -1} {
10658 set tags [lreplace $tags $i $i]
10659 incr i -1
10660 break
10665 if {[array names growing] ne {}} {
10666 # graph isn't finished, need to check if any tag could get
10667 # eclipsed by another tag coming later. Simply ignore any
10668 # tags that could later get eclipsed.
10669 set ctags {}
10670 foreach t $tags {
10671 if {[is_certain $t $origid]} {
10672 lappend ctags $t
10675 if {$tags eq $ctags} {
10676 set cached_dtags($origid) $tags
10677 } else {
10678 set tags $ctags
10680 } else {
10681 set cached_dtags($origid) $tags
10683 set t3 [clock clicks -milliseconds]
10684 if {0 && $t3 - $t1 >= 100} {
10685 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10686 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10688 return $tags
10691 proc anctags {id} {
10692 global arcnos arcids arcout arcend arctags idtags allparents
10693 global growing cached_atags
10695 if {![info exists allparents($id)]} {
10696 return {}
10698 set t1 [clock clicks -milliseconds]
10699 set argid $id
10700 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10701 # part-way along an arc; check that arc first
10702 set a [lindex $arcnos($id) 0]
10703 if {$arctags($a) ne {}} {
10704 validate_arctags $a
10705 set i [lsearch -exact $arcids($a) $id]
10706 foreach t $arctags($a) {
10707 set j [lsearch -exact $arcids($a) $t]
10708 if {$j > $i} {
10709 return $t
10713 if {![info exists arcend($a)]} {
10714 return {}
10716 set id $arcend($a)
10717 if {[info exists idtags($id)]} {
10718 return $id
10721 if {[info exists cached_atags($id)]} {
10722 return $cached_atags($id)
10725 set origid $id
10726 set todo [list $id]
10727 set queued($id) 1
10728 set taglist {}
10729 set nc 1
10730 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10731 set id [lindex $todo $i]
10732 set done($id) 1
10733 set td [info exists hastaggeddescendent($id)]
10734 if {!$td} {
10735 incr nc -1
10737 # ignore tags on starting node
10738 if {!$td && $i > 0} {
10739 if {[info exists idtags($id)]} {
10740 set tagloc($id) $id
10741 set td 1
10742 } elseif {[info exists cached_atags($id)]} {
10743 set tagloc($id) $cached_atags($id)
10744 set td 1
10747 foreach a $arcout($id) {
10748 if {!$td && $arctags($a) ne {}} {
10749 validate_arctags $a
10750 if {$arctags($a) ne {}} {
10751 lappend tagloc($id) [lindex $arctags($a) 0]
10754 if {![info exists arcend($a)]} continue
10755 set d $arcend($a)
10756 if {$td || $arctags($a) ne {}} {
10757 set tomark [list $d]
10758 for {set j 0} {$j < [llength $tomark]} {incr j} {
10759 set dd [lindex $tomark $j]
10760 if {![info exists hastaggeddescendent($dd)]} {
10761 if {[info exists done($dd)]} {
10762 foreach b $arcout($dd) {
10763 if {[info exists arcend($b)]} {
10764 lappend tomark $arcend($b)
10767 if {[info exists tagloc($dd)]} {
10768 unset tagloc($dd)
10770 } elseif {[info exists queued($dd)]} {
10771 incr nc -1
10773 set hastaggeddescendent($dd) 1
10777 if {![info exists queued($d)]} {
10778 lappend todo $d
10779 set queued($d) 1
10780 if {![info exists hastaggeddescendent($d)]} {
10781 incr nc
10786 set t2 [clock clicks -milliseconds]
10787 set loopix $i
10788 set tags {}
10789 foreach id [array names tagloc] {
10790 if {![info exists hastaggeddescendent($id)]} {
10791 foreach t $tagloc($id) {
10792 if {[lsearch -exact $tags $t] < 0} {
10793 lappend tags $t
10799 # remove tags that are ancestors of other tags
10800 for {set i 0} {$i < [llength $tags]} {incr i} {
10801 set a [lindex $tags $i]
10802 for {set j 0} {$j < $i} {incr j} {
10803 set b [lindex $tags $j]
10804 set r [anc_or_desc $a $b]
10805 if {$r == -1} {
10806 set tags [lreplace $tags $j $j]
10807 incr j -1
10808 incr i -1
10809 } elseif {$r == 1} {
10810 set tags [lreplace $tags $i $i]
10811 incr i -1
10812 break
10817 if {[array names growing] ne {}} {
10818 # graph isn't finished, need to check if any tag could get
10819 # eclipsed by another tag coming later. Simply ignore any
10820 # tags that could later get eclipsed.
10821 set ctags {}
10822 foreach t $tags {
10823 if {[is_certain $origid $t]} {
10824 lappend ctags $t
10827 if {$tags eq $ctags} {
10828 set cached_atags($origid) $tags
10829 } else {
10830 set tags $ctags
10832 } else {
10833 set cached_atags($origid) $tags
10835 set t3 [clock clicks -milliseconds]
10836 if {0 && $t3 - $t1 >= 100} {
10837 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10838 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10840 return $tags
10843 # Return the list of IDs that have heads that are descendents of id,
10844 # including id itself if it has a head.
10845 proc descheads {id} {
10846 global arcnos arcstart arcids archeads idheads cached_dheads
10847 global allparents arcout
10849 if {![info exists allparents($id)]} {
10850 return {}
10852 set aret {}
10853 if {![info exists arcout($id)]} {
10854 # part-way along an arc; check it first
10855 set a [lindex $arcnos($id) 0]
10856 if {$archeads($a) ne {}} {
10857 validate_archeads $a
10858 set i [lsearch -exact $arcids($a) $id]
10859 foreach t $archeads($a) {
10860 set j [lsearch -exact $arcids($a) $t]
10861 if {$j > $i} break
10862 lappend aret $t
10865 set id $arcstart($a)
10867 set origid $id
10868 set todo [list $id]
10869 set seen($id) 1
10870 set ret {}
10871 for {set i 0} {$i < [llength $todo]} {incr i} {
10872 set id [lindex $todo $i]
10873 if {[info exists cached_dheads($id)]} {
10874 set ret [concat $ret $cached_dheads($id)]
10875 } else {
10876 if {[info exists idheads($id)]} {
10877 lappend ret $id
10879 foreach a $arcnos($id) {
10880 if {$archeads($a) ne {}} {
10881 validate_archeads $a
10882 if {$archeads($a) ne {}} {
10883 set ret [concat $ret $archeads($a)]
10886 set d $arcstart($a)
10887 if {![info exists seen($d)]} {
10888 lappend todo $d
10889 set seen($d) 1
10894 set ret [lsort -unique $ret]
10895 set cached_dheads($origid) $ret
10896 return [concat $ret $aret]
10899 proc addedtag {id} {
10900 global arcnos arcout cached_dtags cached_atags
10902 if {![info exists arcnos($id)]} return
10903 if {![info exists arcout($id)]} {
10904 recalcarc [lindex $arcnos($id) 0]
10906 catch {unset cached_dtags}
10907 catch {unset cached_atags}
10910 proc addedhead {hid head} {
10911 global arcnos arcout cached_dheads
10913 if {![info exists arcnos($hid)]} return
10914 if {![info exists arcout($hid)]} {
10915 recalcarc [lindex $arcnos($hid) 0]
10917 catch {unset cached_dheads}
10920 proc removedhead {hid head} {
10921 global cached_dheads
10923 catch {unset cached_dheads}
10926 proc movedhead {hid head} {
10927 global arcnos arcout cached_dheads
10929 if {![info exists arcnos($hid)]} return
10930 if {![info exists arcout($hid)]} {
10931 recalcarc [lindex $arcnos($hid) 0]
10933 catch {unset cached_dheads}
10936 proc changedrefs {} {
10937 global cached_dheads cached_dtags cached_atags cached_tagcontent
10938 global arctags archeads arcnos arcout idheads idtags
10940 foreach id [concat [array names idheads] [array names idtags]] {
10941 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10942 set a [lindex $arcnos($id) 0]
10943 if {![info exists donearc($a)]} {
10944 recalcarc $a
10945 set donearc($a) 1
10949 catch {unset cached_tagcontent}
10950 catch {unset cached_dtags}
10951 catch {unset cached_atags}
10952 catch {unset cached_dheads}
10955 proc rereadrefs {} {
10956 global idtags idheads idotherrefs mainheadid
10958 set refids [concat [array names idtags] \
10959 [array names idheads] [array names idotherrefs]]
10960 foreach id $refids {
10961 if {![info exists ref($id)]} {
10962 set ref($id) [listrefs $id]
10965 set oldmainhead $mainheadid
10966 readrefs
10967 changedrefs
10968 set refids [lsort -unique [concat $refids [array names idtags] \
10969 [array names idheads] [array names idotherrefs]]]
10970 foreach id $refids {
10971 set v [listrefs $id]
10972 if {![info exists ref($id)] || $ref($id) != $v} {
10973 redrawtags $id
10976 if {$oldmainhead ne $mainheadid} {
10977 redrawtags $oldmainhead
10978 redrawtags $mainheadid
10980 run refill_reflist
10983 proc listrefs {id} {
10984 global idtags idheads idotherrefs
10986 set x {}
10987 if {[info exists idtags($id)]} {
10988 set x $idtags($id)
10990 set y {}
10991 if {[info exists idheads($id)]} {
10992 set y $idheads($id)
10994 set z {}
10995 if {[info exists idotherrefs($id)]} {
10996 set z $idotherrefs($id)
10998 return [list $x $y $z]
11001 proc add_tag_ctext {tag} {
11002 global ctext cached_tagcontent tagids
11004 if {![info exists cached_tagcontent($tag)]} {
11005 catch {
11006 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11009 $ctext insert end "[mc "Tag"]: $tag\n" bold
11010 if {[info exists cached_tagcontent($tag)]} {
11011 set text $cached_tagcontent($tag)
11012 } else {
11013 set text "[mc "Id"]: $tagids($tag)"
11015 appendwithlinks $text {}
11018 proc showtag {tag isnew} {
11019 global ctext cached_tagcontent tagids linknum tagobjid
11021 if {$isnew} {
11022 addtohistory [list showtag $tag 0] savectextpos
11024 $ctext conf -state normal
11025 clear_ctext
11026 settabs 0
11027 set linknum 0
11028 add_tag_ctext $tag
11029 maybe_scroll_ctext 1
11030 $ctext conf -state disabled
11031 init_flist {}
11034 proc showtags {id isnew} {
11035 global idtags ctext linknum
11037 if {$isnew} {
11038 addtohistory [list showtags $id 0] savectextpos
11040 $ctext conf -state normal
11041 clear_ctext
11042 settabs 0
11043 set linknum 0
11044 set sep {}
11045 foreach tag $idtags($id) {
11046 $ctext insert end $sep
11047 add_tag_ctext $tag
11048 set sep "\n\n"
11050 maybe_scroll_ctext 1
11051 $ctext conf -state disabled
11052 init_flist {}
11055 proc doquit {} {
11056 global stopped
11057 global gitktmpdir
11059 set stopped 100
11060 savestuff .
11061 destroy .
11063 if {[info exists gitktmpdir]} {
11064 catch {file delete -force $gitktmpdir}
11068 proc mkfontdisp {font top which} {
11069 global fontattr fontpref $font NS use_ttk
11071 set fontpref($font) [set $font]
11072 ${NS}::button $top.${font}but -text $which \
11073 -command [list choosefont $font $which]
11074 ${NS}::label $top.$font -relief flat -font $font \
11075 -text $fontattr($font,family) -justify left
11076 grid x $top.${font}but $top.$font -sticky w
11079 proc choosefont {font which} {
11080 global fontparam fontlist fonttop fontattr
11081 global prefstop NS
11083 set fontparam(which) $which
11084 set fontparam(font) $font
11085 set fontparam(family) [font actual $font -family]
11086 set fontparam(size) $fontattr($font,size)
11087 set fontparam(weight) $fontattr($font,weight)
11088 set fontparam(slant) $fontattr($font,slant)
11089 set top .gitkfont
11090 set fonttop $top
11091 if {![winfo exists $top]} {
11092 font create sample
11093 eval font config sample [font actual $font]
11094 ttk_toplevel $top
11095 make_transient $top $prefstop
11096 wm title $top [mc "Gitk font chooser"]
11097 ${NS}::label $top.l -textvariable fontparam(which)
11098 pack $top.l -side top
11099 set fontlist [lsort [font families]]
11100 ${NS}::frame $top.f
11101 listbox $top.f.fam -listvariable fontlist \
11102 -yscrollcommand [list $top.f.sb set]
11103 bind $top.f.fam <<ListboxSelect>> selfontfam
11104 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11105 pack $top.f.sb -side right -fill y
11106 pack $top.f.fam -side left -fill both -expand 1
11107 pack $top.f -side top -fill both -expand 1
11108 ${NS}::frame $top.g
11109 spinbox $top.g.size -from 4 -to 40 -width 4 \
11110 -textvariable fontparam(size) \
11111 -validatecommand {string is integer -strict %s}
11112 checkbutton $top.g.bold -padx 5 \
11113 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11114 -variable fontparam(weight) -onvalue bold -offvalue normal
11115 checkbutton $top.g.ital -padx 5 \
11116 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11117 -variable fontparam(slant) -onvalue italic -offvalue roman
11118 pack $top.g.size $top.g.bold $top.g.ital -side left
11119 pack $top.g -side top
11120 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11121 -background white
11122 $top.c create text 100 25 -anchor center -text $which -font sample \
11123 -fill black -tags text
11124 bind $top.c <Configure> [list centertext $top.c]
11125 pack $top.c -side top -fill x
11126 ${NS}::frame $top.buts
11127 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11128 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11129 bind $top <Key-Return> fontok
11130 bind $top <Key-Escape> fontcan
11131 grid $top.buts.ok $top.buts.can
11132 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11133 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11134 pack $top.buts -side bottom -fill x
11135 trace add variable fontparam write chg_fontparam
11136 } else {
11137 raise $top
11138 $top.c itemconf text -text $which
11140 set i [lsearch -exact $fontlist $fontparam(family)]
11141 if {$i >= 0} {
11142 $top.f.fam selection set $i
11143 $top.f.fam see $i
11147 proc centertext {w} {
11148 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11151 proc fontok {} {
11152 global fontparam fontpref prefstop
11154 set f $fontparam(font)
11155 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11156 if {$fontparam(weight) eq "bold"} {
11157 lappend fontpref($f) "bold"
11159 if {$fontparam(slant) eq "italic"} {
11160 lappend fontpref($f) "italic"
11162 set w $prefstop.notebook.fonts.$f
11163 $w conf -text $fontparam(family) -font $fontpref($f)
11165 fontcan
11168 proc fontcan {} {
11169 global fonttop fontparam
11171 if {[info exists fonttop]} {
11172 catch {destroy $fonttop}
11173 catch {font delete sample}
11174 unset fonttop
11175 unset fontparam
11179 if {[package vsatisfies [package provide Tk] 8.6]} {
11180 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11181 # function to make use of it.
11182 proc choosefont {font which} {
11183 tk fontchooser configure -title $which -font $font \
11184 -command [list on_choosefont $font $which]
11185 tk fontchooser show
11187 proc on_choosefont {font which newfont} {
11188 global fontparam
11189 puts stderr "$font $newfont"
11190 array set f [font actual $newfont]
11191 set fontparam(which) $which
11192 set fontparam(font) $font
11193 set fontparam(family) $f(-family)
11194 set fontparam(size) $f(-size)
11195 set fontparam(weight) $f(-weight)
11196 set fontparam(slant) $f(-slant)
11197 fontok
11201 proc selfontfam {} {
11202 global fonttop fontparam
11204 set i [$fonttop.f.fam curselection]
11205 if {$i ne {}} {
11206 set fontparam(family) [$fonttop.f.fam get $i]
11210 proc chg_fontparam {v sub op} {
11211 global fontparam
11213 font config sample -$sub $fontparam($sub)
11216 # Create a property sheet tab page
11217 proc create_prefs_page {w} {
11218 global NS
11219 set parent [join [lrange [split $w .] 0 end-1] .]
11220 if {[winfo class $parent] eq "TNotebook"} {
11221 ${NS}::frame $w
11222 } else {
11223 ${NS}::labelframe $w
11227 proc prefspage_general {notebook} {
11228 global NS maxwidth maxgraphpct showneartags showlocalchanges
11229 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11230 global hideremotes want_ttk have_ttk maxrefs
11232 set page [create_prefs_page $notebook.general]
11234 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11235 grid $page.ldisp - -sticky w -pady 10
11236 ${NS}::label $page.spacer -text " "
11237 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11238 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11239 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11240 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11241 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11242 grid x $page.maxpctl $page.maxpct -sticky w
11243 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11244 -variable showlocalchanges
11245 grid x $page.showlocal -sticky w
11246 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11247 -variable autoselect
11248 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11249 grid x $page.autoselect $page.autosellen -sticky w
11250 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11251 -variable hideremotes
11252 grid x $page.hideremotes -sticky w
11254 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11255 grid $page.ddisp - -sticky w -pady 10
11256 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11257 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11258 grid x $page.tabstopl $page.tabstop -sticky w
11259 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11260 -variable showneartags
11261 grid x $page.ntag -sticky w
11262 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11263 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11264 grid x $page.maxrefsl $page.maxrefs -sticky w
11265 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11266 -variable limitdiffs
11267 grid x $page.ldiff -sticky w
11268 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11269 -variable perfile_attrs
11270 grid x $page.lattr -sticky w
11272 ${NS}::entry $page.extdifft -textvariable extdifftool
11273 ${NS}::frame $page.extdifff
11274 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11275 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11276 pack $page.extdifff.l $page.extdifff.b -side left
11277 pack configure $page.extdifff.l -padx 10
11278 grid x $page.extdifff $page.extdifft -sticky ew
11280 ${NS}::label $page.lgen -text [mc "General options"]
11281 grid $page.lgen - -sticky w -pady 10
11282 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11283 -text [mc "Use themed widgets"]
11284 if {$have_ttk} {
11285 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11286 } else {
11287 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11289 grid x $page.want_ttk $page.ttk_note -sticky w
11290 return $page
11293 proc prefspage_colors {notebook} {
11294 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11296 set page [create_prefs_page $notebook.colors]
11298 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11299 grid $page.cdisp - -sticky w -pady 10
11300 label $page.ui -padx 40 -relief sunk -background $uicolor
11301 ${NS}::button $page.uibut -text [mc "Interface"] \
11302 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11303 grid x $page.uibut $page.ui -sticky w
11304 label $page.bg -padx 40 -relief sunk -background $bgcolor
11305 ${NS}::button $page.bgbut -text [mc "Background"] \
11306 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11307 grid x $page.bgbut $page.bg -sticky w
11308 label $page.fg -padx 40 -relief sunk -background $fgcolor
11309 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11310 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11311 grid x $page.fgbut $page.fg -sticky w
11312 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11313 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11314 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11315 [list $ctext tag conf d0 -foreground]]
11316 grid x $page.diffoldbut $page.diffold -sticky w
11317 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11318 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11319 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11320 [list $ctext tag conf dresult -foreground]]
11321 grid x $page.diffnewbut $page.diffnew -sticky w
11322 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11323 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11324 -command [list choosecolor diffcolors 2 $page.hunksep \
11325 [mc "diff hunk header"] \
11326 [list $ctext tag conf hunksep -foreground]]
11327 grid x $page.hunksepbut $page.hunksep -sticky w
11328 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11329 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11330 -command [list choosecolor markbgcolor {} $page.markbgsep \
11331 [mc "marked line background"] \
11332 [list $ctext tag conf omark -background]]
11333 grid x $page.markbgbut $page.markbgsep -sticky w
11334 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11335 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11336 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11337 grid x $page.selbgbut $page.selbgsep -sticky w
11338 return $page
11341 proc prefspage_fonts {notebook} {
11342 global NS
11343 set page [create_prefs_page $notebook.fonts]
11344 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11345 grid $page.cfont - -sticky w -pady 10
11346 mkfontdisp mainfont $page [mc "Main font"]
11347 mkfontdisp textfont $page [mc "Diff display font"]
11348 mkfontdisp uifont $page [mc "User interface font"]
11349 return $page
11352 proc doprefs {} {
11353 global maxwidth maxgraphpct use_ttk NS
11354 global oldprefs prefstop showneartags showlocalchanges
11355 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11356 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11357 global hideremotes want_ttk have_ttk
11359 set top .gitkprefs
11360 set prefstop $top
11361 if {[winfo exists $top]} {
11362 raise $top
11363 return
11365 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11366 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11367 set oldprefs($v) [set $v]
11369 ttk_toplevel $top
11370 wm title $top [mc "Gitk preferences"]
11371 make_transient $top .
11373 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11374 set notebook [ttk::notebook $top.notebook]
11375 } else {
11376 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11379 lappend pages [prefspage_general $notebook] [mc "General"]
11380 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11381 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11382 set col 0
11383 foreach {page title} $pages {
11384 if {$use_notebook} {
11385 $notebook add $page -text $title
11386 } else {
11387 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11388 -text $title -command [list raise $page]]
11389 $page configure -text $title
11390 grid $btn -row 0 -column [incr col] -sticky w
11391 grid $page -row 1 -column 0 -sticky news -columnspan 100
11395 if {!$use_notebook} {
11396 grid columnconfigure $notebook 0 -weight 1
11397 grid rowconfigure $notebook 1 -weight 1
11398 raise [lindex $pages 0]
11401 grid $notebook -sticky news -padx 2 -pady 2
11402 grid rowconfigure $top 0 -weight 1
11403 grid columnconfigure $top 0 -weight 1
11405 ${NS}::frame $top.buts
11406 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11407 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11408 bind $top <Key-Return> prefsok
11409 bind $top <Key-Escape> prefscan
11410 grid $top.buts.ok $top.buts.can
11411 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11412 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11413 grid $top.buts - - -pady 10 -sticky ew
11414 grid columnconfigure $top 2 -weight 1
11415 bind $top <Visibility> [list focus $top.buts.ok]
11418 proc choose_extdiff {} {
11419 global extdifftool
11421 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11422 if {$prog ne {}} {
11423 set extdifftool $prog
11427 proc choosecolor {v vi w x cmd} {
11428 global $v
11430 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11431 -title [mc "Gitk: choose color for %s" $x]]
11432 if {$c eq {}} return
11433 $w conf -background $c
11434 lset $v $vi $c
11435 eval $cmd $c
11438 proc setselbg {c} {
11439 global bglist cflist
11440 foreach w $bglist {
11441 $w configure -selectbackground $c
11443 $cflist tag configure highlight \
11444 -background [$cflist cget -selectbackground]
11445 allcanvs itemconf secsel -fill $c
11448 # This sets the background color and the color scheme for the whole UI.
11449 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11450 # if we don't specify one ourselves, which makes the checkbuttons and
11451 # radiobuttons look bad. This chooses white for selectColor if the
11452 # background color is light, or black if it is dark.
11453 proc setui {c} {
11454 if {[tk windowingsystem] eq "win32"} { return }
11455 set bg [winfo rgb . $c]
11456 set selc black
11457 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11458 set selc white
11460 tk_setPalette background $c selectColor $selc
11463 proc setbg {c} {
11464 global bglist
11466 foreach w $bglist {
11467 $w conf -background $c
11471 proc setfg {c} {
11472 global fglist canv
11474 foreach w $fglist {
11475 $w conf -foreground $c
11477 allcanvs itemconf text -fill $c
11478 $canv itemconf circle -outline $c
11479 $canv itemconf markid -outline $c
11482 proc prefscan {} {
11483 global oldprefs prefstop
11485 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11486 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11487 global $v
11488 set $v $oldprefs($v)
11490 catch {destroy $prefstop}
11491 unset prefstop
11492 fontcan
11495 proc prefsok {} {
11496 global maxwidth maxgraphpct
11497 global oldprefs prefstop showneartags showlocalchanges
11498 global fontpref mainfont textfont uifont
11499 global limitdiffs treediffs perfile_attrs
11500 global hideremotes
11502 catch {destroy $prefstop}
11503 unset prefstop
11504 fontcan
11505 set fontchanged 0
11506 if {$mainfont ne $fontpref(mainfont)} {
11507 set mainfont $fontpref(mainfont)
11508 parsefont mainfont $mainfont
11509 eval font configure mainfont [fontflags mainfont]
11510 eval font configure mainfontbold [fontflags mainfont 1]
11511 setcoords
11512 set fontchanged 1
11514 if {$textfont ne $fontpref(textfont)} {
11515 set textfont $fontpref(textfont)
11516 parsefont textfont $textfont
11517 eval font configure textfont [fontflags textfont]
11518 eval font configure textfontbold [fontflags textfont 1]
11520 if {$uifont ne $fontpref(uifont)} {
11521 set uifont $fontpref(uifont)
11522 parsefont uifont $uifont
11523 eval font configure uifont [fontflags uifont]
11525 settabs
11526 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11527 if {$showlocalchanges} {
11528 doshowlocalchanges
11529 } else {
11530 dohidelocalchanges
11533 if {$limitdiffs != $oldprefs(limitdiffs) ||
11534 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11535 # treediffs elements are limited by path;
11536 # won't have encodings cached if perfile_attrs was just turned on
11537 catch {unset treediffs}
11539 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11540 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11541 redisplay
11542 } elseif {$showneartags != $oldprefs(showneartags) ||
11543 $limitdiffs != $oldprefs(limitdiffs)} {
11544 reselectline
11546 if {$hideremotes != $oldprefs(hideremotes)} {
11547 rereadrefs
11551 proc formatdate {d} {
11552 global datetimeformat
11553 if {$d ne {}} {
11554 # If $datetimeformat includes a timezone, display in the
11555 # timezone of the argument. Otherwise, display in local time.
11556 if {[string match {*%[zZ]*} $datetimeformat]} {
11557 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11558 # Tcl < 8.5 does not support -timezone. Emulate it by
11559 # setting TZ (e.g. TZ=<-0430>+04:30).
11560 global env
11561 if {[info exists env(TZ)]} {
11562 set savedTZ $env(TZ)
11564 set zone [lindex $d 1]
11565 set sign [string map {+ - - +} [string index $zone 0]]
11566 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11567 set d [clock format [lindex $d 0] -format $datetimeformat]
11568 if {[info exists savedTZ]} {
11569 set env(TZ) $savedTZ
11570 } else {
11571 unset env(TZ)
11574 } else {
11575 set d [clock format [lindex $d 0] -format $datetimeformat]
11578 return $d
11581 # This list of encoding names and aliases is distilled from
11582 # http://www.iana.org/assignments/character-sets.
11583 # Not all of them are supported by Tcl.
11584 set encoding_aliases {
11585 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11586 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11587 { ISO-10646-UTF-1 csISO10646UTF1 }
11588 { ISO_646.basic:1983 ref csISO646basic1983 }
11589 { INVARIANT csINVARIANT }
11590 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11591 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11592 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11593 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11594 { NATS-DANO iso-ir-9-1 csNATSDANO }
11595 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11596 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11597 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11598 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11599 { ISO-2022-KR csISO2022KR }
11600 { EUC-KR csEUCKR }
11601 { ISO-2022-JP csISO2022JP }
11602 { ISO-2022-JP-2 csISO2022JP2 }
11603 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11604 csISO13JISC6220jp }
11605 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11606 { IT iso-ir-15 ISO646-IT csISO15Italian }
11607 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11608 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11609 { greek7-old iso-ir-18 csISO18Greek7Old }
11610 { latin-greek iso-ir-19 csISO19LatinGreek }
11611 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11612 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11613 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11614 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11615 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11616 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11617 { INIS iso-ir-49 csISO49INIS }
11618 { INIS-8 iso-ir-50 csISO50INIS8 }
11619 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11620 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11621 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11622 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11623 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11624 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11625 csISO60Norwegian1 }
11626 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11627 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11628 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11629 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11630 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11631 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11632 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11633 { greek7 iso-ir-88 csISO88Greek7 }
11634 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11635 { iso-ir-90 csISO90 }
11636 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11637 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11638 csISO92JISC62991984b }
11639 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11640 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11641 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11642 csISO95JIS62291984handadd }
11643 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11644 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11645 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11646 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11647 CP819 csISOLatin1 }
11648 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11649 { T.61-7bit iso-ir-102 csISO102T617bit }
11650 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11651 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11652 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11653 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11654 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11655 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11656 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11657 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11658 arabic csISOLatinArabic }
11659 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11660 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11661 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11662 greek greek8 csISOLatinGreek }
11663 { T.101-G2 iso-ir-128 csISO128T101G2 }
11664 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11665 csISOLatinHebrew }
11666 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11667 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11668 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11669 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11670 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11671 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11672 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11673 csISOLatinCyrillic }
11674 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11675 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11676 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11677 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11678 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11679 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11680 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11681 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11682 { ISO_10367-box iso-ir-155 csISO10367Box }
11683 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11684 { latin-lap lap iso-ir-158 csISO158Lap }
11685 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11686 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11687 { us-dk csUSDK }
11688 { dk-us csDKUS }
11689 { JIS_X0201 X0201 csHalfWidthKatakana }
11690 { KSC5636 ISO646-KR csKSC5636 }
11691 { ISO-10646-UCS-2 csUnicode }
11692 { ISO-10646-UCS-4 csUCS4 }
11693 { DEC-MCS dec csDECMCS }
11694 { hp-roman8 roman8 r8 csHPRoman8 }
11695 { macintosh mac csMacintosh }
11696 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11697 csIBM037 }
11698 { IBM038 EBCDIC-INT cp038 csIBM038 }
11699 { IBM273 CP273 csIBM273 }
11700 { IBM274 EBCDIC-BE CP274 csIBM274 }
11701 { IBM275 EBCDIC-BR cp275 csIBM275 }
11702 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11703 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11704 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11705 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11706 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11707 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11708 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11709 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11710 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11711 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11712 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11713 { IBM437 cp437 437 csPC8CodePage437 }
11714 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11715 { IBM775 cp775 csPC775Baltic }
11716 { IBM850 cp850 850 csPC850Multilingual }
11717 { IBM851 cp851 851 csIBM851 }
11718 { IBM852 cp852 852 csPCp852 }
11719 { IBM855 cp855 855 csIBM855 }
11720 { IBM857 cp857 857 csIBM857 }
11721 { IBM860 cp860 860 csIBM860 }
11722 { IBM861 cp861 861 cp-is csIBM861 }
11723 { IBM862 cp862 862 csPC862LatinHebrew }
11724 { IBM863 cp863 863 csIBM863 }
11725 { IBM864 cp864 csIBM864 }
11726 { IBM865 cp865 865 csIBM865 }
11727 { IBM866 cp866 866 csIBM866 }
11728 { IBM868 CP868 cp-ar csIBM868 }
11729 { IBM869 cp869 869 cp-gr csIBM869 }
11730 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11731 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11732 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11733 { IBM891 cp891 csIBM891 }
11734 { IBM903 cp903 csIBM903 }
11735 { IBM904 cp904 904 csIBBM904 }
11736 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11737 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11738 { IBM1026 CP1026 csIBM1026 }
11739 { EBCDIC-AT-DE csIBMEBCDICATDE }
11740 { EBCDIC-AT-DE-A csEBCDICATDEA }
11741 { EBCDIC-CA-FR csEBCDICCAFR }
11742 { EBCDIC-DK-NO csEBCDICDKNO }
11743 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11744 { EBCDIC-FI-SE csEBCDICFISE }
11745 { EBCDIC-FI-SE-A csEBCDICFISEA }
11746 { EBCDIC-FR csEBCDICFR }
11747 { EBCDIC-IT csEBCDICIT }
11748 { EBCDIC-PT csEBCDICPT }
11749 { EBCDIC-ES csEBCDICES }
11750 { EBCDIC-ES-A csEBCDICESA }
11751 { EBCDIC-ES-S csEBCDICESS }
11752 { EBCDIC-UK csEBCDICUK }
11753 { EBCDIC-US csEBCDICUS }
11754 { UNKNOWN-8BIT csUnknown8BiT }
11755 { MNEMONIC csMnemonic }
11756 { MNEM csMnem }
11757 { VISCII csVISCII }
11758 { VIQR csVIQR }
11759 { KOI8-R csKOI8R }
11760 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11761 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11762 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11763 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11764 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11765 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11766 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11767 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11768 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11769 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11770 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11771 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11772 { IBM1047 IBM-1047 }
11773 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11774 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11775 { UNICODE-1-1 csUnicode11 }
11776 { CESU-8 csCESU-8 }
11777 { BOCU-1 csBOCU-1 }
11778 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11779 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11780 l8 }
11781 { ISO-8859-15 ISO_8859-15 Latin-9 }
11782 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11783 { GBK CP936 MS936 windows-936 }
11784 { JIS_Encoding csJISEncoding }
11785 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11786 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11787 EUC-JP }
11788 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11789 { ISO-10646-UCS-Basic csUnicodeASCII }
11790 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11791 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11792 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11793 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11794 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11795 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11796 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11797 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11798 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11799 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11800 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11801 { Ventura-US csVenturaUS }
11802 { Ventura-International csVenturaInternational }
11803 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11804 { PC8-Turkish csPC8Turkish }
11805 { IBM-Symbols csIBMSymbols }
11806 { IBM-Thai csIBMThai }
11807 { HP-Legal csHPLegal }
11808 { HP-Pi-font csHPPiFont }
11809 { HP-Math8 csHPMath8 }
11810 { Adobe-Symbol-Encoding csHPPSMath }
11811 { HP-DeskTop csHPDesktop }
11812 { Ventura-Math csVenturaMath }
11813 { Microsoft-Publishing csMicrosoftPublishing }
11814 { Windows-31J csWindows31J }
11815 { GB2312 csGB2312 }
11816 { Big5 csBig5 }
11819 proc tcl_encoding {enc} {
11820 global encoding_aliases tcl_encoding_cache
11821 if {[info exists tcl_encoding_cache($enc)]} {
11822 return $tcl_encoding_cache($enc)
11824 set names [encoding names]
11825 set lcnames [string tolower $names]
11826 set enc [string tolower $enc]
11827 set i [lsearch -exact $lcnames $enc]
11828 if {$i < 0} {
11829 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11830 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11831 set i [lsearch -exact $lcnames $encx]
11834 if {$i < 0} {
11835 foreach l $encoding_aliases {
11836 set ll [string tolower $l]
11837 if {[lsearch -exact $ll $enc] < 0} continue
11838 # look through the aliases for one that tcl knows about
11839 foreach e $ll {
11840 set i [lsearch -exact $lcnames $e]
11841 if {$i < 0} {
11842 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11843 set i [lsearch -exact $lcnames $ex]
11846 if {$i >= 0} break
11848 break
11851 set tclenc {}
11852 if {$i >= 0} {
11853 set tclenc [lindex $names $i]
11855 set tcl_encoding_cache($enc) $tclenc
11856 return $tclenc
11859 proc gitattr {path attr default} {
11860 global path_attr_cache
11861 if {[info exists path_attr_cache($attr,$path)]} {
11862 set r $path_attr_cache($attr,$path)
11863 } else {
11864 set r "unspecified"
11865 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11866 regexp "(.*): $attr: (.*)" $line m f r
11868 set path_attr_cache($attr,$path) $r
11870 if {$r eq "unspecified"} {
11871 return $default
11873 return $r
11876 proc cache_gitattr {attr pathlist} {
11877 global path_attr_cache
11878 set newlist {}
11879 foreach path $pathlist {
11880 if {![info exists path_attr_cache($attr,$path)]} {
11881 lappend newlist $path
11884 set lim 1000
11885 if {[tk windowingsystem] == "win32"} {
11886 # windows has a 32k limit on the arguments to a command...
11887 set lim 30
11889 while {$newlist ne {}} {
11890 set head [lrange $newlist 0 [expr {$lim - 1}]]
11891 set newlist [lrange $newlist $lim end]
11892 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11893 foreach row [split $rlist "\n"] {
11894 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11895 if {[string index $path 0] eq "\""} {
11896 set path [encoding convertfrom [lindex $path 0]]
11898 set path_attr_cache($attr,$path) $value
11905 proc get_path_encoding {path} {
11906 global gui_encoding perfile_attrs
11907 set tcl_enc $gui_encoding
11908 if {$path ne {} && $perfile_attrs} {
11909 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11910 if {$enc2 ne {}} {
11911 set tcl_enc $enc2
11914 return $tcl_enc
11917 # First check that Tcl/Tk is recent enough
11918 if {[catch {package require Tk 8.4} err]} {
11919 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11920 Gitk requires at least Tcl/Tk 8.4." list
11921 exit 1
11924 # on OSX bring the current Wish process window to front
11925 if {[tk windowingsystem] eq "aqua"} {
11926 exec osascript -e [format {
11927 tell application "System Events"
11928 set frontmost of processes whose unix id is %d to true
11929 end tell
11930 } [pid] ]
11933 # Unset GIT_TRACE var if set
11934 if { [info exists ::env(GIT_TRACE)] } {
11935 unset ::env(GIT_TRACE)
11938 # defaults...
11939 set wrcomcmd "git diff-tree --stdin -p --pretty"
11941 set gitencoding {}
11942 catch {
11943 set gitencoding [exec git config --get i18n.commitencoding]
11945 catch {
11946 set gitencoding [exec git config --get i18n.logoutputencoding]
11948 if {$gitencoding == ""} {
11949 set gitencoding "utf-8"
11951 set tclencoding [tcl_encoding $gitencoding]
11952 if {$tclencoding == {}} {
11953 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11956 set gui_encoding [encoding system]
11957 catch {
11958 set enc [exec git config --get gui.encoding]
11959 if {$enc ne {}} {
11960 set tclenc [tcl_encoding $enc]
11961 if {$tclenc ne {}} {
11962 set gui_encoding $tclenc
11963 } else {
11964 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11969 set log_showroot true
11970 catch {
11971 set log_showroot [exec git config --bool --get log.showroot]
11974 if {[tk windowingsystem] eq "aqua"} {
11975 set mainfont {{Lucida Grande} 9}
11976 set textfont {Monaco 9}
11977 set uifont {{Lucida Grande} 9 bold}
11978 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
11979 # fontconfig!
11980 set mainfont {sans 9}
11981 set textfont {monospace 9}
11982 set uifont {sans 9 bold}
11983 } else {
11984 set mainfont {Helvetica 9}
11985 set textfont {Courier 9}
11986 set uifont {Helvetica 9 bold}
11988 set tabstop 8
11989 set findmergefiles 0
11990 set maxgraphpct 50
11991 set maxwidth 16
11992 set revlistorder 0
11993 set fastdate 0
11994 set uparrowlen 5
11995 set downarrowlen 5
11996 set mingaplen 100
11997 set cmitmode "patch"
11998 set wrapcomment "none"
11999 set showneartags 1
12000 set hideremotes 0
12001 set maxrefs 20
12002 set visiblerefs {"master"}
12003 set maxlinelen 200
12004 set showlocalchanges 1
12005 set limitdiffs 1
12006 set datetimeformat "%Y-%m-%d %H:%M:%S"
12007 set autoselect 1
12008 set autosellen 40
12009 set perfile_attrs 0
12010 set want_ttk 1
12012 if {[tk windowingsystem] eq "aqua"} {
12013 set extdifftool "opendiff"
12014 } else {
12015 set extdifftool "meld"
12018 set colors {green red blue magenta darkgrey brown orange}
12019 if {[tk windowingsystem] eq "win32"} {
12020 set uicolor SystemButtonFace
12021 set uifgcolor SystemButtonText
12022 set uifgdisabledcolor SystemDisabledText
12023 set bgcolor SystemWindow
12024 set fgcolor SystemWindowText
12025 set selectbgcolor SystemHighlight
12026 } else {
12027 set uicolor grey85
12028 set uifgcolor black
12029 set uifgdisabledcolor "#999"
12030 set bgcolor white
12031 set fgcolor black
12032 set selectbgcolor gray85
12034 set diffcolors {red "#00a000" blue}
12035 set diffcontext 3
12036 set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12037 set ignorespace 0
12038 set worddiff ""
12039 set markbgcolor "#e0e0ff"
12041 set headbgcolor green
12042 set headfgcolor black
12043 set headoutlinecolor black
12044 set remotebgcolor #ffddaa
12045 set tagbgcolor yellow
12046 set tagfgcolor black
12047 set tagoutlinecolor black
12048 set reflinecolor black
12049 set filesepbgcolor #aaaaaa
12050 set filesepfgcolor black
12051 set linehoverbgcolor #ffff80
12052 set linehoverfgcolor black
12053 set linehoveroutlinecolor black
12054 set mainheadcirclecolor yellow
12055 set workingfilescirclecolor red
12056 set indexcirclecolor green
12057 set circlecolors {white blue gray blue blue}
12058 set linkfgcolor blue
12059 set circleoutlinecolor $fgcolor
12060 set foundbgcolor yellow
12061 set currentsearchhitbgcolor orange
12063 # button for popping up context menus
12064 if {[tk windowingsystem] eq "aqua"} {
12065 set ctxbut <Button-2>
12066 } else {
12067 set ctxbut <Button-3>
12070 ## For msgcat loading, first locate the installation location.
12071 if { [info exists ::env(GITK_MSGSDIR)] } {
12072 ## Msgsdir was manually set in the environment.
12073 set gitk_msgsdir $::env(GITK_MSGSDIR)
12074 } else {
12075 ## Let's guess the prefix from argv0.
12076 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12077 set gitk_libdir [file join $gitk_prefix share gitk lib]
12078 set gitk_msgsdir [file join $gitk_libdir msgs]
12079 unset gitk_prefix
12082 ## Internationalization (i18n) through msgcat and gettext. See
12083 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12084 package require msgcat
12085 namespace import ::msgcat::mc
12086 ## And eventually load the actual message catalog
12087 ::msgcat::mcload $gitk_msgsdir
12089 catch {
12090 # follow the XDG base directory specification by default. See
12091 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12092 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12093 # XDG_CONFIG_HOME environment variable is set
12094 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12095 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12096 } else {
12097 # default XDG_CONFIG_HOME
12098 set config_file "~/.config/git/gitk"
12099 set config_file_tmp "~/.config/git/gitk-tmp"
12101 if {![file exists $config_file]} {
12102 # for backward compatibility use the old config file if it exists
12103 if {[file exists "~/.gitk"]} {
12104 set config_file "~/.gitk"
12105 set config_file_tmp "~/.gitk-tmp"
12106 } elseif {![file exists [file dirname $config_file]]} {
12107 file mkdir [file dirname $config_file]
12110 source $config_file
12113 set config_variables {
12114 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12115 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12116 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12117 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12118 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12119 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12120 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12121 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12122 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12123 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12126 parsefont mainfont $mainfont
12127 eval font create mainfont [fontflags mainfont]
12128 eval font create mainfontbold [fontflags mainfont 1]
12130 parsefont textfont $textfont
12131 eval font create textfont [fontflags textfont]
12132 eval font create textfontbold [fontflags textfont 1]
12134 parsefont uifont $uifont
12135 eval font create uifont [fontflags uifont]
12137 setui $uicolor
12139 setoptions
12141 # check that we can find a .git directory somewhere...
12142 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12143 show_error {} . [mc "Cannot find a git repository here."]
12144 exit 1
12147 set selecthead {}
12148 set selectheadid {}
12150 set revtreeargs {}
12151 set cmdline_files {}
12152 set i 0
12153 set revtreeargscmd {}
12154 foreach arg $argv {
12155 switch -glob -- $arg {
12156 "" { }
12157 "--" {
12158 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12159 break
12161 "--select-commit=*" {
12162 set selecthead [string range $arg 16 end]
12164 "--argscmd=*" {
12165 set revtreeargscmd [string range $arg 10 end]
12167 default {
12168 lappend revtreeargs $arg
12171 incr i
12174 if {$selecthead eq "HEAD"} {
12175 set selecthead {}
12178 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12179 # no -- on command line, but some arguments (other than --argscmd)
12180 if {[catch {
12181 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12182 set cmdline_files [split $f "\n"]
12183 set n [llength $cmdline_files]
12184 set revtreeargs [lrange $revtreeargs 0 end-$n]
12185 # Unfortunately git rev-parse doesn't produce an error when
12186 # something is both a revision and a filename. To be consistent
12187 # with git log and git rev-list, check revtreeargs for filenames.
12188 foreach arg $revtreeargs {
12189 if {[file exists $arg]} {
12190 show_error {} . [mc "Ambiguous argument '%s': both revision\
12191 and filename" $arg]
12192 exit 1
12195 } err]} {
12196 # unfortunately we get both stdout and stderr in $err,
12197 # so look for "fatal:".
12198 set i [string first "fatal:" $err]
12199 if {$i > 0} {
12200 set err [string range $err [expr {$i + 6}] end]
12202 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12203 exit 1
12207 set nullid "0000000000000000000000000000000000000000"
12208 set nullid2 "0000000000000000000000000000000000000001"
12209 set nullfile "/dev/null"
12211 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12212 if {![info exists have_ttk]} {
12213 set have_ttk [llength [info commands ::ttk::style]]
12215 set use_ttk [expr {$have_ttk && $want_ttk}]
12216 set NS [expr {$use_ttk ? "ttk" : ""}]
12218 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12220 set show_notes {}
12221 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12222 set show_notes "--show-notes"
12225 set appname "gitk"
12227 set runq {}
12228 set history {}
12229 set historyindex 0
12230 set fh_serial 0
12231 set nhl_names {}
12232 set highlight_paths {}
12233 set findpattern {}
12234 set searchdirn -forwards
12235 set boldids {}
12236 set boldnameids {}
12237 set diffelide {0 0}
12238 set markingmatches 0
12239 set linkentercount 0
12240 set need_redisplay 0
12241 set nrows_drawn 0
12242 set firsttabstop 0
12244 set nextviewnum 1
12245 set curview 0
12246 set selectedview 0
12247 set selectedhlview [mc "None"]
12248 set highlight_related [mc "None"]
12249 set highlight_files {}
12250 set viewfiles(0) {}
12251 set viewperm(0) 0
12252 set viewargs(0) {}
12253 set viewargscmd(0) {}
12255 set selectedline {}
12256 set numcommits 0
12257 set loginstance 0
12258 set cmdlineok 0
12259 set stopped 0
12260 set stuffsaved 0
12261 set patchnum 0
12262 set lserial 0
12263 set hasworktree [hasworktree]
12264 set cdup {}
12265 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12266 set cdup [exec git rev-parse --show-cdup]
12268 set worktree [exec git rev-parse --show-toplevel]
12269 setcoords
12270 makewindow
12271 catch {
12272 image create photo gitlogo -width 16 -height 16
12274 image create photo gitlogominus -width 4 -height 2
12275 gitlogominus put #C00000 -to 0 0 4 2
12276 gitlogo copy gitlogominus -to 1 5
12277 gitlogo copy gitlogominus -to 6 5
12278 gitlogo copy gitlogominus -to 11 5
12279 image delete gitlogominus
12281 image create photo gitlogoplus -width 4 -height 4
12282 gitlogoplus put #008000 -to 1 0 3 4
12283 gitlogoplus put #008000 -to 0 1 4 3
12284 gitlogo copy gitlogoplus -to 1 9
12285 gitlogo copy gitlogoplus -to 6 9
12286 gitlogo copy gitlogoplus -to 11 9
12287 image delete gitlogoplus
12289 image create photo gitlogo32 -width 32 -height 32
12290 gitlogo32 copy gitlogo -zoom 2 2
12292 wm iconphoto . -default gitlogo gitlogo32
12294 # wait for the window to become visible
12295 tkwait visibility .
12296 wm title . "$appname: [reponame]"
12297 update
12298 readrefs
12300 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12301 # create a view for the files/dirs specified on the command line
12302 set curview 1
12303 set selectedview 1
12304 set nextviewnum 2
12305 set viewname(1) [mc "Command line"]
12306 set viewfiles(1) $cmdline_files
12307 set viewargs(1) $revtreeargs
12308 set viewargscmd(1) $revtreeargscmd
12309 set viewperm(1) 0
12310 set vdatemode(1) 0
12311 addviewmenu 1
12312 .bar.view entryconf [mca "Edit view..."] -state normal
12313 .bar.view entryconf [mca "Delete view"] -state normal
12316 if {[info exists permviews]} {
12317 foreach v $permviews {
12318 set n $nextviewnum
12319 incr nextviewnum
12320 set viewname($n) [lindex $v 0]
12321 set viewfiles($n) [lindex $v 1]
12322 set viewargs($n) [lindex $v 2]
12323 set viewargscmd($n) [lindex $v 3]
12324 set viewperm($n) 1
12325 addviewmenu $n
12329 if {[tk windowingsystem] eq "win32"} {
12330 focus -force .
12333 getcommits {}
12335 # Local variables:
12336 # mode: tcl
12337 # indent-tabs-mode: t
12338 # tab-width: 8
12339 # End: