Merge branch 'master' of git://repo.or.cz/alt-git
[git/mingw.git] / gitk-git / gitk
blob33f06e0761be0c921378109037356348dcf4a1f4
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2011 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 package require Tk
12 proc hasworktree {} {
13 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
14 [exec git rev-parse --is-inside-git-dir] == "false"}]
17 # A simple scheduler for compute-intensive stuff.
18 # The aim is to make sure that event handlers for GUI actions can
19 # run at least every 50-100 ms. Unfortunately fileevent handlers are
20 # run before X event handlers, so reading from a fast source can
21 # make the GUI completely unresponsive.
22 proc run args {
23 global isonrunq runq currunq
25 set script $args
26 if {[info exists isonrunq($script)]} return
27 if {$runq eq {} && ![info exists currunq]} {
28 after idle dorunq
30 lappend runq [list {} $script]
31 set isonrunq($script) 1
34 proc filerun {fd script} {
35 fileevent $fd readable [list filereadable $fd $script]
38 proc filereadable {fd script} {
39 global runq currunq
41 fileevent $fd readable {}
42 if {$runq eq {} && ![info exists currunq]} {
43 after idle dorunq
45 lappend runq [list $fd $script]
48 proc nukefile {fd} {
49 global runq
51 for {set i 0} {$i < [llength $runq]} {} {
52 if {[lindex $runq $i 0] eq $fd} {
53 set runq [lreplace $runq $i $i]
54 } else {
55 incr i
60 proc dorunq {} {
61 global isonrunq runq currunq
63 set tstart [clock clicks -milliseconds]
64 set t0 $tstart
65 while {[llength $runq] > 0} {
66 set fd [lindex $runq 0 0]
67 set script [lindex $runq 0 1]
68 set currunq [lindex $runq 0]
69 set runq [lrange $runq 1 end]
70 set repeat [eval $script]
71 unset currunq
72 set t1 [clock clicks -milliseconds]
73 set t [expr {$t1 - $t0}]
74 if {$repeat ne {} && $repeat} {
75 if {$fd eq {} || $repeat == 2} {
76 # script returns 1 if it wants to be readded
77 # file readers return 2 if they could do more straight away
78 lappend runq [list $fd $script]
79 } else {
80 fileevent $fd readable [list filereadable $fd $script]
82 } elseif {$fd eq {}} {
83 unset isonrunq($script)
85 set t0 $t1
86 if {$t1 - $tstart >= 80} break
88 if {$runq ne {}} {
89 after idle dorunq
93 proc reg_instance {fd} {
94 global commfd leftover loginstance
96 set i [incr loginstance]
97 set commfd($i) $fd
98 set leftover($i) {}
99 return $i
102 proc unmerged_files {files} {
103 global nr_unmerged
105 # find the list of unmerged files
106 set mlist {}
107 set nr_unmerged 0
108 if {[catch {
109 set fd [open "| git ls-files -u" r]
110 } err]} {
111 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
112 exit 1
114 while {[gets $fd line] >= 0} {
115 set i [string first "\t" $line]
116 if {$i < 0} continue
117 set fname [string range $line [expr {$i+1}] end]
118 if {[lsearch -exact $mlist $fname] >= 0} continue
119 incr nr_unmerged
120 if {$files eq {} || [path_filter $files $fname]} {
121 lappend mlist $fname
124 catch {close $fd}
125 return $mlist
128 proc parseviewargs {n arglist} {
129 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
130 global worddiff git_version
132 set vdatemode($n) 0
133 set vmergeonly($n) 0
134 set glflags {}
135 set diffargs {}
136 set nextisval 0
137 set revargs {}
138 set origargs $arglist
139 set allknown 1
140 set filtered 0
141 set i -1
142 foreach arg $arglist {
143 incr i
144 if {$nextisval} {
145 lappend glflags $arg
146 set nextisval 0
147 continue
149 switch -glob -- $arg {
150 "-d" -
151 "--date-order" {
152 set vdatemode($n) 1
153 # remove from origargs in case we hit an unknown option
154 set origargs [lreplace $origargs $i $i]
155 incr i -1
157 "-[puabwcrRBMC]" -
158 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
159 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
160 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
161 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
162 "--ignore-space-change" - "-U*" - "--unified=*" {
163 # These request or affect diff output, which we don't want.
164 # Some could be used to set our defaults for diff display.
165 lappend diffargs $arg
167 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
168 "--name-only" - "--name-status" - "--color" -
169 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
170 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
171 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
172 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
173 "--objects" - "--objects-edge" - "--reverse" {
174 # These cause our parsing of git log's output to fail, or else
175 # they're options we want to set ourselves, so ignore them.
177 "--color-words*" - "--word-diff=color" {
178 # These trigger a word diff in the console interface,
179 # so help the user by enabling our own support
180 if {[package vcompare $git_version "1.7.2"] >= 0} {
181 set worddiff [mc "Color words"]
184 "--word-diff*" {
185 if {[package vcompare $git_version "1.7.2"] >= 0} {
186 set worddiff [mc "Markup words"]
189 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
190 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
191 "--full-history" - "--dense" - "--sparse" -
192 "--follow" - "--left-right" - "--encoding=*" {
193 # These are harmless, and some are even useful
194 lappend glflags $arg
196 "--diff-filter=*" - "--no-merges" - "--unpacked" -
197 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
198 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
199 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
200 "--remove-empty" - "--first-parent" - "--cherry-pick" -
201 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
202 "--simplify-by-decoration" {
203 # These mean that we get a subset of the commits
204 set filtered 1
205 lappend glflags $arg
207 "-n" {
208 # This appears to be the only one that has a value as a
209 # separate word following it
210 set filtered 1
211 set nextisval 1
212 lappend glflags $arg
214 "--not" - "--all" {
215 lappend revargs $arg
217 "--merge" {
218 set vmergeonly($n) 1
219 # git rev-parse doesn't understand --merge
220 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
222 "--no-replace-objects" {
223 set env(GIT_NO_REPLACE_OBJECTS) "1"
225 "-*" {
226 # Other flag arguments including -<n>
227 if {[string is digit -strict [string range $arg 1 end]]} {
228 set filtered 1
229 } else {
230 # a flag argument that we don't recognize;
231 # that means we can't optimize
232 set allknown 0
234 lappend glflags $arg
236 default {
237 # Non-flag arguments specify commits or ranges of commits
238 if {[string match "*...*" $arg]} {
239 lappend revargs --gitk-symmetric-diff-marker
241 lappend revargs $arg
245 set vdflags($n) $diffargs
246 set vflags($n) $glflags
247 set vrevs($n) $revargs
248 set vfiltered($n) $filtered
249 set vorigargs($n) $origargs
250 return $allknown
253 proc parseviewrevs {view revs} {
254 global vposids vnegids
256 if {$revs eq {}} {
257 set revs HEAD
259 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
260 # we get stdout followed by stderr in $err
261 # for an unknown rev, git rev-parse echoes it and then errors out
262 set errlines [split $err "\n"]
263 set badrev {}
264 for {set l 0} {$l < [llength $errlines]} {incr l} {
265 set line [lindex $errlines $l]
266 if {!([string length $line] == 40 && [string is xdigit $line])} {
267 if {[string match "fatal:*" $line]} {
268 if {[string match "fatal: ambiguous argument*" $line]
269 && $badrev ne {}} {
270 if {[llength $badrev] == 1} {
271 set err "unknown revision $badrev"
272 } else {
273 set err "unknown revisions: [join $badrev ", "]"
275 } else {
276 set err [join [lrange $errlines $l end] "\n"]
278 break
280 lappend badrev $line
283 error_popup "[mc "Error parsing revisions:"] $err"
284 return {}
286 set ret {}
287 set pos {}
288 set neg {}
289 set sdm 0
290 foreach id [split $ids "\n"] {
291 if {$id eq "--gitk-symmetric-diff-marker"} {
292 set sdm 4
293 } elseif {[string match "^*" $id]} {
294 if {$sdm != 1} {
295 lappend ret $id
296 if {$sdm == 3} {
297 set sdm 0
300 lappend neg [string range $id 1 end]
301 } else {
302 if {$sdm != 2} {
303 lappend ret $id
304 } else {
305 lset ret end $id...[lindex $ret end]
307 lappend pos $id
309 incr sdm -1
311 set vposids($view) $pos
312 set vnegids($view) $neg
313 return $ret
316 # Start off a git log process and arrange to read its output
317 proc start_rev_list {view} {
318 global startmsecs commitidx viewcomplete curview
319 global tclencoding
320 global viewargs viewargscmd viewfiles vfilelimit
321 global showlocalchanges
322 global viewactive viewinstances vmergeonly
323 global mainheadid viewmainheadid viewmainheadid_orig
324 global vcanopt vflags vrevs vorigargs
325 global show_notes
327 set startmsecs [clock clicks -milliseconds]
328 set commitidx($view) 0
329 # these are set this way for the error exits
330 set viewcomplete($view) 1
331 set viewactive($view) 0
332 varcinit $view
334 set args $viewargs($view)
335 if {$viewargscmd($view) ne {}} {
336 if {[catch {
337 set str [exec sh -c $viewargscmd($view)]
338 } err]} {
339 error_popup "[mc "Error executing --argscmd command:"] $err"
340 return 0
342 set args [concat $args [split $str "\n"]]
344 set vcanopt($view) [parseviewargs $view $args]
346 set files $viewfiles($view)
347 if {$vmergeonly($view)} {
348 set files [unmerged_files $files]
349 if {$files eq {}} {
350 global nr_unmerged
351 if {$nr_unmerged == 0} {
352 error_popup [mc "No files selected: --merge specified but\
353 no files are unmerged."]
354 } else {
355 error_popup [mc "No files selected: --merge specified but\
356 no unmerged files are within file limit."]
358 return 0
361 set vfilelimit($view) $files
363 if {$vcanopt($view)} {
364 set revs [parseviewrevs $view $vrevs($view)]
365 if {$revs eq {}} {
366 return 0
368 set args [concat $vflags($view) $revs]
369 } else {
370 set args $vorigargs($view)
373 if {[catch {
374 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
375 --parents --boundary $args "--" $files] r]
376 } err]} {
377 error_popup "[mc "Error executing git log:"] $err"
378 return 0
380 set i [reg_instance $fd]
381 set viewinstances($view) [list $i]
382 set viewmainheadid($view) $mainheadid
383 set viewmainheadid_orig($view) $mainheadid
384 if {$files ne {} && $mainheadid ne {}} {
385 get_viewmainhead $view
387 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
388 interestedin $viewmainheadid($view) dodiffindex
390 fconfigure $fd -blocking 0 -translation lf -eofchar {}
391 if {$tclencoding != {}} {
392 fconfigure $fd -encoding $tclencoding
394 filerun $fd [list getcommitlines $fd $i $view 0]
395 nowbusy $view [mc "Reading"]
396 set viewcomplete($view) 0
397 set viewactive($view) 1
398 return 1
401 proc stop_instance {inst} {
402 global commfd leftover
404 set fd $commfd($inst)
405 catch {
406 set pid [pid $fd]
408 if {$::tcl_platform(platform) eq {windows}} {
409 exec kill -f $pid
410 } else {
411 exec kill $pid
414 catch {close $fd}
415 nukefile $fd
416 unset commfd($inst)
417 unset leftover($inst)
420 proc stop_backends {} {
421 global commfd
423 foreach inst [array names commfd] {
424 stop_instance $inst
428 proc stop_rev_list {view} {
429 global viewinstances
431 foreach inst $viewinstances($view) {
432 stop_instance $inst
434 set viewinstances($view) {}
437 proc reset_pending_select {selid} {
438 global pending_select mainheadid selectheadid
440 if {$selid ne {}} {
441 set pending_select $selid
442 } elseif {$selectheadid ne {}} {
443 set pending_select $selectheadid
444 } else {
445 set pending_select $mainheadid
449 proc getcommits {selid} {
450 global canv curview need_redisplay viewactive
452 initlayout
453 if {[start_rev_list $curview]} {
454 reset_pending_select $selid
455 show_status [mc "Reading commits..."]
456 set need_redisplay 1
457 } else {
458 show_status [mc "No commits selected"]
462 proc updatecommits {} {
463 global curview vcanopt vorigargs vfilelimit viewinstances
464 global viewactive viewcomplete tclencoding
465 global startmsecs showneartags showlocalchanges
466 global mainheadid viewmainheadid viewmainheadid_orig pending_select
467 global hasworktree
468 global varcid vposids vnegids vflags vrevs
469 global show_notes
471 set hasworktree [hasworktree]
472 rereadrefs
473 set view $curview
474 if {$mainheadid ne $viewmainheadid_orig($view)} {
475 if {$showlocalchanges} {
476 dohidelocalchanges
478 set viewmainheadid($view) $mainheadid
479 set viewmainheadid_orig($view) $mainheadid
480 if {$vfilelimit($view) ne {}} {
481 get_viewmainhead $view
484 if {$showlocalchanges} {
485 doshowlocalchanges
487 if {$vcanopt($view)} {
488 set oldpos $vposids($view)
489 set oldneg $vnegids($view)
490 set revs [parseviewrevs $view $vrevs($view)]
491 if {$revs eq {}} {
492 return
494 # note: getting the delta when negative refs change is hard,
495 # and could require multiple git log invocations, so in that
496 # case we ask git log for all the commits (not just the delta)
497 if {$oldneg eq $vnegids($view)} {
498 set newrevs {}
499 set npos 0
500 # take out positive refs that we asked for before or
501 # that we have already seen
502 foreach rev $revs {
503 if {[string length $rev] == 40} {
504 if {[lsearch -exact $oldpos $rev] < 0
505 && ![info exists varcid($view,$rev)]} {
506 lappend newrevs $rev
507 incr npos
509 } else {
510 lappend $newrevs $rev
513 if {$npos == 0} return
514 set revs $newrevs
515 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
517 set args [concat $vflags($view) $revs --not $oldpos]
518 } else {
519 set args $vorigargs($view)
521 if {[catch {
522 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
523 --parents --boundary $args "--" $vfilelimit($view)] r]
524 } err]} {
525 error_popup "[mc "Error executing git log:"] $err"
526 return
528 if {$viewactive($view) == 0} {
529 set startmsecs [clock clicks -milliseconds]
531 set i [reg_instance $fd]
532 lappend viewinstances($view) $i
533 fconfigure $fd -blocking 0 -translation lf -eofchar {}
534 if {$tclencoding != {}} {
535 fconfigure $fd -encoding $tclencoding
537 filerun $fd [list getcommitlines $fd $i $view 1]
538 incr viewactive($view)
539 set viewcomplete($view) 0
540 reset_pending_select {}
541 nowbusy $view [mc "Reading"]
542 if {$showneartags} {
543 getallcommits
547 proc reloadcommits {} {
548 global curview viewcomplete selectedline currentid thickerline
549 global showneartags treediffs commitinterest cached_commitrow
550 global targetid
552 set selid {}
553 if {$selectedline ne {}} {
554 set selid $currentid
557 if {!$viewcomplete($curview)} {
558 stop_rev_list $curview
560 resetvarcs $curview
561 set selectedline {}
562 catch {unset currentid}
563 catch {unset thickerline}
564 catch {unset treediffs}
565 readrefs
566 changedrefs
567 if {$showneartags} {
568 getallcommits
570 clear_display
571 catch {unset commitinterest}
572 catch {unset cached_commitrow}
573 catch {unset targetid}
574 setcanvscroll
575 getcommits $selid
576 return 0
579 # This makes a string representation of a positive integer which
580 # sorts as a string in numerical order
581 proc strrep {n} {
582 if {$n < 16} {
583 return [format "%x" $n]
584 } elseif {$n < 256} {
585 return [format "x%.2x" $n]
586 } elseif {$n < 65536} {
587 return [format "y%.4x" $n]
589 return [format "z%.8x" $n]
592 # Procedures used in reordering commits from git log (without
593 # --topo-order) into the order for display.
595 proc varcinit {view} {
596 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
597 global vtokmod varcmod vrowmod varcix vlastins
599 set varcstart($view) {{}}
600 set vupptr($view) {0}
601 set vdownptr($view) {0}
602 set vleftptr($view) {0}
603 set vbackptr($view) {0}
604 set varctok($view) {{}}
605 set varcrow($view) {{}}
606 set vtokmod($view) {}
607 set varcmod($view) 0
608 set vrowmod($view) 0
609 set varcix($view) {{}}
610 set vlastins($view) {0}
613 proc resetvarcs {view} {
614 global varcid varccommits parents children vseedcount ordertok
616 foreach vid [array names varcid $view,*] {
617 unset varcid($vid)
618 unset children($vid)
619 unset parents($vid)
621 # some commits might have children but haven't been seen yet
622 foreach vid [array names children $view,*] {
623 unset children($vid)
625 foreach va [array names varccommits $view,*] {
626 unset varccommits($va)
628 foreach vd [array names vseedcount $view,*] {
629 unset vseedcount($vd)
631 catch {unset ordertok}
634 # returns a list of the commits with no children
635 proc seeds {v} {
636 global vdownptr vleftptr varcstart
638 set ret {}
639 set a [lindex $vdownptr($v) 0]
640 while {$a != 0} {
641 lappend ret [lindex $varcstart($v) $a]
642 set a [lindex $vleftptr($v) $a]
644 return $ret
647 proc newvarc {view id} {
648 global varcid varctok parents children vdatemode
649 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
650 global commitdata commitinfo vseedcount varccommits vlastins
652 set a [llength $varctok($view)]
653 set vid $view,$id
654 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
655 if {![info exists commitinfo($id)]} {
656 parsecommit $id $commitdata($id) 1
658 set cdate [lindex [lindex $commitinfo($id) 4] 0]
659 if {![string is integer -strict $cdate]} {
660 set cdate 0
662 if {![info exists vseedcount($view,$cdate)]} {
663 set vseedcount($view,$cdate) -1
665 set c [incr vseedcount($view,$cdate)]
666 set cdate [expr {$cdate ^ 0xffffffff}]
667 set tok "s[strrep $cdate][strrep $c]"
668 } else {
669 set tok {}
671 set ka 0
672 if {[llength $children($vid)] > 0} {
673 set kid [lindex $children($vid) end]
674 set k $varcid($view,$kid)
675 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
676 set ki $kid
677 set ka $k
678 set tok [lindex $varctok($view) $k]
681 if {$ka != 0} {
682 set i [lsearch -exact $parents($view,$ki) $id]
683 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
684 append tok [strrep $j]
686 set c [lindex $vlastins($view) $ka]
687 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
688 set c $ka
689 set b [lindex $vdownptr($view) $ka]
690 } else {
691 set b [lindex $vleftptr($view) $c]
693 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
694 set c $b
695 set b [lindex $vleftptr($view) $c]
697 if {$c == $ka} {
698 lset vdownptr($view) $ka $a
699 lappend vbackptr($view) 0
700 } else {
701 lset vleftptr($view) $c $a
702 lappend vbackptr($view) $c
704 lset vlastins($view) $ka $a
705 lappend vupptr($view) $ka
706 lappend vleftptr($view) $b
707 if {$b != 0} {
708 lset vbackptr($view) $b $a
710 lappend varctok($view) $tok
711 lappend varcstart($view) $id
712 lappend vdownptr($view) 0
713 lappend varcrow($view) {}
714 lappend varcix($view) {}
715 set varccommits($view,$a) {}
716 lappend vlastins($view) 0
717 return $a
720 proc splitvarc {p v} {
721 global varcid varcstart varccommits varctok vtokmod
722 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
724 set oa $varcid($v,$p)
725 set otok [lindex $varctok($v) $oa]
726 set ac $varccommits($v,$oa)
727 set i [lsearch -exact $varccommits($v,$oa) $p]
728 if {$i <= 0} return
729 set na [llength $varctok($v)]
730 # "%" sorts before "0"...
731 set tok "$otok%[strrep $i]"
732 lappend varctok($v) $tok
733 lappend varcrow($v) {}
734 lappend varcix($v) {}
735 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
736 set varccommits($v,$na) [lrange $ac $i end]
737 lappend varcstart($v) $p
738 foreach id $varccommits($v,$na) {
739 set varcid($v,$id) $na
741 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
742 lappend vlastins($v) [lindex $vlastins($v) $oa]
743 lset vdownptr($v) $oa $na
744 lset vlastins($v) $oa 0
745 lappend vupptr($v) $oa
746 lappend vleftptr($v) 0
747 lappend vbackptr($v) 0
748 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
749 lset vupptr($v) $b $na
751 if {[string compare $otok $vtokmod($v)] <= 0} {
752 modify_arc $v $oa
756 proc renumbervarc {a v} {
757 global parents children varctok varcstart varccommits
758 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
760 set t1 [clock clicks -milliseconds]
761 set todo {}
762 set isrelated($a) 1
763 set kidchanged($a) 1
764 set ntot 0
765 while {$a != 0} {
766 if {[info exists isrelated($a)]} {
767 lappend todo $a
768 set id [lindex $varccommits($v,$a) end]
769 foreach p $parents($v,$id) {
770 if {[info exists varcid($v,$p)]} {
771 set isrelated($varcid($v,$p)) 1
775 incr ntot
776 set b [lindex $vdownptr($v) $a]
777 if {$b == 0} {
778 while {$a != 0} {
779 set b [lindex $vleftptr($v) $a]
780 if {$b != 0} break
781 set a [lindex $vupptr($v) $a]
784 set a $b
786 foreach a $todo {
787 if {![info exists kidchanged($a)]} continue
788 set id [lindex $varcstart($v) $a]
789 if {[llength $children($v,$id)] > 1} {
790 set children($v,$id) [lsort -command [list vtokcmp $v] \
791 $children($v,$id)]
793 set oldtok [lindex $varctok($v) $a]
794 if {!$vdatemode($v)} {
795 set tok {}
796 } else {
797 set tok $oldtok
799 set ka 0
800 set kid [last_real_child $v,$id]
801 if {$kid ne {}} {
802 set k $varcid($v,$kid)
803 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
804 set ki $kid
805 set ka $k
806 set tok [lindex $varctok($v) $k]
809 if {$ka != 0} {
810 set i [lsearch -exact $parents($v,$ki) $id]
811 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
812 append tok [strrep $j]
814 if {$tok eq $oldtok} {
815 continue
817 set id [lindex $varccommits($v,$a) end]
818 foreach p $parents($v,$id) {
819 if {[info exists varcid($v,$p)]} {
820 set kidchanged($varcid($v,$p)) 1
821 } else {
822 set sortkids($p) 1
825 lset varctok($v) $a $tok
826 set b [lindex $vupptr($v) $a]
827 if {$b != $ka} {
828 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
829 modify_arc $v $ka
831 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
832 modify_arc $v $b
834 set c [lindex $vbackptr($v) $a]
835 set d [lindex $vleftptr($v) $a]
836 if {$c == 0} {
837 lset vdownptr($v) $b $d
838 } else {
839 lset vleftptr($v) $c $d
841 if {$d != 0} {
842 lset vbackptr($v) $d $c
844 if {[lindex $vlastins($v) $b] == $a} {
845 lset vlastins($v) $b $c
847 lset vupptr($v) $a $ka
848 set c [lindex $vlastins($v) $ka]
849 if {$c == 0 || \
850 [string compare $tok [lindex $varctok($v) $c]] < 0} {
851 set c $ka
852 set b [lindex $vdownptr($v) $ka]
853 } else {
854 set b [lindex $vleftptr($v) $c]
856 while {$b != 0 && \
857 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
858 set c $b
859 set b [lindex $vleftptr($v) $c]
861 if {$c == $ka} {
862 lset vdownptr($v) $ka $a
863 lset vbackptr($v) $a 0
864 } else {
865 lset vleftptr($v) $c $a
866 lset vbackptr($v) $a $c
868 lset vleftptr($v) $a $b
869 if {$b != 0} {
870 lset vbackptr($v) $b $a
872 lset vlastins($v) $ka $a
875 foreach id [array names sortkids] {
876 if {[llength $children($v,$id)] > 1} {
877 set children($v,$id) [lsort -command [list vtokcmp $v] \
878 $children($v,$id)]
881 set t2 [clock clicks -milliseconds]
882 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
885 # Fix up the graph after we have found out that in view $v,
886 # $p (a commit that we have already seen) is actually the parent
887 # of the last commit in arc $a.
888 proc fix_reversal {p a v} {
889 global varcid varcstart varctok vupptr
891 set pa $varcid($v,$p)
892 if {$p ne [lindex $varcstart($v) $pa]} {
893 splitvarc $p $v
894 set pa $varcid($v,$p)
896 # seeds always need to be renumbered
897 if {[lindex $vupptr($v) $pa] == 0 ||
898 [string compare [lindex $varctok($v) $a] \
899 [lindex $varctok($v) $pa]] > 0} {
900 renumbervarc $pa $v
904 proc insertrow {id p v} {
905 global cmitlisted children parents varcid varctok vtokmod
906 global varccommits ordertok commitidx numcommits curview
907 global targetid targetrow
909 readcommit $id
910 set vid $v,$id
911 set cmitlisted($vid) 1
912 set children($vid) {}
913 set parents($vid) [list $p]
914 set a [newvarc $v $id]
915 set varcid($vid) $a
916 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
917 modify_arc $v $a
919 lappend varccommits($v,$a) $id
920 set vp $v,$p
921 if {[llength [lappend children($vp) $id]] > 1} {
922 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
923 catch {unset ordertok}
925 fix_reversal $p $a $v
926 incr commitidx($v)
927 if {$v == $curview} {
928 set numcommits $commitidx($v)
929 setcanvscroll
930 if {[info exists targetid]} {
931 if {![comes_before $targetid $p]} {
932 incr targetrow
938 proc insertfakerow {id p} {
939 global varcid varccommits parents children cmitlisted
940 global commitidx varctok vtokmod targetid targetrow curview numcommits
942 set v $curview
943 set a $varcid($v,$p)
944 set i [lsearch -exact $varccommits($v,$a) $p]
945 if {$i < 0} {
946 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
947 return
949 set children($v,$id) {}
950 set parents($v,$id) [list $p]
951 set varcid($v,$id) $a
952 lappend children($v,$p) $id
953 set cmitlisted($v,$id) 1
954 set numcommits [incr commitidx($v)]
955 # note we deliberately don't update varcstart($v) even if $i == 0
956 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
957 modify_arc $v $a $i
958 if {[info exists targetid]} {
959 if {![comes_before $targetid $p]} {
960 incr targetrow
963 setcanvscroll
964 drawvisible
967 proc removefakerow {id} {
968 global varcid varccommits parents children commitidx
969 global varctok vtokmod cmitlisted currentid selectedline
970 global targetid curview numcommits
972 set v $curview
973 if {[llength $parents($v,$id)] != 1} {
974 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
975 return
977 set p [lindex $parents($v,$id) 0]
978 set a $varcid($v,$id)
979 set i [lsearch -exact $varccommits($v,$a) $id]
980 if {$i < 0} {
981 puts "oops: removefakerow can't find [shortids $id] on arc $a"
982 return
984 unset varcid($v,$id)
985 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
986 unset parents($v,$id)
987 unset children($v,$id)
988 unset cmitlisted($v,$id)
989 set numcommits [incr commitidx($v) -1]
990 set j [lsearch -exact $children($v,$p) $id]
991 if {$j >= 0} {
992 set children($v,$p) [lreplace $children($v,$p) $j $j]
994 modify_arc $v $a $i
995 if {[info exist currentid] && $id eq $currentid} {
996 unset currentid
997 set selectedline {}
999 if {[info exists targetid] && $targetid eq $id} {
1000 set targetid $p
1002 setcanvscroll
1003 drawvisible
1006 proc real_children {vp} {
1007 global children nullid nullid2
1009 set kids {}
1010 foreach id $children($vp) {
1011 if {$id ne $nullid && $id ne $nullid2} {
1012 lappend kids $id
1015 return $kids
1018 proc first_real_child {vp} {
1019 global children nullid nullid2
1021 foreach id $children($vp) {
1022 if {$id ne $nullid && $id ne $nullid2} {
1023 return $id
1026 return {}
1029 proc last_real_child {vp} {
1030 global children nullid nullid2
1032 set kids $children($vp)
1033 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1034 set id [lindex $kids $i]
1035 if {$id ne $nullid && $id ne $nullid2} {
1036 return $id
1039 return {}
1042 proc vtokcmp {v a b} {
1043 global varctok varcid
1045 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1046 [lindex $varctok($v) $varcid($v,$b)]]
1049 # This assumes that if lim is not given, the caller has checked that
1050 # arc a's token is less than $vtokmod($v)
1051 proc modify_arc {v a {lim {}}} {
1052 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1054 if {$lim ne {}} {
1055 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1056 if {$c > 0} return
1057 if {$c == 0} {
1058 set r [lindex $varcrow($v) $a]
1059 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1062 set vtokmod($v) [lindex $varctok($v) $a]
1063 set varcmod($v) $a
1064 if {$v == $curview} {
1065 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1066 set a [lindex $vupptr($v) $a]
1067 set lim {}
1069 set r 0
1070 if {$a != 0} {
1071 if {$lim eq {}} {
1072 set lim [llength $varccommits($v,$a)]
1074 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1076 set vrowmod($v) $r
1077 undolayout $r
1081 proc update_arcrows {v} {
1082 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1083 global varcid vrownum varcorder varcix varccommits
1084 global vupptr vdownptr vleftptr varctok
1085 global displayorder parentlist curview cached_commitrow
1087 if {$vrowmod($v) == $commitidx($v)} return
1088 if {$v == $curview} {
1089 if {[llength $displayorder] > $vrowmod($v)} {
1090 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1091 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1093 catch {unset cached_commitrow}
1095 set narctot [expr {[llength $varctok($v)] - 1}]
1096 set a $varcmod($v)
1097 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1098 # go up the tree until we find something that has a row number,
1099 # or we get to a seed
1100 set a [lindex $vupptr($v) $a]
1102 if {$a == 0} {
1103 set a [lindex $vdownptr($v) 0]
1104 if {$a == 0} return
1105 set vrownum($v) {0}
1106 set varcorder($v) [list $a]
1107 lset varcix($v) $a 0
1108 lset varcrow($v) $a 0
1109 set arcn 0
1110 set row 0
1111 } else {
1112 set arcn [lindex $varcix($v) $a]
1113 if {[llength $vrownum($v)] > $arcn + 1} {
1114 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1115 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1117 set row [lindex $varcrow($v) $a]
1119 while {1} {
1120 set p $a
1121 incr row [llength $varccommits($v,$a)]
1122 # go down if possible
1123 set b [lindex $vdownptr($v) $a]
1124 if {$b == 0} {
1125 # if not, go left, or go up until we can go left
1126 while {$a != 0} {
1127 set b [lindex $vleftptr($v) $a]
1128 if {$b != 0} break
1129 set a [lindex $vupptr($v) $a]
1131 if {$a == 0} break
1133 set a $b
1134 incr arcn
1135 lappend vrownum($v) $row
1136 lappend varcorder($v) $a
1137 lset varcix($v) $a $arcn
1138 lset varcrow($v) $a $row
1140 set vtokmod($v) [lindex $varctok($v) $p]
1141 set varcmod($v) $p
1142 set vrowmod($v) $row
1143 if {[info exists currentid]} {
1144 set selectedline [rowofcommit $currentid]
1148 # Test whether view $v contains commit $id
1149 proc commitinview {id v} {
1150 global varcid
1152 return [info exists varcid($v,$id)]
1155 # Return the row number for commit $id in the current view
1156 proc rowofcommit {id} {
1157 global varcid varccommits varcrow curview cached_commitrow
1158 global varctok vtokmod
1160 set v $curview
1161 if {![info exists varcid($v,$id)]} {
1162 puts "oops rowofcommit no arc for [shortids $id]"
1163 return {}
1165 set a $varcid($v,$id)
1166 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1167 update_arcrows $v
1169 if {[info exists cached_commitrow($id)]} {
1170 return $cached_commitrow($id)
1172 set i [lsearch -exact $varccommits($v,$a) $id]
1173 if {$i < 0} {
1174 puts "oops didn't find commit [shortids $id] in arc $a"
1175 return {}
1177 incr i [lindex $varcrow($v) $a]
1178 set cached_commitrow($id) $i
1179 return $i
1182 # Returns 1 if a is on an earlier row than b, otherwise 0
1183 proc comes_before {a b} {
1184 global varcid varctok curview
1186 set v $curview
1187 if {$a eq $b || ![info exists varcid($v,$a)] || \
1188 ![info exists varcid($v,$b)]} {
1189 return 0
1191 if {$varcid($v,$a) != $varcid($v,$b)} {
1192 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1193 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1195 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1198 proc bsearch {l elt} {
1199 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1200 return 0
1202 set lo 0
1203 set hi [llength $l]
1204 while {$hi - $lo > 1} {
1205 set mid [expr {int(($lo + $hi) / 2)}]
1206 set t [lindex $l $mid]
1207 if {$elt < $t} {
1208 set hi $mid
1209 } elseif {$elt > $t} {
1210 set lo $mid
1211 } else {
1212 return $mid
1215 return $lo
1218 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1219 proc make_disporder {start end} {
1220 global vrownum curview commitidx displayorder parentlist
1221 global varccommits varcorder parents vrowmod varcrow
1222 global d_valid_start d_valid_end
1224 if {$end > $vrowmod($curview)} {
1225 update_arcrows $curview
1227 set ai [bsearch $vrownum($curview) $start]
1228 set start [lindex $vrownum($curview) $ai]
1229 set narc [llength $vrownum($curview)]
1230 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1231 set a [lindex $varcorder($curview) $ai]
1232 set l [llength $displayorder]
1233 set al [llength $varccommits($curview,$a)]
1234 if {$l < $r + $al} {
1235 if {$l < $r} {
1236 set pad [ntimes [expr {$r - $l}] {}]
1237 set displayorder [concat $displayorder $pad]
1238 set parentlist [concat $parentlist $pad]
1239 } elseif {$l > $r} {
1240 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1241 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1243 foreach id $varccommits($curview,$a) {
1244 lappend displayorder $id
1245 lappend parentlist $parents($curview,$id)
1247 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1248 set i $r
1249 foreach id $varccommits($curview,$a) {
1250 lset displayorder $i $id
1251 lset parentlist $i $parents($curview,$id)
1252 incr i
1255 incr r $al
1259 proc commitonrow {row} {
1260 global displayorder
1262 set id [lindex $displayorder $row]
1263 if {$id eq {}} {
1264 make_disporder $row [expr {$row + 1}]
1265 set id [lindex $displayorder $row]
1267 return $id
1270 proc closevarcs {v} {
1271 global varctok varccommits varcid parents children
1272 global cmitlisted commitidx vtokmod
1274 set missing_parents 0
1275 set scripts {}
1276 set narcs [llength $varctok($v)]
1277 for {set a 1} {$a < $narcs} {incr a} {
1278 set id [lindex $varccommits($v,$a) end]
1279 foreach p $parents($v,$id) {
1280 if {[info exists varcid($v,$p)]} continue
1281 # add p as a new commit
1282 incr missing_parents
1283 set cmitlisted($v,$p) 0
1284 set parents($v,$p) {}
1285 if {[llength $children($v,$p)] == 1 &&
1286 [llength $parents($v,$id)] == 1} {
1287 set b $a
1288 } else {
1289 set b [newvarc $v $p]
1291 set varcid($v,$p) $b
1292 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1293 modify_arc $v $b
1295 lappend varccommits($v,$b) $p
1296 incr commitidx($v)
1297 set scripts [check_interest $p $scripts]
1300 if {$missing_parents > 0} {
1301 foreach s $scripts {
1302 eval $s
1307 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1308 # Assumes we already have an arc for $rwid.
1309 proc rewrite_commit {v id rwid} {
1310 global children parents varcid varctok vtokmod varccommits
1312 foreach ch $children($v,$id) {
1313 # make $rwid be $ch's parent in place of $id
1314 set i [lsearch -exact $parents($v,$ch) $id]
1315 if {$i < 0} {
1316 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1318 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1319 # add $ch to $rwid's children and sort the list if necessary
1320 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1321 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1322 $children($v,$rwid)]
1324 # fix the graph after joining $id to $rwid
1325 set a $varcid($v,$ch)
1326 fix_reversal $rwid $a $v
1327 # parentlist is wrong for the last element of arc $a
1328 # even if displayorder is right, hence the 3rd arg here
1329 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1333 # Mechanism for registering a command to be executed when we come
1334 # across a particular commit. To handle the case when only the
1335 # prefix of the commit is known, the commitinterest array is now
1336 # indexed by the first 4 characters of the ID. Each element is a
1337 # list of id, cmd pairs.
1338 proc interestedin {id cmd} {
1339 global commitinterest
1341 lappend commitinterest([string range $id 0 3]) $id $cmd
1344 proc check_interest {id scripts} {
1345 global commitinterest
1347 set prefix [string range $id 0 3]
1348 if {[info exists commitinterest($prefix)]} {
1349 set newlist {}
1350 foreach {i script} $commitinterest($prefix) {
1351 if {[string match "$i*" $id]} {
1352 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1353 } else {
1354 lappend newlist $i $script
1357 if {$newlist ne {}} {
1358 set commitinterest($prefix) $newlist
1359 } else {
1360 unset commitinterest($prefix)
1363 return $scripts
1366 proc getcommitlines {fd inst view updating} {
1367 global cmitlisted leftover
1368 global commitidx commitdata vdatemode
1369 global parents children curview hlview
1370 global idpending ordertok
1371 global varccommits varcid varctok vtokmod vfilelimit
1373 set stuff [read $fd 500000]
1374 # git log doesn't terminate the last commit with a null...
1375 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1376 set stuff "\0"
1378 if {$stuff == {}} {
1379 if {![eof $fd]} {
1380 return 1
1382 global commfd viewcomplete viewactive viewname
1383 global viewinstances
1384 unset commfd($inst)
1385 set i [lsearch -exact $viewinstances($view) $inst]
1386 if {$i >= 0} {
1387 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1389 # set it blocking so we wait for the process to terminate
1390 fconfigure $fd -blocking 1
1391 if {[catch {close $fd} err]} {
1392 set fv {}
1393 if {$view != $curview} {
1394 set fv " for the \"$viewname($view)\" view"
1396 if {[string range $err 0 4] == "usage"} {
1397 set err "Gitk: error reading commits$fv:\
1398 bad arguments to git log."
1399 if {$viewname($view) eq "Command line"} {
1400 append err \
1401 " (Note: arguments to gitk are passed to git log\
1402 to allow selection of commits to be displayed.)"
1404 } else {
1405 set err "Error reading commits$fv: $err"
1407 error_popup $err
1409 if {[incr viewactive($view) -1] <= 0} {
1410 set viewcomplete($view) 1
1411 # Check if we have seen any ids listed as parents that haven't
1412 # appeared in the list
1413 closevarcs $view
1414 notbusy $view
1416 if {$view == $curview} {
1417 run chewcommits
1419 return 0
1421 set start 0
1422 set gotsome 0
1423 set scripts {}
1424 while 1 {
1425 set i [string first "\0" $stuff $start]
1426 if {$i < 0} {
1427 append leftover($inst) [string range $stuff $start end]
1428 break
1430 if {$start == 0} {
1431 set cmit $leftover($inst)
1432 append cmit [string range $stuff 0 [expr {$i - 1}]]
1433 set leftover($inst) {}
1434 } else {
1435 set cmit [string range $stuff $start [expr {$i - 1}]]
1437 set start [expr {$i + 1}]
1438 set j [string first "\n" $cmit]
1439 set ok 0
1440 set listed 1
1441 if {$j >= 0 && [string match "commit *" $cmit]} {
1442 set ids [string range $cmit 7 [expr {$j - 1}]]
1443 if {[string match {[-^<>]*} $ids]} {
1444 switch -- [string index $ids 0] {
1445 "-" {set listed 0}
1446 "^" {set listed 2}
1447 "<" {set listed 3}
1448 ">" {set listed 4}
1450 set ids [string range $ids 1 end]
1452 set ok 1
1453 foreach id $ids {
1454 if {[string length $id] != 40} {
1455 set ok 0
1456 break
1460 if {!$ok} {
1461 set shortcmit $cmit
1462 if {[string length $shortcmit] > 80} {
1463 set shortcmit "[string range $shortcmit 0 80]..."
1465 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1466 exit 1
1468 set id [lindex $ids 0]
1469 set vid $view,$id
1471 if {!$listed && $updating && ![info exists varcid($vid)] &&
1472 $vfilelimit($view) ne {}} {
1473 # git log doesn't rewrite parents for unlisted commits
1474 # when doing path limiting, so work around that here
1475 # by working out the rewritten parent with git rev-list
1476 # and if we already know about it, using the rewritten
1477 # parent as a substitute parent for $id's children.
1478 if {![catch {
1479 set rwid [exec git rev-list --first-parent --max-count=1 \
1480 $id -- $vfilelimit($view)]
1481 }]} {
1482 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1483 # use $rwid in place of $id
1484 rewrite_commit $view $id $rwid
1485 continue
1490 set a 0
1491 if {[info exists varcid($vid)]} {
1492 if {$cmitlisted($vid) || !$listed} continue
1493 set a $varcid($vid)
1495 if {$listed} {
1496 set olds [lrange $ids 1 end]
1497 } else {
1498 set olds {}
1500 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1501 set cmitlisted($vid) $listed
1502 set parents($vid) $olds
1503 if {![info exists children($vid)]} {
1504 set children($vid) {}
1505 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1506 set k [lindex $children($vid) 0]
1507 if {[llength $parents($view,$k)] == 1 &&
1508 (!$vdatemode($view) ||
1509 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1510 set a $varcid($view,$k)
1513 if {$a == 0} {
1514 # new arc
1515 set a [newvarc $view $id]
1517 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1518 modify_arc $view $a
1520 if {![info exists varcid($vid)]} {
1521 set varcid($vid) $a
1522 lappend varccommits($view,$a) $id
1523 incr commitidx($view)
1526 set i 0
1527 foreach p $olds {
1528 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1529 set vp $view,$p
1530 if {[llength [lappend children($vp) $id]] > 1 &&
1531 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1532 set children($vp) [lsort -command [list vtokcmp $view] \
1533 $children($vp)]
1534 catch {unset ordertok}
1536 if {[info exists varcid($view,$p)]} {
1537 fix_reversal $p $a $view
1540 incr i
1543 set scripts [check_interest $id $scripts]
1544 set gotsome 1
1546 if {$gotsome} {
1547 global numcommits hlview
1549 if {$view == $curview} {
1550 set numcommits $commitidx($view)
1551 run chewcommits
1553 if {[info exists hlview] && $view == $hlview} {
1554 # we never actually get here...
1555 run vhighlightmore
1557 foreach s $scripts {
1558 eval $s
1561 return 2
1564 proc chewcommits {} {
1565 global curview hlview viewcomplete
1566 global pending_select
1568 layoutmore
1569 if {$viewcomplete($curview)} {
1570 global commitidx varctok
1571 global numcommits startmsecs
1573 if {[info exists pending_select]} {
1574 update
1575 reset_pending_select {}
1577 if {[commitinview $pending_select $curview]} {
1578 selectline [rowofcommit $pending_select] 1
1579 } else {
1580 set row [first_real_row]
1581 selectline $row 1
1584 if {$commitidx($curview) > 0} {
1585 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1586 #puts "overall $ms ms for $numcommits commits"
1587 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1588 } else {
1589 show_status [mc "No commits selected"]
1591 notbusy layout
1593 return 0
1596 proc do_readcommit {id} {
1597 global tclencoding
1599 # Invoke git-log to handle automatic encoding conversion
1600 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1601 # Read the results using i18n.logoutputencoding
1602 fconfigure $fd -translation lf -eofchar {}
1603 if {$tclencoding != {}} {
1604 fconfigure $fd -encoding $tclencoding
1606 set contents [read $fd]
1607 close $fd
1608 # Remove the heading line
1609 regsub {^commit [0-9a-f]+\n} $contents {} contents
1611 return $contents
1614 proc readcommit {id} {
1615 if {[catch {set contents [do_readcommit $id]}]} return
1616 parsecommit $id $contents 1
1619 proc parsecommit {id contents listed} {
1620 global commitinfo
1622 set inhdr 1
1623 set comment {}
1624 set headline {}
1625 set auname {}
1626 set audate {}
1627 set comname {}
1628 set comdate {}
1629 set hdrend [string first "\n\n" $contents]
1630 if {$hdrend < 0} {
1631 # should never happen...
1632 set hdrend [string length $contents]
1634 set header [string range $contents 0 [expr {$hdrend - 1}]]
1635 set comment [string range $contents [expr {$hdrend + 2}] end]
1636 foreach line [split $header "\n"] {
1637 set line [split $line " "]
1638 set tag [lindex $line 0]
1639 if {$tag == "author"} {
1640 set audate [lrange $line end-1 end]
1641 set auname [join [lrange $line 1 end-2] " "]
1642 } elseif {$tag == "committer"} {
1643 set comdate [lrange $line end-1 end]
1644 set comname [join [lrange $line 1 end-2] " "]
1647 set headline {}
1648 # take the first non-blank line of the comment as the headline
1649 set headline [string trimleft $comment]
1650 set i [string first "\n" $headline]
1651 if {$i >= 0} {
1652 set headline [string range $headline 0 $i]
1654 set headline [string trimright $headline]
1655 set i [string first "\r" $headline]
1656 if {$i >= 0} {
1657 set headline [string trimright [string range $headline 0 $i]]
1659 if {!$listed} {
1660 # git log indents the comment by 4 spaces;
1661 # if we got this via git cat-file, add the indentation
1662 set newcomment {}
1663 foreach line [split $comment "\n"] {
1664 append newcomment " "
1665 append newcomment $line
1666 append newcomment "\n"
1668 set comment $newcomment
1670 set hasnote [string first "\nNotes:\n" $contents]
1671 set commitinfo($id) [list $headline $auname $audate \
1672 $comname $comdate $comment $hasnote]
1675 proc getcommit {id} {
1676 global commitdata commitinfo
1678 if {[info exists commitdata($id)]} {
1679 parsecommit $id $commitdata($id) 1
1680 } else {
1681 readcommit $id
1682 if {![info exists commitinfo($id)]} {
1683 set commitinfo($id) [list [mc "No commit information available"]]
1686 return 1
1689 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1690 # and are present in the current view.
1691 # This is fairly slow...
1692 proc longid {prefix} {
1693 global varcid curview
1695 set ids {}
1696 foreach match [array names varcid "$curview,$prefix*"] {
1697 lappend ids [lindex [split $match ","] 1]
1699 return $ids
1702 proc readrefs {} {
1703 global tagids idtags headids idheads tagobjid
1704 global otherrefids idotherrefs mainhead mainheadid
1705 global selecthead selectheadid
1706 global hideremotes
1708 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1709 catch {unset $v}
1711 set refd [open [list | git show-ref -d] r]
1712 while {[gets $refd line] >= 0} {
1713 if {[string index $line 40] ne " "} continue
1714 set id [string range $line 0 39]
1715 set ref [string range $line 41 end]
1716 if {![string match "refs/*" $ref]} continue
1717 set name [string range $ref 5 end]
1718 if {[string match "remotes/*" $name]} {
1719 if {![string match "*/HEAD" $name] && !$hideremotes} {
1720 set headids($name) $id
1721 lappend idheads($id) $name
1723 } elseif {[string match "heads/*" $name]} {
1724 set name [string range $name 6 end]
1725 set headids($name) $id
1726 lappend idheads($id) $name
1727 } elseif {[string match "tags/*" $name]} {
1728 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1729 # which is what we want since the former is the commit ID
1730 set name [string range $name 5 end]
1731 if {[string match "*^{}" $name]} {
1732 set name [string range $name 0 end-3]
1733 } else {
1734 set tagobjid($name) $id
1736 set tagids($name) $id
1737 lappend idtags($id) $name
1738 } else {
1739 set otherrefids($name) $id
1740 lappend idotherrefs($id) $name
1743 catch {close $refd}
1744 set mainhead {}
1745 set mainheadid {}
1746 catch {
1747 set mainheadid [exec git rev-parse HEAD]
1748 set thehead [exec git symbolic-ref HEAD]
1749 if {[string match "refs/heads/*" $thehead]} {
1750 set mainhead [string range $thehead 11 end]
1753 set selectheadid {}
1754 if {$selecthead ne {}} {
1755 catch {
1756 set selectheadid [exec git rev-parse --verify $selecthead]
1761 # skip over fake commits
1762 proc first_real_row {} {
1763 global nullid nullid2 numcommits
1765 for {set row 0} {$row < $numcommits} {incr row} {
1766 set id [commitonrow $row]
1767 if {$id ne $nullid && $id ne $nullid2} {
1768 break
1771 return $row
1774 # update things for a head moved to a child of its previous location
1775 proc movehead {id name} {
1776 global headids idheads
1778 removehead $headids($name) $name
1779 set headids($name) $id
1780 lappend idheads($id) $name
1783 # update things when a head has been removed
1784 proc removehead {id name} {
1785 global headids idheads
1787 if {$idheads($id) eq $name} {
1788 unset idheads($id)
1789 } else {
1790 set i [lsearch -exact $idheads($id) $name]
1791 if {$i >= 0} {
1792 set idheads($id) [lreplace $idheads($id) $i $i]
1795 unset headids($name)
1798 proc ttk_toplevel {w args} {
1799 global use_ttk
1800 eval [linsert $args 0 ::toplevel $w]
1801 if {$use_ttk} {
1802 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1804 return $w
1807 proc make_transient {window origin} {
1808 global have_tk85
1810 # In MacOS Tk 8.4 transient appears to work by setting
1811 # overrideredirect, which is utterly useless, since the
1812 # windows get no border, and are not even kept above
1813 # the parent.
1814 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1816 wm transient $window $origin
1818 # Windows fails to place transient windows normally, so
1819 # schedule a callback to center them on the parent.
1820 if {[tk windowingsystem] eq {win32}} {
1821 after idle [list tk::PlaceWindow $window widget $origin]
1825 proc show_error {w top msg {mc mc}} {
1826 global NS
1827 if {![info exists NS]} {set NS ""}
1828 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1829 message $w.m -text $msg -justify center -aspect 400
1830 pack $w.m -side top -fill x -padx 20 -pady 20
1831 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1832 pack $w.ok -side bottom -fill x
1833 bind $top <Visibility> "grab $top; focus $top"
1834 bind $top <Key-Return> "destroy $top"
1835 bind $top <Key-space> "destroy $top"
1836 bind $top <Key-Escape> "destroy $top"
1837 tkwait window $top
1840 proc error_popup {msg {owner .}} {
1841 if {[tk windowingsystem] eq "win32"} {
1842 tk_messageBox -icon error -type ok -title [wm title .] \
1843 -parent $owner -message $msg
1844 } else {
1845 set w .error
1846 ttk_toplevel $w
1847 make_transient $w $owner
1848 show_error $w $w $msg
1852 proc confirm_popup {msg {owner .}} {
1853 global confirm_ok NS
1854 set confirm_ok 0
1855 set w .confirm
1856 ttk_toplevel $w
1857 make_transient $w $owner
1858 message $w.m -text $msg -justify center -aspect 400
1859 pack $w.m -side top -fill x -padx 20 -pady 20
1860 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1861 pack $w.ok -side left -fill x
1862 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1863 pack $w.cancel -side right -fill x
1864 bind $w <Visibility> "grab $w; focus $w"
1865 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1866 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1867 bind $w <Key-Escape> "destroy $w"
1868 tk::PlaceWindow $w widget $owner
1869 tkwait window $w
1870 return $confirm_ok
1873 proc setoptions {} {
1874 if {[tk windowingsystem] ne "win32"} {
1875 option add *Panedwindow.showHandle 1 startupFile
1876 option add *Panedwindow.sashRelief raised startupFile
1877 if {[tk windowingsystem] ne "aqua"} {
1878 option add *Menu.font uifont startupFile
1880 } else {
1881 option add *Menu.TearOff 0 startupFile
1883 option add *Button.font uifont startupFile
1884 option add *Checkbutton.font uifont startupFile
1885 option add *Radiobutton.font uifont startupFile
1886 option add *Menubutton.font uifont startupFile
1887 option add *Label.font uifont startupFile
1888 option add *Message.font uifont startupFile
1889 option add *Entry.font textfont startupFile
1890 option add *Text.font textfont startupFile
1891 option add *Labelframe.font uifont startupFile
1892 option add *Spinbox.font textfont startupFile
1893 option add *Listbox.font mainfont startupFile
1896 # Make a menu and submenus.
1897 # m is the window name for the menu, items is the list of menu items to add.
1898 # Each item is a list {mc label type description options...}
1899 # mc is ignored; it's so we can put mc there to alert xgettext
1900 # label is the string that appears in the menu
1901 # type is cascade, command or radiobutton (should add checkbutton)
1902 # description depends on type; it's the sublist for cascade, the
1903 # command to invoke for command, or {variable value} for radiobutton
1904 proc makemenu {m items} {
1905 menu $m
1906 if {[tk windowingsystem] eq {aqua}} {
1907 set Meta1 Cmd
1908 } else {
1909 set Meta1 Ctrl
1911 foreach i $items {
1912 set name [mc [lindex $i 1]]
1913 set type [lindex $i 2]
1914 set thing [lindex $i 3]
1915 set params [list $type]
1916 if {$name ne {}} {
1917 set u [string first "&" [string map {&& x} $name]]
1918 lappend params -label [string map {&& & & {}} $name]
1919 if {$u >= 0} {
1920 lappend params -underline $u
1923 switch -- $type {
1924 "cascade" {
1925 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1926 lappend params -menu $m.$submenu
1928 "command" {
1929 lappend params -command $thing
1931 "radiobutton" {
1932 lappend params -variable [lindex $thing 0] \
1933 -value [lindex $thing 1]
1936 set tail [lrange $i 4 end]
1937 regsub -all {\yMeta1\y} $tail $Meta1 tail
1938 eval $m add $params $tail
1939 if {$type eq "cascade"} {
1940 makemenu $m.$submenu $thing
1945 # translate string and remove ampersands
1946 proc mca {str} {
1947 return [string map {&& & & {}} [mc $str]]
1950 proc makedroplist {w varname args} {
1951 global use_ttk
1952 if {$use_ttk} {
1953 set width 0
1954 foreach label $args {
1955 set cx [string length $label]
1956 if {$cx > $width} {set width $cx}
1958 set gm [ttk::combobox $w -width $width -state readonly\
1959 -textvariable $varname -values $args]
1960 } else {
1961 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
1963 return $gm
1966 proc makewindow {} {
1967 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1968 global tabstop
1969 global findtype findtypemenu findloc findstring fstring geometry
1970 global entries sha1entry sha1string sha1but
1971 global diffcontextstring diffcontext
1972 global ignorespace
1973 global maincursor textcursor curtextcursor
1974 global rowctxmenu fakerowmenu mergemax wrapcomment
1975 global highlight_files gdttype
1976 global searchstring sstring
1977 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1978 global headctxmenu progresscanv progressitem progresscoords statusw
1979 global fprogitem fprogcoord lastprogupdate progupdatepending
1980 global rprogitem rprogcoord rownumsel numcommits
1981 global have_tk85 use_ttk NS
1982 global git_version
1983 global worddiff
1985 # The "mc" arguments here are purely so that xgettext
1986 # sees the following string as needing to be translated
1987 set file {
1988 mc "File" cascade {
1989 {mc "Update" command updatecommits -accelerator F5}
1990 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1991 {mc "Reread references" command rereadrefs}
1992 {mc "List references" command showrefs -accelerator F2}
1993 {xx "" separator}
1994 {mc "Start git gui" command {exec git gui &}}
1995 {xx "" separator}
1996 {mc "Quit" command doquit -accelerator Meta1-Q}
1998 set edit {
1999 mc "Edit" cascade {
2000 {mc "Preferences" command doprefs}
2002 set view {
2003 mc "View" cascade {
2004 {mc "New view..." command {newview 0} -accelerator Shift-F4}
2005 {mc "Edit view..." command editview -state disabled -accelerator F4}
2006 {mc "Delete view" command delview -state disabled}
2007 {xx "" separator}
2008 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2010 if {[tk windowingsystem] ne "aqua"} {
2011 set help {
2012 mc "Help" cascade {
2013 {mc "About gitk" command about}
2014 {mc "Key bindings" command keys}
2016 set bar [list $file $edit $view $help]
2017 } else {
2018 proc ::tk::mac::ShowPreferences {} {doprefs}
2019 proc ::tk::mac::Quit {} {doquit}
2020 lset file end [lreplace [lindex $file end] end-1 end]
2021 set apple {
2022 xx "Apple" cascade {
2023 {mc "About gitk" command about}
2024 {xx "" separator}
2026 set help {
2027 mc "Help" cascade {
2028 {mc "Key bindings" command keys}
2030 set bar [list $apple $file $view $help]
2032 makemenu .bar $bar
2033 . configure -menu .bar
2035 if {$use_ttk} {
2036 # cover the non-themed toplevel with a themed frame.
2037 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2040 # the gui has upper and lower half, parts of a paned window.
2041 ${NS}::panedwindow .ctop -orient vertical
2043 # possibly use assumed geometry
2044 if {![info exists geometry(pwsash0)]} {
2045 set geometry(topheight) [expr {15 * $linespc}]
2046 set geometry(topwidth) [expr {80 * $charspc}]
2047 set geometry(botheight) [expr {15 * $linespc}]
2048 set geometry(botwidth) [expr {50 * $charspc}]
2049 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2050 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2053 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2054 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2055 ${NS}::frame .tf.histframe
2056 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2057 if {!$use_ttk} {
2058 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2061 # create three canvases
2062 set cscroll .tf.histframe.csb
2063 set canv .tf.histframe.pwclist.canv
2064 canvas $canv \
2065 -selectbackground $selectbgcolor \
2066 -background $bgcolor -bd 0 \
2067 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2068 .tf.histframe.pwclist add $canv
2069 set canv2 .tf.histframe.pwclist.canv2
2070 canvas $canv2 \
2071 -selectbackground $selectbgcolor \
2072 -background $bgcolor -bd 0 -yscrollincr $linespc
2073 .tf.histframe.pwclist add $canv2
2074 set canv3 .tf.histframe.pwclist.canv3
2075 canvas $canv3 \
2076 -selectbackground $selectbgcolor \
2077 -background $bgcolor -bd 0 -yscrollincr $linespc
2078 .tf.histframe.pwclist add $canv3
2079 if {$use_ttk} {
2080 bind .tf.histframe.pwclist <Map> {
2081 bind %W <Map> {}
2082 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2083 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2085 } else {
2086 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2087 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2090 # a scroll bar to rule them
2091 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2092 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2093 pack $cscroll -side right -fill y
2094 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2095 lappend bglist $canv $canv2 $canv3
2096 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2098 # we have two button bars at bottom of top frame. Bar 1
2099 ${NS}::frame .tf.bar
2100 ${NS}::frame .tf.lbar -height 15
2102 set sha1entry .tf.bar.sha1
2103 set entries $sha1entry
2104 set sha1but .tf.bar.sha1label
2105 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2106 -command gotocommit -width 8
2107 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2108 pack .tf.bar.sha1label -side left
2109 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2110 trace add variable sha1string write sha1change
2111 pack $sha1entry -side left -pady 2
2113 image create bitmap bm-left -data {
2114 #define left_width 16
2115 #define left_height 16
2116 static unsigned char left_bits[] = {
2117 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2118 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2119 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2121 image create bitmap bm-right -data {
2122 #define right_width 16
2123 #define right_height 16
2124 static unsigned char right_bits[] = {
2125 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2126 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2127 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2129 ${NS}::button .tf.bar.leftbut -image bm-left -command goback \
2130 -state disabled -width 26
2131 pack .tf.bar.leftbut -side left -fill y
2132 ${NS}::button .tf.bar.rightbut -image bm-right -command goforw \
2133 -state disabled -width 26
2134 pack .tf.bar.rightbut -side left -fill y
2136 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2137 set rownumsel {}
2138 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2139 -relief sunken -anchor e
2140 ${NS}::label .tf.bar.rowlabel2 -text "/"
2141 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2142 -relief sunken -anchor e
2143 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2144 -side left
2145 if {!$use_ttk} {
2146 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2148 global selectedline
2149 trace add variable selectedline write selectedline_change
2151 # Status label and progress bar
2152 set statusw .tf.bar.status
2153 ${NS}::label $statusw -width 15 -relief sunken
2154 pack $statusw -side left -padx 5
2155 if {$use_ttk} {
2156 set progresscanv [ttk::progressbar .tf.bar.progress]
2157 } else {
2158 set h [expr {[font metrics uifont -linespace] + 2}]
2159 set progresscanv .tf.bar.progress
2160 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2161 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2162 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2163 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2165 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2166 set progresscoords {0 0}
2167 set fprogcoord 0
2168 set rprogcoord 0
2169 bind $progresscanv <Configure> adjustprogress
2170 set lastprogupdate [clock clicks -milliseconds]
2171 set progupdatepending 0
2173 # build up the bottom bar of upper window
2174 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2175 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2176 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2177 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2178 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2179 -side left -fill y
2180 set gdttype [mc "containing:"]
2181 set gm [makedroplist .tf.lbar.gdttype gdttype \
2182 [mc "containing:"] \
2183 [mc "touching paths:"] \
2184 [mc "adding/removing string:"]]
2185 trace add variable gdttype write gdttype_change
2186 pack .tf.lbar.gdttype -side left -fill y
2188 set findstring {}
2189 set fstring .tf.lbar.findstring
2190 lappend entries $fstring
2191 ${NS}::entry $fstring -width 30 -textvariable findstring
2192 trace add variable findstring write find_change
2193 set findtype [mc "Exact"]
2194 set findtypemenu [makedroplist .tf.lbar.findtype \
2195 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2196 trace add variable findtype write findcom_change
2197 set findloc [mc "All fields"]
2198 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2199 [mc "Comments"] [mc "Author"] [mc "Committer"]
2200 trace add variable findloc write find_change
2201 pack .tf.lbar.findloc -side right
2202 pack .tf.lbar.findtype -side right
2203 pack $fstring -side left -expand 1 -fill x
2205 # Finish putting the upper half of the viewer together
2206 pack .tf.lbar -in .tf -side bottom -fill x
2207 pack .tf.bar -in .tf -side bottom -fill x
2208 pack .tf.histframe -fill both -side top -expand 1
2209 .ctop add .tf
2210 if {!$use_ttk} {
2211 .ctop paneconfigure .tf -height $geometry(topheight)
2212 .ctop paneconfigure .tf -width $geometry(topwidth)
2215 # now build up the bottom
2216 ${NS}::panedwindow .pwbottom -orient horizontal
2218 # lower left, a text box over search bar, scroll bar to the right
2219 # if we know window height, then that will set the lower text height, otherwise
2220 # we set lower text height which will drive window height
2221 if {[info exists geometry(main)]} {
2222 ${NS}::frame .bleft -width $geometry(botwidth)
2223 } else {
2224 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2226 ${NS}::frame .bleft.top
2227 ${NS}::frame .bleft.mid
2228 ${NS}::frame .bleft.bottom
2230 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2231 pack .bleft.top.search -side left -padx 5
2232 set sstring .bleft.top.sstring
2233 set searchstring ""
2234 ${NS}::entry $sstring -width 20 -textvariable searchstring
2235 lappend entries $sstring
2236 trace add variable searchstring write incrsearch
2237 pack $sstring -side left -expand 1 -fill x
2238 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2239 -command changediffdisp -variable diffelide -value {0 0}
2240 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2241 -command changediffdisp -variable diffelide -value {0 1}
2242 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2243 -command changediffdisp -variable diffelide -value {1 0}
2244 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2245 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2246 spinbox .bleft.mid.diffcontext -width 5 \
2247 -from 0 -increment 1 -to 10000000 \
2248 -validate all -validatecommand "diffcontextvalidate %P" \
2249 -textvariable diffcontextstring
2250 .bleft.mid.diffcontext set $diffcontext
2251 trace add variable diffcontextstring write diffcontextchange
2252 lappend entries .bleft.mid.diffcontext
2253 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2254 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2255 -command changeignorespace -variable ignorespace
2256 pack .bleft.mid.ignspace -side left -padx 5
2258 set worddiff [mc "Line diff"]
2259 if {[package vcompare $git_version "1.7.2"] >= 0} {
2260 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2261 [mc "Markup words"] [mc "Color words"]
2262 trace add variable worddiff write changeworddiff
2263 pack .bleft.mid.worddiff -side left -padx 5
2266 set ctext .bleft.bottom.ctext
2267 text $ctext -background $bgcolor -foreground $fgcolor \
2268 -state disabled -font textfont \
2269 -yscrollcommand scrolltext -wrap none \
2270 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2271 if {$have_tk85} {
2272 $ctext conf -tabstyle wordprocessor
2274 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2275 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2276 pack .bleft.top -side top -fill x
2277 pack .bleft.mid -side top -fill x
2278 grid $ctext .bleft.bottom.sb -sticky nsew
2279 grid .bleft.bottom.sbhorizontal -sticky ew
2280 grid columnconfigure .bleft.bottom 0 -weight 1
2281 grid rowconfigure .bleft.bottom 0 -weight 1
2282 grid rowconfigure .bleft.bottom 1 -weight 0
2283 pack .bleft.bottom -side top -fill both -expand 1
2284 lappend bglist $ctext
2285 lappend fglist $ctext
2287 $ctext tag conf comment -wrap $wrapcomment
2288 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2289 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2290 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2291 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2292 $ctext tag conf m0 -fore red
2293 $ctext tag conf m1 -fore blue
2294 $ctext tag conf m2 -fore green
2295 $ctext tag conf m3 -fore purple
2296 $ctext tag conf m4 -fore brown
2297 $ctext tag conf m5 -fore "#009090"
2298 $ctext tag conf m6 -fore magenta
2299 $ctext tag conf m7 -fore "#808000"
2300 $ctext tag conf m8 -fore "#009000"
2301 $ctext tag conf m9 -fore "#ff0080"
2302 $ctext tag conf m10 -fore cyan
2303 $ctext tag conf m11 -fore "#b07070"
2304 $ctext tag conf m12 -fore "#70b0f0"
2305 $ctext tag conf m13 -fore "#70f0b0"
2306 $ctext tag conf m14 -fore "#f0b070"
2307 $ctext tag conf m15 -fore "#ff70b0"
2308 $ctext tag conf mmax -fore darkgrey
2309 set mergemax 16
2310 $ctext tag conf mresult -font textfontbold
2311 $ctext tag conf msep -font textfontbold
2312 $ctext tag conf found -back yellow
2314 .pwbottom add .bleft
2315 if {!$use_ttk} {
2316 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2319 # lower right
2320 ${NS}::frame .bright
2321 ${NS}::frame .bright.mode
2322 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2323 -command reselectline -variable cmitmode -value "patch"
2324 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2325 -command reselectline -variable cmitmode -value "tree"
2326 grid .bright.mode.patch .bright.mode.tree -sticky ew
2327 pack .bright.mode -side top -fill x
2328 set cflist .bright.cfiles
2329 set indent [font measure mainfont "nn"]
2330 text $cflist \
2331 -selectbackground $selectbgcolor \
2332 -background $bgcolor -foreground $fgcolor \
2333 -font mainfont \
2334 -tabs [list $indent [expr {2 * $indent}]] \
2335 -yscrollcommand ".bright.sb set" \
2336 -cursor [. cget -cursor] \
2337 -spacing1 1 -spacing3 1
2338 lappend bglist $cflist
2339 lappend fglist $cflist
2340 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2341 pack .bright.sb -side right -fill y
2342 pack $cflist -side left -fill both -expand 1
2343 $cflist tag configure highlight \
2344 -background [$cflist cget -selectbackground]
2345 $cflist tag configure bold -font mainfontbold
2347 .pwbottom add .bright
2348 .ctop add .pwbottom
2350 # restore window width & height if known
2351 if {[info exists geometry(main)]} {
2352 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2353 if {$w > [winfo screenwidth .]} {
2354 set w [winfo screenwidth .]
2356 if {$h > [winfo screenheight .]} {
2357 set h [winfo screenheight .]
2359 wm geometry . "${w}x$h"
2363 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2364 wm state . $geometry(state)
2367 if {[tk windowingsystem] eq {aqua}} {
2368 set M1B M1
2369 set ::BM "3"
2370 } else {
2371 set M1B Control
2372 set ::BM "2"
2375 if {$use_ttk} {
2376 bind .ctop <Map> {
2377 bind %W <Map> {}
2378 %W sashpos 0 $::geometry(topheight)
2380 bind .pwbottom <Map> {
2381 bind %W <Map> {}
2382 %W sashpos 0 $::geometry(botwidth)
2386 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2387 pack .ctop -fill both -expand 1
2388 bindall <1> {selcanvline %W %x %y}
2389 #bindall <B1-Motion> {selcanvline %W %x %y}
2390 if {[tk windowingsystem] == "win32"} {
2391 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2392 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2393 } else {
2394 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2395 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2396 if {[tk windowingsystem] eq "aqua"} {
2397 bindall <MouseWheel> {
2398 set delta [expr {- (%D)}]
2399 allcanvs yview scroll $delta units
2401 bindall <Shift-MouseWheel> {
2402 set delta [expr {- (%D)}]
2403 $canv xview scroll $delta units
2407 bindall <$::BM> "canvscan mark %W %x %y"
2408 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2409 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2410 bind . <$M1B-Key-w> doquit
2411 bindkey <Home> selfirstline
2412 bindkey <End> sellastline
2413 bind . <Key-Up> "selnextline -1"
2414 bind . <Key-Down> "selnextline 1"
2415 bind . <Shift-Key-Up> "dofind -1 0"
2416 bind . <Shift-Key-Down> "dofind 1 0"
2417 bindkey <Key-Right> "goforw"
2418 bindkey <Key-Left> "goback"
2419 bind . <Key-Prior> "selnextpage -1"
2420 bind . <Key-Next> "selnextpage 1"
2421 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2422 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2423 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2424 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2425 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2426 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2427 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2428 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2429 bindkey <Key-space> "$ctext yview scroll 1 pages"
2430 bindkey p "selnextline -1"
2431 bindkey n "selnextline 1"
2432 bindkey z "goback"
2433 bindkey x "goforw"
2434 bindkey k "selnextline -1"
2435 bindkey j "selnextline 1"
2436 bindkey h "goback"
2437 bindkey l "goforw"
2438 bindkey b prevfile
2439 bindkey d "$ctext yview scroll 18 units"
2440 bindkey u "$ctext yview scroll -18 units"
2441 bindkey / {focus $fstring}
2442 bindkey <Key-KP_Divide> {focus $fstring}
2443 bindkey <Key-Return> {dofind 1 1}
2444 bindkey ? {dofind -1 1}
2445 bindkey f nextfile
2446 bind . <F5> updatecommits
2447 bind . <$M1B-F5> reloadcommits
2448 bind . <F2> showrefs
2449 bind . <Shift-F4> {newview 0}
2450 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2451 bind . <F4> edit_or_newview
2452 bind . <$M1B-q> doquit
2453 bind . <$M1B-f> {dofind 1 1}
2454 bind . <$M1B-g> {dofind 1 0}
2455 bind . <$M1B-r> dosearchback
2456 bind . <$M1B-s> dosearch
2457 bind . <$M1B-equal> {incrfont 1}
2458 bind . <$M1B-plus> {incrfont 1}
2459 bind . <$M1B-KP_Add> {incrfont 1}
2460 bind . <$M1B-minus> {incrfont -1}
2461 bind . <$M1B-KP_Subtract> {incrfont -1}
2462 wm protocol . WM_DELETE_WINDOW doquit
2463 bind . <Destroy> {stop_backends}
2464 bind . <Button-1> "click %W"
2465 bind $fstring <Key-Return> {dofind 1 1}
2466 bind $sha1entry <Key-Return> {gotocommit; break}
2467 bind $sha1entry <<PasteSelection>> clearsha1
2468 bind $cflist <1> {sel_flist %W %x %y; break}
2469 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2470 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2471 global ctxbut
2472 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2473 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2474 bind $ctext <Button-1> {focus %W}
2476 set maincursor [. cget -cursor]
2477 set textcursor [$ctext cget -cursor]
2478 set curtextcursor $textcursor
2480 set rowctxmenu .rowctxmenu
2481 makemenu $rowctxmenu {
2482 {mc "Diff this -> selected" command {diffvssel 0}}
2483 {mc "Diff selected -> this" command {diffvssel 1}}
2484 {mc "Make patch" command mkpatch}
2485 {mc "Create tag" command mktag}
2486 {mc "Write commit to file" command writecommit}
2487 {mc "Create new branch" command mkbranch}
2488 {mc "Cherry-pick this commit" command cherrypick}
2489 {mc "Reset HEAD branch to here" command resethead}
2490 {mc "Mark this commit" command markhere}
2491 {mc "Return to mark" command gotomark}
2492 {mc "Find descendant of this and mark" command find_common_desc}
2493 {mc "Compare with marked commit" command compare_commits}
2495 $rowctxmenu configure -tearoff 0
2497 set fakerowmenu .fakerowmenu
2498 makemenu $fakerowmenu {
2499 {mc "Diff this -> selected" command {diffvssel 0}}
2500 {mc "Diff selected -> this" command {diffvssel 1}}
2501 {mc "Make patch" command mkpatch}
2503 $fakerowmenu configure -tearoff 0
2505 set headctxmenu .headctxmenu
2506 makemenu $headctxmenu {
2507 {mc "Check out this branch" command cobranch}
2508 {mc "Remove this branch" command rmbranch}
2510 $headctxmenu configure -tearoff 0
2512 global flist_menu
2513 set flist_menu .flistctxmenu
2514 makemenu $flist_menu {
2515 {mc "Highlight this too" command {flist_hl 0}}
2516 {mc "Highlight this only" command {flist_hl 1}}
2517 {mc "External diff" command {external_diff}}
2518 {mc "Blame parent commit" command {external_blame 1}}
2520 $flist_menu configure -tearoff 0
2522 global diff_menu
2523 set diff_menu .diffctxmenu
2524 makemenu $diff_menu {
2525 {mc "Show origin of this line" command show_line_source}
2526 {mc "Run git gui blame on this line" command {external_blame_diff}}
2528 $diff_menu configure -tearoff 0
2531 # Windows sends all mouse wheel events to the current focused window, not
2532 # the one where the mouse hovers, so bind those events here and redirect
2533 # to the correct window
2534 proc windows_mousewheel_redirector {W X Y D} {
2535 global canv canv2 canv3
2536 set w [winfo containing -displayof $W $X $Y]
2537 if {$w ne ""} {
2538 set u [expr {$D < 0 ? 5 : -5}]
2539 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2540 allcanvs yview scroll $u units
2541 } else {
2542 catch {
2543 $w yview scroll $u units
2549 # Update row number label when selectedline changes
2550 proc selectedline_change {n1 n2 op} {
2551 global selectedline rownumsel
2553 if {$selectedline eq {}} {
2554 set rownumsel {}
2555 } else {
2556 set rownumsel [expr {$selectedline + 1}]
2560 # mouse-2 makes all windows scan vertically, but only the one
2561 # the cursor is in scans horizontally
2562 proc canvscan {op w x y} {
2563 global canv canv2 canv3
2564 foreach c [list $canv $canv2 $canv3] {
2565 if {$c == $w} {
2566 $c scan $op $x $y
2567 } else {
2568 $c scan $op 0 $y
2573 proc scrollcanv {cscroll f0 f1} {
2574 $cscroll set $f0 $f1
2575 drawvisible
2576 flushhighlights
2579 # when we make a key binding for the toplevel, make sure
2580 # it doesn't get triggered when that key is pressed in the
2581 # find string entry widget.
2582 proc bindkey {ev script} {
2583 global entries
2584 bind . $ev $script
2585 set escript [bind Entry $ev]
2586 if {$escript == {}} {
2587 set escript [bind Entry <Key>]
2589 foreach e $entries {
2590 bind $e $ev "$escript; break"
2594 # set the focus back to the toplevel for any click outside
2595 # the entry widgets
2596 proc click {w} {
2597 global ctext entries
2598 foreach e [concat $entries $ctext] {
2599 if {$w == $e} return
2601 focus .
2604 # Adjust the progress bar for a change in requested extent or canvas size
2605 proc adjustprogress {} {
2606 global progresscanv progressitem progresscoords
2607 global fprogitem fprogcoord lastprogupdate progupdatepending
2608 global rprogitem rprogcoord use_ttk
2610 if {$use_ttk} {
2611 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2612 return
2615 set w [expr {[winfo width $progresscanv] - 4}]
2616 set x0 [expr {$w * [lindex $progresscoords 0]}]
2617 set x1 [expr {$w * [lindex $progresscoords 1]}]
2618 set h [winfo height $progresscanv]
2619 $progresscanv coords $progressitem $x0 0 $x1 $h
2620 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2621 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2622 set now [clock clicks -milliseconds]
2623 if {$now >= $lastprogupdate + 100} {
2624 set progupdatepending 0
2625 update
2626 } elseif {!$progupdatepending} {
2627 set progupdatepending 1
2628 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2632 proc doprogupdate {} {
2633 global lastprogupdate progupdatepending
2635 if {$progupdatepending} {
2636 set progupdatepending 0
2637 set lastprogupdate [clock clicks -milliseconds]
2638 update
2642 proc savestuff {w} {
2643 global canv canv2 canv3 mainfont textfont uifont tabstop
2644 global stuffsaved findmergefiles maxgraphpct
2645 global maxwidth showneartags showlocalchanges
2646 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2647 global cmitmode wrapcomment datetimeformat limitdiffs
2648 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2649 global autoselect autosellen extdifftool perfile_attrs markbgcolor use_ttk
2650 global hideremotes want_ttk
2652 if {$stuffsaved} return
2653 if {![winfo viewable .]} return
2654 catch {
2655 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2656 set f [open "~/.gitk-new" w]
2657 if {$::tcl_platform(platform) eq {windows}} {
2658 file attributes "~/.gitk-new" -hidden true
2660 puts $f [list set mainfont $mainfont]
2661 puts $f [list set textfont $textfont]
2662 puts $f [list set uifont $uifont]
2663 puts $f [list set tabstop $tabstop]
2664 puts $f [list set findmergefiles $findmergefiles]
2665 puts $f [list set maxgraphpct $maxgraphpct]
2666 puts $f [list set maxwidth $maxwidth]
2667 puts $f [list set cmitmode $cmitmode]
2668 puts $f [list set wrapcomment $wrapcomment]
2669 puts $f [list set autoselect $autoselect]
2670 puts $f [list set autosellen $autosellen]
2671 puts $f [list set showneartags $showneartags]
2672 puts $f [list set hideremotes $hideremotes]
2673 puts $f [list set showlocalchanges $showlocalchanges]
2674 puts $f [list set datetimeformat $datetimeformat]
2675 puts $f [list set limitdiffs $limitdiffs]
2676 puts $f [list set uicolor $uicolor]
2677 puts $f [list set want_ttk $want_ttk]
2678 puts $f [list set bgcolor $bgcolor]
2679 puts $f [list set fgcolor $fgcolor]
2680 puts $f [list set colors $colors]
2681 puts $f [list set diffcolors $diffcolors]
2682 puts $f [list set markbgcolor $markbgcolor]
2683 puts $f [list set diffcontext $diffcontext]
2684 puts $f [list set selectbgcolor $selectbgcolor]
2685 puts $f [list set extdifftool $extdifftool]
2686 puts $f [list set perfile_attrs $perfile_attrs]
2688 puts $f "set geometry(main) [wm geometry .]"
2689 puts $f "set geometry(state) [wm state .]"
2690 puts $f "set geometry(topwidth) [winfo width .tf]"
2691 puts $f "set geometry(topheight) [winfo height .tf]"
2692 if {$use_ttk} {
2693 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2694 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2695 } else {
2696 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2697 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2699 puts $f "set geometry(botwidth) [winfo width .bleft]"
2700 puts $f "set geometry(botheight) [winfo height .bleft]"
2702 puts -nonewline $f "set permviews {"
2703 for {set v 0} {$v < $nextviewnum} {incr v} {
2704 if {$viewperm($v)} {
2705 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2708 puts $f "}"
2709 close $f
2710 catch {file delete "~/.gitk"}
2711 file rename -force "~/.gitk-new" "~/.gitk"
2713 set stuffsaved 1
2716 proc resizeclistpanes {win w} {
2717 global oldwidth use_ttk
2718 if {[info exists oldwidth($win)]} {
2719 if {$use_ttk} {
2720 set s0 [$win sashpos 0]
2721 set s1 [$win sashpos 1]
2722 } else {
2723 set s0 [$win sash coord 0]
2724 set s1 [$win sash coord 1]
2726 if {$w < 60} {
2727 set sash0 [expr {int($w/2 - 2)}]
2728 set sash1 [expr {int($w*5/6 - 2)}]
2729 } else {
2730 set factor [expr {1.0 * $w / $oldwidth($win)}]
2731 set sash0 [expr {int($factor * [lindex $s0 0])}]
2732 set sash1 [expr {int($factor * [lindex $s1 0])}]
2733 if {$sash0 < 30} {
2734 set sash0 30
2736 if {$sash1 < $sash0 + 20} {
2737 set sash1 [expr {$sash0 + 20}]
2739 if {$sash1 > $w - 10} {
2740 set sash1 [expr {$w - 10}]
2741 if {$sash0 > $sash1 - 20} {
2742 set sash0 [expr {$sash1 - 20}]
2746 if {$use_ttk} {
2747 $win sashpos 0 $sash0
2748 $win sashpos 1 $sash1
2749 } else {
2750 $win sash place 0 $sash0 [lindex $s0 1]
2751 $win sash place 1 $sash1 [lindex $s1 1]
2754 set oldwidth($win) $w
2757 proc resizecdetpanes {win w} {
2758 global oldwidth use_ttk
2759 if {[info exists oldwidth($win)]} {
2760 if {$use_ttk} {
2761 set s0 [$win sashpos 0]
2762 } else {
2763 set s0 [$win sash coord 0]
2765 if {$w < 60} {
2766 set sash0 [expr {int($w*3/4 - 2)}]
2767 } else {
2768 set factor [expr {1.0 * $w / $oldwidth($win)}]
2769 set sash0 [expr {int($factor * [lindex $s0 0])}]
2770 if {$sash0 < 45} {
2771 set sash0 45
2773 if {$sash0 > $w - 15} {
2774 set sash0 [expr {$w - 15}]
2777 if {$use_ttk} {
2778 $win sashpos 0 $sash0
2779 } else {
2780 $win sash place 0 $sash0 [lindex $s0 1]
2783 set oldwidth($win) $w
2786 proc allcanvs args {
2787 global canv canv2 canv3
2788 eval $canv $args
2789 eval $canv2 $args
2790 eval $canv3 $args
2793 proc bindall {event action} {
2794 global canv canv2 canv3
2795 bind $canv $event $action
2796 bind $canv2 $event $action
2797 bind $canv3 $event $action
2800 proc about {} {
2801 global uifont NS
2802 set w .about
2803 if {[winfo exists $w]} {
2804 raise $w
2805 return
2807 ttk_toplevel $w
2808 wm title $w [mc "About gitk"]
2809 make_transient $w .
2810 message $w.m -text [mc "
2811 Gitk - a commit viewer for git
2813 Copyright \u00a9 2005-2011 Paul Mackerras
2815 Use and redistribute under the terms of the GNU General Public License"] \
2816 -justify center -aspect 400 -border 2 -bg white -relief groove
2817 pack $w.m -side top -fill x -padx 2 -pady 2
2818 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2819 pack $w.ok -side bottom
2820 bind $w <Visibility> "focus $w.ok"
2821 bind $w <Key-Escape> "destroy $w"
2822 bind $w <Key-Return> "destroy $w"
2823 tk::PlaceWindow $w widget .
2826 proc keys {} {
2827 global NS
2828 set w .keys
2829 if {[winfo exists $w]} {
2830 raise $w
2831 return
2833 if {[tk windowingsystem] eq {aqua}} {
2834 set M1T Cmd
2835 } else {
2836 set M1T Ctrl
2838 ttk_toplevel $w
2839 wm title $w [mc "Gitk key bindings"]
2840 make_transient $w .
2841 message $w.m -text "
2842 [mc "Gitk key bindings:"]
2844 [mc "<%s-Q> Quit" $M1T]
2845 [mc "<%s-W> Close window" $M1T]
2846 [mc "<Home> Move to first commit"]
2847 [mc "<End> Move to last commit"]
2848 [mc "<Up>, p, k Move up one commit"]
2849 [mc "<Down>, n, j Move down one commit"]
2850 [mc "<Left>, z, h Go back in history list"]
2851 [mc "<Right>, x, l Go forward in history list"]
2852 [mc "<PageUp> Move up one page in commit list"]
2853 [mc "<PageDown> Move down one page in commit list"]
2854 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2855 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2856 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2857 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2858 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2859 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2860 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2861 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2862 [mc "<Delete>, b Scroll diff view up one page"]
2863 [mc "<Backspace> Scroll diff view up one page"]
2864 [mc "<Space> Scroll diff view down one page"]
2865 [mc "u Scroll diff view up 18 lines"]
2866 [mc "d Scroll diff view down 18 lines"]
2867 [mc "<%s-F> Find" $M1T]
2868 [mc "<%s-G> Move to next find hit" $M1T]
2869 [mc "<Return> Move to next find hit"]
2870 [mc "/ Focus the search box"]
2871 [mc "? Move to previous find hit"]
2872 [mc "f Scroll diff view to next file"]
2873 [mc "<%s-S> Search for next hit in diff view" $M1T]
2874 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2875 [mc "<%s-KP+> Increase font size" $M1T]
2876 [mc "<%s-plus> Increase font size" $M1T]
2877 [mc "<%s-KP-> Decrease font size" $M1T]
2878 [mc "<%s-minus> Decrease font size" $M1T]
2879 [mc "<F5> Update"]
2881 -justify left -bg white -border 2 -relief groove
2882 pack $w.m -side top -fill both -padx 2 -pady 2
2883 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2884 bind $w <Key-Escape> [list destroy $w]
2885 pack $w.ok -side bottom
2886 bind $w <Visibility> "focus $w.ok"
2887 bind $w <Key-Escape> "destroy $w"
2888 bind $w <Key-Return> "destroy $w"
2891 # Procedures for manipulating the file list window at the
2892 # bottom right of the overall window.
2894 proc treeview {w l openlevs} {
2895 global treecontents treediropen treeheight treeparent treeindex
2897 set ix 0
2898 set treeindex() 0
2899 set lev 0
2900 set prefix {}
2901 set prefixend -1
2902 set prefendstack {}
2903 set htstack {}
2904 set ht 0
2905 set treecontents() {}
2906 $w conf -state normal
2907 foreach f $l {
2908 while {[string range $f 0 $prefixend] ne $prefix} {
2909 if {$lev <= $openlevs} {
2910 $w mark set e:$treeindex($prefix) "end -1c"
2911 $w mark gravity e:$treeindex($prefix) left
2913 set treeheight($prefix) $ht
2914 incr ht [lindex $htstack end]
2915 set htstack [lreplace $htstack end end]
2916 set prefixend [lindex $prefendstack end]
2917 set prefendstack [lreplace $prefendstack end end]
2918 set prefix [string range $prefix 0 $prefixend]
2919 incr lev -1
2921 set tail [string range $f [expr {$prefixend+1}] end]
2922 while {[set slash [string first "/" $tail]] >= 0} {
2923 lappend htstack $ht
2924 set ht 0
2925 lappend prefendstack $prefixend
2926 incr prefixend [expr {$slash + 1}]
2927 set d [string range $tail 0 $slash]
2928 lappend treecontents($prefix) $d
2929 set oldprefix $prefix
2930 append prefix $d
2931 set treecontents($prefix) {}
2932 set treeindex($prefix) [incr ix]
2933 set treeparent($prefix) $oldprefix
2934 set tail [string range $tail [expr {$slash+1}] end]
2935 if {$lev <= $openlevs} {
2936 set ht 1
2937 set treediropen($prefix) [expr {$lev < $openlevs}]
2938 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2939 $w mark set d:$ix "end -1c"
2940 $w mark gravity d:$ix left
2941 set str "\n"
2942 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2943 $w insert end $str
2944 $w image create end -align center -image $bm -padx 1 \
2945 -name a:$ix
2946 $w insert end $d [highlight_tag $prefix]
2947 $w mark set s:$ix "end -1c"
2948 $w mark gravity s:$ix left
2950 incr lev
2952 if {$tail ne {}} {
2953 if {$lev <= $openlevs} {
2954 incr ht
2955 set str "\n"
2956 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2957 $w insert end $str
2958 $w insert end $tail [highlight_tag $f]
2960 lappend treecontents($prefix) $tail
2963 while {$htstack ne {}} {
2964 set treeheight($prefix) $ht
2965 incr ht [lindex $htstack end]
2966 set htstack [lreplace $htstack end end]
2967 set prefixend [lindex $prefendstack end]
2968 set prefendstack [lreplace $prefendstack end end]
2969 set prefix [string range $prefix 0 $prefixend]
2971 $w conf -state disabled
2974 proc linetoelt {l} {
2975 global treeheight treecontents
2977 set y 2
2978 set prefix {}
2979 while {1} {
2980 foreach e $treecontents($prefix) {
2981 if {$y == $l} {
2982 return "$prefix$e"
2984 set n 1
2985 if {[string index $e end] eq "/"} {
2986 set n $treeheight($prefix$e)
2987 if {$y + $n > $l} {
2988 append prefix $e
2989 incr y
2990 break
2993 incr y $n
2998 proc highlight_tree {y prefix} {
2999 global treeheight treecontents cflist
3001 foreach e $treecontents($prefix) {
3002 set path $prefix$e
3003 if {[highlight_tag $path] ne {}} {
3004 $cflist tag add bold $y.0 "$y.0 lineend"
3006 incr y
3007 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3008 set y [highlight_tree $y $path]
3011 return $y
3014 proc treeclosedir {w dir} {
3015 global treediropen treeheight treeparent treeindex
3017 set ix $treeindex($dir)
3018 $w conf -state normal
3019 $w delete s:$ix e:$ix
3020 set treediropen($dir) 0
3021 $w image configure a:$ix -image tri-rt
3022 $w conf -state disabled
3023 set n [expr {1 - $treeheight($dir)}]
3024 while {$dir ne {}} {
3025 incr treeheight($dir) $n
3026 set dir $treeparent($dir)
3030 proc treeopendir {w dir} {
3031 global treediropen treeheight treeparent treecontents treeindex
3033 set ix $treeindex($dir)
3034 $w conf -state normal
3035 $w image configure a:$ix -image tri-dn
3036 $w mark set e:$ix s:$ix
3037 $w mark gravity e:$ix right
3038 set lev 0
3039 set str "\n"
3040 set n [llength $treecontents($dir)]
3041 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3042 incr lev
3043 append str "\t"
3044 incr treeheight($x) $n
3046 foreach e $treecontents($dir) {
3047 set de $dir$e
3048 if {[string index $e end] eq "/"} {
3049 set iy $treeindex($de)
3050 $w mark set d:$iy e:$ix
3051 $w mark gravity d:$iy left
3052 $w insert e:$ix $str
3053 set treediropen($de) 0
3054 $w image create e:$ix -align center -image tri-rt -padx 1 \
3055 -name a:$iy
3056 $w insert e:$ix $e [highlight_tag $de]
3057 $w mark set s:$iy e:$ix
3058 $w mark gravity s:$iy left
3059 set treeheight($de) 1
3060 } else {
3061 $w insert e:$ix $str
3062 $w insert e:$ix $e [highlight_tag $de]
3065 $w mark gravity e:$ix right
3066 $w conf -state disabled
3067 set treediropen($dir) 1
3068 set top [lindex [split [$w index @0,0] .] 0]
3069 set ht [$w cget -height]
3070 set l [lindex [split [$w index s:$ix] .] 0]
3071 if {$l < $top} {
3072 $w yview $l.0
3073 } elseif {$l + $n + 1 > $top + $ht} {
3074 set top [expr {$l + $n + 2 - $ht}]
3075 if {$l < $top} {
3076 set top $l
3078 $w yview $top.0
3082 proc treeclick {w x y} {
3083 global treediropen cmitmode ctext cflist cflist_top
3085 if {$cmitmode ne "tree"} return
3086 if {![info exists cflist_top]} return
3087 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3088 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3089 $cflist tag add highlight $l.0 "$l.0 lineend"
3090 set cflist_top $l
3091 if {$l == 1} {
3092 $ctext yview 1.0
3093 return
3095 set e [linetoelt $l]
3096 if {[string index $e end] ne "/"} {
3097 showfile $e
3098 } elseif {$treediropen($e)} {
3099 treeclosedir $w $e
3100 } else {
3101 treeopendir $w $e
3105 proc setfilelist {id} {
3106 global treefilelist cflist jump_to_here
3108 treeview $cflist $treefilelist($id) 0
3109 if {$jump_to_here ne {}} {
3110 set f [lindex $jump_to_here 0]
3111 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3112 showfile $f
3117 image create bitmap tri-rt -background black -foreground blue -data {
3118 #define tri-rt_width 13
3119 #define tri-rt_height 13
3120 static unsigned char tri-rt_bits[] = {
3121 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3122 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3123 0x00, 0x00};
3124 } -maskdata {
3125 #define tri-rt-mask_width 13
3126 #define tri-rt-mask_height 13
3127 static unsigned char tri-rt-mask_bits[] = {
3128 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3129 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3130 0x08, 0x00};
3132 image create bitmap tri-dn -background black -foreground blue -data {
3133 #define tri-dn_width 13
3134 #define tri-dn_height 13
3135 static unsigned char tri-dn_bits[] = {
3136 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3137 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3138 0x00, 0x00};
3139 } -maskdata {
3140 #define tri-dn-mask_width 13
3141 #define tri-dn-mask_height 13
3142 static unsigned char tri-dn-mask_bits[] = {
3143 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3144 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3145 0x00, 0x00};
3148 image create bitmap reficon-T -background black -foreground yellow -data {
3149 #define tagicon_width 13
3150 #define tagicon_height 9
3151 static unsigned char tagicon_bits[] = {
3152 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3153 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3154 } -maskdata {
3155 #define tagicon-mask_width 13
3156 #define tagicon-mask_height 9
3157 static unsigned char tagicon-mask_bits[] = {
3158 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3159 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3161 set rectdata {
3162 #define headicon_width 13
3163 #define headicon_height 9
3164 static unsigned char headicon_bits[] = {
3165 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3166 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3168 set rectmask {
3169 #define headicon-mask_width 13
3170 #define headicon-mask_height 9
3171 static unsigned char headicon-mask_bits[] = {
3172 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3173 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3175 image create bitmap reficon-H -background black -foreground green \
3176 -data $rectdata -maskdata $rectmask
3177 image create bitmap reficon-o -background black -foreground "#ddddff" \
3178 -data $rectdata -maskdata $rectmask
3180 proc init_flist {first} {
3181 global cflist cflist_top difffilestart
3183 $cflist conf -state normal
3184 $cflist delete 0.0 end
3185 if {$first ne {}} {
3186 $cflist insert end $first
3187 set cflist_top 1
3188 $cflist tag add highlight 1.0 "1.0 lineend"
3189 } else {
3190 catch {unset cflist_top}
3192 $cflist conf -state disabled
3193 set difffilestart {}
3196 proc highlight_tag {f} {
3197 global highlight_paths
3199 foreach p $highlight_paths {
3200 if {[string match $p $f]} {
3201 return "bold"
3204 return {}
3207 proc highlight_filelist {} {
3208 global cmitmode cflist
3210 $cflist conf -state normal
3211 if {$cmitmode ne "tree"} {
3212 set end [lindex [split [$cflist index end] .] 0]
3213 for {set l 2} {$l < $end} {incr l} {
3214 set line [$cflist get $l.0 "$l.0 lineend"]
3215 if {[highlight_tag $line] ne {}} {
3216 $cflist tag add bold $l.0 "$l.0 lineend"
3219 } else {
3220 highlight_tree 2 {}
3222 $cflist conf -state disabled
3225 proc unhighlight_filelist {} {
3226 global cflist
3228 $cflist conf -state normal
3229 $cflist tag remove bold 1.0 end
3230 $cflist conf -state disabled
3233 proc add_flist {fl} {
3234 global cflist
3236 $cflist conf -state normal
3237 foreach f $fl {
3238 $cflist insert end "\n"
3239 $cflist insert end $f [highlight_tag $f]
3241 $cflist conf -state disabled
3244 proc sel_flist {w x y} {
3245 global ctext difffilestart cflist cflist_top cmitmode
3247 if {$cmitmode eq "tree"} return
3248 if {![info exists cflist_top]} return
3249 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3250 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3251 $cflist tag add highlight $l.0 "$l.0 lineend"
3252 set cflist_top $l
3253 if {$l == 1} {
3254 $ctext yview 1.0
3255 } else {
3256 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3260 proc pop_flist_menu {w X Y x y} {
3261 global ctext cflist cmitmode flist_menu flist_menu_file
3262 global treediffs diffids
3264 stopfinding
3265 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3266 if {$l <= 1} return
3267 if {$cmitmode eq "tree"} {
3268 set e [linetoelt $l]
3269 if {[string index $e end] eq "/"} return
3270 } else {
3271 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3273 set flist_menu_file $e
3274 set xdiffstate "normal"
3275 if {$cmitmode eq "tree"} {
3276 set xdiffstate "disabled"
3278 # Disable "External diff" item in tree mode
3279 $flist_menu entryconf 2 -state $xdiffstate
3280 tk_popup $flist_menu $X $Y
3283 proc find_ctext_fileinfo {line} {
3284 global ctext_file_names ctext_file_lines
3286 set ok [bsearch $ctext_file_lines $line]
3287 set tline [lindex $ctext_file_lines $ok]
3289 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3290 return {}
3291 } else {
3292 return [list [lindex $ctext_file_names $ok] $tline]
3296 proc pop_diff_menu {w X Y x y} {
3297 global ctext diff_menu flist_menu_file
3298 global diff_menu_txtpos diff_menu_line
3299 global diff_menu_filebase
3301 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3302 set diff_menu_line [lindex $diff_menu_txtpos 0]
3303 # don't pop up the menu on hunk-separator or file-separator lines
3304 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3305 return
3307 stopfinding
3308 set f [find_ctext_fileinfo $diff_menu_line]
3309 if {$f eq {}} return
3310 set flist_menu_file [lindex $f 0]
3311 set diff_menu_filebase [lindex $f 1]
3312 tk_popup $diff_menu $X $Y
3315 proc flist_hl {only} {
3316 global flist_menu_file findstring gdttype
3318 set x [shellquote $flist_menu_file]
3319 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3320 set findstring $x
3321 } else {
3322 append findstring " " $x
3324 set gdttype [mc "touching paths:"]
3327 proc gitknewtmpdir {} {
3328 global diffnum gitktmpdir gitdir
3330 if {![info exists gitktmpdir]} {
3331 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3332 if {[catch {file mkdir $gitktmpdir} err]} {
3333 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3334 unset gitktmpdir
3335 return {}
3337 set diffnum 0
3339 incr diffnum
3340 set diffdir [file join $gitktmpdir $diffnum]
3341 if {[catch {file mkdir $diffdir} err]} {
3342 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3343 return {}
3345 return $diffdir
3348 proc save_file_from_commit {filename output what} {
3349 global nullfile
3351 if {[catch {exec git show $filename -- > $output} err]} {
3352 if {[string match "fatal: bad revision *" $err]} {
3353 return $nullfile
3355 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3356 return {}
3358 return $output
3361 proc external_diff_get_one_file {diffid filename diffdir} {
3362 global nullid nullid2 nullfile
3363 global worktree
3365 if {$diffid == $nullid} {
3366 set difffile [file join $worktree $filename]
3367 if {[file exists $difffile]} {
3368 return $difffile
3370 return $nullfile
3372 if {$diffid == $nullid2} {
3373 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3374 return [save_file_from_commit :$filename $difffile index]
3376 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3377 return [save_file_from_commit $diffid:$filename $difffile \
3378 "revision $diffid"]
3381 proc external_diff {} {
3382 global nullid nullid2
3383 global flist_menu_file
3384 global diffids
3385 global extdifftool
3387 if {[llength $diffids] == 1} {
3388 # no reference commit given
3389 set diffidto [lindex $diffids 0]
3390 if {$diffidto eq $nullid} {
3391 # diffing working copy with index
3392 set diffidfrom $nullid2
3393 } elseif {$diffidto eq $nullid2} {
3394 # diffing index with HEAD
3395 set diffidfrom "HEAD"
3396 } else {
3397 # use first parent commit
3398 global parentlist selectedline
3399 set diffidfrom [lindex $parentlist $selectedline 0]
3401 } else {
3402 set diffidfrom [lindex $diffids 0]
3403 set diffidto [lindex $diffids 1]
3406 # make sure that several diffs wont collide
3407 set diffdir [gitknewtmpdir]
3408 if {$diffdir eq {}} return
3410 # gather files to diff
3411 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3412 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3414 if {$difffromfile ne {} && $difftofile ne {}} {
3415 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3416 if {[catch {set fl [open |$cmd r]} err]} {
3417 file delete -force $diffdir
3418 error_popup "$extdifftool: [mc "command failed:"] $err"
3419 } else {
3420 fconfigure $fl -blocking 0
3421 filerun $fl [list delete_at_eof $fl $diffdir]
3426 proc find_hunk_blamespec {base line} {
3427 global ctext
3429 # Find and parse the hunk header
3430 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3431 if {$s_lix eq {}} return
3433 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3434 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3435 s_line old_specs osz osz1 new_line nsz]} {
3436 return
3439 # base lines for the parents
3440 set base_lines [list $new_line]
3441 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3442 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3443 old_spec old_line osz]} {
3444 return
3446 lappend base_lines $old_line
3449 # Now scan the lines to determine offset within the hunk
3450 set max_parent [expr {[llength $base_lines]-2}]
3451 set dline 0
3452 set s_lno [lindex [split $s_lix "."] 0]
3454 # Determine if the line is removed
3455 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3456 if {[string match {[-+ ]*} $chunk]} {
3457 set removed_idx [string first "-" $chunk]
3458 # Choose a parent index
3459 if {$removed_idx >= 0} {
3460 set parent $removed_idx
3461 } else {
3462 set unchanged_idx [string first " " $chunk]
3463 if {$unchanged_idx >= 0} {
3464 set parent $unchanged_idx
3465 } else {
3466 # blame the current commit
3467 set parent -1
3470 # then count other lines that belong to it
3471 for {set i $line} {[incr i -1] > $s_lno} {} {
3472 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3473 # Determine if the line is removed
3474 set removed_idx [string first "-" $chunk]
3475 if {$parent >= 0} {
3476 set code [string index $chunk $parent]
3477 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3478 incr dline
3480 } else {
3481 if {$removed_idx < 0} {
3482 incr dline
3486 incr parent
3487 } else {
3488 set parent 0
3491 incr dline [lindex $base_lines $parent]
3492 return [list $parent $dline]
3495 proc external_blame_diff {} {
3496 global currentid cmitmode
3497 global diff_menu_txtpos diff_menu_line
3498 global diff_menu_filebase flist_menu_file
3500 if {$cmitmode eq "tree"} {
3501 set parent_idx 0
3502 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3503 } else {
3504 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3505 if {$hinfo ne {}} {
3506 set parent_idx [lindex $hinfo 0]
3507 set line [lindex $hinfo 1]
3508 } else {
3509 set parent_idx 0
3510 set line 0
3514 external_blame $parent_idx $line
3517 # Find the SHA1 ID of the blob for file $fname in the index
3518 # at stage 0 or 2
3519 proc index_sha1 {fname} {
3520 set f [open [list | git ls-files -s $fname] r]
3521 while {[gets $f line] >= 0} {
3522 set info [lindex [split $line "\t"] 0]
3523 set stage [lindex $info 2]
3524 if {$stage eq "0" || $stage eq "2"} {
3525 close $f
3526 return [lindex $info 1]
3529 close $f
3530 return {}
3533 # Turn an absolute path into one relative to the current directory
3534 proc make_relative {f} {
3535 if {[file pathtype $f] eq "relative"} {
3536 return $f
3538 set elts [file split $f]
3539 set here [file split [pwd]]
3540 set ei 0
3541 set hi 0
3542 set res {}
3543 foreach d $here {
3544 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3545 lappend res ".."
3546 } else {
3547 incr ei
3549 incr hi
3551 set elts [concat $res [lrange $elts $ei end]]
3552 return [eval file join $elts]
3555 proc external_blame {parent_idx {line {}}} {
3556 global flist_menu_file cdup
3557 global nullid nullid2
3558 global parentlist selectedline currentid
3560 if {$parent_idx > 0} {
3561 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3562 } else {
3563 set base_commit $currentid
3566 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3567 error_popup [mc "No such commit"]
3568 return
3571 set cmdline [list git gui blame]
3572 if {$line ne {} && $line > 1} {
3573 lappend cmdline "--line=$line"
3575 set f [file join $cdup $flist_menu_file]
3576 # Unfortunately it seems git gui blame doesn't like
3577 # being given an absolute path...
3578 set f [make_relative $f]
3579 lappend cmdline $base_commit $f
3580 if {[catch {eval exec $cmdline &} err]} {
3581 error_popup "[mc "git gui blame: command failed:"] $err"
3585 proc show_line_source {} {
3586 global cmitmode currentid parents curview blamestuff blameinst
3587 global diff_menu_line diff_menu_filebase flist_menu_file
3588 global nullid nullid2 gitdir cdup
3590 set from_index {}
3591 if {$cmitmode eq "tree"} {
3592 set id $currentid
3593 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3594 } else {
3595 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3596 if {$h eq {}} return
3597 set pi [lindex $h 0]
3598 if {$pi == 0} {
3599 mark_ctext_line $diff_menu_line
3600 return
3602 incr pi -1
3603 if {$currentid eq $nullid} {
3604 if {$pi > 0} {
3605 # must be a merge in progress...
3606 if {[catch {
3607 # get the last line from .git/MERGE_HEAD
3608 set f [open [file join $gitdir MERGE_HEAD] r]
3609 set id [lindex [split [read $f] "\n"] end-1]
3610 close $f
3611 } err]} {
3612 error_popup [mc "Couldn't read merge head: %s" $err]
3613 return
3615 } elseif {$parents($curview,$currentid) eq $nullid2} {
3616 # need to do the blame from the index
3617 if {[catch {
3618 set from_index [index_sha1 $flist_menu_file]
3619 } err]} {
3620 error_popup [mc "Error reading index: %s" $err]
3621 return
3623 } else {
3624 set id $parents($curview,$currentid)
3626 } else {
3627 set id [lindex $parents($curview,$currentid) $pi]
3629 set line [lindex $h 1]
3631 set blameargs {}
3632 if {$from_index ne {}} {
3633 lappend blameargs | git cat-file blob $from_index
3635 lappend blameargs | git blame -p -L$line,+1
3636 if {$from_index ne {}} {
3637 lappend blameargs --contents -
3638 } else {
3639 lappend blameargs $id
3641 lappend blameargs -- [file join $cdup $flist_menu_file]
3642 if {[catch {
3643 set f [open $blameargs r]
3644 } err]} {
3645 error_popup [mc "Couldn't start git blame: %s" $err]
3646 return
3648 nowbusy blaming [mc "Searching"]
3649 fconfigure $f -blocking 0
3650 set i [reg_instance $f]
3651 set blamestuff($i) {}
3652 set blameinst $i
3653 filerun $f [list read_line_source $f $i]
3656 proc stopblaming {} {
3657 global blameinst
3659 if {[info exists blameinst]} {
3660 stop_instance $blameinst
3661 unset blameinst
3662 notbusy blaming
3666 proc read_line_source {fd inst} {
3667 global blamestuff curview commfd blameinst nullid nullid2
3669 while {[gets $fd line] >= 0} {
3670 lappend blamestuff($inst) $line
3672 if {![eof $fd]} {
3673 return 1
3675 unset commfd($inst)
3676 unset blameinst
3677 notbusy blaming
3678 fconfigure $fd -blocking 1
3679 if {[catch {close $fd} err]} {
3680 error_popup [mc "Error running git blame: %s" $err]
3681 return 0
3684 set fname {}
3685 set line [split [lindex $blamestuff($inst) 0] " "]
3686 set id [lindex $line 0]
3687 set lnum [lindex $line 1]
3688 if {[string length $id] == 40 && [string is xdigit $id] &&
3689 [string is digit -strict $lnum]} {
3690 # look for "filename" line
3691 foreach l $blamestuff($inst) {
3692 if {[string match "filename *" $l]} {
3693 set fname [string range $l 9 end]
3694 break
3698 if {$fname ne {}} {
3699 # all looks good, select it
3700 if {$id eq $nullid} {
3701 # blame uses all-zeroes to mean not committed,
3702 # which would mean a change in the index
3703 set id $nullid2
3705 if {[commitinview $id $curview]} {
3706 selectline [rowofcommit $id] 1 [list $fname $lnum]
3707 } else {
3708 error_popup [mc "That line comes from commit %s, \
3709 which is not in this view" [shortids $id]]
3711 } else {
3712 puts "oops couldn't parse git blame output"
3714 return 0
3717 # delete $dir when we see eof on $f (presumably because the child has exited)
3718 proc delete_at_eof {f dir} {
3719 while {[gets $f line] >= 0} {}
3720 if {[eof $f]} {
3721 if {[catch {close $f} err]} {
3722 error_popup "[mc "External diff viewer failed:"] $err"
3724 file delete -force $dir
3725 return 0
3727 return 1
3730 # Functions for adding and removing shell-type quoting
3732 proc shellquote {str} {
3733 if {![string match "*\['\"\\ \t]*" $str]} {
3734 return $str
3736 if {![string match "*\['\"\\]*" $str]} {
3737 return "\"$str\""
3739 if {![string match "*'*" $str]} {
3740 return "'$str'"
3742 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3745 proc shellarglist {l} {
3746 set str {}
3747 foreach a $l {
3748 if {$str ne {}} {
3749 append str " "
3751 append str [shellquote $a]
3753 return $str
3756 proc shelldequote {str} {
3757 set ret {}
3758 set used -1
3759 while {1} {
3760 incr used
3761 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3762 append ret [string range $str $used end]
3763 set used [string length $str]
3764 break
3766 set first [lindex $first 0]
3767 set ch [string index $str $first]
3768 if {$first > $used} {
3769 append ret [string range $str $used [expr {$first - 1}]]
3770 set used $first
3772 if {$ch eq " " || $ch eq "\t"} break
3773 incr used
3774 if {$ch eq "'"} {
3775 set first [string first "'" $str $used]
3776 if {$first < 0} {
3777 error "unmatched single-quote"
3779 append ret [string range $str $used [expr {$first - 1}]]
3780 set used $first
3781 continue
3783 if {$ch eq "\\"} {
3784 if {$used >= [string length $str]} {
3785 error "trailing backslash"
3787 append ret [string index $str $used]
3788 continue
3790 # here ch == "\""
3791 while {1} {
3792 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3793 error "unmatched double-quote"
3795 set first [lindex $first 0]
3796 set ch [string index $str $first]
3797 if {$first > $used} {
3798 append ret [string range $str $used [expr {$first - 1}]]
3799 set used $first
3801 if {$ch eq "\""} break
3802 incr used
3803 append ret [string index $str $used]
3804 incr used
3807 return [list $used $ret]
3810 proc shellsplit {str} {
3811 set l {}
3812 while {1} {
3813 set str [string trimleft $str]
3814 if {$str eq {}} break
3815 set dq [shelldequote $str]
3816 set n [lindex $dq 0]
3817 set word [lindex $dq 1]
3818 set str [string range $str $n end]
3819 lappend l $word
3821 return $l
3824 # Code to implement multiple views
3826 proc newview {ishighlight} {
3827 global nextviewnum newviewname newishighlight
3828 global revtreeargs viewargscmd newviewopts curview
3830 set newishighlight $ishighlight
3831 set top .gitkview
3832 if {[winfo exists $top]} {
3833 raise $top
3834 return
3836 decode_view_opts $nextviewnum $revtreeargs
3837 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3838 set newviewopts($nextviewnum,perm) 0
3839 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3840 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3843 set known_view_options {
3844 {perm b . {} {mc "Remember this view"}}
3845 {reflabel l + {} {mc "References (space separated list):"}}
3846 {refs t15 .. {} {mc "Branches & tags:"}}
3847 {allrefs b *. "--all" {mc "All refs"}}
3848 {branches b . "--branches" {mc "All (local) branches"}}
3849 {tags b . "--tags" {mc "All tags"}}
3850 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3851 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3852 {author t15 .. "--author=*" {mc "Author:"}}
3853 {committer t15 . "--committer=*" {mc "Committer:"}}
3854 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3855 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3856 {changes_l l + {} {mc "Changes to Files:"}}
3857 {pickaxe_s r0 . {} {mc "Fixed String"}}
3858 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3859 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3860 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3861 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3862 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3863 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3864 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3865 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3866 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3867 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3868 {lright b . "--left-right" {mc "Mark branch sides"}}
3869 {first b . "--first-parent" {mc "Limit to first parent"}}
3870 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3871 {args t50 *. {} {mc "Additional arguments to git log:"}}
3872 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3873 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3876 # Convert $newviewopts($n, ...) into args for git log.
3877 proc encode_view_opts {n} {
3878 global known_view_options newviewopts
3880 set rargs [list]
3881 foreach opt $known_view_options {
3882 set patterns [lindex $opt 3]
3883 if {$patterns eq {}} continue
3884 set pattern [lindex $patterns 0]
3886 if {[lindex $opt 1] eq "b"} {
3887 set val $newviewopts($n,[lindex $opt 0])
3888 if {$val} {
3889 lappend rargs $pattern
3891 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3892 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3893 set val $newviewopts($n,$button_id)
3894 if {$val eq $value} {
3895 lappend rargs $pattern
3897 } else {
3898 set val $newviewopts($n,[lindex $opt 0])
3899 set val [string trim $val]
3900 if {$val ne {}} {
3901 set pfix [string range $pattern 0 end-1]
3902 lappend rargs $pfix$val
3906 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3907 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3910 # Fill $newviewopts($n, ...) based on args for git log.
3911 proc decode_view_opts {n view_args} {
3912 global known_view_options newviewopts
3914 foreach opt $known_view_options {
3915 set id [lindex $opt 0]
3916 if {[lindex $opt 1] eq "b"} {
3917 # Checkboxes
3918 set val 0
3919 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3920 # Radiobuttons
3921 regexp {^(.*_)} $id uselessvar id
3922 set val 0
3923 } else {
3924 # Text fields
3925 set val {}
3927 set newviewopts($n,$id) $val
3929 set oargs [list]
3930 set refargs [list]
3931 foreach arg $view_args {
3932 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3933 && ![info exists found(limit)]} {
3934 set newviewopts($n,limit) $cnt
3935 set found(limit) 1
3936 continue
3938 catch { unset val }
3939 foreach opt $known_view_options {
3940 set id [lindex $opt 0]
3941 if {[info exists found($id)]} continue
3942 foreach pattern [lindex $opt 3] {
3943 if {![string match $pattern $arg]} continue
3944 if {[lindex $opt 1] eq "b"} {
3945 # Check buttons
3946 set val 1
3947 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3948 # Radio buttons
3949 regexp {^(.*_)} $id uselessvar id
3950 set val $num
3951 } else {
3952 # Text input fields
3953 set size [string length $pattern]
3954 set val [string range $arg [expr {$size-1}] end]
3956 set newviewopts($n,$id) $val
3957 set found($id) 1
3958 break
3960 if {[info exists val]} break
3962 if {[info exists val]} continue
3963 if {[regexp {^-} $arg]} {
3964 lappend oargs $arg
3965 } else {
3966 lappend refargs $arg
3969 set newviewopts($n,refs) [shellarglist $refargs]
3970 set newviewopts($n,args) [shellarglist $oargs]
3973 proc edit_or_newview {} {
3974 global curview
3976 if {$curview > 0} {
3977 editview
3978 } else {
3979 newview 0
3983 proc editview {} {
3984 global curview
3985 global viewname viewperm newviewname newviewopts
3986 global viewargs viewargscmd
3988 set top .gitkvedit-$curview
3989 if {[winfo exists $top]} {
3990 raise $top
3991 return
3993 decode_view_opts $curview $viewargs($curview)
3994 set newviewname($curview) $viewname($curview)
3995 set newviewopts($curview,perm) $viewperm($curview)
3996 set newviewopts($curview,cmd) $viewargscmd($curview)
3997 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4000 proc vieweditor {top n title} {
4001 global newviewname newviewopts viewfiles bgcolor
4002 global known_view_options NS
4004 ttk_toplevel $top
4005 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4006 make_transient $top .
4008 # View name
4009 ${NS}::frame $top.nfr
4010 ${NS}::label $top.nl -text [mc "View Name"]
4011 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4012 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4013 pack $top.nl -in $top.nfr -side left -padx {0 5}
4014 pack $top.name -in $top.nfr -side left -padx {0 25}
4016 # View options
4017 set cframe $top.nfr
4018 set cexpand 0
4019 set cnt 0
4020 foreach opt $known_view_options {
4021 set id [lindex $opt 0]
4022 set type [lindex $opt 1]
4023 set flags [lindex $opt 2]
4024 set title [eval [lindex $opt 4]]
4025 set lxpad 0
4027 if {$flags eq "+" || $flags eq "*"} {
4028 set cframe $top.fr$cnt
4029 incr cnt
4030 ${NS}::frame $cframe
4031 pack $cframe -in $top -fill x -pady 3 -padx 3
4032 set cexpand [expr {$flags eq "*"}]
4033 } elseif {$flags eq ".." || $flags eq "*."} {
4034 set cframe $top.fr$cnt
4035 incr cnt
4036 ${NS}::frame $cframe
4037 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4038 set cexpand [expr {$flags eq "*."}]
4039 } else {
4040 set lxpad 5
4043 if {$type eq "l"} {
4044 ${NS}::label $cframe.l_$id -text $title
4045 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4046 } elseif {$type eq "b"} {
4047 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4048 pack $cframe.c_$id -in $cframe -side left \
4049 -padx [list $lxpad 0] -expand $cexpand -anchor w
4050 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4051 regexp {^(.*_)} $id uselessvar button_id
4052 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4053 pack $cframe.c_$id -in $cframe -side left \
4054 -padx [list $lxpad 0] -expand $cexpand -anchor w
4055 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4056 ${NS}::label $cframe.l_$id -text $title
4057 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4058 -textvariable newviewopts($n,$id)
4059 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4060 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4061 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4062 ${NS}::label $cframe.l_$id -text $title
4063 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4064 -textvariable newviewopts($n,$id)
4065 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4066 pack $cframe.e_$id -in $cframe -side top -fill x
4067 } elseif {$type eq "path"} {
4068 ${NS}::label $top.l -text $title
4069 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4070 text $top.t -width 40 -height 5 -background $bgcolor
4071 if {[info exists viewfiles($n)]} {
4072 foreach f $viewfiles($n) {
4073 $top.t insert end $f
4074 $top.t insert end "\n"
4076 $top.t delete {end - 1c} end
4077 $top.t mark set insert 0.0
4079 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4083 ${NS}::frame $top.buts
4084 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4085 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4086 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4087 bind $top <Control-Return> [list newviewok $top $n]
4088 bind $top <F5> [list newviewok $top $n 1]
4089 bind $top <Escape> [list destroy $top]
4090 grid $top.buts.ok $top.buts.apply $top.buts.can
4091 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4092 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4093 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4094 pack $top.buts -in $top -side top -fill x
4095 focus $top.t
4098 proc doviewmenu {m first cmd op argv} {
4099 set nmenu [$m index end]
4100 for {set i $first} {$i <= $nmenu} {incr i} {
4101 if {[$m entrycget $i -command] eq $cmd} {
4102 eval $m $op $i $argv
4103 break
4108 proc allviewmenus {n op args} {
4109 # global viewhlmenu
4111 doviewmenu .bar.view 5 [list showview $n] $op $args
4112 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4115 proc newviewok {top n {apply 0}} {
4116 global nextviewnum newviewperm newviewname newishighlight
4117 global viewname viewfiles viewperm selectedview curview
4118 global viewargs viewargscmd newviewopts viewhlmenu
4120 if {[catch {
4121 set newargs [encode_view_opts $n]
4122 } err]} {
4123 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4124 return
4126 set files {}
4127 foreach f [split [$top.t get 0.0 end] "\n"] {
4128 set ft [string trim $f]
4129 if {$ft ne {}} {
4130 lappend files $ft
4133 if {![info exists viewfiles($n)]} {
4134 # creating a new view
4135 incr nextviewnum
4136 set viewname($n) $newviewname($n)
4137 set viewperm($n) $newviewopts($n,perm)
4138 set viewfiles($n) $files
4139 set viewargs($n) $newargs
4140 set viewargscmd($n) $newviewopts($n,cmd)
4141 addviewmenu $n
4142 if {!$newishighlight} {
4143 run showview $n
4144 } else {
4145 run addvhighlight $n
4147 } else {
4148 # editing an existing view
4149 set viewperm($n) $newviewopts($n,perm)
4150 if {$newviewname($n) ne $viewname($n)} {
4151 set viewname($n) $newviewname($n)
4152 doviewmenu .bar.view 5 [list showview $n] \
4153 entryconf [list -label $viewname($n)]
4154 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4155 # entryconf [list -label $viewname($n) -value $viewname($n)]
4157 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4158 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4159 set viewfiles($n) $files
4160 set viewargs($n) $newargs
4161 set viewargscmd($n) $newviewopts($n,cmd)
4162 if {$curview == $n} {
4163 run reloadcommits
4167 if {$apply} return
4168 catch {destroy $top}
4171 proc delview {} {
4172 global curview viewperm hlview selectedhlview
4174 if {$curview == 0} return
4175 if {[info exists hlview] && $hlview == $curview} {
4176 set selectedhlview [mc "None"]
4177 unset hlview
4179 allviewmenus $curview delete
4180 set viewperm($curview) 0
4181 showview 0
4184 proc addviewmenu {n} {
4185 global viewname viewhlmenu
4187 .bar.view add radiobutton -label $viewname($n) \
4188 -command [list showview $n] -variable selectedview -value $n
4189 #$viewhlmenu add radiobutton -label $viewname($n) \
4190 # -command [list addvhighlight $n] -variable selectedhlview
4193 proc showview {n} {
4194 global curview cached_commitrow ordertok
4195 global displayorder parentlist rowidlist rowisopt rowfinal
4196 global colormap rowtextx nextcolor canvxmax
4197 global numcommits viewcomplete
4198 global selectedline currentid canv canvy0
4199 global treediffs
4200 global pending_select mainheadid
4201 global commitidx
4202 global selectedview
4203 global hlview selectedhlview commitinterest
4205 if {$n == $curview} return
4206 set selid {}
4207 set ymax [lindex [$canv cget -scrollregion] 3]
4208 set span [$canv yview]
4209 set ytop [expr {[lindex $span 0] * $ymax}]
4210 set ybot [expr {[lindex $span 1] * $ymax}]
4211 set yscreen [expr {($ybot - $ytop) / 2}]
4212 if {$selectedline ne {}} {
4213 set selid $currentid
4214 set y [yc $selectedline]
4215 if {$ytop < $y && $y < $ybot} {
4216 set yscreen [expr {$y - $ytop}]
4218 } elseif {[info exists pending_select]} {
4219 set selid $pending_select
4220 unset pending_select
4222 unselectline
4223 normalline
4224 catch {unset treediffs}
4225 clear_display
4226 if {[info exists hlview] && $hlview == $n} {
4227 unset hlview
4228 set selectedhlview [mc "None"]
4230 catch {unset commitinterest}
4231 catch {unset cached_commitrow}
4232 catch {unset ordertok}
4234 set curview $n
4235 set selectedview $n
4236 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4237 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4239 run refill_reflist
4240 if {![info exists viewcomplete($n)]} {
4241 getcommits $selid
4242 return
4245 set displayorder {}
4246 set parentlist {}
4247 set rowidlist {}
4248 set rowisopt {}
4249 set rowfinal {}
4250 set numcommits $commitidx($n)
4252 catch {unset colormap}
4253 catch {unset rowtextx}
4254 set nextcolor 0
4255 set canvxmax [$canv cget -width]
4256 set curview $n
4257 set row 0
4258 setcanvscroll
4259 set yf 0
4260 set row {}
4261 if {$selid ne {} && [commitinview $selid $n]} {
4262 set row [rowofcommit $selid]
4263 # try to get the selected row in the same position on the screen
4264 set ymax [lindex [$canv cget -scrollregion] 3]
4265 set ytop [expr {[yc $row] - $yscreen}]
4266 if {$ytop < 0} {
4267 set ytop 0
4269 set yf [expr {$ytop * 1.0 / $ymax}]
4271 allcanvs yview moveto $yf
4272 drawvisible
4273 if {$row ne {}} {
4274 selectline $row 0
4275 } elseif {!$viewcomplete($n)} {
4276 reset_pending_select $selid
4277 } else {
4278 reset_pending_select {}
4280 if {[commitinview $pending_select $curview]} {
4281 selectline [rowofcommit $pending_select] 1
4282 } else {
4283 set row [first_real_row]
4284 if {$row < $numcommits} {
4285 selectline $row 0
4289 if {!$viewcomplete($n)} {
4290 if {$numcommits == 0} {
4291 show_status [mc "Reading commits..."]
4293 } elseif {$numcommits == 0} {
4294 show_status [mc "No commits selected"]
4298 # Stuff relating to the highlighting facility
4300 proc ishighlighted {id} {
4301 global vhighlights fhighlights nhighlights rhighlights
4303 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4304 return $nhighlights($id)
4306 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4307 return $vhighlights($id)
4309 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4310 return $fhighlights($id)
4312 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4313 return $rhighlights($id)
4315 return 0
4318 proc bolden {id font} {
4319 global canv linehtag currentid boldids need_redisplay markedid
4321 # need_redisplay = 1 means the display is stale and about to be redrawn
4322 if {$need_redisplay} return
4323 lappend boldids $id
4324 $canv itemconf $linehtag($id) -font $font
4325 if {[info exists currentid] && $id eq $currentid} {
4326 $canv delete secsel
4327 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4328 -outline {{}} -tags secsel \
4329 -fill [$canv cget -selectbackground]]
4330 $canv lower $t
4332 if {[info exists markedid] && $id eq $markedid} {
4333 make_idmark $id
4337 proc bolden_name {id font} {
4338 global canv2 linentag currentid boldnameids need_redisplay
4340 if {$need_redisplay} return
4341 lappend boldnameids $id
4342 $canv2 itemconf $linentag($id) -font $font
4343 if {[info exists currentid] && $id eq $currentid} {
4344 $canv2 delete secsel
4345 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4346 -outline {{}} -tags secsel \
4347 -fill [$canv2 cget -selectbackground]]
4348 $canv2 lower $t
4352 proc unbolden {} {
4353 global boldids
4355 set stillbold {}
4356 foreach id $boldids {
4357 if {![ishighlighted $id]} {
4358 bolden $id mainfont
4359 } else {
4360 lappend stillbold $id
4363 set boldids $stillbold
4366 proc addvhighlight {n} {
4367 global hlview viewcomplete curview vhl_done commitidx
4369 if {[info exists hlview]} {
4370 delvhighlight
4372 set hlview $n
4373 if {$n != $curview && ![info exists viewcomplete($n)]} {
4374 start_rev_list $n
4376 set vhl_done $commitidx($hlview)
4377 if {$vhl_done > 0} {
4378 drawvisible
4382 proc delvhighlight {} {
4383 global hlview vhighlights
4385 if {![info exists hlview]} return
4386 unset hlview
4387 catch {unset vhighlights}
4388 unbolden
4391 proc vhighlightmore {} {
4392 global hlview vhl_done commitidx vhighlights curview
4394 set max $commitidx($hlview)
4395 set vr [visiblerows]
4396 set r0 [lindex $vr 0]
4397 set r1 [lindex $vr 1]
4398 for {set i $vhl_done} {$i < $max} {incr i} {
4399 set id [commitonrow $i $hlview]
4400 if {[commitinview $id $curview]} {
4401 set row [rowofcommit $id]
4402 if {$r0 <= $row && $row <= $r1} {
4403 if {![highlighted $row]} {
4404 bolden $id mainfontbold
4406 set vhighlights($id) 1
4410 set vhl_done $max
4411 return 0
4414 proc askvhighlight {row id} {
4415 global hlview vhighlights iddrawn
4417 if {[commitinview $id $hlview]} {
4418 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4419 bolden $id mainfontbold
4421 set vhighlights($id) 1
4422 } else {
4423 set vhighlights($id) 0
4427 proc hfiles_change {} {
4428 global highlight_files filehighlight fhighlights fh_serial
4429 global highlight_paths
4431 if {[info exists filehighlight]} {
4432 # delete previous highlights
4433 catch {close $filehighlight}
4434 unset filehighlight
4435 catch {unset fhighlights}
4436 unbolden
4437 unhighlight_filelist
4439 set highlight_paths {}
4440 after cancel do_file_hl $fh_serial
4441 incr fh_serial
4442 if {$highlight_files ne {}} {
4443 after 300 do_file_hl $fh_serial
4447 proc gdttype_change {name ix op} {
4448 global gdttype highlight_files findstring findpattern
4450 stopfinding
4451 if {$findstring ne {}} {
4452 if {$gdttype eq [mc "containing:"]} {
4453 if {$highlight_files ne {}} {
4454 set highlight_files {}
4455 hfiles_change
4457 findcom_change
4458 } else {
4459 if {$findpattern ne {}} {
4460 set findpattern {}
4461 findcom_change
4463 set highlight_files $findstring
4464 hfiles_change
4466 drawvisible
4468 # enable/disable findtype/findloc menus too
4471 proc find_change {name ix op} {
4472 global gdttype findstring highlight_files
4474 stopfinding
4475 if {$gdttype eq [mc "containing:"]} {
4476 findcom_change
4477 } else {
4478 if {$highlight_files ne $findstring} {
4479 set highlight_files $findstring
4480 hfiles_change
4483 drawvisible
4486 proc findcom_change args {
4487 global nhighlights boldnameids
4488 global findpattern findtype findstring gdttype
4490 stopfinding
4491 # delete previous highlights, if any
4492 foreach id $boldnameids {
4493 bolden_name $id mainfont
4495 set boldnameids {}
4496 catch {unset nhighlights}
4497 unbolden
4498 unmarkmatches
4499 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4500 set findpattern {}
4501 } elseif {$findtype eq [mc "Regexp"]} {
4502 set findpattern $findstring
4503 } else {
4504 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4505 $findstring]
4506 set findpattern "*$e*"
4510 proc makepatterns {l} {
4511 set ret {}
4512 foreach e $l {
4513 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4514 if {[string index $ee end] eq "/"} {
4515 lappend ret "$ee*"
4516 } else {
4517 lappend ret $ee
4518 lappend ret "$ee/*"
4521 return $ret
4524 proc do_file_hl {serial} {
4525 global highlight_files filehighlight highlight_paths gdttype fhl_list
4526 global cdup findtype
4528 if {$gdttype eq [mc "touching paths:"]} {
4529 # If "exact" match then convert backslashes to forward slashes.
4530 # Most useful to support Windows-flavoured file paths.
4531 if {$findtype eq [mc "Exact"]} {
4532 set highlight_files [string map {"\\" "/"} $highlight_files]
4534 if {[catch {set paths [shellsplit $highlight_files]}]} return
4535 set highlight_paths [makepatterns $paths]
4536 highlight_filelist
4537 set relative_paths {}
4538 foreach path $paths {
4539 lappend relative_paths [file join $cdup $path]
4541 set gdtargs [concat -- $relative_paths]
4542 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4543 set gdtargs [list "-S$highlight_files"]
4544 } else {
4545 # must be "containing:", i.e. we're searching commit info
4546 return
4548 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4549 set filehighlight [open $cmd r+]
4550 fconfigure $filehighlight -blocking 0
4551 filerun $filehighlight readfhighlight
4552 set fhl_list {}
4553 drawvisible
4554 flushhighlights
4557 proc flushhighlights {} {
4558 global filehighlight fhl_list
4560 if {[info exists filehighlight]} {
4561 lappend fhl_list {}
4562 puts $filehighlight ""
4563 flush $filehighlight
4567 proc askfilehighlight {row id} {
4568 global filehighlight fhighlights fhl_list
4570 lappend fhl_list $id
4571 set fhighlights($id) -1
4572 puts $filehighlight $id
4575 proc readfhighlight {} {
4576 global filehighlight fhighlights curview iddrawn
4577 global fhl_list find_dirn
4579 if {![info exists filehighlight]} {
4580 return 0
4582 set nr 0
4583 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4584 set line [string trim $line]
4585 set i [lsearch -exact $fhl_list $line]
4586 if {$i < 0} continue
4587 for {set j 0} {$j < $i} {incr j} {
4588 set id [lindex $fhl_list $j]
4589 set fhighlights($id) 0
4591 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4592 if {$line eq {}} continue
4593 if {![commitinview $line $curview]} continue
4594 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4595 bolden $line mainfontbold
4597 set fhighlights($line) 1
4599 if {[eof $filehighlight]} {
4600 # strange...
4601 puts "oops, git diff-tree died"
4602 catch {close $filehighlight}
4603 unset filehighlight
4604 return 0
4606 if {[info exists find_dirn]} {
4607 run findmore
4609 return 1
4612 proc doesmatch {f} {
4613 global findtype findpattern
4615 if {$findtype eq [mc "Regexp"]} {
4616 return [regexp $findpattern $f]
4617 } elseif {$findtype eq [mc "IgnCase"]} {
4618 return [string match -nocase $findpattern $f]
4619 } else {
4620 return [string match $findpattern $f]
4624 proc askfindhighlight {row id} {
4625 global nhighlights commitinfo iddrawn
4626 global findloc
4627 global markingmatches
4629 if {![info exists commitinfo($id)]} {
4630 getcommit $id
4632 set info $commitinfo($id)
4633 set isbold 0
4634 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4635 foreach f $info ty $fldtypes {
4636 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4637 [doesmatch $f]} {
4638 if {$ty eq [mc "Author"]} {
4639 set isbold 2
4640 break
4642 set isbold 1
4645 if {$isbold && [info exists iddrawn($id)]} {
4646 if {![ishighlighted $id]} {
4647 bolden $id mainfontbold
4648 if {$isbold > 1} {
4649 bolden_name $id mainfontbold
4652 if {$markingmatches} {
4653 markrowmatches $row $id
4656 set nhighlights($id) $isbold
4659 proc markrowmatches {row id} {
4660 global canv canv2 linehtag linentag commitinfo findloc
4662 set headline [lindex $commitinfo($id) 0]
4663 set author [lindex $commitinfo($id) 1]
4664 $canv delete match$row
4665 $canv2 delete match$row
4666 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4667 set m [findmatches $headline]
4668 if {$m ne {}} {
4669 markmatches $canv $row $headline $linehtag($id) $m \
4670 [$canv itemcget $linehtag($id) -font] $row
4673 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4674 set m [findmatches $author]
4675 if {$m ne {}} {
4676 markmatches $canv2 $row $author $linentag($id) $m \
4677 [$canv2 itemcget $linentag($id) -font] $row
4682 proc vrel_change {name ix op} {
4683 global highlight_related
4685 rhighlight_none
4686 if {$highlight_related ne [mc "None"]} {
4687 run drawvisible
4691 # prepare for testing whether commits are descendents or ancestors of a
4692 proc rhighlight_sel {a} {
4693 global descendent desc_todo ancestor anc_todo
4694 global highlight_related
4696 catch {unset descendent}
4697 set desc_todo [list $a]
4698 catch {unset ancestor}
4699 set anc_todo [list $a]
4700 if {$highlight_related ne [mc "None"]} {
4701 rhighlight_none
4702 run drawvisible
4706 proc rhighlight_none {} {
4707 global rhighlights
4709 catch {unset rhighlights}
4710 unbolden
4713 proc is_descendent {a} {
4714 global curview children descendent desc_todo
4716 set v $curview
4717 set la [rowofcommit $a]
4718 set todo $desc_todo
4719 set leftover {}
4720 set done 0
4721 for {set i 0} {$i < [llength $todo]} {incr i} {
4722 set do [lindex $todo $i]
4723 if {[rowofcommit $do] < $la} {
4724 lappend leftover $do
4725 continue
4727 foreach nk $children($v,$do) {
4728 if {![info exists descendent($nk)]} {
4729 set descendent($nk) 1
4730 lappend todo $nk
4731 if {$nk eq $a} {
4732 set done 1
4736 if {$done} {
4737 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4738 return
4741 set descendent($a) 0
4742 set desc_todo $leftover
4745 proc is_ancestor {a} {
4746 global curview parents ancestor anc_todo
4748 set v $curview
4749 set la [rowofcommit $a]
4750 set todo $anc_todo
4751 set leftover {}
4752 set done 0
4753 for {set i 0} {$i < [llength $todo]} {incr i} {
4754 set do [lindex $todo $i]
4755 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4756 lappend leftover $do
4757 continue
4759 foreach np $parents($v,$do) {
4760 if {![info exists ancestor($np)]} {
4761 set ancestor($np) 1
4762 lappend todo $np
4763 if {$np eq $a} {
4764 set done 1
4768 if {$done} {
4769 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4770 return
4773 set ancestor($a) 0
4774 set anc_todo $leftover
4777 proc askrelhighlight {row id} {
4778 global descendent highlight_related iddrawn rhighlights
4779 global selectedline ancestor
4781 if {$selectedline eq {}} return
4782 set isbold 0
4783 if {$highlight_related eq [mc "Descendant"] ||
4784 $highlight_related eq [mc "Not descendant"]} {
4785 if {![info exists descendent($id)]} {
4786 is_descendent $id
4788 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4789 set isbold 1
4791 } elseif {$highlight_related eq [mc "Ancestor"] ||
4792 $highlight_related eq [mc "Not ancestor"]} {
4793 if {![info exists ancestor($id)]} {
4794 is_ancestor $id
4796 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4797 set isbold 1
4800 if {[info exists iddrawn($id)]} {
4801 if {$isbold && ![ishighlighted $id]} {
4802 bolden $id mainfontbold
4805 set rhighlights($id) $isbold
4808 # Graph layout functions
4810 proc shortids {ids} {
4811 set res {}
4812 foreach id $ids {
4813 if {[llength $id] > 1} {
4814 lappend res [shortids $id]
4815 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4816 lappend res [string range $id 0 7]
4817 } else {
4818 lappend res $id
4821 return $res
4824 proc ntimes {n o} {
4825 set ret {}
4826 set o [list $o]
4827 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4828 if {($n & $mask) != 0} {
4829 set ret [concat $ret $o]
4831 set o [concat $o $o]
4833 return $ret
4836 proc ordertoken {id} {
4837 global ordertok curview varcid varcstart varctok curview parents children
4838 global nullid nullid2
4840 if {[info exists ordertok($id)]} {
4841 return $ordertok($id)
4843 set origid $id
4844 set todo {}
4845 while {1} {
4846 if {[info exists varcid($curview,$id)]} {
4847 set a $varcid($curview,$id)
4848 set p [lindex $varcstart($curview) $a]
4849 } else {
4850 set p [lindex $children($curview,$id) 0]
4852 if {[info exists ordertok($p)]} {
4853 set tok $ordertok($p)
4854 break
4856 set id [first_real_child $curview,$p]
4857 if {$id eq {}} {
4858 # it's a root
4859 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4860 break
4862 if {[llength $parents($curview,$id)] == 1} {
4863 lappend todo [list $p {}]
4864 } else {
4865 set j [lsearch -exact $parents($curview,$id) $p]
4866 if {$j < 0} {
4867 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4869 lappend todo [list $p [strrep $j]]
4872 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4873 set p [lindex $todo $i 0]
4874 append tok [lindex $todo $i 1]
4875 set ordertok($p) $tok
4877 set ordertok($origid) $tok
4878 return $tok
4881 # Work out where id should go in idlist so that order-token
4882 # values increase from left to right
4883 proc idcol {idlist id {i 0}} {
4884 set t [ordertoken $id]
4885 if {$i < 0} {
4886 set i 0
4888 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4889 if {$i > [llength $idlist]} {
4890 set i [llength $idlist]
4892 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4893 incr i
4894 } else {
4895 if {$t > [ordertoken [lindex $idlist $i]]} {
4896 while {[incr i] < [llength $idlist] &&
4897 $t >= [ordertoken [lindex $idlist $i]]} {}
4900 return $i
4903 proc initlayout {} {
4904 global rowidlist rowisopt rowfinal displayorder parentlist
4905 global numcommits canvxmax canv
4906 global nextcolor
4907 global colormap rowtextx
4909 set numcommits 0
4910 set displayorder {}
4911 set parentlist {}
4912 set nextcolor 0
4913 set rowidlist {}
4914 set rowisopt {}
4915 set rowfinal {}
4916 set canvxmax [$canv cget -width]
4917 catch {unset colormap}
4918 catch {unset rowtextx}
4919 setcanvscroll
4922 proc setcanvscroll {} {
4923 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4924 global lastscrollset lastscrollrows
4926 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4927 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4928 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4929 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4930 set lastscrollset [clock clicks -milliseconds]
4931 set lastscrollrows $numcommits
4934 proc visiblerows {} {
4935 global canv numcommits linespc
4937 set ymax [lindex [$canv cget -scrollregion] 3]
4938 if {$ymax eq {} || $ymax == 0} return
4939 set f [$canv yview]
4940 set y0 [expr {int([lindex $f 0] * $ymax)}]
4941 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4942 if {$r0 < 0} {
4943 set r0 0
4945 set y1 [expr {int([lindex $f 1] * $ymax)}]
4946 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4947 if {$r1 >= $numcommits} {
4948 set r1 [expr {$numcommits - 1}]
4950 return [list $r0 $r1]
4953 proc layoutmore {} {
4954 global commitidx viewcomplete curview
4955 global numcommits pending_select curview
4956 global lastscrollset lastscrollrows
4958 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4959 [clock clicks -milliseconds] - $lastscrollset > 500} {
4960 setcanvscroll
4962 if {[info exists pending_select] &&
4963 [commitinview $pending_select $curview]} {
4964 update
4965 selectline [rowofcommit $pending_select] 1
4967 drawvisible
4970 # With path limiting, we mightn't get the actual HEAD commit,
4971 # so ask git rev-list what is the first ancestor of HEAD that
4972 # touches a file in the path limit.
4973 proc get_viewmainhead {view} {
4974 global viewmainheadid vfilelimit viewinstances mainheadid
4976 catch {
4977 set rfd [open [concat | git rev-list -1 $mainheadid \
4978 -- $vfilelimit($view)] r]
4979 set j [reg_instance $rfd]
4980 lappend viewinstances($view) $j
4981 fconfigure $rfd -blocking 0
4982 filerun $rfd [list getviewhead $rfd $j $view]
4983 set viewmainheadid($curview) {}
4987 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4988 proc getviewhead {fd inst view} {
4989 global viewmainheadid commfd curview viewinstances showlocalchanges
4991 set id {}
4992 if {[gets $fd line] < 0} {
4993 if {![eof $fd]} {
4994 return 1
4996 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4997 set id $line
4999 set viewmainheadid($view) $id
5000 close $fd
5001 unset commfd($inst)
5002 set i [lsearch -exact $viewinstances($view) $inst]
5003 if {$i >= 0} {
5004 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5006 if {$showlocalchanges && $id ne {} && $view == $curview} {
5007 doshowlocalchanges
5009 return 0
5012 proc doshowlocalchanges {} {
5013 global curview viewmainheadid
5015 if {$viewmainheadid($curview) eq {}} return
5016 if {[commitinview $viewmainheadid($curview) $curview]} {
5017 dodiffindex
5018 } else {
5019 interestedin $viewmainheadid($curview) dodiffindex
5023 proc dohidelocalchanges {} {
5024 global nullid nullid2 lserial curview
5026 if {[commitinview $nullid $curview]} {
5027 removefakerow $nullid
5029 if {[commitinview $nullid2 $curview]} {
5030 removefakerow $nullid2
5032 incr lserial
5035 # spawn off a process to do git diff-index --cached HEAD
5036 proc dodiffindex {} {
5037 global lserial showlocalchanges vfilelimit curview
5038 global hasworktree
5040 if {!$showlocalchanges || !$hasworktree} return
5041 incr lserial
5042 set cmd "|git diff-index --cached HEAD"
5043 if {$vfilelimit($curview) ne {}} {
5044 set cmd [concat $cmd -- $vfilelimit($curview)]
5046 set fd [open $cmd r]
5047 fconfigure $fd -blocking 0
5048 set i [reg_instance $fd]
5049 filerun $fd [list readdiffindex $fd $lserial $i]
5052 proc readdiffindex {fd serial inst} {
5053 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5054 global vfilelimit
5056 set isdiff 1
5057 if {[gets $fd line] < 0} {
5058 if {![eof $fd]} {
5059 return 1
5061 set isdiff 0
5063 # we only need to see one line and we don't really care what it says...
5064 stop_instance $inst
5066 if {$serial != $lserial} {
5067 return 0
5070 # now see if there are any local changes not checked in to the index
5071 set cmd "|git diff-files"
5072 if {$vfilelimit($curview) ne {}} {
5073 set cmd [concat $cmd -- $vfilelimit($curview)]
5075 set fd [open $cmd r]
5076 fconfigure $fd -blocking 0
5077 set i [reg_instance $fd]
5078 filerun $fd [list readdifffiles $fd $serial $i]
5080 if {$isdiff && ![commitinview $nullid2 $curview]} {
5081 # add the line for the changes in the index to the graph
5082 set hl [mc "Local changes checked in to index but not committed"]
5083 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5084 set commitdata($nullid2) "\n $hl\n"
5085 if {[commitinview $nullid $curview]} {
5086 removefakerow $nullid
5088 insertfakerow $nullid2 $viewmainheadid($curview)
5089 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5090 if {[commitinview $nullid $curview]} {
5091 removefakerow $nullid
5093 removefakerow $nullid2
5095 return 0
5098 proc readdifffiles {fd serial inst} {
5099 global viewmainheadid nullid nullid2 curview
5100 global commitinfo commitdata lserial
5102 set isdiff 1
5103 if {[gets $fd line] < 0} {
5104 if {![eof $fd]} {
5105 return 1
5107 set isdiff 0
5109 # we only need to see one line and we don't really care what it says...
5110 stop_instance $inst
5112 if {$serial != $lserial} {
5113 return 0
5116 if {$isdiff && ![commitinview $nullid $curview]} {
5117 # add the line for the local diff to the graph
5118 set hl [mc "Local uncommitted changes, not checked in to index"]
5119 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5120 set commitdata($nullid) "\n $hl\n"
5121 if {[commitinview $nullid2 $curview]} {
5122 set p $nullid2
5123 } else {
5124 set p $viewmainheadid($curview)
5126 insertfakerow $nullid $p
5127 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5128 removefakerow $nullid
5130 return 0
5133 proc nextuse {id row} {
5134 global curview children
5136 if {[info exists children($curview,$id)]} {
5137 foreach kid $children($curview,$id) {
5138 if {![commitinview $kid $curview]} {
5139 return -1
5141 if {[rowofcommit $kid] > $row} {
5142 return [rowofcommit $kid]
5146 if {[commitinview $id $curview]} {
5147 return [rowofcommit $id]
5149 return -1
5152 proc prevuse {id row} {
5153 global curview children
5155 set ret -1
5156 if {[info exists children($curview,$id)]} {
5157 foreach kid $children($curview,$id) {
5158 if {![commitinview $kid $curview]} break
5159 if {[rowofcommit $kid] < $row} {
5160 set ret [rowofcommit $kid]
5164 return $ret
5167 proc make_idlist {row} {
5168 global displayorder parentlist uparrowlen downarrowlen mingaplen
5169 global commitidx curview children
5171 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5172 if {$r < 0} {
5173 set r 0
5175 set ra [expr {$row - $downarrowlen}]
5176 if {$ra < 0} {
5177 set ra 0
5179 set rb [expr {$row + $uparrowlen}]
5180 if {$rb > $commitidx($curview)} {
5181 set rb $commitidx($curview)
5183 make_disporder $r [expr {$rb + 1}]
5184 set ids {}
5185 for {} {$r < $ra} {incr r} {
5186 set nextid [lindex $displayorder [expr {$r + 1}]]
5187 foreach p [lindex $parentlist $r] {
5188 if {$p eq $nextid} continue
5189 set rn [nextuse $p $r]
5190 if {$rn >= $row &&
5191 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5192 lappend ids [list [ordertoken $p] $p]
5196 for {} {$r < $row} {incr r} {
5197 set nextid [lindex $displayorder [expr {$r + 1}]]
5198 foreach p [lindex $parentlist $r] {
5199 if {$p eq $nextid} continue
5200 set rn [nextuse $p $r]
5201 if {$rn < 0 || $rn >= $row} {
5202 lappend ids [list [ordertoken $p] $p]
5206 set id [lindex $displayorder $row]
5207 lappend ids [list [ordertoken $id] $id]
5208 while {$r < $rb} {
5209 foreach p [lindex $parentlist $r] {
5210 set firstkid [lindex $children($curview,$p) 0]
5211 if {[rowofcommit $firstkid] < $row} {
5212 lappend ids [list [ordertoken $p] $p]
5215 incr r
5216 set id [lindex $displayorder $r]
5217 if {$id ne {}} {
5218 set firstkid [lindex $children($curview,$id) 0]
5219 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5220 lappend ids [list [ordertoken $id] $id]
5224 set idlist {}
5225 foreach idx [lsort -unique $ids] {
5226 lappend idlist [lindex $idx 1]
5228 return $idlist
5231 proc rowsequal {a b} {
5232 while {[set i [lsearch -exact $a {}]] >= 0} {
5233 set a [lreplace $a $i $i]
5235 while {[set i [lsearch -exact $b {}]] >= 0} {
5236 set b [lreplace $b $i $i]
5238 return [expr {$a eq $b}]
5241 proc makeupline {id row rend col} {
5242 global rowidlist uparrowlen downarrowlen mingaplen
5244 for {set r $rend} {1} {set r $rstart} {
5245 set rstart [prevuse $id $r]
5246 if {$rstart < 0} return
5247 if {$rstart < $row} break
5249 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5250 set rstart [expr {$rend - $uparrowlen - 1}]
5252 for {set r $rstart} {[incr r] <= $row} {} {
5253 set idlist [lindex $rowidlist $r]
5254 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5255 set col [idcol $idlist $id $col]
5256 lset rowidlist $r [linsert $idlist $col $id]
5257 changedrow $r
5262 proc layoutrows {row endrow} {
5263 global rowidlist rowisopt rowfinal displayorder
5264 global uparrowlen downarrowlen maxwidth mingaplen
5265 global children parentlist
5266 global commitidx viewcomplete curview
5268 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5269 set idlist {}
5270 if {$row > 0} {
5271 set rm1 [expr {$row - 1}]
5272 foreach id [lindex $rowidlist $rm1] {
5273 if {$id ne {}} {
5274 lappend idlist $id
5277 set final [lindex $rowfinal $rm1]
5279 for {} {$row < $endrow} {incr row} {
5280 set rm1 [expr {$row - 1}]
5281 if {$rm1 < 0 || $idlist eq {}} {
5282 set idlist [make_idlist $row]
5283 set final 1
5284 } else {
5285 set id [lindex $displayorder $rm1]
5286 set col [lsearch -exact $idlist $id]
5287 set idlist [lreplace $idlist $col $col]
5288 foreach p [lindex $parentlist $rm1] {
5289 if {[lsearch -exact $idlist $p] < 0} {
5290 set col [idcol $idlist $p $col]
5291 set idlist [linsert $idlist $col $p]
5292 # if not the first child, we have to insert a line going up
5293 if {$id ne [lindex $children($curview,$p) 0]} {
5294 makeupline $p $rm1 $row $col
5298 set id [lindex $displayorder $row]
5299 if {$row > $downarrowlen} {
5300 set termrow [expr {$row - $downarrowlen - 1}]
5301 foreach p [lindex $parentlist $termrow] {
5302 set i [lsearch -exact $idlist $p]
5303 if {$i < 0} continue
5304 set nr [nextuse $p $termrow]
5305 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5306 set idlist [lreplace $idlist $i $i]
5310 set col [lsearch -exact $idlist $id]
5311 if {$col < 0} {
5312 set col [idcol $idlist $id]
5313 set idlist [linsert $idlist $col $id]
5314 if {$children($curview,$id) ne {}} {
5315 makeupline $id $rm1 $row $col
5318 set r [expr {$row + $uparrowlen - 1}]
5319 if {$r < $commitidx($curview)} {
5320 set x $col
5321 foreach p [lindex $parentlist $r] {
5322 if {[lsearch -exact $idlist $p] >= 0} continue
5323 set fk [lindex $children($curview,$p) 0]
5324 if {[rowofcommit $fk] < $row} {
5325 set x [idcol $idlist $p $x]
5326 set idlist [linsert $idlist $x $p]
5329 if {[incr r] < $commitidx($curview)} {
5330 set p [lindex $displayorder $r]
5331 if {[lsearch -exact $idlist $p] < 0} {
5332 set fk [lindex $children($curview,$p) 0]
5333 if {$fk ne {} && [rowofcommit $fk] < $row} {
5334 set x [idcol $idlist $p $x]
5335 set idlist [linsert $idlist $x $p]
5341 if {$final && !$viewcomplete($curview) &&
5342 $row + $uparrowlen + $mingaplen + $downarrowlen
5343 >= $commitidx($curview)} {
5344 set final 0
5346 set l [llength $rowidlist]
5347 if {$row == $l} {
5348 lappend rowidlist $idlist
5349 lappend rowisopt 0
5350 lappend rowfinal $final
5351 } elseif {$row < $l} {
5352 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5353 lset rowidlist $row $idlist
5354 changedrow $row
5356 lset rowfinal $row $final
5357 } else {
5358 set pad [ntimes [expr {$row - $l}] {}]
5359 set rowidlist [concat $rowidlist $pad]
5360 lappend rowidlist $idlist
5361 set rowfinal [concat $rowfinal $pad]
5362 lappend rowfinal $final
5363 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5366 return $row
5369 proc changedrow {row} {
5370 global displayorder iddrawn rowisopt need_redisplay
5372 set l [llength $rowisopt]
5373 if {$row < $l} {
5374 lset rowisopt $row 0
5375 if {$row + 1 < $l} {
5376 lset rowisopt [expr {$row + 1}] 0
5377 if {$row + 2 < $l} {
5378 lset rowisopt [expr {$row + 2}] 0
5382 set id [lindex $displayorder $row]
5383 if {[info exists iddrawn($id)]} {
5384 set need_redisplay 1
5388 proc insert_pad {row col npad} {
5389 global rowidlist
5391 set pad [ntimes $npad {}]
5392 set idlist [lindex $rowidlist $row]
5393 set bef [lrange $idlist 0 [expr {$col - 1}]]
5394 set aft [lrange $idlist $col end]
5395 set i [lsearch -exact $aft {}]
5396 if {$i > 0} {
5397 set aft [lreplace $aft $i $i]
5399 lset rowidlist $row [concat $bef $pad $aft]
5400 changedrow $row
5403 proc optimize_rows {row col endrow} {
5404 global rowidlist rowisopt displayorder curview children
5406 if {$row < 1} {
5407 set row 1
5409 for {} {$row < $endrow} {incr row; set col 0} {
5410 if {[lindex $rowisopt $row]} continue
5411 set haspad 0
5412 set y0 [expr {$row - 1}]
5413 set ym [expr {$row - 2}]
5414 set idlist [lindex $rowidlist $row]
5415 set previdlist [lindex $rowidlist $y0]
5416 if {$idlist eq {} || $previdlist eq {}} continue
5417 if {$ym >= 0} {
5418 set pprevidlist [lindex $rowidlist $ym]
5419 if {$pprevidlist eq {}} continue
5420 } else {
5421 set pprevidlist {}
5423 set x0 -1
5424 set xm -1
5425 for {} {$col < [llength $idlist]} {incr col} {
5426 set id [lindex $idlist $col]
5427 if {[lindex $previdlist $col] eq $id} continue
5428 if {$id eq {}} {
5429 set haspad 1
5430 continue
5432 set x0 [lsearch -exact $previdlist $id]
5433 if {$x0 < 0} continue
5434 set z [expr {$x0 - $col}]
5435 set isarrow 0
5436 set z0 {}
5437 if {$ym >= 0} {
5438 set xm [lsearch -exact $pprevidlist $id]
5439 if {$xm >= 0} {
5440 set z0 [expr {$xm - $x0}]
5443 if {$z0 eq {}} {
5444 # if row y0 is the first child of $id then it's not an arrow
5445 if {[lindex $children($curview,$id) 0] ne
5446 [lindex $displayorder $y0]} {
5447 set isarrow 1
5450 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5451 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5452 set isarrow 1
5454 # Looking at lines from this row to the previous row,
5455 # make them go straight up if they end in an arrow on
5456 # the previous row; otherwise make them go straight up
5457 # or at 45 degrees.
5458 if {$z < -1 || ($z < 0 && $isarrow)} {
5459 # Line currently goes left too much;
5460 # insert pads in the previous row, then optimize it
5461 set npad [expr {-1 - $z + $isarrow}]
5462 insert_pad $y0 $x0 $npad
5463 if {$y0 > 0} {
5464 optimize_rows $y0 $x0 $row
5466 set previdlist [lindex $rowidlist $y0]
5467 set x0 [lsearch -exact $previdlist $id]
5468 set z [expr {$x0 - $col}]
5469 if {$z0 ne {}} {
5470 set pprevidlist [lindex $rowidlist $ym]
5471 set xm [lsearch -exact $pprevidlist $id]
5472 set z0 [expr {$xm - $x0}]
5474 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5475 # Line currently goes right too much;
5476 # insert pads in this line
5477 set npad [expr {$z - 1 + $isarrow}]
5478 insert_pad $row $col $npad
5479 set idlist [lindex $rowidlist $row]
5480 incr col $npad
5481 set z [expr {$x0 - $col}]
5482 set haspad 1
5484 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5485 # this line links to its first child on row $row-2
5486 set id [lindex $displayorder $ym]
5487 set xc [lsearch -exact $pprevidlist $id]
5488 if {$xc >= 0} {
5489 set z0 [expr {$xc - $x0}]
5492 # avoid lines jigging left then immediately right
5493 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5494 insert_pad $y0 $x0 1
5495 incr x0
5496 optimize_rows $y0 $x0 $row
5497 set previdlist [lindex $rowidlist $y0]
5500 if {!$haspad} {
5501 # Find the first column that doesn't have a line going right
5502 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5503 set id [lindex $idlist $col]
5504 if {$id eq {}} break
5505 set x0 [lsearch -exact $previdlist $id]
5506 if {$x0 < 0} {
5507 # check if this is the link to the first child
5508 set kid [lindex $displayorder $y0]
5509 if {[lindex $children($curview,$id) 0] eq $kid} {
5510 # it is, work out offset to child
5511 set x0 [lsearch -exact $previdlist $kid]
5514 if {$x0 <= $col} break
5516 # Insert a pad at that column as long as it has a line and
5517 # isn't the last column
5518 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5519 set idlist [linsert $idlist $col {}]
5520 lset rowidlist $row $idlist
5521 changedrow $row
5527 proc xc {row col} {
5528 global canvx0 linespc
5529 return [expr {$canvx0 + $col * $linespc}]
5532 proc yc {row} {
5533 global canvy0 linespc
5534 return [expr {$canvy0 + $row * $linespc}]
5537 proc linewidth {id} {
5538 global thickerline lthickness
5540 set wid $lthickness
5541 if {[info exists thickerline] && $id eq $thickerline} {
5542 set wid [expr {2 * $lthickness}]
5544 return $wid
5547 proc rowranges {id} {
5548 global curview children uparrowlen downarrowlen
5549 global rowidlist
5551 set kids $children($curview,$id)
5552 if {$kids eq {}} {
5553 return {}
5555 set ret {}
5556 lappend kids $id
5557 foreach child $kids {
5558 if {![commitinview $child $curview]} break
5559 set row [rowofcommit $child]
5560 if {![info exists prev]} {
5561 lappend ret [expr {$row + 1}]
5562 } else {
5563 if {$row <= $prevrow} {
5564 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5566 # see if the line extends the whole way from prevrow to row
5567 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5568 [lsearch -exact [lindex $rowidlist \
5569 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5570 # it doesn't, see where it ends
5571 set r [expr {$prevrow + $downarrowlen}]
5572 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5573 while {[incr r -1] > $prevrow &&
5574 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5575 } else {
5576 while {[incr r] <= $row &&
5577 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5578 incr r -1
5580 lappend ret $r
5581 # see where it starts up again
5582 set r [expr {$row - $uparrowlen}]
5583 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5584 while {[incr r] < $row &&
5585 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5586 } else {
5587 while {[incr r -1] >= $prevrow &&
5588 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5589 incr r
5591 lappend ret $r
5594 if {$child eq $id} {
5595 lappend ret $row
5597 set prev $child
5598 set prevrow $row
5600 return $ret
5603 proc drawlineseg {id row endrow arrowlow} {
5604 global rowidlist displayorder iddrawn linesegs
5605 global canv colormap linespc curview maxlinelen parentlist
5607 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5608 set le [expr {$row + 1}]
5609 set arrowhigh 1
5610 while {1} {
5611 set c [lsearch -exact [lindex $rowidlist $le] $id]
5612 if {$c < 0} {
5613 incr le -1
5614 break
5616 lappend cols $c
5617 set x [lindex $displayorder $le]
5618 if {$x eq $id} {
5619 set arrowhigh 0
5620 break
5622 if {[info exists iddrawn($x)] || $le == $endrow} {
5623 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5624 if {$c >= 0} {
5625 lappend cols $c
5626 set arrowhigh 0
5628 break
5630 incr le
5632 if {$le <= $row} {
5633 return $row
5636 set lines {}
5637 set i 0
5638 set joinhigh 0
5639 if {[info exists linesegs($id)]} {
5640 set lines $linesegs($id)
5641 foreach li $lines {
5642 set r0 [lindex $li 0]
5643 if {$r0 > $row} {
5644 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5645 set joinhigh 1
5647 break
5649 incr i
5652 set joinlow 0
5653 if {$i > 0} {
5654 set li [lindex $lines [expr {$i-1}]]
5655 set r1 [lindex $li 1]
5656 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5657 set joinlow 1
5661 set x [lindex $cols [expr {$le - $row}]]
5662 set xp [lindex $cols [expr {$le - 1 - $row}]]
5663 set dir [expr {$xp - $x}]
5664 if {$joinhigh} {
5665 set ith [lindex $lines $i 2]
5666 set coords [$canv coords $ith]
5667 set ah [$canv itemcget $ith -arrow]
5668 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5669 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5670 if {$x2 ne {} && $x - $x2 == $dir} {
5671 set coords [lrange $coords 0 end-2]
5673 } else {
5674 set coords [list [xc $le $x] [yc $le]]
5676 if {$joinlow} {
5677 set itl [lindex $lines [expr {$i-1}] 2]
5678 set al [$canv itemcget $itl -arrow]
5679 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5680 } elseif {$arrowlow} {
5681 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5682 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5683 set arrowlow 0
5686 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5687 for {set y $le} {[incr y -1] > $row} {} {
5688 set x $xp
5689 set xp [lindex $cols [expr {$y - 1 - $row}]]
5690 set ndir [expr {$xp - $x}]
5691 if {$dir != $ndir || $xp < 0} {
5692 lappend coords [xc $y $x] [yc $y]
5694 set dir $ndir
5696 if {!$joinlow} {
5697 if {$xp < 0} {
5698 # join parent line to first child
5699 set ch [lindex $displayorder $row]
5700 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5701 if {$xc < 0} {
5702 puts "oops: drawlineseg: child $ch not on row $row"
5703 } elseif {$xc != $x} {
5704 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5705 set d [expr {int(0.5 * $linespc)}]
5706 set x1 [xc $row $x]
5707 if {$xc < $x} {
5708 set x2 [expr {$x1 - $d}]
5709 } else {
5710 set x2 [expr {$x1 + $d}]
5712 set y2 [yc $row]
5713 set y1 [expr {$y2 + $d}]
5714 lappend coords $x1 $y1 $x2 $y2
5715 } elseif {$xc < $x - 1} {
5716 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5717 } elseif {$xc > $x + 1} {
5718 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5720 set x $xc
5722 lappend coords [xc $row $x] [yc $row]
5723 } else {
5724 set xn [xc $row $xp]
5725 set yn [yc $row]
5726 lappend coords $xn $yn
5728 if {!$joinhigh} {
5729 assigncolor $id
5730 set t [$canv create line $coords -width [linewidth $id] \
5731 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5732 $canv lower $t
5733 bindline $t $id
5734 set lines [linsert $lines $i [list $row $le $t]]
5735 } else {
5736 $canv coords $ith $coords
5737 if {$arrow ne $ah} {
5738 $canv itemconf $ith -arrow $arrow
5740 lset lines $i 0 $row
5742 } else {
5743 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5744 set ndir [expr {$xo - $xp}]
5745 set clow [$canv coords $itl]
5746 if {$dir == $ndir} {
5747 set clow [lrange $clow 2 end]
5749 set coords [concat $coords $clow]
5750 if {!$joinhigh} {
5751 lset lines [expr {$i-1}] 1 $le
5752 } else {
5753 # coalesce two pieces
5754 $canv delete $ith
5755 set b [lindex $lines [expr {$i-1}] 0]
5756 set e [lindex $lines $i 1]
5757 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5759 $canv coords $itl $coords
5760 if {$arrow ne $al} {
5761 $canv itemconf $itl -arrow $arrow
5765 set linesegs($id) $lines
5766 return $le
5769 proc drawparentlinks {id row} {
5770 global rowidlist canv colormap curview parentlist
5771 global idpos linespc
5773 set rowids [lindex $rowidlist $row]
5774 set col [lsearch -exact $rowids $id]
5775 if {$col < 0} return
5776 set olds [lindex $parentlist $row]
5777 set row2 [expr {$row + 1}]
5778 set x [xc $row $col]
5779 set y [yc $row]
5780 set y2 [yc $row2]
5781 set d [expr {int(0.5 * $linespc)}]
5782 set ymid [expr {$y + $d}]
5783 set ids [lindex $rowidlist $row2]
5784 # rmx = right-most X coord used
5785 set rmx 0
5786 foreach p $olds {
5787 set i [lsearch -exact $ids $p]
5788 if {$i < 0} {
5789 puts "oops, parent $p of $id not in list"
5790 continue
5792 set x2 [xc $row2 $i]
5793 if {$x2 > $rmx} {
5794 set rmx $x2
5796 set j [lsearch -exact $rowids $p]
5797 if {$j < 0} {
5798 # drawlineseg will do this one for us
5799 continue
5801 assigncolor $p
5802 # should handle duplicated parents here...
5803 set coords [list $x $y]
5804 if {$i != $col} {
5805 # if attaching to a vertical segment, draw a smaller
5806 # slant for visual distinctness
5807 if {$i == $j} {
5808 if {$i < $col} {
5809 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5810 } else {
5811 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5813 } elseif {$i < $col && $i < $j} {
5814 # segment slants towards us already
5815 lappend coords [xc $row $j] $y
5816 } else {
5817 if {$i < $col - 1} {
5818 lappend coords [expr {$x2 + $linespc}] $y
5819 } elseif {$i > $col + 1} {
5820 lappend coords [expr {$x2 - $linespc}] $y
5822 lappend coords $x2 $y2
5824 } else {
5825 lappend coords $x2 $y2
5827 set t [$canv create line $coords -width [linewidth $p] \
5828 -fill $colormap($p) -tags lines.$p]
5829 $canv lower $t
5830 bindline $t $p
5832 if {$rmx > [lindex $idpos($id) 1]} {
5833 lset idpos($id) 1 $rmx
5834 redrawtags $id
5838 proc drawlines {id} {
5839 global canv
5841 $canv itemconf lines.$id -width [linewidth $id]
5844 proc drawcmittext {id row col} {
5845 global linespc canv canv2 canv3 fgcolor curview
5846 global cmitlisted commitinfo rowidlist parentlist
5847 global rowtextx idpos idtags idheads idotherrefs
5848 global linehtag linentag linedtag selectedline
5849 global canvxmax boldids boldnameids fgcolor markedid
5850 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5852 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5853 set listed $cmitlisted($curview,$id)
5854 if {$id eq $nullid} {
5855 set ofill red
5856 } elseif {$id eq $nullid2} {
5857 set ofill green
5858 } elseif {$id eq $mainheadid} {
5859 set ofill yellow
5860 } else {
5861 set ofill [lindex $circlecolors $listed]
5863 set x [xc $row $col]
5864 set y [yc $row]
5865 set orad [expr {$linespc / 3}]
5866 if {$listed <= 2} {
5867 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5868 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5869 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5870 } elseif {$listed == 3} {
5871 # triangle pointing left for left-side commits
5872 set t [$canv create polygon \
5873 [expr {$x - $orad}] $y \
5874 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5875 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5876 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5877 } else {
5878 # triangle pointing right for right-side commits
5879 set t [$canv create polygon \
5880 [expr {$x + $orad - 1}] $y \
5881 [expr {$x - $orad}] [expr {$y - $orad}] \
5882 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5883 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5885 set circleitem($row) $t
5886 $canv raise $t
5887 $canv bind $t <1> {selcanvline {} %x %y}
5888 set rmx [llength [lindex $rowidlist $row]]
5889 set olds [lindex $parentlist $row]
5890 if {$olds ne {}} {
5891 set nextids [lindex $rowidlist [expr {$row + 1}]]
5892 foreach p $olds {
5893 set i [lsearch -exact $nextids $p]
5894 if {$i > $rmx} {
5895 set rmx $i
5899 set xt [xc $row $rmx]
5900 set rowtextx($row) $xt
5901 set idpos($id) [list $x $xt $y]
5902 if {[info exists idtags($id)] || [info exists idheads($id)]
5903 || [info exists idotherrefs($id)]} {
5904 set xt [drawtags $id $x $xt $y]
5906 if {[lindex $commitinfo($id) 6] > 0} {
5907 set xt [drawnotesign $xt $y]
5909 set headline [lindex $commitinfo($id) 0]
5910 set name [lindex $commitinfo($id) 1]
5911 set date [lindex $commitinfo($id) 2]
5912 set date [formatdate $date]
5913 set font mainfont
5914 set nfont mainfont
5915 set isbold [ishighlighted $id]
5916 if {$isbold > 0} {
5917 lappend boldids $id
5918 set font mainfontbold
5919 if {$isbold > 1} {
5920 lappend boldnameids $id
5921 set nfont mainfontbold
5924 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5925 -text $headline -font $font -tags text]
5926 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5927 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5928 -text $name -font $nfont -tags text]
5929 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5930 -text $date -font mainfont -tags text]
5931 if {$selectedline == $row} {
5932 make_secsel $id
5934 if {[info exists markedid] && $markedid eq $id} {
5935 make_idmark $id
5937 set xr [expr {$xt + [font measure $font $headline]}]
5938 if {$xr > $canvxmax} {
5939 set canvxmax $xr
5940 setcanvscroll
5944 proc drawcmitrow {row} {
5945 global displayorder rowidlist nrows_drawn
5946 global iddrawn markingmatches
5947 global commitinfo numcommits
5948 global filehighlight fhighlights findpattern nhighlights
5949 global hlview vhighlights
5950 global highlight_related rhighlights
5952 if {$row >= $numcommits} return
5954 set id [lindex $displayorder $row]
5955 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5956 askvhighlight $row $id
5958 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5959 askfilehighlight $row $id
5961 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5962 askfindhighlight $row $id
5964 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5965 askrelhighlight $row $id
5967 if {![info exists iddrawn($id)]} {
5968 set col [lsearch -exact [lindex $rowidlist $row] $id]
5969 if {$col < 0} {
5970 puts "oops, row $row id $id not in list"
5971 return
5973 if {![info exists commitinfo($id)]} {
5974 getcommit $id
5976 assigncolor $id
5977 drawcmittext $id $row $col
5978 set iddrawn($id) 1
5979 incr nrows_drawn
5981 if {$markingmatches} {
5982 markrowmatches $row $id
5986 proc drawcommits {row {endrow {}}} {
5987 global numcommits iddrawn displayorder curview need_redisplay
5988 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5990 if {$row < 0} {
5991 set row 0
5993 if {$endrow eq {}} {
5994 set endrow $row
5996 if {$endrow >= $numcommits} {
5997 set endrow [expr {$numcommits - 1}]
6000 set rl1 [expr {$row - $downarrowlen - 3}]
6001 if {$rl1 < 0} {
6002 set rl1 0
6004 set ro1 [expr {$row - 3}]
6005 if {$ro1 < 0} {
6006 set ro1 0
6008 set r2 [expr {$endrow + $uparrowlen + 3}]
6009 if {$r2 > $numcommits} {
6010 set r2 $numcommits
6012 for {set r $rl1} {$r < $r2} {incr r} {
6013 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6014 if {$rl1 < $r} {
6015 layoutrows $rl1 $r
6017 set rl1 [expr {$r + 1}]
6020 if {$rl1 < $r} {
6021 layoutrows $rl1 $r
6023 optimize_rows $ro1 0 $r2
6024 if {$need_redisplay || $nrows_drawn > 2000} {
6025 clear_display
6028 # make the lines join to already-drawn rows either side
6029 set r [expr {$row - 1}]
6030 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6031 set r $row
6033 set er [expr {$endrow + 1}]
6034 if {$er >= $numcommits ||
6035 ![info exists iddrawn([lindex $displayorder $er])]} {
6036 set er $endrow
6038 for {} {$r <= $er} {incr r} {
6039 set id [lindex $displayorder $r]
6040 set wasdrawn [info exists iddrawn($id)]
6041 drawcmitrow $r
6042 if {$r == $er} break
6043 set nextid [lindex $displayorder [expr {$r + 1}]]
6044 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6045 drawparentlinks $id $r
6047 set rowids [lindex $rowidlist $r]
6048 foreach lid $rowids {
6049 if {$lid eq {}} continue
6050 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6051 if {$lid eq $id} {
6052 # see if this is the first child of any of its parents
6053 foreach p [lindex $parentlist $r] {
6054 if {[lsearch -exact $rowids $p] < 0} {
6055 # make this line extend up to the child
6056 set lineend($p) [drawlineseg $p $r $er 0]
6059 } else {
6060 set lineend($lid) [drawlineseg $lid $r $er 1]
6066 proc undolayout {row} {
6067 global uparrowlen mingaplen downarrowlen
6068 global rowidlist rowisopt rowfinal need_redisplay
6070 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6071 if {$r < 0} {
6072 set r 0
6074 if {[llength $rowidlist] > $r} {
6075 incr r -1
6076 set rowidlist [lrange $rowidlist 0 $r]
6077 set rowfinal [lrange $rowfinal 0 $r]
6078 set rowisopt [lrange $rowisopt 0 $r]
6079 set need_redisplay 1
6080 run drawvisible
6084 proc drawvisible {} {
6085 global canv linespc curview vrowmod selectedline targetrow targetid
6086 global need_redisplay cscroll numcommits
6088 set fs [$canv yview]
6089 set ymax [lindex [$canv cget -scrollregion] 3]
6090 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6091 set f0 [lindex $fs 0]
6092 set f1 [lindex $fs 1]
6093 set y0 [expr {int($f0 * $ymax)}]
6094 set y1 [expr {int($f1 * $ymax)}]
6096 if {[info exists targetid]} {
6097 if {[commitinview $targetid $curview]} {
6098 set r [rowofcommit $targetid]
6099 if {$r != $targetrow} {
6100 # Fix up the scrollregion and change the scrolling position
6101 # now that our target row has moved.
6102 set diff [expr {($r - $targetrow) * $linespc}]
6103 set targetrow $r
6104 setcanvscroll
6105 set ymax [lindex [$canv cget -scrollregion] 3]
6106 incr y0 $diff
6107 incr y1 $diff
6108 set f0 [expr {$y0 / $ymax}]
6109 set f1 [expr {$y1 / $ymax}]
6110 allcanvs yview moveto $f0
6111 $cscroll set $f0 $f1
6112 set need_redisplay 1
6114 } else {
6115 unset targetid
6119 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6120 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6121 if {$endrow >= $vrowmod($curview)} {
6122 update_arcrows $curview
6124 if {$selectedline ne {} &&
6125 $row <= $selectedline && $selectedline <= $endrow} {
6126 set targetrow $selectedline
6127 } elseif {[info exists targetid]} {
6128 set targetrow [expr {int(($row + $endrow) / 2)}]
6130 if {[info exists targetrow]} {
6131 if {$targetrow >= $numcommits} {
6132 set targetrow [expr {$numcommits - 1}]
6134 set targetid [commitonrow $targetrow]
6136 drawcommits $row $endrow
6139 proc clear_display {} {
6140 global iddrawn linesegs need_redisplay nrows_drawn
6141 global vhighlights fhighlights nhighlights rhighlights
6142 global linehtag linentag linedtag boldids boldnameids
6144 allcanvs delete all
6145 catch {unset iddrawn}
6146 catch {unset linesegs}
6147 catch {unset linehtag}
6148 catch {unset linentag}
6149 catch {unset linedtag}
6150 set boldids {}
6151 set boldnameids {}
6152 catch {unset vhighlights}
6153 catch {unset fhighlights}
6154 catch {unset nhighlights}
6155 catch {unset rhighlights}
6156 set need_redisplay 0
6157 set nrows_drawn 0
6160 proc findcrossings {id} {
6161 global rowidlist parentlist numcommits displayorder
6163 set cross {}
6164 set ccross {}
6165 foreach {s e} [rowranges $id] {
6166 if {$e >= $numcommits} {
6167 set e [expr {$numcommits - 1}]
6169 if {$e <= $s} continue
6170 for {set row $e} {[incr row -1] >= $s} {} {
6171 set x [lsearch -exact [lindex $rowidlist $row] $id]
6172 if {$x < 0} break
6173 set olds [lindex $parentlist $row]
6174 set kid [lindex $displayorder $row]
6175 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6176 if {$kidx < 0} continue
6177 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6178 foreach p $olds {
6179 set px [lsearch -exact $nextrow $p]
6180 if {$px < 0} continue
6181 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6182 if {[lsearch -exact $ccross $p] >= 0} continue
6183 if {$x == $px + ($kidx < $px? -1: 1)} {
6184 lappend ccross $p
6185 } elseif {[lsearch -exact $cross $p] < 0} {
6186 lappend cross $p
6192 return [concat $ccross {{}} $cross]
6195 proc assigncolor {id} {
6196 global colormap colors nextcolor
6197 global parents children children curview
6199 if {[info exists colormap($id)]} return
6200 set ncolors [llength $colors]
6201 if {[info exists children($curview,$id)]} {
6202 set kids $children($curview,$id)
6203 } else {
6204 set kids {}
6206 if {[llength $kids] == 1} {
6207 set child [lindex $kids 0]
6208 if {[info exists colormap($child)]
6209 && [llength $parents($curview,$child)] == 1} {
6210 set colormap($id) $colormap($child)
6211 return
6214 set badcolors {}
6215 set origbad {}
6216 foreach x [findcrossings $id] {
6217 if {$x eq {}} {
6218 # delimiter between corner crossings and other crossings
6219 if {[llength $badcolors] >= $ncolors - 1} break
6220 set origbad $badcolors
6222 if {[info exists colormap($x)]
6223 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6224 lappend badcolors $colormap($x)
6227 if {[llength $badcolors] >= $ncolors} {
6228 set badcolors $origbad
6230 set origbad $badcolors
6231 if {[llength $badcolors] < $ncolors - 1} {
6232 foreach child $kids {
6233 if {[info exists colormap($child)]
6234 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6235 lappend badcolors $colormap($child)
6237 foreach p $parents($curview,$child) {
6238 if {[info exists colormap($p)]
6239 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6240 lappend badcolors $colormap($p)
6244 if {[llength $badcolors] >= $ncolors} {
6245 set badcolors $origbad
6248 for {set i 0} {$i <= $ncolors} {incr i} {
6249 set c [lindex $colors $nextcolor]
6250 if {[incr nextcolor] >= $ncolors} {
6251 set nextcolor 0
6253 if {[lsearch -exact $badcolors $c]} break
6255 set colormap($id) $c
6258 proc bindline {t id} {
6259 global canv
6261 $canv bind $t <Enter> "lineenter %x %y $id"
6262 $canv bind $t <Motion> "linemotion %x %y $id"
6263 $canv bind $t <Leave> "lineleave $id"
6264 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6267 proc drawtags {id x xt y1} {
6268 global idtags idheads idotherrefs mainhead
6269 global linespc lthickness
6270 global canv rowtextx curview fgcolor bgcolor ctxbut
6272 set marks {}
6273 set ntags 0
6274 set nheads 0
6275 if {[info exists idtags($id)]} {
6276 set marks $idtags($id)
6277 set ntags [llength $marks]
6279 if {[info exists idheads($id)]} {
6280 set marks [concat $marks $idheads($id)]
6281 set nheads [llength $idheads($id)]
6283 if {[info exists idotherrefs($id)]} {
6284 set marks [concat $marks $idotherrefs($id)]
6286 if {$marks eq {}} {
6287 return $xt
6290 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6291 set yt [expr {$y1 - 0.5 * $linespc}]
6292 set yb [expr {$yt + $linespc - 1}]
6293 set xvals {}
6294 set wvals {}
6295 set i -1
6296 foreach tag $marks {
6297 incr i
6298 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6299 set wid [font measure mainfontbold $tag]
6300 } else {
6301 set wid [font measure mainfont $tag]
6303 lappend xvals $xt
6304 lappend wvals $wid
6305 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6307 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6308 -width $lthickness -fill black -tags tag.$id]
6309 $canv lower $t
6310 foreach tag $marks x $xvals wid $wvals {
6311 set tag_quoted [string map {% %%} $tag]
6312 set xl [expr {$x + $delta}]
6313 set xr [expr {$x + $delta + $wid + $lthickness}]
6314 set font mainfont
6315 if {[incr ntags -1] >= 0} {
6316 # draw a tag
6317 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6318 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6319 -width 1 -outline black -fill yellow -tags tag.$id]
6320 $canv bind $t <1> [list showtag $tag_quoted 1]
6321 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6322 } else {
6323 # draw a head or other ref
6324 if {[incr nheads -1] >= 0} {
6325 set col green
6326 if {$tag eq $mainhead} {
6327 set font mainfontbold
6329 } else {
6330 set col "#ddddff"
6332 set xl [expr {$xl - $delta/2}]
6333 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6334 -width 1 -outline black -fill $col -tags tag.$id
6335 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6336 set rwid [font measure mainfont $remoteprefix]
6337 set xi [expr {$x + 1}]
6338 set yti [expr {$yt + 1}]
6339 set xri [expr {$x + $rwid}]
6340 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6341 -width 0 -fill "#ffddaa" -tags tag.$id
6344 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6345 -font $font -tags [list tag.$id text]]
6346 if {$ntags >= 0} {
6347 $canv bind $t <1> [list showtag $tag_quoted 1]
6348 } elseif {$nheads >= 0} {
6349 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6352 return $xt
6355 proc drawnotesign {xt y} {
6356 global linespc canv fgcolor
6358 set orad [expr {$linespc / 3}]
6359 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6360 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6361 -fill yellow -outline $fgcolor -width 1 -tags circle]
6362 set xt [expr {$xt + $orad * 3}]
6363 return $xt
6366 proc xcoord {i level ln} {
6367 global canvx0 xspc1 xspc2
6369 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6370 if {$i > 0 && $i == $level} {
6371 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6372 } elseif {$i > $level} {
6373 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6375 return $x
6378 proc show_status {msg} {
6379 global canv fgcolor
6381 clear_display
6382 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6383 -tags text -fill $fgcolor
6386 # Don't change the text pane cursor if it is currently the hand cursor,
6387 # showing that we are over a sha1 ID link.
6388 proc settextcursor {c} {
6389 global ctext curtextcursor
6391 if {[$ctext cget -cursor] == $curtextcursor} {
6392 $ctext config -cursor $c
6394 set curtextcursor $c
6397 proc nowbusy {what {name {}}} {
6398 global isbusy busyname statusw
6400 if {[array names isbusy] eq {}} {
6401 . config -cursor watch
6402 settextcursor watch
6404 set isbusy($what) 1
6405 set busyname($what) $name
6406 if {$name ne {}} {
6407 $statusw conf -text $name
6411 proc notbusy {what} {
6412 global isbusy maincursor textcursor busyname statusw
6414 catch {
6415 unset isbusy($what)
6416 if {$busyname($what) ne {} &&
6417 [$statusw cget -text] eq $busyname($what)} {
6418 $statusw conf -text {}
6421 if {[array names isbusy] eq {}} {
6422 . config -cursor $maincursor
6423 settextcursor $textcursor
6427 proc findmatches {f} {
6428 global findtype findstring
6429 if {$findtype == [mc "Regexp"]} {
6430 set matches [regexp -indices -all -inline $findstring $f]
6431 } else {
6432 set fs $findstring
6433 if {$findtype == [mc "IgnCase"]} {
6434 set f [string tolower $f]
6435 set fs [string tolower $fs]
6437 set matches {}
6438 set i 0
6439 set l [string length $fs]
6440 while {[set j [string first $fs $f $i]] >= 0} {
6441 lappend matches [list $j [expr {$j+$l-1}]]
6442 set i [expr {$j + $l}]
6445 return $matches
6448 proc dofind {{dirn 1} {wrap 1}} {
6449 global findstring findstartline findcurline selectedline numcommits
6450 global gdttype filehighlight fh_serial find_dirn findallowwrap
6452 if {[info exists find_dirn]} {
6453 if {$find_dirn == $dirn} return
6454 stopfinding
6456 focus .
6457 if {$findstring eq {} || $numcommits == 0} return
6458 if {$selectedline eq {}} {
6459 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6460 } else {
6461 set findstartline $selectedline
6463 set findcurline $findstartline
6464 nowbusy finding [mc "Searching"]
6465 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6466 after cancel do_file_hl $fh_serial
6467 do_file_hl $fh_serial
6469 set find_dirn $dirn
6470 set findallowwrap $wrap
6471 run findmore
6474 proc stopfinding {} {
6475 global find_dirn findcurline fprogcoord
6477 if {[info exists find_dirn]} {
6478 unset find_dirn
6479 unset findcurline
6480 notbusy finding
6481 set fprogcoord 0
6482 adjustprogress
6484 stopblaming
6487 proc findmore {} {
6488 global commitdata commitinfo numcommits findpattern findloc
6489 global findstartline findcurline findallowwrap
6490 global find_dirn gdttype fhighlights fprogcoord
6491 global curview varcorder vrownum varccommits vrowmod
6493 if {![info exists find_dirn]} {
6494 return 0
6496 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6497 set l $findcurline
6498 set moretodo 0
6499 if {$find_dirn > 0} {
6500 incr l
6501 if {$l >= $numcommits} {
6502 set l 0
6504 if {$l <= $findstartline} {
6505 set lim [expr {$findstartline + 1}]
6506 } else {
6507 set lim $numcommits
6508 set moretodo $findallowwrap
6510 } else {
6511 if {$l == 0} {
6512 set l $numcommits
6514 incr l -1
6515 if {$l >= $findstartline} {
6516 set lim [expr {$findstartline - 1}]
6517 } else {
6518 set lim -1
6519 set moretodo $findallowwrap
6522 set n [expr {($lim - $l) * $find_dirn}]
6523 if {$n > 500} {
6524 set n 500
6525 set moretodo 1
6527 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6528 update_arcrows $curview
6530 set found 0
6531 set domore 1
6532 set ai [bsearch $vrownum($curview) $l]
6533 set a [lindex $varcorder($curview) $ai]
6534 set arow [lindex $vrownum($curview) $ai]
6535 set ids [lindex $varccommits($curview,$a)]
6536 set arowend [expr {$arow + [llength $ids]}]
6537 if {$gdttype eq [mc "containing:"]} {
6538 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6539 if {$l < $arow || $l >= $arowend} {
6540 incr ai $find_dirn
6541 set a [lindex $varcorder($curview) $ai]
6542 set arow [lindex $vrownum($curview) $ai]
6543 set ids [lindex $varccommits($curview,$a)]
6544 set arowend [expr {$arow + [llength $ids]}]
6546 set id [lindex $ids [expr {$l - $arow}]]
6547 # shouldn't happen unless git log doesn't give all the commits...
6548 if {![info exists commitdata($id)] ||
6549 ![doesmatch $commitdata($id)]} {
6550 continue
6552 if {![info exists commitinfo($id)]} {
6553 getcommit $id
6555 set info $commitinfo($id)
6556 foreach f $info ty $fldtypes {
6557 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6558 [doesmatch $f]} {
6559 set found 1
6560 break
6563 if {$found} break
6565 } else {
6566 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6567 if {$l < $arow || $l >= $arowend} {
6568 incr ai $find_dirn
6569 set a [lindex $varcorder($curview) $ai]
6570 set arow [lindex $vrownum($curview) $ai]
6571 set ids [lindex $varccommits($curview,$a)]
6572 set arowend [expr {$arow + [llength $ids]}]
6574 set id [lindex $ids [expr {$l - $arow}]]
6575 if {![info exists fhighlights($id)]} {
6576 # this sets fhighlights($id) to -1
6577 askfilehighlight $l $id
6579 if {$fhighlights($id) > 0} {
6580 set found $domore
6581 break
6583 if {$fhighlights($id) < 0} {
6584 if {$domore} {
6585 set domore 0
6586 set findcurline [expr {$l - $find_dirn}]
6591 if {$found || ($domore && !$moretodo)} {
6592 unset findcurline
6593 unset find_dirn
6594 notbusy finding
6595 set fprogcoord 0
6596 adjustprogress
6597 if {$found} {
6598 findselectline $l
6599 } else {
6600 bell
6602 return 0
6604 if {!$domore} {
6605 flushhighlights
6606 } else {
6607 set findcurline [expr {$l - $find_dirn}]
6609 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6610 if {$n < 0} {
6611 incr n $numcommits
6613 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6614 adjustprogress
6615 return $domore
6618 proc findselectline {l} {
6619 global findloc commentend ctext findcurline markingmatches gdttype
6621 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6622 set findcurline $l
6623 selectline $l 1
6624 if {$markingmatches &&
6625 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6626 # highlight the matches in the comments
6627 set f [$ctext get 1.0 $commentend]
6628 set matches [findmatches $f]
6629 foreach match $matches {
6630 set start [lindex $match 0]
6631 set end [expr {[lindex $match 1] + 1}]
6632 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6635 drawvisible
6638 # mark the bits of a headline or author that match a find string
6639 proc markmatches {canv l str tag matches font row} {
6640 global selectedline
6642 set bbox [$canv bbox $tag]
6643 set x0 [lindex $bbox 0]
6644 set y0 [lindex $bbox 1]
6645 set y1 [lindex $bbox 3]
6646 foreach match $matches {
6647 set start [lindex $match 0]
6648 set end [lindex $match 1]
6649 if {$start > $end} continue
6650 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6651 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6652 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6653 [expr {$x0+$xlen+2}] $y1 \
6654 -outline {} -tags [list match$l matches] -fill yellow]
6655 $canv lower $t
6656 if {$row == $selectedline} {
6657 $canv raise $t secsel
6662 proc unmarkmatches {} {
6663 global markingmatches
6665 allcanvs delete matches
6666 set markingmatches 0
6667 stopfinding
6670 proc selcanvline {w x y} {
6671 global canv canvy0 ctext linespc
6672 global rowtextx
6673 set ymax [lindex [$canv cget -scrollregion] 3]
6674 if {$ymax == {}} return
6675 set yfrac [lindex [$canv yview] 0]
6676 set y [expr {$y + $yfrac * $ymax}]
6677 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6678 if {$l < 0} {
6679 set l 0
6681 if {$w eq $canv} {
6682 set xmax [lindex [$canv cget -scrollregion] 2]
6683 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6684 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6686 unmarkmatches
6687 selectline $l 1
6690 proc commit_descriptor {p} {
6691 global commitinfo
6692 if {![info exists commitinfo($p)]} {
6693 getcommit $p
6695 set l "..."
6696 if {[llength $commitinfo($p)] > 1} {
6697 set l [lindex $commitinfo($p) 0]
6699 return "$p ($l)\n"
6702 # append some text to the ctext widget, and make any SHA1 ID
6703 # that we know about be a clickable link.
6704 proc appendwithlinks {text tags} {
6705 global ctext linknum curview
6707 set start [$ctext index "end - 1c"]
6708 $ctext insert end $text $tags
6709 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6710 foreach l $links {
6711 set s [lindex $l 0]
6712 set e [lindex $l 1]
6713 set linkid [string range $text $s $e]
6714 incr e
6715 $ctext tag delete link$linknum
6716 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6717 setlink $linkid link$linknum
6718 incr linknum
6722 proc setlink {id lk} {
6723 global curview ctext pendinglinks
6725 set known 0
6726 if {[string length $id] < 40} {
6727 set matches [longid $id]
6728 if {[llength $matches] > 0} {
6729 if {[llength $matches] > 1} return
6730 set known 1
6731 set id [lindex $matches 0]
6733 } else {
6734 set known [commitinview $id $curview]
6736 if {$known} {
6737 $ctext tag conf $lk -foreground blue -underline 1
6738 $ctext tag bind $lk <1> [list selbyid $id]
6739 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6740 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6741 } else {
6742 lappend pendinglinks($id) $lk
6743 interestedin $id {makelink %P}
6747 proc appendshortlink {id {pre {}} {post {}}} {
6748 global ctext linknum
6750 $ctext insert end $pre
6751 $ctext tag delete link$linknum
6752 $ctext insert end [string range $id 0 7] link$linknum
6753 $ctext insert end $post
6754 setlink $id link$linknum
6755 incr linknum
6758 proc makelink {id} {
6759 global pendinglinks
6761 if {![info exists pendinglinks($id)]} return
6762 foreach lk $pendinglinks($id) {
6763 setlink $id $lk
6765 unset pendinglinks($id)
6768 proc linkcursor {w inc} {
6769 global linkentercount curtextcursor
6771 if {[incr linkentercount $inc] > 0} {
6772 $w configure -cursor hand2
6773 } else {
6774 $w configure -cursor $curtextcursor
6775 if {$linkentercount < 0} {
6776 set linkentercount 0
6781 proc viewnextline {dir} {
6782 global canv linespc
6784 $canv delete hover
6785 set ymax [lindex [$canv cget -scrollregion] 3]
6786 set wnow [$canv yview]
6787 set wtop [expr {[lindex $wnow 0] * $ymax}]
6788 set newtop [expr {$wtop + $dir * $linespc}]
6789 if {$newtop < 0} {
6790 set newtop 0
6791 } elseif {$newtop > $ymax} {
6792 set newtop $ymax
6794 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6797 # add a list of tag or branch names at position pos
6798 # returns the number of names inserted
6799 proc appendrefs {pos ids var} {
6800 global ctext linknum curview $var maxrefs
6802 if {[catch {$ctext index $pos}]} {
6803 return 0
6805 $ctext conf -state normal
6806 $ctext delete $pos "$pos lineend"
6807 set tags {}
6808 foreach id $ids {
6809 foreach tag [set $var\($id\)] {
6810 lappend tags [list $tag $id]
6813 if {[llength $tags] > $maxrefs} {
6814 $ctext insert $pos "[mc "many"] ([llength $tags])"
6815 } else {
6816 set tags [lsort -index 0 -decreasing $tags]
6817 set sep {}
6818 foreach ti $tags {
6819 set id [lindex $ti 1]
6820 set lk link$linknum
6821 incr linknum
6822 $ctext tag delete $lk
6823 $ctext insert $pos $sep
6824 $ctext insert $pos [lindex $ti 0] $lk
6825 setlink $id $lk
6826 set sep ", "
6829 $ctext conf -state disabled
6830 return [llength $tags]
6833 # called when we have finished computing the nearby tags
6834 proc dispneartags {delay} {
6835 global selectedline currentid showneartags tagphase
6837 if {$selectedline eq {} || !$showneartags} return
6838 after cancel dispnexttag
6839 if {$delay} {
6840 after 200 dispnexttag
6841 set tagphase -1
6842 } else {
6843 after idle dispnexttag
6844 set tagphase 0
6848 proc dispnexttag {} {
6849 global selectedline currentid showneartags tagphase ctext
6851 if {$selectedline eq {} || !$showneartags} return
6852 switch -- $tagphase {
6854 set dtags [desctags $currentid]
6855 if {$dtags ne {}} {
6856 appendrefs precedes $dtags idtags
6860 set atags [anctags $currentid]
6861 if {$atags ne {}} {
6862 appendrefs follows $atags idtags
6866 set dheads [descheads $currentid]
6867 if {$dheads ne {}} {
6868 if {[appendrefs branch $dheads idheads] > 1
6869 && [$ctext get "branch -3c"] eq "h"} {
6870 # turn "Branch" into "Branches"
6871 $ctext conf -state normal
6872 $ctext insert "branch -2c" "es"
6873 $ctext conf -state disabled
6878 if {[incr tagphase] <= 2} {
6879 after idle dispnexttag
6883 proc make_secsel {id} {
6884 global linehtag linentag linedtag canv canv2 canv3
6886 if {![info exists linehtag($id)]} return
6887 $canv delete secsel
6888 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6889 -tags secsel -fill [$canv cget -selectbackground]]
6890 $canv lower $t
6891 $canv2 delete secsel
6892 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6893 -tags secsel -fill [$canv2 cget -selectbackground]]
6894 $canv2 lower $t
6895 $canv3 delete secsel
6896 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6897 -tags secsel -fill [$canv3 cget -selectbackground]]
6898 $canv3 lower $t
6901 proc make_idmark {id} {
6902 global linehtag canv fgcolor
6904 if {![info exists linehtag($id)]} return
6905 $canv delete markid
6906 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6907 -tags markid -outline $fgcolor]
6908 $canv raise $t
6911 proc selectline {l isnew {desired_loc {}}} {
6912 global canv ctext commitinfo selectedline
6913 global canvy0 linespc parents children curview
6914 global currentid sha1entry
6915 global commentend idtags linknum
6916 global mergemax numcommits pending_select
6917 global cmitmode showneartags allcommits
6918 global targetrow targetid lastscrollrows
6919 global autoselect autosellen jump_to_here
6921 catch {unset pending_select}
6922 $canv delete hover
6923 normalline
6924 unsel_reflist
6925 stopfinding
6926 if {$l < 0 || $l >= $numcommits} return
6927 set id [commitonrow $l]
6928 set targetid $id
6929 set targetrow $l
6930 set selectedline $l
6931 set currentid $id
6932 if {$lastscrollrows < $numcommits} {
6933 setcanvscroll
6936 set y [expr {$canvy0 + $l * $linespc}]
6937 set ymax [lindex [$canv cget -scrollregion] 3]
6938 set ytop [expr {$y - $linespc - 1}]
6939 set ybot [expr {$y + $linespc + 1}]
6940 set wnow [$canv yview]
6941 set wtop [expr {[lindex $wnow 0] * $ymax}]
6942 set wbot [expr {[lindex $wnow 1] * $ymax}]
6943 set wh [expr {$wbot - $wtop}]
6944 set newtop $wtop
6945 if {$ytop < $wtop} {
6946 if {$ybot < $wtop} {
6947 set newtop [expr {$y - $wh / 2.0}]
6948 } else {
6949 set newtop $ytop
6950 if {$newtop > $wtop - $linespc} {
6951 set newtop [expr {$wtop - $linespc}]
6954 } elseif {$ybot > $wbot} {
6955 if {$ytop > $wbot} {
6956 set newtop [expr {$y - $wh / 2.0}]
6957 } else {
6958 set newtop [expr {$ybot - $wh}]
6959 if {$newtop < $wtop + $linespc} {
6960 set newtop [expr {$wtop + $linespc}]
6964 if {$newtop != $wtop} {
6965 if {$newtop < 0} {
6966 set newtop 0
6968 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6969 drawvisible
6972 make_secsel $id
6974 if {$isnew} {
6975 addtohistory [list selbyid $id 0] savecmitpos
6978 $sha1entry delete 0 end
6979 $sha1entry insert 0 $id
6980 if {$autoselect} {
6981 $sha1entry selection range 0 $autosellen
6983 rhighlight_sel $id
6985 $ctext conf -state normal
6986 clear_ctext
6987 set linknum 0
6988 if {![info exists commitinfo($id)]} {
6989 getcommit $id
6991 set info $commitinfo($id)
6992 set date [formatdate [lindex $info 2]]
6993 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6994 set date [formatdate [lindex $info 4]]
6995 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6996 if {[info exists idtags($id)]} {
6997 $ctext insert end [mc "Tags:"]
6998 foreach tag $idtags($id) {
6999 $ctext insert end " $tag"
7001 $ctext insert end "\n"
7004 set headers {}
7005 set olds $parents($curview,$id)
7006 if {[llength $olds] > 1} {
7007 set np 0
7008 foreach p $olds {
7009 if {$np >= $mergemax} {
7010 set tag mmax
7011 } else {
7012 set tag m$np
7014 $ctext insert end "[mc "Parent"]: " $tag
7015 appendwithlinks [commit_descriptor $p] {}
7016 incr np
7018 } else {
7019 foreach p $olds {
7020 append headers "[mc "Parent"]: [commit_descriptor $p]"
7024 foreach c $children($curview,$id) {
7025 append headers "[mc "Child"]: [commit_descriptor $c]"
7028 # make anything that looks like a SHA1 ID be a clickable link
7029 appendwithlinks $headers {}
7030 if {$showneartags} {
7031 if {![info exists allcommits]} {
7032 getallcommits
7034 $ctext insert end "[mc "Branch"]: "
7035 $ctext mark set branch "end -1c"
7036 $ctext mark gravity branch left
7037 $ctext insert end "\n[mc "Follows"]: "
7038 $ctext mark set follows "end -1c"
7039 $ctext mark gravity follows left
7040 $ctext insert end "\n[mc "Precedes"]: "
7041 $ctext mark set precedes "end -1c"
7042 $ctext mark gravity precedes left
7043 $ctext insert end "\n"
7044 dispneartags 1
7046 $ctext insert end "\n"
7047 set comment [lindex $info 5]
7048 if {[string first "\r" $comment] >= 0} {
7049 set comment [string map {"\r" "\n "} $comment]
7051 appendwithlinks $comment {comment}
7053 $ctext tag remove found 1.0 end
7054 $ctext conf -state disabled
7055 set commentend [$ctext index "end - 1c"]
7057 set jump_to_here $desired_loc
7058 init_flist [mc "Comments"]
7059 if {$cmitmode eq "tree"} {
7060 gettree $id
7061 } elseif {[llength $olds] <= 1} {
7062 startdiff $id
7063 } else {
7064 mergediff $id
7068 proc selfirstline {} {
7069 unmarkmatches
7070 selectline 0 1
7073 proc sellastline {} {
7074 global numcommits
7075 unmarkmatches
7076 set l [expr {$numcommits - 1}]
7077 selectline $l 1
7080 proc selnextline {dir} {
7081 global selectedline
7082 focus .
7083 if {$selectedline eq {}} return
7084 set l [expr {$selectedline + $dir}]
7085 unmarkmatches
7086 selectline $l 1
7089 proc selnextpage {dir} {
7090 global canv linespc selectedline numcommits
7092 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7093 if {$lpp < 1} {
7094 set lpp 1
7096 allcanvs yview scroll [expr {$dir * $lpp}] units
7097 drawvisible
7098 if {$selectedline eq {}} return
7099 set l [expr {$selectedline + $dir * $lpp}]
7100 if {$l < 0} {
7101 set l 0
7102 } elseif {$l >= $numcommits} {
7103 set l [expr $numcommits - 1]
7105 unmarkmatches
7106 selectline $l 1
7109 proc unselectline {} {
7110 global selectedline currentid
7112 set selectedline {}
7113 catch {unset currentid}
7114 allcanvs delete secsel
7115 rhighlight_none
7118 proc reselectline {} {
7119 global selectedline
7121 if {$selectedline ne {}} {
7122 selectline $selectedline 0
7126 proc addtohistory {cmd {saveproc {}}} {
7127 global history historyindex curview
7129 unset_posvars
7130 save_position
7131 set elt [list $curview $cmd $saveproc {}]
7132 if {$historyindex > 0
7133 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7134 return
7137 if {$historyindex < [llength $history]} {
7138 set history [lreplace $history $historyindex end $elt]
7139 } else {
7140 lappend history $elt
7142 incr historyindex
7143 if {$historyindex > 1} {
7144 .tf.bar.leftbut conf -state normal
7145 } else {
7146 .tf.bar.leftbut conf -state disabled
7148 .tf.bar.rightbut conf -state disabled
7151 # save the scrolling position of the diff display pane
7152 proc save_position {} {
7153 global historyindex history
7155 if {$historyindex < 1} return
7156 set hi [expr {$historyindex - 1}]
7157 set fn [lindex $history $hi 2]
7158 if {$fn ne {}} {
7159 lset history $hi 3 [eval $fn]
7163 proc unset_posvars {} {
7164 global last_posvars
7166 if {[info exists last_posvars]} {
7167 foreach {var val} $last_posvars {
7168 global $var
7169 catch {unset $var}
7171 unset last_posvars
7175 proc godo {elt} {
7176 global curview last_posvars
7178 set view [lindex $elt 0]
7179 set cmd [lindex $elt 1]
7180 set pv [lindex $elt 3]
7181 if {$curview != $view} {
7182 showview $view
7184 unset_posvars
7185 foreach {var val} $pv {
7186 global $var
7187 set $var $val
7189 set last_posvars $pv
7190 eval $cmd
7193 proc goback {} {
7194 global history historyindex
7195 focus .
7197 if {$historyindex > 1} {
7198 save_position
7199 incr historyindex -1
7200 godo [lindex $history [expr {$historyindex - 1}]]
7201 .tf.bar.rightbut conf -state normal
7203 if {$historyindex <= 1} {
7204 .tf.bar.leftbut conf -state disabled
7208 proc goforw {} {
7209 global history historyindex
7210 focus .
7212 if {$historyindex < [llength $history]} {
7213 save_position
7214 set cmd [lindex $history $historyindex]
7215 incr historyindex
7216 godo $cmd
7217 .tf.bar.leftbut conf -state normal
7219 if {$historyindex >= [llength $history]} {
7220 .tf.bar.rightbut conf -state disabled
7224 proc gettree {id} {
7225 global treefilelist treeidlist diffids diffmergeid treepending
7226 global nullid nullid2
7228 set diffids $id
7229 catch {unset diffmergeid}
7230 if {![info exists treefilelist($id)]} {
7231 if {![info exists treepending]} {
7232 if {$id eq $nullid} {
7233 set cmd [list | git ls-files]
7234 } elseif {$id eq $nullid2} {
7235 set cmd [list | git ls-files --stage -t]
7236 } else {
7237 set cmd [list | git ls-tree -r $id]
7239 if {[catch {set gtf [open $cmd r]}]} {
7240 return
7242 set treepending $id
7243 set treefilelist($id) {}
7244 set treeidlist($id) {}
7245 fconfigure $gtf -blocking 0 -encoding binary
7246 filerun $gtf [list gettreeline $gtf $id]
7248 } else {
7249 setfilelist $id
7253 proc gettreeline {gtf id} {
7254 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7256 set nl 0
7257 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7258 if {$diffids eq $nullid} {
7259 set fname $line
7260 } else {
7261 set i [string first "\t" $line]
7262 if {$i < 0} continue
7263 set fname [string range $line [expr {$i+1}] end]
7264 set line [string range $line 0 [expr {$i-1}]]
7265 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7266 set sha1 [lindex $line 2]
7267 lappend treeidlist($id) $sha1
7269 if {[string index $fname 0] eq "\""} {
7270 set fname [lindex $fname 0]
7272 set fname [encoding convertfrom $fname]
7273 lappend treefilelist($id) $fname
7275 if {![eof $gtf]} {
7276 return [expr {$nl >= 1000? 2: 1}]
7278 close $gtf
7279 unset treepending
7280 if {$cmitmode ne "tree"} {
7281 if {![info exists diffmergeid]} {
7282 gettreediffs $diffids
7284 } elseif {$id ne $diffids} {
7285 gettree $diffids
7286 } else {
7287 setfilelist $id
7289 return 0
7292 proc showfile {f} {
7293 global treefilelist treeidlist diffids nullid nullid2
7294 global ctext_file_names ctext_file_lines
7295 global ctext commentend
7297 set i [lsearch -exact $treefilelist($diffids) $f]
7298 if {$i < 0} {
7299 puts "oops, $f not in list for id $diffids"
7300 return
7302 if {$diffids eq $nullid} {
7303 if {[catch {set bf [open $f r]} err]} {
7304 puts "oops, can't read $f: $err"
7305 return
7307 } else {
7308 set blob [lindex $treeidlist($diffids) $i]
7309 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7310 puts "oops, error reading blob $blob: $err"
7311 return
7314 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7315 filerun $bf [list getblobline $bf $diffids]
7316 $ctext config -state normal
7317 clear_ctext $commentend
7318 lappend ctext_file_names $f
7319 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7320 $ctext insert end "\n"
7321 $ctext insert end "$f\n" filesep
7322 $ctext config -state disabled
7323 $ctext yview $commentend
7324 settabs 0
7327 proc getblobline {bf id} {
7328 global diffids cmitmode ctext
7330 if {$id ne $diffids || $cmitmode ne "tree"} {
7331 catch {close $bf}
7332 return 0
7334 $ctext config -state normal
7335 set nl 0
7336 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7337 $ctext insert end "$line\n"
7339 if {[eof $bf]} {
7340 global jump_to_here ctext_file_names commentend
7342 # delete last newline
7343 $ctext delete "end - 2c" "end - 1c"
7344 close $bf
7345 if {$jump_to_here ne {} &&
7346 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7347 set lnum [expr {[lindex $jump_to_here 1] +
7348 [lindex [split $commentend .] 0]}]
7349 mark_ctext_line $lnum
7351 $ctext config -state disabled
7352 return 0
7354 $ctext config -state disabled
7355 return [expr {$nl >= 1000? 2: 1}]
7358 proc mark_ctext_line {lnum} {
7359 global ctext markbgcolor
7361 $ctext tag delete omark
7362 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7363 $ctext tag conf omark -background $markbgcolor
7364 $ctext see $lnum.0
7367 proc mergediff {id} {
7368 global diffmergeid
7369 global diffids treediffs
7370 global parents curview
7372 set diffmergeid $id
7373 set diffids $id
7374 set treediffs($id) {}
7375 set np [llength $parents($curview,$id)]
7376 settabs $np
7377 getblobdiffs $id
7380 proc startdiff {ids} {
7381 global treediffs diffids treepending diffmergeid nullid nullid2
7383 settabs 1
7384 set diffids $ids
7385 catch {unset diffmergeid}
7386 if {![info exists treediffs($ids)] ||
7387 [lsearch -exact $ids $nullid] >= 0 ||
7388 [lsearch -exact $ids $nullid2] >= 0} {
7389 if {![info exists treepending]} {
7390 gettreediffs $ids
7392 } else {
7393 addtocflist $ids
7397 proc path_filter {filter name} {
7398 foreach p $filter {
7399 set l [string length $p]
7400 if {[string index $p end] eq "/"} {
7401 if {[string compare -length $l $p $name] == 0} {
7402 return 1
7404 } else {
7405 if {[string compare -length $l $p $name] == 0 &&
7406 ([string length $name] == $l ||
7407 [string index $name $l] eq "/")} {
7408 return 1
7412 return 0
7415 proc addtocflist {ids} {
7416 global treediffs
7418 add_flist $treediffs($ids)
7419 getblobdiffs $ids
7422 proc diffcmd {ids flags} {
7423 global nullid nullid2
7425 set i [lsearch -exact $ids $nullid]
7426 set j [lsearch -exact $ids $nullid2]
7427 if {$i >= 0} {
7428 if {[llength $ids] > 1 && $j < 0} {
7429 # comparing working directory with some specific revision
7430 set cmd [concat | git diff-index $flags]
7431 if {$i == 0} {
7432 lappend cmd -R [lindex $ids 1]
7433 } else {
7434 lappend cmd [lindex $ids 0]
7436 } else {
7437 # comparing working directory with index
7438 set cmd [concat | git diff-files $flags]
7439 if {$j == 1} {
7440 lappend cmd -R
7443 } elseif {$j >= 0} {
7444 set cmd [concat | git diff-index --cached $flags]
7445 if {[llength $ids] > 1} {
7446 # comparing index with specific revision
7447 if {$j == 0} {
7448 lappend cmd -R [lindex $ids 1]
7449 } else {
7450 lappend cmd [lindex $ids 0]
7452 } else {
7453 # comparing index with HEAD
7454 lappend cmd HEAD
7456 } else {
7457 set cmd [concat | git diff-tree -r $flags $ids]
7459 return $cmd
7462 proc gettreediffs {ids} {
7463 global treediff treepending
7465 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7467 set treepending $ids
7468 set treediff {}
7469 fconfigure $gdtf -blocking 0 -encoding binary
7470 filerun $gdtf [list gettreediffline $gdtf $ids]
7473 proc gettreediffline {gdtf ids} {
7474 global treediff treediffs treepending diffids diffmergeid
7475 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7477 set nr 0
7478 set sublist {}
7479 set max 1000
7480 if {$perfile_attrs} {
7481 # cache_gitattr is slow, and even slower on win32 where we
7482 # have to invoke it for only about 30 paths at a time
7483 set max 500
7484 if {[tk windowingsystem] == "win32"} {
7485 set max 120
7488 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7489 set i [string first "\t" $line]
7490 if {$i >= 0} {
7491 set file [string range $line [expr {$i+1}] end]
7492 if {[string index $file 0] eq "\""} {
7493 set file [lindex $file 0]
7495 set file [encoding convertfrom $file]
7496 if {$file ne [lindex $treediff end]} {
7497 lappend treediff $file
7498 lappend sublist $file
7502 if {$perfile_attrs} {
7503 cache_gitattr encoding $sublist
7505 if {![eof $gdtf]} {
7506 return [expr {$nr >= $max? 2: 1}]
7508 close $gdtf
7509 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7510 set flist {}
7511 foreach f $treediff {
7512 if {[path_filter $vfilelimit($curview) $f]} {
7513 lappend flist $f
7516 set treediffs($ids) $flist
7517 } else {
7518 set treediffs($ids) $treediff
7520 unset treepending
7521 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7522 gettree $diffids
7523 } elseif {$ids != $diffids} {
7524 if {![info exists diffmergeid]} {
7525 gettreediffs $diffids
7527 } else {
7528 addtocflist $ids
7530 return 0
7533 # empty string or positive integer
7534 proc diffcontextvalidate {v} {
7535 return [regexp {^(|[1-9][0-9]*)$} $v]
7538 proc diffcontextchange {n1 n2 op} {
7539 global diffcontextstring diffcontext
7541 if {[string is integer -strict $diffcontextstring]} {
7542 if {$diffcontextstring >= 0} {
7543 set diffcontext $diffcontextstring
7544 reselectline
7549 proc changeignorespace {} {
7550 reselectline
7553 proc changeworddiff {name ix op} {
7554 reselectline
7557 proc getblobdiffs {ids} {
7558 global blobdifffd diffids env
7559 global diffinhdr treediffs
7560 global diffcontext
7561 global ignorespace
7562 global worddiff
7563 global limitdiffs vfilelimit curview
7564 global diffencoding targetline diffnparents
7565 global git_version currdiffsubmod
7567 set textconv {}
7568 if {[package vcompare $git_version "1.6.1"] >= 0} {
7569 set textconv "--textconv"
7571 set submodule {}
7572 if {[package vcompare $git_version "1.6.6"] >= 0} {
7573 set submodule "--submodule"
7575 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7576 if {$ignorespace} {
7577 append cmd " -w"
7579 if {$worddiff ne [mc "Line diff"]} {
7580 append cmd " --word-diff=porcelain"
7582 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7583 set cmd [concat $cmd -- $vfilelimit($curview)]
7585 if {[catch {set bdf [open $cmd r]} err]} {
7586 error_popup [mc "Error getting diffs: %s" $err]
7587 return
7589 set targetline {}
7590 set diffnparents 0
7591 set diffinhdr 0
7592 set diffencoding [get_path_encoding {}]
7593 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7594 set blobdifffd($ids) $bdf
7595 set currdiffsubmod ""
7596 filerun $bdf [list getblobdiffline $bdf $diffids]
7599 proc savecmitpos {} {
7600 global ctext cmitmode
7602 if {$cmitmode eq "tree"} {
7603 return {}
7605 return [list target_scrollpos [$ctext index @0,0]]
7608 proc savectextpos {} {
7609 global ctext
7611 return [list target_scrollpos [$ctext index @0,0]]
7614 proc maybe_scroll_ctext {ateof} {
7615 global ctext target_scrollpos
7617 if {![info exists target_scrollpos]} return
7618 if {!$ateof} {
7619 set nlines [expr {[winfo height $ctext]
7620 / [font metrics textfont -linespace]}]
7621 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7623 $ctext yview $target_scrollpos
7624 unset target_scrollpos
7627 proc setinlist {var i val} {
7628 global $var
7630 while {[llength [set $var]] < $i} {
7631 lappend $var {}
7633 if {[llength [set $var]] == $i} {
7634 lappend $var $val
7635 } else {
7636 lset $var $i $val
7640 proc makediffhdr {fname ids} {
7641 global ctext curdiffstart treediffs diffencoding
7642 global ctext_file_names jump_to_here targetline diffline
7644 set fname [encoding convertfrom $fname]
7645 set diffencoding [get_path_encoding $fname]
7646 set i [lsearch -exact $treediffs($ids) $fname]
7647 if {$i >= 0} {
7648 setinlist difffilestart $i $curdiffstart
7650 lset ctext_file_names end $fname
7651 set l [expr {(78 - [string length $fname]) / 2}]
7652 set pad [string range "----------------------------------------" 1 $l]
7653 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7654 set targetline {}
7655 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7656 set targetline [lindex $jump_to_here 1]
7658 set diffline 0
7661 proc getblobdiffline {bdf ids} {
7662 global diffids blobdifffd ctext curdiffstart
7663 global diffnexthead diffnextnote difffilestart
7664 global ctext_file_names ctext_file_lines
7665 global diffinhdr treediffs mergemax diffnparents
7666 global diffencoding jump_to_here targetline diffline currdiffsubmod
7667 global worddiff
7669 set nr 0
7670 $ctext conf -state normal
7671 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7672 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7673 catch {close $bdf}
7674 return 0
7676 if {![string compare -length 5 "diff " $line]} {
7677 if {![regexp {^diff (--cc|--git) } $line m type]} {
7678 set line [encoding convertfrom $line]
7679 $ctext insert end "$line\n" hunksep
7680 continue
7682 # start of a new file
7683 set diffinhdr 1
7684 $ctext insert end "\n"
7685 set curdiffstart [$ctext index "end - 1c"]
7686 lappend ctext_file_names ""
7687 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7688 $ctext insert end "\n" filesep
7690 if {$type eq "--cc"} {
7691 # start of a new file in a merge diff
7692 set fname [string range $line 10 end]
7693 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7694 lappend treediffs($ids) $fname
7695 add_flist [list $fname]
7698 } else {
7699 set line [string range $line 11 end]
7700 # If the name hasn't changed the length will be odd,
7701 # the middle char will be a space, and the two bits either
7702 # side will be a/name and b/name, or "a/name" and "b/name".
7703 # If the name has changed we'll get "rename from" and
7704 # "rename to" or "copy from" and "copy to" lines following
7705 # this, and we'll use them to get the filenames.
7706 # This complexity is necessary because spaces in the
7707 # filename(s) don't get escaped.
7708 set l [string length $line]
7709 set i [expr {$l / 2}]
7710 if {!(($l & 1) && [string index $line $i] eq " " &&
7711 [string range $line 2 [expr {$i - 1}]] eq \
7712 [string range $line [expr {$i + 3}] end])} {
7713 continue
7715 # unescape if quoted and chop off the a/ from the front
7716 if {[string index $line 0] eq "\""} {
7717 set fname [string range [lindex $line 0] 2 end]
7718 } else {
7719 set fname [string range $line 2 [expr {$i - 1}]]
7722 makediffhdr $fname $ids
7724 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7725 set fname [encoding convertfrom [string range $line 16 end]]
7726 $ctext insert end "\n"
7727 set curdiffstart [$ctext index "end - 1c"]
7728 lappend ctext_file_names $fname
7729 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7730 $ctext insert end "$line\n" filesep
7731 set i [lsearch -exact $treediffs($ids) $fname]
7732 if {$i >= 0} {
7733 setinlist difffilestart $i $curdiffstart
7736 } elseif {![string compare -length 2 "@@" $line]} {
7737 regexp {^@@+} $line ats
7738 set line [encoding convertfrom $diffencoding $line]
7739 $ctext insert end "$line\n" hunksep
7740 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7741 set diffline $nl
7743 set diffnparents [expr {[string length $ats] - 1}]
7744 set diffinhdr 0
7746 } elseif {![string compare -length 10 "Submodule " $line]} {
7747 # start of a new submodule
7748 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
7749 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
7750 } else {
7751 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
7753 if {$currdiffsubmod != $fname} {
7754 $ctext insert end "\n"; # Add newline after commit message
7756 set curdiffstart [$ctext index "end - 1c"]
7757 lappend ctext_file_names ""
7758 if {$currdiffsubmod != $fname} {
7759 lappend ctext_file_lines $fname
7760 makediffhdr $fname $ids
7761 set currdiffsubmod $fname
7762 $ctext insert end "\n$line\n" filesep
7763 } else {
7764 $ctext insert end "$line\n" filesep
7766 } elseif {![string compare -length 3 " >" $line]} {
7767 set $currdiffsubmod ""
7768 set line [encoding convertfrom $diffencoding $line]
7769 $ctext insert end "$line\n" dresult
7770 } elseif {![string compare -length 3 " <" $line]} {
7771 set $currdiffsubmod ""
7772 set line [encoding convertfrom $diffencoding $line]
7773 $ctext insert end "$line\n" d0
7774 } elseif {$diffinhdr} {
7775 if {![string compare -length 12 "rename from " $line]} {
7776 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7777 if {[string index $fname 0] eq "\""} {
7778 set fname [lindex $fname 0]
7780 set fname [encoding convertfrom $fname]
7781 set i [lsearch -exact $treediffs($ids) $fname]
7782 if {$i >= 0} {
7783 setinlist difffilestart $i $curdiffstart
7785 } elseif {![string compare -length 10 $line "rename to "] ||
7786 ![string compare -length 8 $line "copy to "]} {
7787 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7788 if {[string index $fname 0] eq "\""} {
7789 set fname [lindex $fname 0]
7791 makediffhdr $fname $ids
7792 } elseif {[string compare -length 3 $line "---"] == 0} {
7793 # do nothing
7794 continue
7795 } elseif {[string compare -length 3 $line "+++"] == 0} {
7796 set diffinhdr 0
7797 continue
7799 $ctext insert end "$line\n" filesep
7801 } else {
7802 set line [string map {\x1A ^Z} \
7803 [encoding convertfrom $diffencoding $line]]
7804 # parse the prefix - one ' ', '-' or '+' for each parent
7805 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7806 set tag [expr {$diffnparents > 1? "m": "d"}]
7807 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
7808 set words_pre_markup ""
7809 set words_post_markup ""
7810 if {[string trim $prefix " -+"] eq {}} {
7811 # prefix only has " ", "-" and "+" in it: normal diff line
7812 set num [string first "-" $prefix]
7813 if {$dowords} {
7814 set line [string range $line 1 end]
7816 if {$num >= 0} {
7817 # removed line, first parent with line is $num
7818 if {$num >= $mergemax} {
7819 set num "max"
7821 if {$dowords && $worddiff eq [mc "Markup words"]} {
7822 $ctext insert end "\[-$line-\]" $tag$num
7823 } else {
7824 $ctext insert end "$line" $tag$num
7826 if {!$dowords} {
7827 $ctext insert end "\n" $tag$num
7829 } else {
7830 set tags {}
7831 if {[string first "+" $prefix] >= 0} {
7832 # added line
7833 lappend tags ${tag}result
7834 if {$diffnparents > 1} {
7835 set num [string first " " $prefix]
7836 if {$num >= 0} {
7837 if {$num >= $mergemax} {
7838 set num "max"
7840 lappend tags m$num
7843 set words_pre_markup "{+"
7844 set words_post_markup "+}"
7846 if {$targetline ne {}} {
7847 if {$diffline == $targetline} {
7848 set seehere [$ctext index "end - 1 chars"]
7849 set targetline {}
7850 } else {
7851 incr diffline
7854 if {$dowords && $worddiff eq [mc "Markup words"]} {
7855 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
7856 } else {
7857 $ctext insert end "$line" $tags
7859 if {!$dowords} {
7860 $ctext insert end "\n" $tags
7863 } elseif {$dowords && $prefix eq "~"} {
7864 $ctext insert end "\n" {}
7865 } else {
7866 # "\ No newline at end of file",
7867 # or something else we don't recognize
7868 $ctext insert end "$line\n" hunksep
7872 if {[info exists seehere]} {
7873 mark_ctext_line [lindex [split $seehere .] 0]
7875 maybe_scroll_ctext [eof $bdf]
7876 $ctext conf -state disabled
7877 if {[eof $bdf]} {
7878 catch {close $bdf}
7879 return 0
7881 return [expr {$nr >= 1000? 2: 1}]
7884 proc changediffdisp {} {
7885 global ctext diffelide
7887 $ctext tag conf d0 -elide [lindex $diffelide 0]
7888 $ctext tag conf dresult -elide [lindex $diffelide 1]
7891 proc highlightfile {loc cline} {
7892 global ctext cflist cflist_top
7894 $ctext yview $loc
7895 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7896 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7897 $cflist see $cline.0
7898 set cflist_top $cline
7901 proc prevfile {} {
7902 global difffilestart ctext cmitmode
7904 if {$cmitmode eq "tree"} return
7905 set prev 0.0
7906 set prevline 1
7907 set here [$ctext index @0,0]
7908 foreach loc $difffilestart {
7909 if {[$ctext compare $loc >= $here]} {
7910 highlightfile $prev $prevline
7911 return
7913 set prev $loc
7914 incr prevline
7916 highlightfile $prev $prevline
7919 proc nextfile {} {
7920 global difffilestart ctext cmitmode
7922 if {$cmitmode eq "tree"} return
7923 set here [$ctext index @0,0]
7924 set line 1
7925 foreach loc $difffilestart {
7926 incr line
7927 if {[$ctext compare $loc > $here]} {
7928 highlightfile $loc $line
7929 return
7934 proc clear_ctext {{first 1.0}} {
7935 global ctext smarktop smarkbot
7936 global ctext_file_names ctext_file_lines
7937 global pendinglinks
7939 set l [lindex [split $first .] 0]
7940 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7941 set smarktop $l
7943 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7944 set smarkbot $l
7946 $ctext delete $first end
7947 if {$first eq "1.0"} {
7948 catch {unset pendinglinks}
7950 set ctext_file_names {}
7951 set ctext_file_lines {}
7954 proc settabs {{firstab {}}} {
7955 global firsttabstop tabstop ctext have_tk85
7957 if {$firstab ne {} && $have_tk85} {
7958 set firsttabstop $firstab
7960 set w [font measure textfont "0"]
7961 if {$firsttabstop != 0} {
7962 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7963 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7964 } elseif {$have_tk85 || $tabstop != 8} {
7965 $ctext conf -tabs [expr {$tabstop * $w}]
7966 } else {
7967 $ctext conf -tabs {}
7971 proc incrsearch {name ix op} {
7972 global ctext searchstring searchdirn
7974 $ctext tag remove found 1.0 end
7975 if {[catch {$ctext index anchor}]} {
7976 # no anchor set, use start of selection, or of visible area
7977 set sel [$ctext tag ranges sel]
7978 if {$sel ne {}} {
7979 $ctext mark set anchor [lindex $sel 0]
7980 } elseif {$searchdirn eq "-forwards"} {
7981 $ctext mark set anchor @0,0
7982 } else {
7983 $ctext mark set anchor @0,[winfo height $ctext]
7986 if {$searchstring ne {}} {
7987 set here [$ctext search $searchdirn -- $searchstring anchor]
7988 if {$here ne {}} {
7989 $ctext see $here
7991 searchmarkvisible 1
7995 proc dosearch {} {
7996 global sstring ctext searchstring searchdirn
7998 focus $sstring
7999 $sstring icursor end
8000 set searchdirn -forwards
8001 if {$searchstring ne {}} {
8002 set sel [$ctext tag ranges sel]
8003 if {$sel ne {}} {
8004 set start "[lindex $sel 0] + 1c"
8005 } elseif {[catch {set start [$ctext index anchor]}]} {
8006 set start "@0,0"
8008 set match [$ctext search -count mlen -- $searchstring $start]
8009 $ctext tag remove sel 1.0 end
8010 if {$match eq {}} {
8011 bell
8012 return
8014 $ctext see $match
8015 set mend "$match + $mlen c"
8016 $ctext tag add sel $match $mend
8017 $ctext mark unset anchor
8021 proc dosearchback {} {
8022 global sstring ctext searchstring searchdirn
8024 focus $sstring
8025 $sstring icursor end
8026 set searchdirn -backwards
8027 if {$searchstring ne {}} {
8028 set sel [$ctext tag ranges sel]
8029 if {$sel ne {}} {
8030 set start [lindex $sel 0]
8031 } elseif {[catch {set start [$ctext index anchor]}]} {
8032 set start @0,[winfo height $ctext]
8034 set match [$ctext search -backwards -count ml -- $searchstring $start]
8035 $ctext tag remove sel 1.0 end
8036 if {$match eq {}} {
8037 bell
8038 return
8040 $ctext see $match
8041 set mend "$match + $ml c"
8042 $ctext tag add sel $match $mend
8043 $ctext mark unset anchor
8047 proc searchmark {first last} {
8048 global ctext searchstring
8050 set mend $first.0
8051 while {1} {
8052 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8053 if {$match eq {}} break
8054 set mend "$match + $mlen c"
8055 $ctext tag add found $match $mend
8059 proc searchmarkvisible {doall} {
8060 global ctext smarktop smarkbot
8062 set topline [lindex [split [$ctext index @0,0] .] 0]
8063 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8064 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8065 # no overlap with previous
8066 searchmark $topline $botline
8067 set smarktop $topline
8068 set smarkbot $botline
8069 } else {
8070 if {$topline < $smarktop} {
8071 searchmark $topline [expr {$smarktop-1}]
8072 set smarktop $topline
8074 if {$botline > $smarkbot} {
8075 searchmark [expr {$smarkbot+1}] $botline
8076 set smarkbot $botline
8081 proc scrolltext {f0 f1} {
8082 global searchstring
8084 .bleft.bottom.sb set $f0 $f1
8085 if {$searchstring ne {}} {
8086 searchmarkvisible 0
8090 proc setcoords {} {
8091 global linespc charspc canvx0 canvy0
8092 global xspc1 xspc2 lthickness
8094 set linespc [font metrics mainfont -linespace]
8095 set charspc [font measure mainfont "m"]
8096 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8097 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8098 set lthickness [expr {int($linespc / 9) + 1}]
8099 set xspc1(0) $linespc
8100 set xspc2 $linespc
8103 proc redisplay {} {
8104 global canv
8105 global selectedline
8107 set ymax [lindex [$canv cget -scrollregion] 3]
8108 if {$ymax eq {} || $ymax == 0} return
8109 set span [$canv yview]
8110 clear_display
8111 setcanvscroll
8112 allcanvs yview moveto [lindex $span 0]
8113 drawvisible
8114 if {$selectedline ne {}} {
8115 selectline $selectedline 0
8116 allcanvs yview moveto [lindex $span 0]
8120 proc parsefont {f n} {
8121 global fontattr
8123 set fontattr($f,family) [lindex $n 0]
8124 set s [lindex $n 1]
8125 if {$s eq {} || $s == 0} {
8126 set s 10
8127 } elseif {$s < 0} {
8128 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8130 set fontattr($f,size) $s
8131 set fontattr($f,weight) normal
8132 set fontattr($f,slant) roman
8133 foreach style [lrange $n 2 end] {
8134 switch -- $style {
8135 "normal" -
8136 "bold" {set fontattr($f,weight) $style}
8137 "roman" -
8138 "italic" {set fontattr($f,slant) $style}
8143 proc fontflags {f {isbold 0}} {
8144 global fontattr
8146 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8147 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8148 -slant $fontattr($f,slant)]
8151 proc fontname {f} {
8152 global fontattr
8154 set n [list $fontattr($f,family) $fontattr($f,size)]
8155 if {$fontattr($f,weight) eq "bold"} {
8156 lappend n "bold"
8158 if {$fontattr($f,slant) eq "italic"} {
8159 lappend n "italic"
8161 return $n
8164 proc incrfont {inc} {
8165 global mainfont textfont ctext canv cflist showrefstop
8166 global stopped entries fontattr
8168 unmarkmatches
8169 set s $fontattr(mainfont,size)
8170 incr s $inc
8171 if {$s < 1} {
8172 set s 1
8174 set fontattr(mainfont,size) $s
8175 font config mainfont -size $s
8176 font config mainfontbold -size $s
8177 set mainfont [fontname mainfont]
8178 set s $fontattr(textfont,size)
8179 incr s $inc
8180 if {$s < 1} {
8181 set s 1
8183 set fontattr(textfont,size) $s
8184 font config textfont -size $s
8185 font config textfontbold -size $s
8186 set textfont [fontname textfont]
8187 setcoords
8188 settabs
8189 redisplay
8192 proc clearsha1 {} {
8193 global sha1entry sha1string
8194 if {[string length $sha1string] == 40} {
8195 $sha1entry delete 0 end
8199 proc sha1change {n1 n2 op} {
8200 global sha1string currentid sha1but
8201 if {$sha1string == {}
8202 || ([info exists currentid] && $sha1string == $currentid)} {
8203 set state disabled
8204 } else {
8205 set state normal
8207 if {[$sha1but cget -state] == $state} return
8208 if {$state == "normal"} {
8209 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8210 } else {
8211 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8215 proc gotocommit {} {
8216 global sha1string tagids headids curview varcid
8218 if {$sha1string == {}
8219 || ([info exists currentid] && $sha1string == $currentid)} return
8220 if {[info exists tagids($sha1string)]} {
8221 set id $tagids($sha1string)
8222 } elseif {[info exists headids($sha1string)]} {
8223 set id $headids($sha1string)
8224 } else {
8225 set id [string tolower $sha1string]
8226 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8227 set matches [longid $id]
8228 if {$matches ne {}} {
8229 if {[llength $matches] > 1} {
8230 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8231 return
8233 set id [lindex $matches 0]
8235 } else {
8236 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8237 error_popup [mc "Revision %s is not known" $sha1string]
8238 return
8242 if {[commitinview $id $curview]} {
8243 selectline [rowofcommit $id] 1
8244 return
8246 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8247 set msg [mc "SHA1 id %s is not known" $sha1string]
8248 } else {
8249 set msg [mc "Revision %s is not in the current view" $sha1string]
8251 error_popup $msg
8254 proc lineenter {x y id} {
8255 global hoverx hovery hoverid hovertimer
8256 global commitinfo canv
8258 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8259 set hoverx $x
8260 set hovery $y
8261 set hoverid $id
8262 if {[info exists hovertimer]} {
8263 after cancel $hovertimer
8265 set hovertimer [after 500 linehover]
8266 $canv delete hover
8269 proc linemotion {x y id} {
8270 global hoverx hovery hoverid hovertimer
8272 if {[info exists hoverid] && $id == $hoverid} {
8273 set hoverx $x
8274 set hovery $y
8275 if {[info exists hovertimer]} {
8276 after cancel $hovertimer
8278 set hovertimer [after 500 linehover]
8282 proc lineleave {id} {
8283 global hoverid hovertimer canv
8285 if {[info exists hoverid] && $id == $hoverid} {
8286 $canv delete hover
8287 if {[info exists hovertimer]} {
8288 after cancel $hovertimer
8289 unset hovertimer
8291 unset hoverid
8295 proc linehover {} {
8296 global hoverx hovery hoverid hovertimer
8297 global canv linespc lthickness
8298 global commitinfo
8300 set text [lindex $commitinfo($hoverid) 0]
8301 set ymax [lindex [$canv cget -scrollregion] 3]
8302 if {$ymax == {}} return
8303 set yfrac [lindex [$canv yview] 0]
8304 set x [expr {$hoverx + 2 * $linespc}]
8305 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8306 set x0 [expr {$x - 2 * $lthickness}]
8307 set y0 [expr {$y - 2 * $lthickness}]
8308 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8309 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8310 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8311 -fill \#ffff80 -outline black -width 1 -tags hover]
8312 $canv raise $t
8313 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8314 -font mainfont]
8315 $canv raise $t
8318 proc clickisonarrow {id y} {
8319 global lthickness
8321 set ranges [rowranges $id]
8322 set thresh [expr {2 * $lthickness + 6}]
8323 set n [expr {[llength $ranges] - 1}]
8324 for {set i 1} {$i < $n} {incr i} {
8325 set row [lindex $ranges $i]
8326 if {abs([yc $row] - $y) < $thresh} {
8327 return $i
8330 return {}
8333 proc arrowjump {id n y} {
8334 global canv
8336 # 1 <-> 2, 3 <-> 4, etc...
8337 set n [expr {(($n - 1) ^ 1) + 1}]
8338 set row [lindex [rowranges $id] $n]
8339 set yt [yc $row]
8340 set ymax [lindex [$canv cget -scrollregion] 3]
8341 if {$ymax eq {} || $ymax <= 0} return
8342 set view [$canv yview]
8343 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8344 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8345 if {$yfrac < 0} {
8346 set yfrac 0
8348 allcanvs yview moveto $yfrac
8351 proc lineclick {x y id isnew} {
8352 global ctext commitinfo children canv thickerline curview
8354 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8355 unmarkmatches
8356 unselectline
8357 normalline
8358 $canv delete hover
8359 # draw this line thicker than normal
8360 set thickerline $id
8361 drawlines $id
8362 if {$isnew} {
8363 set ymax [lindex [$canv cget -scrollregion] 3]
8364 if {$ymax eq {}} return
8365 set yfrac [lindex [$canv yview] 0]
8366 set y [expr {$y + $yfrac * $ymax}]
8368 set dirn [clickisonarrow $id $y]
8369 if {$dirn ne {}} {
8370 arrowjump $id $dirn $y
8371 return
8374 if {$isnew} {
8375 addtohistory [list lineclick $x $y $id 0] savectextpos
8377 # fill the details pane with info about this line
8378 $ctext conf -state normal
8379 clear_ctext
8380 settabs 0
8381 $ctext insert end "[mc "Parent"]:\t"
8382 $ctext insert end $id link0
8383 setlink $id link0
8384 set info $commitinfo($id)
8385 $ctext insert end "\n\t[lindex $info 0]\n"
8386 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8387 set date [formatdate [lindex $info 2]]
8388 $ctext insert end "\t[mc "Date"]:\t$date\n"
8389 set kids $children($curview,$id)
8390 if {$kids ne {}} {
8391 $ctext insert end "\n[mc "Children"]:"
8392 set i 0
8393 foreach child $kids {
8394 incr i
8395 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8396 set info $commitinfo($child)
8397 $ctext insert end "\n\t"
8398 $ctext insert end $child link$i
8399 setlink $child link$i
8400 $ctext insert end "\n\t[lindex $info 0]"
8401 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8402 set date [formatdate [lindex $info 2]]
8403 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8406 maybe_scroll_ctext 1
8407 $ctext conf -state disabled
8408 init_flist {}
8411 proc normalline {} {
8412 global thickerline
8413 if {[info exists thickerline]} {
8414 set id $thickerline
8415 unset thickerline
8416 drawlines $id
8420 proc selbyid {id {isnew 1}} {
8421 global curview
8422 if {[commitinview $id $curview]} {
8423 selectline [rowofcommit $id] $isnew
8427 proc mstime {} {
8428 global startmstime
8429 if {![info exists startmstime]} {
8430 set startmstime [clock clicks -milliseconds]
8432 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8435 proc rowmenu {x y id} {
8436 global rowctxmenu selectedline rowmenuid curview
8437 global nullid nullid2 fakerowmenu mainhead markedid
8439 stopfinding
8440 set rowmenuid $id
8441 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8442 set state disabled
8443 } else {
8444 set state normal
8446 if {$id ne $nullid && $id ne $nullid2} {
8447 set menu $rowctxmenu
8448 if {$mainhead ne {}} {
8449 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8450 } else {
8451 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8453 if {[info exists markedid] && $markedid ne $id} {
8454 $menu entryconfigure 9 -state normal
8455 $menu entryconfigure 10 -state normal
8456 $menu entryconfigure 11 -state normal
8457 } else {
8458 $menu entryconfigure 9 -state disabled
8459 $menu entryconfigure 10 -state disabled
8460 $menu entryconfigure 11 -state disabled
8462 } else {
8463 set menu $fakerowmenu
8465 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8466 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8467 $menu entryconfigure [mca "Make patch"] -state $state
8468 tk_popup $menu $x $y
8471 proc markhere {} {
8472 global rowmenuid markedid canv
8474 set markedid $rowmenuid
8475 make_idmark $markedid
8478 proc gotomark {} {
8479 global markedid
8481 if {[info exists markedid]} {
8482 selbyid $markedid
8486 proc replace_by_kids {l r} {
8487 global curview children
8489 set id [commitonrow $r]
8490 set l [lreplace $l 0 0]
8491 foreach kid $children($curview,$id) {
8492 lappend l [rowofcommit $kid]
8494 return [lsort -integer -decreasing -unique $l]
8497 proc find_common_desc {} {
8498 global markedid rowmenuid curview children
8500 if {![info exists markedid]} return
8501 if {![commitinview $markedid $curview] ||
8502 ![commitinview $rowmenuid $curview]} return
8503 #set t1 [clock clicks -milliseconds]
8504 set l1 [list [rowofcommit $markedid]]
8505 set l2 [list [rowofcommit $rowmenuid]]
8506 while 1 {
8507 set r1 [lindex $l1 0]
8508 set r2 [lindex $l2 0]
8509 if {$r1 eq {} || $r2 eq {}} break
8510 if {$r1 == $r2} {
8511 selectline $r1 1
8512 break
8514 if {$r1 > $r2} {
8515 set l1 [replace_by_kids $l1 $r1]
8516 } else {
8517 set l2 [replace_by_kids $l2 $r2]
8520 #set t2 [clock clicks -milliseconds]
8521 #puts "took [expr {$t2-$t1}]ms"
8524 proc compare_commits {} {
8525 global markedid rowmenuid curview children
8527 if {![info exists markedid]} return
8528 if {![commitinview $markedid $curview]} return
8529 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8530 do_cmp_commits $markedid $rowmenuid
8533 proc getpatchid {id} {
8534 global patchids
8536 if {![info exists patchids($id)]} {
8537 set cmd [diffcmd [list $id] {-p --root}]
8538 # trim off the initial "|"
8539 set cmd [lrange $cmd 1 end]
8540 if {[catch {
8541 set x [eval exec $cmd | git patch-id]
8542 set patchids($id) [lindex $x 0]
8543 }]} {
8544 set patchids($id) "error"
8547 return $patchids($id)
8550 proc do_cmp_commits {a b} {
8551 global ctext curview parents children patchids commitinfo
8553 $ctext conf -state normal
8554 clear_ctext
8555 init_flist {}
8556 for {set i 0} {$i < 100} {incr i} {
8557 set skipa 0
8558 set skipb 0
8559 if {[llength $parents($curview,$a)] > 1} {
8560 appendshortlink $a [mc "Skipping merge commit "] "\n"
8561 set skipa 1
8562 } else {
8563 set patcha [getpatchid $a]
8565 if {[llength $parents($curview,$b)] > 1} {
8566 appendshortlink $b [mc "Skipping merge commit "] "\n"
8567 set skipb 1
8568 } else {
8569 set patchb [getpatchid $b]
8571 if {!$skipa && !$skipb} {
8572 set heada [lindex $commitinfo($a) 0]
8573 set headb [lindex $commitinfo($b) 0]
8574 if {$patcha eq "error"} {
8575 appendshortlink $a [mc "Error getting patch ID for "] \
8576 [mc " - stopping\n"]
8577 break
8579 if {$patchb eq "error"} {
8580 appendshortlink $b [mc "Error getting patch ID for "] \
8581 [mc " - stopping\n"]
8582 break
8584 if {$patcha eq $patchb} {
8585 if {$heada eq $headb} {
8586 appendshortlink $a [mc "Commit "]
8587 appendshortlink $b " == " " $heada\n"
8588 } else {
8589 appendshortlink $a [mc "Commit "] " $heada\n"
8590 appendshortlink $b [mc " is the same patch as\n "] \
8591 " $headb\n"
8593 set skipa 1
8594 set skipb 1
8595 } else {
8596 $ctext insert end "\n"
8597 appendshortlink $a [mc "Commit "] " $heada\n"
8598 appendshortlink $b [mc " differs from\n "] \
8599 " $headb\n"
8600 $ctext insert end [mc "Diff of commits:\n\n"]
8601 $ctext conf -state disabled
8602 update
8603 diffcommits $a $b
8604 return
8607 if {$skipa} {
8608 set kids [real_children $curview,$a]
8609 if {[llength $kids] != 1} {
8610 $ctext insert end "\n"
8611 appendshortlink $a [mc "Commit "] \
8612 [mc " has %s children - stopping\n" [llength $kids]]
8613 break
8615 set a [lindex $kids 0]
8617 if {$skipb} {
8618 set kids [real_children $curview,$b]
8619 if {[llength $kids] != 1} {
8620 appendshortlink $b [mc "Commit "] \
8621 [mc " has %s children - stopping\n" [llength $kids]]
8622 break
8624 set b [lindex $kids 0]
8627 $ctext conf -state disabled
8630 proc diffcommits {a b} {
8631 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
8633 set tmpdir [gitknewtmpdir]
8634 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8635 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8636 if {[catch {
8637 exec git diff-tree -p --pretty $a >$fna
8638 exec git diff-tree -p --pretty $b >$fnb
8639 } err]} {
8640 error_popup [mc "Error writing commit to file: %s" $err]
8641 return
8643 if {[catch {
8644 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8645 } err]} {
8646 error_popup [mc "Error diffing commits: %s" $err]
8647 return
8649 set diffids [list commits $a $b]
8650 set blobdifffd($diffids) $fd
8651 set diffinhdr 0
8652 set currdiffsubmod ""
8653 filerun $fd [list getblobdiffline $fd $diffids]
8656 proc diffvssel {dirn} {
8657 global rowmenuid selectedline
8659 if {$selectedline eq {}} return
8660 if {$dirn} {
8661 set oldid [commitonrow $selectedline]
8662 set newid $rowmenuid
8663 } else {
8664 set oldid $rowmenuid
8665 set newid [commitonrow $selectedline]
8667 addtohistory [list doseldiff $oldid $newid] savectextpos
8668 doseldiff $oldid $newid
8671 proc doseldiff {oldid newid} {
8672 global ctext
8673 global commitinfo
8675 $ctext conf -state normal
8676 clear_ctext
8677 init_flist [mc "Top"]
8678 $ctext insert end "[mc "From"] "
8679 $ctext insert end $oldid link0
8680 setlink $oldid link0
8681 $ctext insert end "\n "
8682 $ctext insert end [lindex $commitinfo($oldid) 0]
8683 $ctext insert end "\n\n[mc "To"] "
8684 $ctext insert end $newid link1
8685 setlink $newid link1
8686 $ctext insert end "\n "
8687 $ctext insert end [lindex $commitinfo($newid) 0]
8688 $ctext insert end "\n"
8689 $ctext conf -state disabled
8690 $ctext tag remove found 1.0 end
8691 startdiff [list $oldid $newid]
8694 proc mkpatch {} {
8695 global rowmenuid currentid commitinfo patchtop patchnum NS
8697 if {![info exists currentid]} return
8698 set oldid $currentid
8699 set oldhead [lindex $commitinfo($oldid) 0]
8700 set newid $rowmenuid
8701 set newhead [lindex $commitinfo($newid) 0]
8702 set top .patch
8703 set patchtop $top
8704 catch {destroy $top}
8705 ttk_toplevel $top
8706 make_transient $top .
8707 ${NS}::label $top.title -text [mc "Generate patch"]
8708 grid $top.title - -pady 10
8709 ${NS}::label $top.from -text [mc "From:"]
8710 ${NS}::entry $top.fromsha1 -width 40
8711 $top.fromsha1 insert 0 $oldid
8712 $top.fromsha1 conf -state readonly
8713 grid $top.from $top.fromsha1 -sticky w
8714 ${NS}::entry $top.fromhead -width 60
8715 $top.fromhead insert 0 $oldhead
8716 $top.fromhead conf -state readonly
8717 grid x $top.fromhead -sticky w
8718 ${NS}::label $top.to -text [mc "To:"]
8719 ${NS}::entry $top.tosha1 -width 40
8720 $top.tosha1 insert 0 $newid
8721 $top.tosha1 conf -state readonly
8722 grid $top.to $top.tosha1 -sticky w
8723 ${NS}::entry $top.tohead -width 60
8724 $top.tohead insert 0 $newhead
8725 $top.tohead conf -state readonly
8726 grid x $top.tohead -sticky w
8727 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8728 grid $top.rev x -pady 10 -padx 5
8729 ${NS}::label $top.flab -text [mc "Output file:"]
8730 ${NS}::entry $top.fname -width 60
8731 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8732 incr patchnum
8733 grid $top.flab $top.fname -sticky w
8734 ${NS}::frame $top.buts
8735 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8736 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8737 bind $top <Key-Return> mkpatchgo
8738 bind $top <Key-Escape> mkpatchcan
8739 grid $top.buts.gen $top.buts.can
8740 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8741 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8742 grid $top.buts - -pady 10 -sticky ew
8743 focus $top.fname
8746 proc mkpatchrev {} {
8747 global patchtop
8749 set oldid [$patchtop.fromsha1 get]
8750 set oldhead [$patchtop.fromhead get]
8751 set newid [$patchtop.tosha1 get]
8752 set newhead [$patchtop.tohead get]
8753 foreach e [list fromsha1 fromhead tosha1 tohead] \
8754 v [list $newid $newhead $oldid $oldhead] {
8755 $patchtop.$e conf -state normal
8756 $patchtop.$e delete 0 end
8757 $patchtop.$e insert 0 $v
8758 $patchtop.$e conf -state readonly
8762 proc mkpatchgo {} {
8763 global patchtop nullid nullid2
8765 set oldid [$patchtop.fromsha1 get]
8766 set newid [$patchtop.tosha1 get]
8767 set fname [$patchtop.fname get]
8768 set cmd [diffcmd [list $oldid $newid] -p]
8769 # trim off the initial "|"
8770 set cmd [lrange $cmd 1 end]
8771 lappend cmd >$fname &
8772 if {[catch {eval exec $cmd} err]} {
8773 error_popup "[mc "Error creating patch:"] $err" $patchtop
8775 catch {destroy $patchtop}
8776 unset patchtop
8779 proc mkpatchcan {} {
8780 global patchtop
8782 catch {destroy $patchtop}
8783 unset patchtop
8786 proc mktag {} {
8787 global rowmenuid mktagtop commitinfo NS
8789 set top .maketag
8790 set mktagtop $top
8791 catch {destroy $top}
8792 ttk_toplevel $top
8793 make_transient $top .
8794 ${NS}::label $top.title -text [mc "Create tag"]
8795 grid $top.title - -pady 10
8796 ${NS}::label $top.id -text [mc "ID:"]
8797 ${NS}::entry $top.sha1 -width 40
8798 $top.sha1 insert 0 $rowmenuid
8799 $top.sha1 conf -state readonly
8800 grid $top.id $top.sha1 -sticky w
8801 ${NS}::entry $top.head -width 60
8802 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8803 $top.head conf -state readonly
8804 grid x $top.head -sticky w
8805 ${NS}::label $top.tlab -text [mc "Tag name:"]
8806 ${NS}::entry $top.tag -width 60
8807 grid $top.tlab $top.tag -sticky w
8808 ${NS}::label $top.op -text [mc "Tag message is optional"]
8809 grid $top.op -columnspan 2 -sticky we
8810 ${NS}::label $top.mlab -text [mc "Tag message:"]
8811 ${NS}::entry $top.msg -width 60
8812 grid $top.mlab $top.msg -sticky w
8813 ${NS}::frame $top.buts
8814 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8815 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8816 bind $top <Key-Return> mktaggo
8817 bind $top <Key-Escape> mktagcan
8818 grid $top.buts.gen $top.buts.can
8819 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8820 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8821 grid $top.buts - -pady 10 -sticky ew
8822 focus $top.tag
8825 proc domktag {} {
8826 global mktagtop env tagids idtags
8828 set id [$mktagtop.sha1 get]
8829 set tag [$mktagtop.tag get]
8830 set msg [$mktagtop.msg get]
8831 if {$tag == {}} {
8832 error_popup [mc "No tag name specified"] $mktagtop
8833 return 0
8835 if {[info exists tagids($tag)]} {
8836 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8837 return 0
8839 if {[catch {
8840 if {$msg != {}} {
8841 exec git tag -a -m $msg $tag $id
8842 } else {
8843 exec git tag $tag $id
8845 } err]} {
8846 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8847 return 0
8850 set tagids($tag) $id
8851 lappend idtags($id) $tag
8852 redrawtags $id
8853 addedtag $id
8854 dispneartags 0
8855 run refill_reflist
8856 return 1
8859 proc redrawtags {id} {
8860 global canv linehtag idpos currentid curview cmitlisted markedid
8861 global canvxmax iddrawn circleitem mainheadid circlecolors
8863 if {![commitinview $id $curview]} return
8864 if {![info exists iddrawn($id)]} return
8865 set row [rowofcommit $id]
8866 if {$id eq $mainheadid} {
8867 set ofill yellow
8868 } else {
8869 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8871 $canv itemconf $circleitem($row) -fill $ofill
8872 $canv delete tag.$id
8873 set xt [eval drawtags $id $idpos($id)]
8874 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8875 set text [$canv itemcget $linehtag($id) -text]
8876 set font [$canv itemcget $linehtag($id) -font]
8877 set xr [expr {$xt + [font measure $font $text]}]
8878 if {$xr > $canvxmax} {
8879 set canvxmax $xr
8880 setcanvscroll
8882 if {[info exists currentid] && $currentid == $id} {
8883 make_secsel $id
8885 if {[info exists markedid] && $markedid eq $id} {
8886 make_idmark $id
8890 proc mktagcan {} {
8891 global mktagtop
8893 catch {destroy $mktagtop}
8894 unset mktagtop
8897 proc mktaggo {} {
8898 if {![domktag]} return
8899 mktagcan
8902 proc writecommit {} {
8903 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8905 set top .writecommit
8906 set wrcomtop $top
8907 catch {destroy $top}
8908 ttk_toplevel $top
8909 make_transient $top .
8910 ${NS}::label $top.title -text [mc "Write commit to file"]
8911 grid $top.title - -pady 10
8912 ${NS}::label $top.id -text [mc "ID:"]
8913 ${NS}::entry $top.sha1 -width 40
8914 $top.sha1 insert 0 $rowmenuid
8915 $top.sha1 conf -state readonly
8916 grid $top.id $top.sha1 -sticky w
8917 ${NS}::entry $top.head -width 60
8918 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8919 $top.head conf -state readonly
8920 grid x $top.head -sticky w
8921 ${NS}::label $top.clab -text [mc "Command:"]
8922 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8923 grid $top.clab $top.cmd -sticky w -pady 10
8924 ${NS}::label $top.flab -text [mc "Output file:"]
8925 ${NS}::entry $top.fname -width 60
8926 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8927 grid $top.flab $top.fname -sticky w
8928 ${NS}::frame $top.buts
8929 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8930 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8931 bind $top <Key-Return> wrcomgo
8932 bind $top <Key-Escape> wrcomcan
8933 grid $top.buts.gen $top.buts.can
8934 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8935 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8936 grid $top.buts - -pady 10 -sticky ew
8937 focus $top.fname
8940 proc wrcomgo {} {
8941 global wrcomtop
8943 set id [$wrcomtop.sha1 get]
8944 set cmd "echo $id | [$wrcomtop.cmd get]"
8945 set fname [$wrcomtop.fname get]
8946 if {[catch {exec sh -c $cmd >$fname &} err]} {
8947 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8949 catch {destroy $wrcomtop}
8950 unset wrcomtop
8953 proc wrcomcan {} {
8954 global wrcomtop
8956 catch {destroy $wrcomtop}
8957 unset wrcomtop
8960 proc mkbranch {} {
8961 global rowmenuid mkbrtop NS
8963 set top .makebranch
8964 catch {destroy $top}
8965 ttk_toplevel $top
8966 make_transient $top .
8967 ${NS}::label $top.title -text [mc "Create new branch"]
8968 grid $top.title - -pady 10
8969 ${NS}::label $top.id -text [mc "ID:"]
8970 ${NS}::entry $top.sha1 -width 40
8971 $top.sha1 insert 0 $rowmenuid
8972 $top.sha1 conf -state readonly
8973 grid $top.id $top.sha1 -sticky w
8974 ${NS}::label $top.nlab -text [mc "Name:"]
8975 ${NS}::entry $top.name -width 40
8976 grid $top.nlab $top.name -sticky w
8977 ${NS}::frame $top.buts
8978 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8979 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8980 bind $top <Key-Return> [list mkbrgo $top]
8981 bind $top <Key-Escape> "catch {destroy $top}"
8982 grid $top.buts.go $top.buts.can
8983 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8984 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8985 grid $top.buts - -pady 10 -sticky ew
8986 focus $top.name
8989 proc mkbrgo {top} {
8990 global headids idheads
8992 set name [$top.name get]
8993 set id [$top.sha1 get]
8994 set cmdargs {}
8995 set old_id {}
8996 if {$name eq {}} {
8997 error_popup [mc "Please specify a name for the new branch"] $top
8998 return
9000 if {[info exists headids($name)]} {
9001 if {![confirm_popup [mc \
9002 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9003 return
9005 set old_id $headids($name)
9006 lappend cmdargs -f
9008 catch {destroy $top}
9009 lappend cmdargs $name $id
9010 nowbusy newbranch
9011 update
9012 if {[catch {
9013 eval exec git branch $cmdargs
9014 } err]} {
9015 notbusy newbranch
9016 error_popup $err
9017 } else {
9018 notbusy newbranch
9019 if {$old_id ne {}} {
9020 movehead $id $name
9021 movedhead $id $name
9022 redrawtags $old_id
9023 redrawtags $id
9024 } else {
9025 set headids($name) $id
9026 lappend idheads($id) $name
9027 addedhead $id $name
9028 redrawtags $id
9030 dispneartags 0
9031 run refill_reflist
9035 proc exec_citool {tool_args {baseid {}}} {
9036 global commitinfo env
9038 set save_env [array get env GIT_AUTHOR_*]
9040 if {$baseid ne {}} {
9041 if {![info exists commitinfo($baseid)]} {
9042 getcommit $baseid
9044 set author [lindex $commitinfo($baseid) 1]
9045 set date [lindex $commitinfo($baseid) 2]
9046 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9047 $author author name email]
9048 && $date ne {}} {
9049 set env(GIT_AUTHOR_NAME) $name
9050 set env(GIT_AUTHOR_EMAIL) $email
9051 set env(GIT_AUTHOR_DATE) $date
9055 eval exec git citool $tool_args &
9057 array unset env GIT_AUTHOR_*
9058 array set env $save_env
9061 proc cherrypick {} {
9062 global rowmenuid curview
9063 global mainhead mainheadid
9064 global gitdir
9066 set oldhead [exec git rev-parse HEAD]
9067 set dheads [descheads $rowmenuid]
9068 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9069 set ok [confirm_popup [mc "Commit %s is already\
9070 included in branch %s -- really re-apply it?" \
9071 [string range $rowmenuid 0 7] $mainhead]]
9072 if {!$ok} return
9074 nowbusy cherrypick [mc "Cherry-picking"]
9075 update
9076 # Unfortunately git-cherry-pick writes stuff to stderr even when
9077 # no error occurs, and exec takes that as an indication of error...
9078 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9079 notbusy cherrypick
9080 if {[regexp -line \
9081 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9082 $err msg fname]} {
9083 error_popup [mc "Cherry-pick failed because of local changes\
9084 to file '%s'.\nPlease commit, reset or stash\
9085 your changes and try again." $fname]
9086 } elseif {[regexp -line \
9087 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9088 $err]} {
9089 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9090 conflict.\nDo you wish to run git citool to\
9091 resolve it?"]]} {
9092 # Force citool to read MERGE_MSG
9093 file delete [file join $gitdir "GITGUI_MSG"]
9094 exec_citool {} $rowmenuid
9096 } else {
9097 error_popup $err
9099 run updatecommits
9100 return
9102 set newhead [exec git rev-parse HEAD]
9103 if {$newhead eq $oldhead} {
9104 notbusy cherrypick
9105 error_popup [mc "No changes committed"]
9106 return
9108 addnewchild $newhead $oldhead
9109 if {[commitinview $oldhead $curview]} {
9110 # XXX this isn't right if we have a path limit...
9111 insertrow $newhead $oldhead $curview
9112 if {$mainhead ne {}} {
9113 movehead $newhead $mainhead
9114 movedhead $newhead $mainhead
9116 set mainheadid $newhead
9117 redrawtags $oldhead
9118 redrawtags $newhead
9119 selbyid $newhead
9121 notbusy cherrypick
9124 proc resethead {} {
9125 global mainhead rowmenuid confirm_ok resettype NS
9127 set confirm_ok 0
9128 set w ".confirmreset"
9129 ttk_toplevel $w
9130 make_transient $w .
9131 wm title $w [mc "Confirm reset"]
9132 ${NS}::label $w.m -text \
9133 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9134 pack $w.m -side top -fill x -padx 20 -pady 20
9135 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9136 set resettype mixed
9137 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9138 -text [mc "Soft: Leave working tree and index untouched"]
9139 grid $w.f.soft -sticky w
9140 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9141 -text [mc "Mixed: Leave working tree untouched, reset index"]
9142 grid $w.f.mixed -sticky w
9143 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9144 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9145 grid $w.f.hard -sticky w
9146 pack $w.f -side top -fill x -padx 4
9147 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9148 pack $w.ok -side left -fill x -padx 20 -pady 20
9149 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9150 bind $w <Key-Escape> [list destroy $w]
9151 pack $w.cancel -side right -fill x -padx 20 -pady 20
9152 bind $w <Visibility> "grab $w; focus $w"
9153 tkwait window $w
9154 if {!$confirm_ok} return
9155 if {[catch {set fd [open \
9156 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9157 error_popup $err
9158 } else {
9159 dohidelocalchanges
9160 filerun $fd [list readresetstat $fd]
9161 nowbusy reset [mc "Resetting"]
9162 selbyid $rowmenuid
9166 proc readresetstat {fd} {
9167 global mainhead mainheadid showlocalchanges rprogcoord
9169 if {[gets $fd line] >= 0} {
9170 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9171 set rprogcoord [expr {1.0 * $m / $n}]
9172 adjustprogress
9174 return 1
9176 set rprogcoord 0
9177 adjustprogress
9178 notbusy reset
9179 if {[catch {close $fd} err]} {
9180 error_popup $err
9182 set oldhead $mainheadid
9183 set newhead [exec git rev-parse HEAD]
9184 if {$newhead ne $oldhead} {
9185 movehead $newhead $mainhead
9186 movedhead $newhead $mainhead
9187 set mainheadid $newhead
9188 redrawtags $oldhead
9189 redrawtags $newhead
9191 if {$showlocalchanges} {
9192 doshowlocalchanges
9194 return 0
9197 # context menu for a head
9198 proc headmenu {x y id head} {
9199 global headmenuid headmenuhead headctxmenu mainhead
9201 stopfinding
9202 set headmenuid $id
9203 set headmenuhead $head
9204 set state normal
9205 if {[string match "remotes/*" $head]} {
9206 set state disabled
9208 if {$head eq $mainhead} {
9209 set state disabled
9211 $headctxmenu entryconfigure 0 -state $state
9212 $headctxmenu entryconfigure 1 -state $state
9213 tk_popup $headctxmenu $x $y
9216 proc cobranch {} {
9217 global headmenuid headmenuhead headids
9218 global showlocalchanges
9220 # check the tree is clean first??
9221 nowbusy checkout [mc "Checking out"]
9222 update
9223 dohidelocalchanges
9224 if {[catch {
9225 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9226 } err]} {
9227 notbusy checkout
9228 error_popup $err
9229 if {$showlocalchanges} {
9230 dodiffindex
9232 } else {
9233 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9237 proc readcheckoutstat {fd newhead newheadid} {
9238 global mainhead mainheadid headids showlocalchanges progresscoords
9239 global viewmainheadid curview
9241 if {[gets $fd line] >= 0} {
9242 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9243 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9244 adjustprogress
9246 return 1
9248 set progresscoords {0 0}
9249 adjustprogress
9250 notbusy checkout
9251 if {[catch {close $fd} err]} {
9252 error_popup $err
9254 set oldmainid $mainheadid
9255 set mainhead $newhead
9256 set mainheadid $newheadid
9257 set viewmainheadid($curview) $newheadid
9258 redrawtags $oldmainid
9259 redrawtags $newheadid
9260 selbyid $newheadid
9261 if {$showlocalchanges} {
9262 dodiffindex
9266 proc rmbranch {} {
9267 global headmenuid headmenuhead mainhead
9268 global idheads
9270 set head $headmenuhead
9271 set id $headmenuid
9272 # this check shouldn't be needed any more...
9273 if {$head eq $mainhead} {
9274 error_popup [mc "Cannot delete the currently checked-out branch"]
9275 return
9277 set dheads [descheads $id]
9278 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9279 # the stuff on this branch isn't on any other branch
9280 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9281 branch.\nReally delete branch %s?" $head $head]]} return
9283 nowbusy rmbranch
9284 update
9285 if {[catch {exec git branch -D $head} err]} {
9286 notbusy rmbranch
9287 error_popup $err
9288 return
9290 removehead $id $head
9291 removedhead $id $head
9292 redrawtags $id
9293 notbusy rmbranch
9294 dispneartags 0
9295 run refill_reflist
9298 # Display a list of tags and heads
9299 proc showrefs {} {
9300 global showrefstop bgcolor fgcolor selectbgcolor NS
9301 global bglist fglist reflistfilter reflist maincursor
9303 set top .showrefs
9304 set showrefstop $top
9305 if {[winfo exists $top]} {
9306 raise $top
9307 refill_reflist
9308 return
9310 ttk_toplevel $top
9311 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9312 make_transient $top .
9313 text $top.list -background $bgcolor -foreground $fgcolor \
9314 -selectbackground $selectbgcolor -font mainfont \
9315 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9316 -width 30 -height 20 -cursor $maincursor \
9317 -spacing1 1 -spacing3 1 -state disabled
9318 $top.list tag configure highlight -background $selectbgcolor
9319 lappend bglist $top.list
9320 lappend fglist $top.list
9321 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9322 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9323 grid $top.list $top.ysb -sticky nsew
9324 grid $top.xsb x -sticky ew
9325 ${NS}::frame $top.f
9326 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9327 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9328 set reflistfilter "*"
9329 trace add variable reflistfilter write reflistfilter_change
9330 pack $top.f.e -side right -fill x -expand 1
9331 pack $top.f.l -side left
9332 grid $top.f - -sticky ew -pady 2
9333 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9334 bind $top <Key-Escape> [list destroy $top]
9335 grid $top.close -
9336 grid columnconfigure $top 0 -weight 1
9337 grid rowconfigure $top 0 -weight 1
9338 bind $top.list <1> {break}
9339 bind $top.list <B1-Motion> {break}
9340 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9341 set reflist {}
9342 refill_reflist
9345 proc sel_reflist {w x y} {
9346 global showrefstop reflist headids tagids otherrefids
9348 if {![winfo exists $showrefstop]} return
9349 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9350 set ref [lindex $reflist [expr {$l-1}]]
9351 set n [lindex $ref 0]
9352 switch -- [lindex $ref 1] {
9353 "H" {selbyid $headids($n)}
9354 "T" {selbyid $tagids($n)}
9355 "o" {selbyid $otherrefids($n)}
9357 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9360 proc unsel_reflist {} {
9361 global showrefstop
9363 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9364 $showrefstop.list tag remove highlight 0.0 end
9367 proc reflistfilter_change {n1 n2 op} {
9368 global reflistfilter
9370 after cancel refill_reflist
9371 after 200 refill_reflist
9374 proc refill_reflist {} {
9375 global reflist reflistfilter showrefstop headids tagids otherrefids
9376 global curview
9378 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9379 set refs {}
9380 foreach n [array names headids] {
9381 if {[string match $reflistfilter $n]} {
9382 if {[commitinview $headids($n) $curview]} {
9383 lappend refs [list $n H]
9384 } else {
9385 interestedin $headids($n) {run refill_reflist}
9389 foreach n [array names tagids] {
9390 if {[string match $reflistfilter $n]} {
9391 if {[commitinview $tagids($n) $curview]} {
9392 lappend refs [list $n T]
9393 } else {
9394 interestedin $tagids($n) {run refill_reflist}
9398 foreach n [array names otherrefids] {
9399 if {[string match $reflistfilter $n]} {
9400 if {[commitinview $otherrefids($n) $curview]} {
9401 lappend refs [list $n o]
9402 } else {
9403 interestedin $otherrefids($n) {run refill_reflist}
9407 set refs [lsort -index 0 $refs]
9408 if {$refs eq $reflist} return
9410 # Update the contents of $showrefstop.list according to the
9411 # differences between $reflist (old) and $refs (new)
9412 $showrefstop.list conf -state normal
9413 $showrefstop.list insert end "\n"
9414 set i 0
9415 set j 0
9416 while {$i < [llength $reflist] || $j < [llength $refs]} {
9417 if {$i < [llength $reflist]} {
9418 if {$j < [llength $refs]} {
9419 set cmp [string compare [lindex $reflist $i 0] \
9420 [lindex $refs $j 0]]
9421 if {$cmp == 0} {
9422 set cmp [string compare [lindex $reflist $i 1] \
9423 [lindex $refs $j 1]]
9425 } else {
9426 set cmp -1
9428 } else {
9429 set cmp 1
9431 switch -- $cmp {
9432 -1 {
9433 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9434 incr i
9437 incr i
9438 incr j
9441 set l [expr {$j + 1}]
9442 $showrefstop.list image create $l.0 -align baseline \
9443 -image reficon-[lindex $refs $j 1] -padx 2
9444 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9445 incr j
9449 set reflist $refs
9450 # delete last newline
9451 $showrefstop.list delete end-2c end-1c
9452 $showrefstop.list conf -state disabled
9455 # Stuff for finding nearby tags
9456 proc getallcommits {} {
9457 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9458 global idheads idtags idotherrefs allparents tagobjid
9459 global gitdir
9461 if {![info exists allcommits]} {
9462 set nextarc 0
9463 set allcommits 0
9464 set seeds {}
9465 set allcwait 0
9466 set cachedarcs 0
9467 set allccache [file join $gitdir "gitk.cache"]
9468 if {![catch {
9469 set f [open $allccache r]
9470 set allcwait 1
9471 getcache $f
9472 }]} return
9475 if {$allcwait} {
9476 return
9478 set cmd [list | git rev-list --parents]
9479 set allcupdate [expr {$seeds ne {}}]
9480 if {!$allcupdate} {
9481 set ids "--all"
9482 } else {
9483 set refs [concat [array names idheads] [array names idtags] \
9484 [array names idotherrefs]]
9485 set ids {}
9486 set tagobjs {}
9487 foreach name [array names tagobjid] {
9488 lappend tagobjs $tagobjid($name)
9490 foreach id [lsort -unique $refs] {
9491 if {![info exists allparents($id)] &&
9492 [lsearch -exact $tagobjs $id] < 0} {
9493 lappend ids $id
9496 if {$ids ne {}} {
9497 foreach id $seeds {
9498 lappend ids "^$id"
9502 if {$ids ne {}} {
9503 set fd [open [concat $cmd $ids] r]
9504 fconfigure $fd -blocking 0
9505 incr allcommits
9506 nowbusy allcommits
9507 filerun $fd [list getallclines $fd]
9508 } else {
9509 dispneartags 0
9513 # Since most commits have 1 parent and 1 child, we group strings of
9514 # such commits into "arcs" joining branch/merge points (BMPs), which
9515 # are commits that either don't have 1 parent or don't have 1 child.
9517 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9518 # arcout(id) - outgoing arcs for BMP
9519 # arcids(a) - list of IDs on arc including end but not start
9520 # arcstart(a) - BMP ID at start of arc
9521 # arcend(a) - BMP ID at end of arc
9522 # growing(a) - arc a is still growing
9523 # arctags(a) - IDs out of arcids (excluding end) that have tags
9524 # archeads(a) - IDs out of arcids (excluding end) that have heads
9525 # The start of an arc is at the descendent end, so "incoming" means
9526 # coming from descendents, and "outgoing" means going towards ancestors.
9528 proc getallclines {fd} {
9529 global allparents allchildren idtags idheads nextarc
9530 global arcnos arcids arctags arcout arcend arcstart archeads growing
9531 global seeds allcommits cachedarcs allcupdate
9533 set nid 0
9534 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9535 set id [lindex $line 0]
9536 if {[info exists allparents($id)]} {
9537 # seen it already
9538 continue
9540 set cachedarcs 0
9541 set olds [lrange $line 1 end]
9542 set allparents($id) $olds
9543 if {![info exists allchildren($id)]} {
9544 set allchildren($id) {}
9545 set arcnos($id) {}
9546 lappend seeds $id
9547 } else {
9548 set a $arcnos($id)
9549 if {[llength $olds] == 1 && [llength $a] == 1} {
9550 lappend arcids($a) $id
9551 if {[info exists idtags($id)]} {
9552 lappend arctags($a) $id
9554 if {[info exists idheads($id)]} {
9555 lappend archeads($a) $id
9557 if {[info exists allparents($olds)]} {
9558 # seen parent already
9559 if {![info exists arcout($olds)]} {
9560 splitarc $olds
9562 lappend arcids($a) $olds
9563 set arcend($a) $olds
9564 unset growing($a)
9566 lappend allchildren($olds) $id
9567 lappend arcnos($olds) $a
9568 continue
9571 foreach a $arcnos($id) {
9572 lappend arcids($a) $id
9573 set arcend($a) $id
9574 unset growing($a)
9577 set ao {}
9578 foreach p $olds {
9579 lappend allchildren($p) $id
9580 set a [incr nextarc]
9581 set arcstart($a) $id
9582 set archeads($a) {}
9583 set arctags($a) {}
9584 set archeads($a) {}
9585 set arcids($a) {}
9586 lappend ao $a
9587 set growing($a) 1
9588 if {[info exists allparents($p)]} {
9589 # seen it already, may need to make a new branch
9590 if {![info exists arcout($p)]} {
9591 splitarc $p
9593 lappend arcids($a) $p
9594 set arcend($a) $p
9595 unset growing($a)
9597 lappend arcnos($p) $a
9599 set arcout($id) $ao
9601 if {$nid > 0} {
9602 global cached_dheads cached_dtags cached_atags
9603 catch {unset cached_dheads}
9604 catch {unset cached_dtags}
9605 catch {unset cached_atags}
9607 if {![eof $fd]} {
9608 return [expr {$nid >= 1000? 2: 1}]
9610 set cacheok 1
9611 if {[catch {
9612 fconfigure $fd -blocking 1
9613 close $fd
9614 } err]} {
9615 # got an error reading the list of commits
9616 # if we were updating, try rereading the whole thing again
9617 if {$allcupdate} {
9618 incr allcommits -1
9619 dropcache $err
9620 return
9622 error_popup "[mc "Error reading commit topology information;\
9623 branch and preceding/following tag information\
9624 will be incomplete."]\n($err)"
9625 set cacheok 0
9627 if {[incr allcommits -1] == 0} {
9628 notbusy allcommits
9629 if {$cacheok} {
9630 run savecache
9633 dispneartags 0
9634 return 0
9637 proc recalcarc {a} {
9638 global arctags archeads arcids idtags idheads
9640 set at {}
9641 set ah {}
9642 foreach id [lrange $arcids($a) 0 end-1] {
9643 if {[info exists idtags($id)]} {
9644 lappend at $id
9646 if {[info exists idheads($id)]} {
9647 lappend ah $id
9650 set arctags($a) $at
9651 set archeads($a) $ah
9654 proc splitarc {p} {
9655 global arcnos arcids nextarc arctags archeads idtags idheads
9656 global arcstart arcend arcout allparents growing
9658 set a $arcnos($p)
9659 if {[llength $a] != 1} {
9660 puts "oops splitarc called but [llength $a] arcs already"
9661 return
9663 set a [lindex $a 0]
9664 set i [lsearch -exact $arcids($a) $p]
9665 if {$i < 0} {
9666 puts "oops splitarc $p not in arc $a"
9667 return
9669 set na [incr nextarc]
9670 if {[info exists arcend($a)]} {
9671 set arcend($na) $arcend($a)
9672 } else {
9673 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9674 set j [lsearch -exact $arcnos($l) $a]
9675 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9677 set tail [lrange $arcids($a) [expr {$i+1}] end]
9678 set arcids($a) [lrange $arcids($a) 0 $i]
9679 set arcend($a) $p
9680 set arcstart($na) $p
9681 set arcout($p) $na
9682 set arcids($na) $tail
9683 if {[info exists growing($a)]} {
9684 set growing($na) 1
9685 unset growing($a)
9688 foreach id $tail {
9689 if {[llength $arcnos($id)] == 1} {
9690 set arcnos($id) $na
9691 } else {
9692 set j [lsearch -exact $arcnos($id) $a]
9693 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9697 # reconstruct tags and heads lists
9698 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9699 recalcarc $a
9700 recalcarc $na
9701 } else {
9702 set arctags($na) {}
9703 set archeads($na) {}
9707 # Update things for a new commit added that is a child of one
9708 # existing commit. Used when cherry-picking.
9709 proc addnewchild {id p} {
9710 global allparents allchildren idtags nextarc
9711 global arcnos arcids arctags arcout arcend arcstart archeads growing
9712 global seeds allcommits
9714 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9715 set allparents($id) [list $p]
9716 set allchildren($id) {}
9717 set arcnos($id) {}
9718 lappend seeds $id
9719 lappend allchildren($p) $id
9720 set a [incr nextarc]
9721 set arcstart($a) $id
9722 set archeads($a) {}
9723 set arctags($a) {}
9724 set arcids($a) [list $p]
9725 set arcend($a) $p
9726 if {![info exists arcout($p)]} {
9727 splitarc $p
9729 lappend arcnos($p) $a
9730 set arcout($id) [list $a]
9733 # This implements a cache for the topology information.
9734 # The cache saves, for each arc, the start and end of the arc,
9735 # the ids on the arc, and the outgoing arcs from the end.
9736 proc readcache {f} {
9737 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9738 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9739 global allcwait
9741 set a $nextarc
9742 set lim $cachedarcs
9743 if {$lim - $a > 500} {
9744 set lim [expr {$a + 500}]
9746 if {[catch {
9747 if {$a == $lim} {
9748 # finish reading the cache and setting up arctags, etc.
9749 set line [gets $f]
9750 if {$line ne "1"} {error "bad final version"}
9751 close $f
9752 foreach id [array names idtags] {
9753 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9754 [llength $allparents($id)] == 1} {
9755 set a [lindex $arcnos($id) 0]
9756 if {$arctags($a) eq {}} {
9757 recalcarc $a
9761 foreach id [array names idheads] {
9762 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9763 [llength $allparents($id)] == 1} {
9764 set a [lindex $arcnos($id) 0]
9765 if {$archeads($a) eq {}} {
9766 recalcarc $a
9770 foreach id [lsort -unique $possible_seeds] {
9771 if {$arcnos($id) eq {}} {
9772 lappend seeds $id
9775 set allcwait 0
9776 } else {
9777 while {[incr a] <= $lim} {
9778 set line [gets $f]
9779 if {[llength $line] != 3} {error "bad line"}
9780 set s [lindex $line 0]
9781 set arcstart($a) $s
9782 lappend arcout($s) $a
9783 if {![info exists arcnos($s)]} {
9784 lappend possible_seeds $s
9785 set arcnos($s) {}
9787 set e [lindex $line 1]
9788 if {$e eq {}} {
9789 set growing($a) 1
9790 } else {
9791 set arcend($a) $e
9792 if {![info exists arcout($e)]} {
9793 set arcout($e) {}
9796 set arcids($a) [lindex $line 2]
9797 foreach id $arcids($a) {
9798 lappend allparents($s) $id
9799 set s $id
9800 lappend arcnos($id) $a
9802 if {![info exists allparents($s)]} {
9803 set allparents($s) {}
9805 set arctags($a) {}
9806 set archeads($a) {}
9808 set nextarc [expr {$a - 1}]
9810 } err]} {
9811 dropcache $err
9812 return 0
9814 if {!$allcwait} {
9815 getallcommits
9817 return $allcwait
9820 proc getcache {f} {
9821 global nextarc cachedarcs possible_seeds
9823 if {[catch {
9824 set line [gets $f]
9825 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9826 # make sure it's an integer
9827 set cachedarcs [expr {int([lindex $line 1])}]
9828 if {$cachedarcs < 0} {error "bad number of arcs"}
9829 set nextarc 0
9830 set possible_seeds {}
9831 run readcache $f
9832 } err]} {
9833 dropcache $err
9835 return 0
9838 proc dropcache {err} {
9839 global allcwait nextarc cachedarcs seeds
9841 #puts "dropping cache ($err)"
9842 foreach v {arcnos arcout arcids arcstart arcend growing \
9843 arctags archeads allparents allchildren} {
9844 global $v
9845 catch {unset $v}
9847 set allcwait 0
9848 set nextarc 0
9849 set cachedarcs 0
9850 set seeds {}
9851 getallcommits
9854 proc writecache {f} {
9855 global cachearc cachedarcs allccache
9856 global arcstart arcend arcnos arcids arcout
9858 set a $cachearc
9859 set lim $cachedarcs
9860 if {$lim - $a > 1000} {
9861 set lim [expr {$a + 1000}]
9863 if {[catch {
9864 while {[incr a] <= $lim} {
9865 if {[info exists arcend($a)]} {
9866 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9867 } else {
9868 puts $f [list $arcstart($a) {} $arcids($a)]
9871 } err]} {
9872 catch {close $f}
9873 catch {file delete $allccache}
9874 #puts "writing cache failed ($err)"
9875 return 0
9877 set cachearc [expr {$a - 1}]
9878 if {$a > $cachedarcs} {
9879 puts $f "1"
9880 close $f
9881 return 0
9883 return 1
9886 proc savecache {} {
9887 global nextarc cachedarcs cachearc allccache
9889 if {$nextarc == $cachedarcs} return
9890 set cachearc 0
9891 set cachedarcs $nextarc
9892 catch {
9893 set f [open $allccache w]
9894 puts $f [list 1 $cachedarcs]
9895 run writecache $f
9899 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9900 # or 0 if neither is true.
9901 proc anc_or_desc {a b} {
9902 global arcout arcstart arcend arcnos cached_isanc
9904 if {$arcnos($a) eq $arcnos($b)} {
9905 # Both are on the same arc(s); either both are the same BMP,
9906 # or if one is not a BMP, the other is also not a BMP or is
9907 # the BMP at end of the arc (and it only has 1 incoming arc).
9908 # Or both can be BMPs with no incoming arcs.
9909 if {$a eq $b || $arcnos($a) eq {}} {
9910 return 0
9912 # assert {[llength $arcnos($a)] == 1}
9913 set arc [lindex $arcnos($a) 0]
9914 set i [lsearch -exact $arcids($arc) $a]
9915 set j [lsearch -exact $arcids($arc) $b]
9916 if {$i < 0 || $i > $j} {
9917 return 1
9918 } else {
9919 return -1
9923 if {![info exists arcout($a)]} {
9924 set arc [lindex $arcnos($a) 0]
9925 if {[info exists arcend($arc)]} {
9926 set aend $arcend($arc)
9927 } else {
9928 set aend {}
9930 set a $arcstart($arc)
9931 } else {
9932 set aend $a
9934 if {![info exists arcout($b)]} {
9935 set arc [lindex $arcnos($b) 0]
9936 if {[info exists arcend($arc)]} {
9937 set bend $arcend($arc)
9938 } else {
9939 set bend {}
9941 set b $arcstart($arc)
9942 } else {
9943 set bend $b
9945 if {$a eq $bend} {
9946 return 1
9948 if {$b eq $aend} {
9949 return -1
9951 if {[info exists cached_isanc($a,$bend)]} {
9952 if {$cached_isanc($a,$bend)} {
9953 return 1
9956 if {[info exists cached_isanc($b,$aend)]} {
9957 if {$cached_isanc($b,$aend)} {
9958 return -1
9960 if {[info exists cached_isanc($a,$bend)]} {
9961 return 0
9965 set todo [list $a $b]
9966 set anc($a) a
9967 set anc($b) b
9968 for {set i 0} {$i < [llength $todo]} {incr i} {
9969 set x [lindex $todo $i]
9970 if {$anc($x) eq {}} {
9971 continue
9973 foreach arc $arcnos($x) {
9974 set xd $arcstart($arc)
9975 if {$xd eq $bend} {
9976 set cached_isanc($a,$bend) 1
9977 set cached_isanc($b,$aend) 0
9978 return 1
9979 } elseif {$xd eq $aend} {
9980 set cached_isanc($b,$aend) 1
9981 set cached_isanc($a,$bend) 0
9982 return -1
9984 if {![info exists anc($xd)]} {
9985 set anc($xd) $anc($x)
9986 lappend todo $xd
9987 } elseif {$anc($xd) ne $anc($x)} {
9988 set anc($xd) {}
9992 set cached_isanc($a,$bend) 0
9993 set cached_isanc($b,$aend) 0
9994 return 0
9997 # This identifies whether $desc has an ancestor that is
9998 # a growing tip of the graph and which is not an ancestor of $anc
9999 # and returns 0 if so and 1 if not.
10000 # If we subsequently discover a tag on such a growing tip, and that
10001 # turns out to be a descendent of $anc (which it could, since we
10002 # don't necessarily see children before parents), then $desc
10003 # isn't a good choice to display as a descendent tag of
10004 # $anc (since it is the descendent of another tag which is
10005 # a descendent of $anc). Similarly, $anc isn't a good choice to
10006 # display as a ancestor tag of $desc.
10008 proc is_certain {desc anc} {
10009 global arcnos arcout arcstart arcend growing problems
10011 set certain {}
10012 if {[llength $arcnos($anc)] == 1} {
10013 # tags on the same arc are certain
10014 if {$arcnos($desc) eq $arcnos($anc)} {
10015 return 1
10017 if {![info exists arcout($anc)]} {
10018 # if $anc is partway along an arc, use the start of the arc instead
10019 set a [lindex $arcnos($anc) 0]
10020 set anc $arcstart($a)
10023 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10024 set x $desc
10025 } else {
10026 set a [lindex $arcnos($desc) 0]
10027 set x $arcend($a)
10029 if {$x == $anc} {
10030 return 1
10032 set anclist [list $x]
10033 set dl($x) 1
10034 set nnh 1
10035 set ngrowanc 0
10036 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10037 set x [lindex $anclist $i]
10038 if {$dl($x)} {
10039 incr nnh -1
10041 set done($x) 1
10042 foreach a $arcout($x) {
10043 if {[info exists growing($a)]} {
10044 if {![info exists growanc($x)] && $dl($x)} {
10045 set growanc($x) 1
10046 incr ngrowanc
10048 } else {
10049 set y $arcend($a)
10050 if {[info exists dl($y)]} {
10051 if {$dl($y)} {
10052 if {!$dl($x)} {
10053 set dl($y) 0
10054 if {![info exists done($y)]} {
10055 incr nnh -1
10057 if {[info exists growanc($x)]} {
10058 incr ngrowanc -1
10060 set xl [list $y]
10061 for {set k 0} {$k < [llength $xl]} {incr k} {
10062 set z [lindex $xl $k]
10063 foreach c $arcout($z) {
10064 if {[info exists arcend($c)]} {
10065 set v $arcend($c)
10066 if {[info exists dl($v)] && $dl($v)} {
10067 set dl($v) 0
10068 if {![info exists done($v)]} {
10069 incr nnh -1
10071 if {[info exists growanc($v)]} {
10072 incr ngrowanc -1
10074 lappend xl $v
10081 } elseif {$y eq $anc || !$dl($x)} {
10082 set dl($y) 0
10083 lappend anclist $y
10084 } else {
10085 set dl($y) 1
10086 lappend anclist $y
10087 incr nnh
10092 foreach x [array names growanc] {
10093 if {$dl($x)} {
10094 return 0
10096 return 0
10098 return 1
10101 proc validate_arctags {a} {
10102 global arctags idtags
10104 set i -1
10105 set na $arctags($a)
10106 foreach id $arctags($a) {
10107 incr i
10108 if {![info exists idtags($id)]} {
10109 set na [lreplace $na $i $i]
10110 incr i -1
10113 set arctags($a) $na
10116 proc validate_archeads {a} {
10117 global archeads idheads
10119 set i -1
10120 set na $archeads($a)
10121 foreach id $archeads($a) {
10122 incr i
10123 if {![info exists idheads($id)]} {
10124 set na [lreplace $na $i $i]
10125 incr i -1
10128 set archeads($a) $na
10131 # Return the list of IDs that have tags that are descendents of id,
10132 # ignoring IDs that are descendents of IDs already reported.
10133 proc desctags {id} {
10134 global arcnos arcstart arcids arctags idtags allparents
10135 global growing cached_dtags
10137 if {![info exists allparents($id)]} {
10138 return {}
10140 set t1 [clock clicks -milliseconds]
10141 set argid $id
10142 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10143 # part-way along an arc; check that arc first
10144 set a [lindex $arcnos($id) 0]
10145 if {$arctags($a) ne {}} {
10146 validate_arctags $a
10147 set i [lsearch -exact $arcids($a) $id]
10148 set tid {}
10149 foreach t $arctags($a) {
10150 set j [lsearch -exact $arcids($a) $t]
10151 if {$j >= $i} break
10152 set tid $t
10154 if {$tid ne {}} {
10155 return $tid
10158 set id $arcstart($a)
10159 if {[info exists idtags($id)]} {
10160 return $id
10163 if {[info exists cached_dtags($id)]} {
10164 return $cached_dtags($id)
10167 set origid $id
10168 set todo [list $id]
10169 set queued($id) 1
10170 set nc 1
10171 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10172 set id [lindex $todo $i]
10173 set done($id) 1
10174 set ta [info exists hastaggedancestor($id)]
10175 if {!$ta} {
10176 incr nc -1
10178 # ignore tags on starting node
10179 if {!$ta && $i > 0} {
10180 if {[info exists idtags($id)]} {
10181 set tagloc($id) $id
10182 set ta 1
10183 } elseif {[info exists cached_dtags($id)]} {
10184 set tagloc($id) $cached_dtags($id)
10185 set ta 1
10188 foreach a $arcnos($id) {
10189 set d $arcstart($a)
10190 if {!$ta && $arctags($a) ne {}} {
10191 validate_arctags $a
10192 if {$arctags($a) ne {}} {
10193 lappend tagloc($id) [lindex $arctags($a) end]
10196 if {$ta || $arctags($a) ne {}} {
10197 set tomark [list $d]
10198 for {set j 0} {$j < [llength $tomark]} {incr j} {
10199 set dd [lindex $tomark $j]
10200 if {![info exists hastaggedancestor($dd)]} {
10201 if {[info exists done($dd)]} {
10202 foreach b $arcnos($dd) {
10203 lappend tomark $arcstart($b)
10205 if {[info exists tagloc($dd)]} {
10206 unset tagloc($dd)
10208 } elseif {[info exists queued($dd)]} {
10209 incr nc -1
10211 set hastaggedancestor($dd) 1
10215 if {![info exists queued($d)]} {
10216 lappend todo $d
10217 set queued($d) 1
10218 if {![info exists hastaggedancestor($d)]} {
10219 incr nc
10224 set tags {}
10225 foreach id [array names tagloc] {
10226 if {![info exists hastaggedancestor($id)]} {
10227 foreach t $tagloc($id) {
10228 if {[lsearch -exact $tags $t] < 0} {
10229 lappend tags $t
10234 set t2 [clock clicks -milliseconds]
10235 set loopix $i
10237 # remove tags that are descendents of other tags
10238 for {set i 0} {$i < [llength $tags]} {incr i} {
10239 set a [lindex $tags $i]
10240 for {set j 0} {$j < $i} {incr j} {
10241 set b [lindex $tags $j]
10242 set r [anc_or_desc $a $b]
10243 if {$r == 1} {
10244 set tags [lreplace $tags $j $j]
10245 incr j -1
10246 incr i -1
10247 } elseif {$r == -1} {
10248 set tags [lreplace $tags $i $i]
10249 incr i -1
10250 break
10255 if {[array names growing] ne {}} {
10256 # graph isn't finished, need to check if any tag could get
10257 # eclipsed by another tag coming later. Simply ignore any
10258 # tags that could later get eclipsed.
10259 set ctags {}
10260 foreach t $tags {
10261 if {[is_certain $t $origid]} {
10262 lappend ctags $t
10265 if {$tags eq $ctags} {
10266 set cached_dtags($origid) $tags
10267 } else {
10268 set tags $ctags
10270 } else {
10271 set cached_dtags($origid) $tags
10273 set t3 [clock clicks -milliseconds]
10274 if {0 && $t3 - $t1 >= 100} {
10275 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10276 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10278 return $tags
10281 proc anctags {id} {
10282 global arcnos arcids arcout arcend arctags idtags allparents
10283 global growing cached_atags
10285 if {![info exists allparents($id)]} {
10286 return {}
10288 set t1 [clock clicks -milliseconds]
10289 set argid $id
10290 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10291 # part-way along an arc; check that arc first
10292 set a [lindex $arcnos($id) 0]
10293 if {$arctags($a) ne {}} {
10294 validate_arctags $a
10295 set i [lsearch -exact $arcids($a) $id]
10296 foreach t $arctags($a) {
10297 set j [lsearch -exact $arcids($a) $t]
10298 if {$j > $i} {
10299 return $t
10303 if {![info exists arcend($a)]} {
10304 return {}
10306 set id $arcend($a)
10307 if {[info exists idtags($id)]} {
10308 return $id
10311 if {[info exists cached_atags($id)]} {
10312 return $cached_atags($id)
10315 set origid $id
10316 set todo [list $id]
10317 set queued($id) 1
10318 set taglist {}
10319 set nc 1
10320 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10321 set id [lindex $todo $i]
10322 set done($id) 1
10323 set td [info exists hastaggeddescendent($id)]
10324 if {!$td} {
10325 incr nc -1
10327 # ignore tags on starting node
10328 if {!$td && $i > 0} {
10329 if {[info exists idtags($id)]} {
10330 set tagloc($id) $id
10331 set td 1
10332 } elseif {[info exists cached_atags($id)]} {
10333 set tagloc($id) $cached_atags($id)
10334 set td 1
10337 foreach a $arcout($id) {
10338 if {!$td && $arctags($a) ne {}} {
10339 validate_arctags $a
10340 if {$arctags($a) ne {}} {
10341 lappend tagloc($id) [lindex $arctags($a) 0]
10344 if {![info exists arcend($a)]} continue
10345 set d $arcend($a)
10346 if {$td || $arctags($a) ne {}} {
10347 set tomark [list $d]
10348 for {set j 0} {$j < [llength $tomark]} {incr j} {
10349 set dd [lindex $tomark $j]
10350 if {![info exists hastaggeddescendent($dd)]} {
10351 if {[info exists done($dd)]} {
10352 foreach b $arcout($dd) {
10353 if {[info exists arcend($b)]} {
10354 lappend tomark $arcend($b)
10357 if {[info exists tagloc($dd)]} {
10358 unset tagloc($dd)
10360 } elseif {[info exists queued($dd)]} {
10361 incr nc -1
10363 set hastaggeddescendent($dd) 1
10367 if {![info exists queued($d)]} {
10368 lappend todo $d
10369 set queued($d) 1
10370 if {![info exists hastaggeddescendent($d)]} {
10371 incr nc
10376 set t2 [clock clicks -milliseconds]
10377 set loopix $i
10378 set tags {}
10379 foreach id [array names tagloc] {
10380 if {![info exists hastaggeddescendent($id)]} {
10381 foreach t $tagloc($id) {
10382 if {[lsearch -exact $tags $t] < 0} {
10383 lappend tags $t
10389 # remove tags that are ancestors of other tags
10390 for {set i 0} {$i < [llength $tags]} {incr i} {
10391 set a [lindex $tags $i]
10392 for {set j 0} {$j < $i} {incr j} {
10393 set b [lindex $tags $j]
10394 set r [anc_or_desc $a $b]
10395 if {$r == -1} {
10396 set tags [lreplace $tags $j $j]
10397 incr j -1
10398 incr i -1
10399 } elseif {$r == 1} {
10400 set tags [lreplace $tags $i $i]
10401 incr i -1
10402 break
10407 if {[array names growing] ne {}} {
10408 # graph isn't finished, need to check if any tag could get
10409 # eclipsed by another tag coming later. Simply ignore any
10410 # tags that could later get eclipsed.
10411 set ctags {}
10412 foreach t $tags {
10413 if {[is_certain $origid $t]} {
10414 lappend ctags $t
10417 if {$tags eq $ctags} {
10418 set cached_atags($origid) $tags
10419 } else {
10420 set tags $ctags
10422 } else {
10423 set cached_atags($origid) $tags
10425 set t3 [clock clicks -milliseconds]
10426 if {0 && $t3 - $t1 >= 100} {
10427 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10428 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10430 return $tags
10433 # Return the list of IDs that have heads that are descendents of id,
10434 # including id itself if it has a head.
10435 proc descheads {id} {
10436 global arcnos arcstart arcids archeads idheads cached_dheads
10437 global allparents
10439 if {![info exists allparents($id)]} {
10440 return {}
10442 set aret {}
10443 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10444 # part-way along an arc; check it first
10445 set a [lindex $arcnos($id) 0]
10446 if {$archeads($a) ne {}} {
10447 validate_archeads $a
10448 set i [lsearch -exact $arcids($a) $id]
10449 foreach t $archeads($a) {
10450 set j [lsearch -exact $arcids($a) $t]
10451 if {$j > $i} break
10452 lappend aret $t
10455 set id $arcstart($a)
10457 set origid $id
10458 set todo [list $id]
10459 set seen($id) 1
10460 set ret {}
10461 for {set i 0} {$i < [llength $todo]} {incr i} {
10462 set id [lindex $todo $i]
10463 if {[info exists cached_dheads($id)]} {
10464 set ret [concat $ret $cached_dheads($id)]
10465 } else {
10466 if {[info exists idheads($id)]} {
10467 lappend ret $id
10469 foreach a $arcnos($id) {
10470 if {$archeads($a) ne {}} {
10471 validate_archeads $a
10472 if {$archeads($a) ne {}} {
10473 set ret [concat $ret $archeads($a)]
10476 set d $arcstart($a)
10477 if {![info exists seen($d)]} {
10478 lappend todo $d
10479 set seen($d) 1
10484 set ret [lsort -unique $ret]
10485 set cached_dheads($origid) $ret
10486 return [concat $ret $aret]
10489 proc addedtag {id} {
10490 global arcnos arcout cached_dtags cached_atags
10492 if {![info exists arcnos($id)]} return
10493 if {![info exists arcout($id)]} {
10494 recalcarc [lindex $arcnos($id) 0]
10496 catch {unset cached_dtags}
10497 catch {unset cached_atags}
10500 proc addedhead {hid head} {
10501 global arcnos arcout cached_dheads
10503 if {![info exists arcnos($hid)]} return
10504 if {![info exists arcout($hid)]} {
10505 recalcarc [lindex $arcnos($hid) 0]
10507 catch {unset cached_dheads}
10510 proc removedhead {hid head} {
10511 global cached_dheads
10513 catch {unset cached_dheads}
10516 proc movedhead {hid head} {
10517 global arcnos arcout cached_dheads
10519 if {![info exists arcnos($hid)]} return
10520 if {![info exists arcout($hid)]} {
10521 recalcarc [lindex $arcnos($hid) 0]
10523 catch {unset cached_dheads}
10526 proc changedrefs {} {
10527 global cached_dheads cached_dtags cached_atags
10528 global arctags archeads arcnos arcout idheads idtags
10530 foreach id [concat [array names idheads] [array names idtags]] {
10531 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10532 set a [lindex $arcnos($id) 0]
10533 if {![info exists donearc($a)]} {
10534 recalcarc $a
10535 set donearc($a) 1
10539 catch {unset cached_dtags}
10540 catch {unset cached_atags}
10541 catch {unset cached_dheads}
10544 proc rereadrefs {} {
10545 global idtags idheads idotherrefs mainheadid
10547 set refids [concat [array names idtags] \
10548 [array names idheads] [array names idotherrefs]]
10549 foreach id $refids {
10550 if {![info exists ref($id)]} {
10551 set ref($id) [listrefs $id]
10554 set oldmainhead $mainheadid
10555 readrefs
10556 changedrefs
10557 set refids [lsort -unique [concat $refids [array names idtags] \
10558 [array names idheads] [array names idotherrefs]]]
10559 foreach id $refids {
10560 set v [listrefs $id]
10561 if {![info exists ref($id)] || $ref($id) != $v} {
10562 redrawtags $id
10565 if {$oldmainhead ne $mainheadid} {
10566 redrawtags $oldmainhead
10567 redrawtags $mainheadid
10569 run refill_reflist
10572 proc listrefs {id} {
10573 global idtags idheads idotherrefs
10575 set x {}
10576 if {[info exists idtags($id)]} {
10577 set x $idtags($id)
10579 set y {}
10580 if {[info exists idheads($id)]} {
10581 set y $idheads($id)
10583 set z {}
10584 if {[info exists idotherrefs($id)]} {
10585 set z $idotherrefs($id)
10587 return [list $x $y $z]
10590 proc showtag {tag isnew} {
10591 global ctext tagcontents tagids linknum tagobjid
10593 if {$isnew} {
10594 addtohistory [list showtag $tag 0] savectextpos
10596 $ctext conf -state normal
10597 clear_ctext
10598 settabs 0
10599 set linknum 0
10600 if {![info exists tagcontents($tag)]} {
10601 catch {
10602 set tagcontents($tag) [exec git cat-file tag $tag]
10605 if {[info exists tagcontents($tag)]} {
10606 set text $tagcontents($tag)
10607 } else {
10608 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10610 appendwithlinks $text {}
10611 maybe_scroll_ctext 1
10612 $ctext conf -state disabled
10613 init_flist {}
10616 proc doquit {} {
10617 global stopped
10618 global gitktmpdir
10620 set stopped 100
10621 savestuff .
10622 destroy .
10624 if {[info exists gitktmpdir]} {
10625 catch {file delete -force $gitktmpdir}
10629 proc mkfontdisp {font top which} {
10630 global fontattr fontpref $font NS use_ttk
10632 set fontpref($font) [set $font]
10633 ${NS}::button $top.${font}but -text $which \
10634 -command [list choosefont $font $which]
10635 ${NS}::label $top.$font -relief flat -font $font \
10636 -text $fontattr($font,family) -justify left
10637 grid x $top.${font}but $top.$font -sticky w
10640 proc choosefont {font which} {
10641 global fontparam fontlist fonttop fontattr
10642 global prefstop NS
10644 set fontparam(which) $which
10645 set fontparam(font) $font
10646 set fontparam(family) [font actual $font -family]
10647 set fontparam(size) $fontattr($font,size)
10648 set fontparam(weight) $fontattr($font,weight)
10649 set fontparam(slant) $fontattr($font,slant)
10650 set top .gitkfont
10651 set fonttop $top
10652 if {![winfo exists $top]} {
10653 font create sample
10654 eval font config sample [font actual $font]
10655 ttk_toplevel $top
10656 make_transient $top $prefstop
10657 wm title $top [mc "Gitk font chooser"]
10658 ${NS}::label $top.l -textvariable fontparam(which)
10659 pack $top.l -side top
10660 set fontlist [lsort [font families]]
10661 ${NS}::frame $top.f
10662 listbox $top.f.fam -listvariable fontlist \
10663 -yscrollcommand [list $top.f.sb set]
10664 bind $top.f.fam <<ListboxSelect>> selfontfam
10665 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10666 pack $top.f.sb -side right -fill y
10667 pack $top.f.fam -side left -fill both -expand 1
10668 pack $top.f -side top -fill both -expand 1
10669 ${NS}::frame $top.g
10670 spinbox $top.g.size -from 4 -to 40 -width 4 \
10671 -textvariable fontparam(size) \
10672 -validatecommand {string is integer -strict %s}
10673 checkbutton $top.g.bold -padx 5 \
10674 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10675 -variable fontparam(weight) -onvalue bold -offvalue normal
10676 checkbutton $top.g.ital -padx 5 \
10677 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10678 -variable fontparam(slant) -onvalue italic -offvalue roman
10679 pack $top.g.size $top.g.bold $top.g.ital -side left
10680 pack $top.g -side top
10681 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10682 -background white
10683 $top.c create text 100 25 -anchor center -text $which -font sample \
10684 -fill black -tags text
10685 bind $top.c <Configure> [list centertext $top.c]
10686 pack $top.c -side top -fill x
10687 ${NS}::frame $top.buts
10688 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10689 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10690 bind $top <Key-Return> fontok
10691 bind $top <Key-Escape> fontcan
10692 grid $top.buts.ok $top.buts.can
10693 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10694 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10695 pack $top.buts -side bottom -fill x
10696 trace add variable fontparam write chg_fontparam
10697 } else {
10698 raise $top
10699 $top.c itemconf text -text $which
10701 set i [lsearch -exact $fontlist $fontparam(family)]
10702 if {$i >= 0} {
10703 $top.f.fam selection set $i
10704 $top.f.fam see $i
10708 proc centertext {w} {
10709 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10712 proc fontok {} {
10713 global fontparam fontpref prefstop
10715 set f $fontparam(font)
10716 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10717 if {$fontparam(weight) eq "bold"} {
10718 lappend fontpref($f) "bold"
10720 if {$fontparam(slant) eq "italic"} {
10721 lappend fontpref($f) "italic"
10723 set w $prefstop.$f
10724 $w conf -text $fontparam(family) -font $fontpref($f)
10726 fontcan
10729 proc fontcan {} {
10730 global fonttop fontparam
10732 if {[info exists fonttop]} {
10733 catch {destroy $fonttop}
10734 catch {font delete sample}
10735 unset fonttop
10736 unset fontparam
10740 if {[package vsatisfies [package provide Tk] 8.6]} {
10741 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10742 # function to make use of it.
10743 proc choosefont {font which} {
10744 tk fontchooser configure -title $which -font $font \
10745 -command [list on_choosefont $font $which]
10746 tk fontchooser show
10748 proc on_choosefont {font which newfont} {
10749 global fontparam
10750 puts stderr "$font $newfont"
10751 array set f [font actual $newfont]
10752 set fontparam(which) $which
10753 set fontparam(font) $font
10754 set fontparam(family) $f(-family)
10755 set fontparam(size) $f(-size)
10756 set fontparam(weight) $f(-weight)
10757 set fontparam(slant) $f(-slant)
10758 fontok
10762 proc selfontfam {} {
10763 global fonttop fontparam
10765 set i [$fonttop.f.fam curselection]
10766 if {$i ne {}} {
10767 set fontparam(family) [$fonttop.f.fam get $i]
10771 proc chg_fontparam {v sub op} {
10772 global fontparam
10774 font config sample -$sub $fontparam($sub)
10777 proc doprefs {} {
10778 global maxwidth maxgraphpct use_ttk NS
10779 global oldprefs prefstop showneartags showlocalchanges
10780 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10781 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
10782 global hideremotes want_ttk have_ttk
10784 set top .gitkprefs
10785 set prefstop $top
10786 if {[winfo exists $top]} {
10787 raise $top
10788 return
10790 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10791 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10792 set oldprefs($v) [set $v]
10794 ttk_toplevel $top
10795 wm title $top [mc "Gitk preferences"]
10796 make_transient $top .
10797 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10798 grid $top.ldisp - -sticky w -pady 10
10799 ${NS}::label $top.spacer -text " "
10800 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10801 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10802 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10803 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10804 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10805 grid x $top.maxpctl $top.maxpct -sticky w
10806 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10807 -variable showlocalchanges
10808 grid x $top.showlocal -sticky w
10809 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1 (length)"] \
10810 -variable autoselect
10811 spinbox $top.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
10812 grid x $top.autoselect $top.autosellen -sticky w
10813 ${NS}::checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10814 -variable hideremotes
10815 grid x $top.hideremotes -sticky w
10817 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10818 grid $top.ddisp - -sticky w -pady 10
10819 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10820 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10821 grid x $top.tabstopl $top.tabstop -sticky w
10822 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10823 -variable showneartags
10824 grid x $top.ntag -sticky w
10825 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10826 -variable limitdiffs
10827 grid x $top.ldiff -sticky w
10828 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10829 -variable perfile_attrs
10830 grid x $top.lattr -sticky w
10832 ${NS}::entry $top.extdifft -textvariable extdifftool
10833 ${NS}::frame $top.extdifff
10834 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10835 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10836 pack $top.extdifff.l $top.extdifff.b -side left
10837 pack configure $top.extdifff.l -padx 10
10838 grid x $top.extdifff $top.extdifft -sticky ew
10840 ${NS}::label $top.lgen -text [mc "General options"]
10841 grid $top.lgen - -sticky w -pady 10
10842 ${NS}::checkbutton $top.want_ttk -variable want_ttk \
10843 -text [mc "Use themed widgets"]
10844 if {$have_ttk} {
10845 ${NS}::label $top.ttk_note -text [mc "(change requires restart)"]
10846 } else {
10847 ${NS}::label $top.ttk_note -text [mc "(currently unavailable)"]
10849 grid x $top.want_ttk $top.ttk_note -sticky w
10851 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10852 grid $top.cdisp - -sticky w -pady 10
10853 label $top.ui -padx 40 -relief sunk -background $uicolor
10854 ${NS}::button $top.uibut -text [mc "Interface"] \
10855 -command [list choosecolor uicolor {} $top.ui [mc "interface"] setui]
10856 grid x $top.uibut $top.ui -sticky w
10857 label $top.bg -padx 40 -relief sunk -background $bgcolor
10858 ${NS}::button $top.bgbut -text [mc "Background"] \
10859 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10860 grid x $top.bgbut $top.bg -sticky w
10861 label $top.fg -padx 40 -relief sunk -background $fgcolor
10862 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10863 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10864 grid x $top.fgbut $top.fg -sticky w
10865 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10866 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10867 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10868 [list $ctext tag conf d0 -foreground]]
10869 grid x $top.diffoldbut $top.diffold -sticky w
10870 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10871 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10872 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10873 [list $ctext tag conf dresult -foreground]]
10874 grid x $top.diffnewbut $top.diffnew -sticky w
10875 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10876 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10877 -command [list choosecolor diffcolors 2 $top.hunksep \
10878 [mc "diff hunk header"] \
10879 [list $ctext tag conf hunksep -foreground]]
10880 grid x $top.hunksepbut $top.hunksep -sticky w
10881 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10882 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10883 -command [list choosecolor markbgcolor {} $top.markbgsep \
10884 [mc "marked line background"] \
10885 [list $ctext tag conf omark -background]]
10886 grid x $top.markbgbut $top.markbgsep -sticky w
10887 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10888 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10889 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10890 grid x $top.selbgbut $top.selbgsep -sticky w
10892 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10893 grid $top.cfont - -sticky w -pady 10
10894 mkfontdisp mainfont $top [mc "Main font"]
10895 mkfontdisp textfont $top [mc "Diff display font"]
10896 mkfontdisp uifont $top [mc "User interface font"]
10898 ${NS}::frame $top.buts
10899 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10900 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10901 bind $top <Key-Return> prefsok
10902 bind $top <Key-Escape> prefscan
10903 grid $top.buts.ok $top.buts.can
10904 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10905 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10906 grid $top.buts - - -pady 10 -sticky ew
10907 grid columnconfigure $top 2 -weight 1
10908 bind $top <Visibility> "focus $top.buts.ok"
10911 proc choose_extdiff {} {
10912 global extdifftool
10914 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10915 if {$prog ne {}} {
10916 set extdifftool $prog
10920 proc choosecolor {v vi w x cmd} {
10921 global $v
10923 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10924 -title [mc "Gitk: choose color for %s" $x]]
10925 if {$c eq {}} return
10926 $w conf -background $c
10927 lset $v $vi $c
10928 eval $cmd $c
10931 proc setselbg {c} {
10932 global bglist cflist
10933 foreach w $bglist {
10934 $w configure -selectbackground $c
10936 $cflist tag configure highlight \
10937 -background [$cflist cget -selectbackground]
10938 allcanvs itemconf secsel -fill $c
10941 # This sets the background color and the color scheme for the whole UI.
10942 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
10943 # if we don't specify one ourselves, which makes the checkbuttons and
10944 # radiobuttons look bad. This chooses white for selectColor if the
10945 # background color is light, or black if it is dark.
10946 proc setui {c} {
10947 if {[tk windowingsystem] eq "win32"} { return }
10948 set bg [winfo rgb . $c]
10949 set selc black
10950 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
10951 set selc white
10953 tk_setPalette background $c selectColor $selc
10956 proc setbg {c} {
10957 global bglist
10959 foreach w $bglist {
10960 $w conf -background $c
10964 proc setfg {c} {
10965 global fglist canv
10967 foreach w $fglist {
10968 $w conf -foreground $c
10970 allcanvs itemconf text -fill $c
10971 $canv itemconf circle -outline $c
10972 $canv itemconf markid -outline $c
10975 proc prefscan {} {
10976 global oldprefs prefstop
10978 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10979 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10980 global $v
10981 set $v $oldprefs($v)
10983 catch {destroy $prefstop}
10984 unset prefstop
10985 fontcan
10988 proc prefsok {} {
10989 global maxwidth maxgraphpct
10990 global oldprefs prefstop showneartags showlocalchanges
10991 global fontpref mainfont textfont uifont
10992 global limitdiffs treediffs perfile_attrs
10993 global hideremotes
10995 catch {destroy $prefstop}
10996 unset prefstop
10997 fontcan
10998 set fontchanged 0
10999 if {$mainfont ne $fontpref(mainfont)} {
11000 set mainfont $fontpref(mainfont)
11001 parsefont mainfont $mainfont
11002 eval font configure mainfont [fontflags mainfont]
11003 eval font configure mainfontbold [fontflags mainfont 1]
11004 setcoords
11005 set fontchanged 1
11007 if {$textfont ne $fontpref(textfont)} {
11008 set textfont $fontpref(textfont)
11009 parsefont textfont $textfont
11010 eval font configure textfont [fontflags textfont]
11011 eval font configure textfontbold [fontflags textfont 1]
11013 if {$uifont ne $fontpref(uifont)} {
11014 set uifont $fontpref(uifont)
11015 parsefont uifont $uifont
11016 eval font configure uifont [fontflags uifont]
11018 settabs
11019 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11020 if {$showlocalchanges} {
11021 doshowlocalchanges
11022 } else {
11023 dohidelocalchanges
11026 if {$limitdiffs != $oldprefs(limitdiffs) ||
11027 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11028 # treediffs elements are limited by path;
11029 # won't have encodings cached if perfile_attrs was just turned on
11030 catch {unset treediffs}
11032 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11033 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11034 redisplay
11035 } elseif {$showneartags != $oldprefs(showneartags) ||
11036 $limitdiffs != $oldprefs(limitdiffs)} {
11037 reselectline
11039 if {$hideremotes != $oldprefs(hideremotes)} {
11040 rereadrefs
11044 proc formatdate {d} {
11045 global datetimeformat
11046 if {$d ne {}} {
11047 set d [clock format [lindex $d 0] -format $datetimeformat]
11049 return $d
11052 # This list of encoding names and aliases is distilled from
11053 # http://www.iana.org/assignments/character-sets.
11054 # Not all of them are supported by Tcl.
11055 set encoding_aliases {
11056 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11057 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11058 { ISO-10646-UTF-1 csISO10646UTF1 }
11059 { ISO_646.basic:1983 ref csISO646basic1983 }
11060 { INVARIANT csINVARIANT }
11061 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11062 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11063 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11064 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11065 { NATS-DANO iso-ir-9-1 csNATSDANO }
11066 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11067 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11068 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11069 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11070 { ISO-2022-KR csISO2022KR }
11071 { EUC-KR csEUCKR }
11072 { ISO-2022-JP csISO2022JP }
11073 { ISO-2022-JP-2 csISO2022JP2 }
11074 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11075 csISO13JISC6220jp }
11076 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11077 { IT iso-ir-15 ISO646-IT csISO15Italian }
11078 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11079 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11080 { greek7-old iso-ir-18 csISO18Greek7Old }
11081 { latin-greek iso-ir-19 csISO19LatinGreek }
11082 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11083 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11084 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11085 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11086 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11087 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11088 { INIS iso-ir-49 csISO49INIS }
11089 { INIS-8 iso-ir-50 csISO50INIS8 }
11090 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11091 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11092 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11093 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11094 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11095 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11096 csISO60Norwegian1 }
11097 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11098 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11099 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11100 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11101 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11102 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11103 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11104 { greek7 iso-ir-88 csISO88Greek7 }
11105 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11106 { iso-ir-90 csISO90 }
11107 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11108 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11109 csISO92JISC62991984b }
11110 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11111 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11112 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11113 csISO95JIS62291984handadd }
11114 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11115 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11116 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11117 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11118 CP819 csISOLatin1 }
11119 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11120 { T.61-7bit iso-ir-102 csISO102T617bit }
11121 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11122 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11123 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11124 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11125 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11126 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11127 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11128 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11129 arabic csISOLatinArabic }
11130 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11131 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11132 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11133 greek greek8 csISOLatinGreek }
11134 { T.101-G2 iso-ir-128 csISO128T101G2 }
11135 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11136 csISOLatinHebrew }
11137 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11138 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11139 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11140 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11141 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11142 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11143 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11144 csISOLatinCyrillic }
11145 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11146 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11147 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11148 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11149 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11150 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11151 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11152 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11153 { ISO_10367-box iso-ir-155 csISO10367Box }
11154 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11155 { latin-lap lap iso-ir-158 csISO158Lap }
11156 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11157 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11158 { us-dk csUSDK }
11159 { dk-us csDKUS }
11160 { JIS_X0201 X0201 csHalfWidthKatakana }
11161 { KSC5636 ISO646-KR csKSC5636 }
11162 { ISO-10646-UCS-2 csUnicode }
11163 { ISO-10646-UCS-4 csUCS4 }
11164 { DEC-MCS dec csDECMCS }
11165 { hp-roman8 roman8 r8 csHPRoman8 }
11166 { macintosh mac csMacintosh }
11167 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11168 csIBM037 }
11169 { IBM038 EBCDIC-INT cp038 csIBM038 }
11170 { IBM273 CP273 csIBM273 }
11171 { IBM274 EBCDIC-BE CP274 csIBM274 }
11172 { IBM275 EBCDIC-BR cp275 csIBM275 }
11173 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11174 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11175 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11176 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11177 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11178 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11179 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11180 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11181 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11182 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11183 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11184 { IBM437 cp437 437 csPC8CodePage437 }
11185 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11186 { IBM775 cp775 csPC775Baltic }
11187 { IBM850 cp850 850 csPC850Multilingual }
11188 { IBM851 cp851 851 csIBM851 }
11189 { IBM852 cp852 852 csPCp852 }
11190 { IBM855 cp855 855 csIBM855 }
11191 { IBM857 cp857 857 csIBM857 }
11192 { IBM860 cp860 860 csIBM860 }
11193 { IBM861 cp861 861 cp-is csIBM861 }
11194 { IBM862 cp862 862 csPC862LatinHebrew }
11195 { IBM863 cp863 863 csIBM863 }
11196 { IBM864 cp864 csIBM864 }
11197 { IBM865 cp865 865 csIBM865 }
11198 { IBM866 cp866 866 csIBM866 }
11199 { IBM868 CP868 cp-ar csIBM868 }
11200 { IBM869 cp869 869 cp-gr csIBM869 }
11201 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11202 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11203 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11204 { IBM891 cp891 csIBM891 }
11205 { IBM903 cp903 csIBM903 }
11206 { IBM904 cp904 904 csIBBM904 }
11207 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11208 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11209 { IBM1026 CP1026 csIBM1026 }
11210 { EBCDIC-AT-DE csIBMEBCDICATDE }
11211 { EBCDIC-AT-DE-A csEBCDICATDEA }
11212 { EBCDIC-CA-FR csEBCDICCAFR }
11213 { EBCDIC-DK-NO csEBCDICDKNO }
11214 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11215 { EBCDIC-FI-SE csEBCDICFISE }
11216 { EBCDIC-FI-SE-A csEBCDICFISEA }
11217 { EBCDIC-FR csEBCDICFR }
11218 { EBCDIC-IT csEBCDICIT }
11219 { EBCDIC-PT csEBCDICPT }
11220 { EBCDIC-ES csEBCDICES }
11221 { EBCDIC-ES-A csEBCDICESA }
11222 { EBCDIC-ES-S csEBCDICESS }
11223 { EBCDIC-UK csEBCDICUK }
11224 { EBCDIC-US csEBCDICUS }
11225 { UNKNOWN-8BIT csUnknown8BiT }
11226 { MNEMONIC csMnemonic }
11227 { MNEM csMnem }
11228 { VISCII csVISCII }
11229 { VIQR csVIQR }
11230 { KOI8-R csKOI8R }
11231 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11232 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11233 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11234 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11235 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11236 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11237 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11238 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11239 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11240 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11241 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11242 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11243 { IBM1047 IBM-1047 }
11244 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11245 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11246 { UNICODE-1-1 csUnicode11 }
11247 { CESU-8 csCESU-8 }
11248 { BOCU-1 csBOCU-1 }
11249 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11250 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11251 l8 }
11252 { ISO-8859-15 ISO_8859-15 Latin-9 }
11253 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11254 { GBK CP936 MS936 windows-936 }
11255 { JIS_Encoding csJISEncoding }
11256 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11257 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11258 EUC-JP }
11259 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11260 { ISO-10646-UCS-Basic csUnicodeASCII }
11261 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11262 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11263 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11264 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11265 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11266 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11267 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11268 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11269 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11270 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11271 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11272 { Ventura-US csVenturaUS }
11273 { Ventura-International csVenturaInternational }
11274 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11275 { PC8-Turkish csPC8Turkish }
11276 { IBM-Symbols csIBMSymbols }
11277 { IBM-Thai csIBMThai }
11278 { HP-Legal csHPLegal }
11279 { HP-Pi-font csHPPiFont }
11280 { HP-Math8 csHPMath8 }
11281 { Adobe-Symbol-Encoding csHPPSMath }
11282 { HP-DeskTop csHPDesktop }
11283 { Ventura-Math csVenturaMath }
11284 { Microsoft-Publishing csMicrosoftPublishing }
11285 { Windows-31J csWindows31J }
11286 { GB2312 csGB2312 }
11287 { Big5 csBig5 }
11290 proc tcl_encoding {enc} {
11291 global encoding_aliases tcl_encoding_cache
11292 if {[info exists tcl_encoding_cache($enc)]} {
11293 return $tcl_encoding_cache($enc)
11295 set names [encoding names]
11296 set lcnames [string tolower $names]
11297 set enc [string tolower $enc]
11298 set i [lsearch -exact $lcnames $enc]
11299 if {$i < 0} {
11300 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11301 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11302 set i [lsearch -exact $lcnames $encx]
11305 if {$i < 0} {
11306 foreach l $encoding_aliases {
11307 set ll [string tolower $l]
11308 if {[lsearch -exact $ll $enc] < 0} continue
11309 # look through the aliases for one that tcl knows about
11310 foreach e $ll {
11311 set i [lsearch -exact $lcnames $e]
11312 if {$i < 0} {
11313 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11314 set i [lsearch -exact $lcnames $ex]
11317 if {$i >= 0} break
11319 break
11322 set tclenc {}
11323 if {$i >= 0} {
11324 set tclenc [lindex $names $i]
11326 set tcl_encoding_cache($enc) $tclenc
11327 return $tclenc
11330 proc gitattr {path attr default} {
11331 global path_attr_cache
11332 if {[info exists path_attr_cache($attr,$path)]} {
11333 set r $path_attr_cache($attr,$path)
11334 } else {
11335 set r "unspecified"
11336 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11337 regexp "(.*): $attr: (.*)" $line m f r
11339 set path_attr_cache($attr,$path) $r
11341 if {$r eq "unspecified"} {
11342 return $default
11344 return $r
11347 proc cache_gitattr {attr pathlist} {
11348 global path_attr_cache
11349 set newlist {}
11350 foreach path $pathlist {
11351 if {![info exists path_attr_cache($attr,$path)]} {
11352 lappend newlist $path
11355 set lim 1000
11356 if {[tk windowingsystem] == "win32"} {
11357 # windows has a 32k limit on the arguments to a command...
11358 set lim 30
11360 while {$newlist ne {}} {
11361 set head [lrange $newlist 0 [expr {$lim - 1}]]
11362 set newlist [lrange $newlist $lim end]
11363 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11364 foreach row [split $rlist "\n"] {
11365 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11366 if {[string index $path 0] eq "\""} {
11367 set path [encoding convertfrom [lindex $path 0]]
11369 set path_attr_cache($attr,$path) $value
11376 proc get_path_encoding {path} {
11377 global gui_encoding perfile_attrs
11378 set tcl_enc $gui_encoding
11379 if {$path ne {} && $perfile_attrs} {
11380 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11381 if {$enc2 ne {}} {
11382 set tcl_enc $enc2
11385 return $tcl_enc
11388 # First check that Tcl/Tk is recent enough
11389 if {[catch {package require Tk 8.4} err]} {
11390 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11391 Gitk requires at least Tcl/Tk 8.4." list
11392 exit 1
11395 # defaults...
11396 set wrcomcmd "git diff-tree --stdin -p --pretty"
11398 set gitencoding {}
11399 catch {
11400 set gitencoding [exec git config --get i18n.commitencoding]
11402 catch {
11403 set gitencoding [exec git config --get i18n.logoutputencoding]
11405 if {$gitencoding == ""} {
11406 set gitencoding "utf-8"
11408 set tclencoding [tcl_encoding $gitencoding]
11409 if {$tclencoding == {}} {
11410 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11413 set gui_encoding [encoding system]
11414 catch {
11415 set enc [exec git config --get gui.encoding]
11416 if {$enc ne {}} {
11417 set tclenc [tcl_encoding $enc]
11418 if {$tclenc ne {}} {
11419 set gui_encoding $tclenc
11420 } else {
11421 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11426 if {[tk windowingsystem] eq "aqua"} {
11427 set mainfont {{Lucida Grande} 9}
11428 set textfont {Monaco 9}
11429 set uifont {{Lucida Grande} 9 bold}
11430 } else {
11431 set mainfont {Helvetica 9}
11432 set textfont {Courier 9}
11433 set uifont {Helvetica 9 bold}
11435 set tabstop 8
11436 set findmergefiles 0
11437 set maxgraphpct 50
11438 set maxwidth 16
11439 set revlistorder 0
11440 set fastdate 0
11441 set uparrowlen 5
11442 set downarrowlen 5
11443 set mingaplen 100
11444 set cmitmode "patch"
11445 set wrapcomment "none"
11446 set showneartags 1
11447 set hideremotes 0
11448 set maxrefs 20
11449 set maxlinelen 200
11450 set showlocalchanges 1
11451 set limitdiffs 1
11452 set datetimeformat "%Y-%m-%d %H:%M:%S"
11453 set autoselect 1
11454 set autosellen 40
11455 set perfile_attrs 0
11456 set want_ttk 1
11458 if {[tk windowingsystem] eq "aqua"} {
11459 set extdifftool "opendiff"
11460 } else {
11461 set extdifftool "meld"
11464 set colors {green red blue magenta darkgrey brown orange}
11465 if {[tk windowingsystem] eq "win32"} {
11466 set uicolor SystemButtonFace
11467 set bgcolor SystemWindow
11468 set fgcolor SystemButtonText
11469 set selectbgcolor SystemHighlight
11470 } else {
11471 set uicolor grey85
11472 set bgcolor white
11473 set fgcolor black
11474 set selectbgcolor gray85
11476 set diffcolors {red "#00a000" blue}
11477 set diffcontext 3
11478 set ignorespace 0
11479 set worddiff ""
11480 set markbgcolor "#e0e0ff"
11482 set circlecolors {white blue gray blue blue}
11484 # button for popping up context menus
11485 if {[tk windowingsystem] eq "aqua"} {
11486 set ctxbut <Button-2>
11487 } else {
11488 set ctxbut <Button-3>
11491 ## For msgcat loading, first locate the installation location.
11492 if { [info exists ::env(GITK_MSGSDIR)] } {
11493 ## Msgsdir was manually set in the environment.
11494 set gitk_msgsdir $::env(GITK_MSGSDIR)
11495 } else {
11496 ## Let's guess the prefix from argv0.
11497 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11498 set gitk_libdir [file join $gitk_prefix share gitk lib]
11499 set gitk_msgsdir [file join $gitk_libdir msgs]
11500 unset gitk_prefix
11503 ## Internationalization (i18n) through msgcat and gettext. See
11504 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11505 package require msgcat
11506 namespace import ::msgcat::mc
11507 ## And eventually load the actual message catalog
11508 ::msgcat::mcload $gitk_msgsdir
11510 catch {source ~/.gitk}
11512 parsefont mainfont $mainfont
11513 eval font create mainfont [fontflags mainfont]
11514 eval font create mainfontbold [fontflags mainfont 1]
11516 parsefont textfont $textfont
11517 eval font create textfont [fontflags textfont]
11518 eval font create textfontbold [fontflags textfont 1]
11520 parsefont uifont $uifont
11521 eval font create uifont [fontflags uifont]
11523 setui $uicolor
11525 setoptions
11527 # check that we can find a .git directory somewhere...
11528 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
11529 show_error {} . [mc "Cannot find a git repository here."]
11530 exit 1
11533 set selecthead {}
11534 set selectheadid {}
11536 set revtreeargs {}
11537 set cmdline_files {}
11538 set i 0
11539 set revtreeargscmd {}
11540 foreach arg $argv {
11541 switch -glob -- $arg {
11542 "" { }
11543 "--" {
11544 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11545 break
11547 "--select-commit=*" {
11548 set selecthead [string range $arg 16 end]
11550 "--argscmd=*" {
11551 set revtreeargscmd [string range $arg 10 end]
11553 default {
11554 lappend revtreeargs $arg
11557 incr i
11560 if {$selecthead eq "HEAD"} {
11561 set selecthead {}
11564 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11565 # no -- on command line, but some arguments (other than --argscmd)
11566 if {[catch {
11567 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11568 set cmdline_files [split $f "\n"]
11569 set n [llength $cmdline_files]
11570 set revtreeargs [lrange $revtreeargs 0 end-$n]
11571 # Unfortunately git rev-parse doesn't produce an error when
11572 # something is both a revision and a filename. To be consistent
11573 # with git log and git rev-list, check revtreeargs for filenames.
11574 foreach arg $revtreeargs {
11575 if {[file exists $arg]} {
11576 show_error {} . [mc "Ambiguous argument '%s': both revision\
11577 and filename" $arg]
11578 exit 1
11581 } err]} {
11582 # unfortunately we get both stdout and stderr in $err,
11583 # so look for "fatal:".
11584 set i [string first "fatal:" $err]
11585 if {$i > 0} {
11586 set err [string range $err [expr {$i + 6}] end]
11588 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11589 exit 1
11593 set nullid "0000000000000000000000000000000000000000"
11594 set nullid2 "0000000000000000000000000000000000000001"
11595 set nullfile "/dev/null"
11597 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11598 if {![info exists have_ttk]} {
11599 set have_ttk [llength [info commands ::ttk::style]]
11601 set use_ttk [expr {$have_ttk && $want_ttk}]
11602 set NS [expr {$use_ttk ? "ttk" : ""}]
11604 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
11606 set show_notes {}
11607 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
11608 set show_notes "--show-notes"
11611 set runq {}
11612 set history {}
11613 set historyindex 0
11614 set fh_serial 0
11615 set nhl_names {}
11616 set highlight_paths {}
11617 set findpattern {}
11618 set searchdirn -forwards
11619 set boldids {}
11620 set boldnameids {}
11621 set diffelide {0 0}
11622 set markingmatches 0
11623 set linkentercount 0
11624 set need_redisplay 0
11625 set nrows_drawn 0
11626 set firsttabstop 0
11628 set nextviewnum 1
11629 set curview 0
11630 set selectedview 0
11631 set selectedhlview [mc "None"]
11632 set highlight_related [mc "None"]
11633 set highlight_files {}
11634 set viewfiles(0) {}
11635 set viewperm(0) 0
11636 set viewargs(0) {}
11637 set viewargscmd(0) {}
11639 set selectedline {}
11640 set numcommits 0
11641 set loginstance 0
11642 set cmdlineok 0
11643 set stopped 0
11644 set stuffsaved 0
11645 set patchnum 0
11646 set lserial 0
11647 set hasworktree [hasworktree]
11648 set cdup {}
11649 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
11650 set cdup [exec git rev-parse --show-cdup]
11652 set worktree [exec git rev-parse --show-toplevel]
11653 setcoords
11654 makewindow
11655 catch {
11656 image create photo gitlogo -width 16 -height 16
11658 image create photo gitlogominus -width 4 -height 2
11659 gitlogominus put #C00000 -to 0 0 4 2
11660 gitlogo copy gitlogominus -to 1 5
11661 gitlogo copy gitlogominus -to 6 5
11662 gitlogo copy gitlogominus -to 11 5
11663 image delete gitlogominus
11665 image create photo gitlogoplus -width 4 -height 4
11666 gitlogoplus put #008000 -to 1 0 3 4
11667 gitlogoplus put #008000 -to 0 1 4 3
11668 gitlogo copy gitlogoplus -to 1 9
11669 gitlogo copy gitlogoplus -to 6 9
11670 gitlogo copy gitlogoplus -to 11 9
11671 image delete gitlogoplus
11673 image create photo gitlogo32 -width 32 -height 32
11674 gitlogo32 copy gitlogo -zoom 2 2
11676 wm iconphoto . -default gitlogo gitlogo32
11678 # wait for the window to become visible
11679 tkwait visibility .
11680 wm title . "[file tail $argv0]: [file tail [pwd]]"
11681 update
11682 readrefs
11684 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11685 # create a view for the files/dirs specified on the command line
11686 set curview 1
11687 set selectedview 1
11688 set nextviewnum 2
11689 set viewname(1) [mc "Command line"]
11690 set viewfiles(1) $cmdline_files
11691 set viewargs(1) $revtreeargs
11692 set viewargscmd(1) $revtreeargscmd
11693 set viewperm(1) 0
11694 set vdatemode(1) 0
11695 addviewmenu 1
11696 .bar.view entryconf [mca "Edit view..."] -state normal
11697 .bar.view entryconf [mca "Delete view"] -state normal
11700 if {[info exists permviews]} {
11701 foreach v $permviews {
11702 set n $nextviewnum
11703 incr nextviewnum
11704 set viewname($n) [lindex $v 0]
11705 set viewfiles($n) [lindex $v 1]
11706 set viewargs($n) [lindex $v 2]
11707 set viewargscmd($n) [lindex $v 3]
11708 set viewperm($n) 1
11709 addviewmenu $n
11713 if {[tk windowingsystem] eq "win32"} {
11714 focus -force .
11717 getcommits {}
11719 # Local variables:
11720 # mode: tcl
11721 # indent-tabs-mode: t
11722 # tab-width: 8
11723 # End: