gitk: Simplify calculation of gitdir
[git/jnareb-git.git] / gitk
blobfacf294cc01d4bdb5091c355f55ce69244b5ec66
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 # A simple scheduler for compute-intensive stuff.
13 # The aim is to make sure that event handlers for GUI actions can
14 # run at least every 50-100 ms. Unfortunately fileevent handlers are
15 # run before X event handlers, so reading from a fast source can
16 # make the GUI completely unresponsive.
17 proc run args {
18 global isonrunq runq currunq
20 set script $args
21 if {[info exists isonrunq($script)]} return
22 if {$runq eq {} && ![info exists currunq]} {
23 after idle dorunq
25 lappend runq [list {} $script]
26 set isonrunq($script) 1
29 proc filerun {fd script} {
30 fileevent $fd readable [list filereadable $fd $script]
33 proc filereadable {fd script} {
34 global runq currunq
36 fileevent $fd readable {}
37 if {$runq eq {} && ![info exists currunq]} {
38 after idle dorunq
40 lappend runq [list $fd $script]
43 proc nukefile {fd} {
44 global runq
46 for {set i 0} {$i < [llength $runq]} {} {
47 if {[lindex $runq $i 0] eq $fd} {
48 set runq [lreplace $runq $i $i]
49 } else {
50 incr i
55 proc dorunq {} {
56 global isonrunq runq currunq
58 set tstart [clock clicks -milliseconds]
59 set t0 $tstart
60 while {[llength $runq] > 0} {
61 set fd [lindex $runq 0 0]
62 set script [lindex $runq 0 1]
63 set currunq [lindex $runq 0]
64 set runq [lrange $runq 1 end]
65 set repeat [eval $script]
66 unset currunq
67 set t1 [clock clicks -milliseconds]
68 set t [expr {$t1 - $t0}]
69 if {$repeat ne {} && $repeat} {
70 if {$fd eq {} || $repeat == 2} {
71 # script returns 1 if it wants to be readded
72 # file readers return 2 if they could do more straight away
73 lappend runq [list $fd $script]
74 } else {
75 fileevent $fd readable [list filereadable $fd $script]
77 } elseif {$fd eq {}} {
78 unset isonrunq($script)
80 set t0 $t1
81 if {$t1 - $tstart >= 80} break
83 if {$runq ne {}} {
84 after idle dorunq
88 proc reg_instance {fd} {
89 global commfd leftover loginstance
91 set i [incr loginstance]
92 set commfd($i) $fd
93 set leftover($i) {}
94 return $i
97 proc unmerged_files {files} {
98 global nr_unmerged
100 # find the list of unmerged files
101 set mlist {}
102 set nr_unmerged 0
103 if {[catch {
104 set fd [open "| git ls-files -u" r]
105 } err]} {
106 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
107 exit 1
109 while {[gets $fd line] >= 0} {
110 set i [string first "\t" $line]
111 if {$i < 0} continue
112 set fname [string range $line [expr {$i+1}] end]
113 if {[lsearch -exact $mlist $fname] >= 0} continue
114 incr nr_unmerged
115 if {$files eq {} || [path_filter $files $fname]} {
116 lappend mlist $fname
119 catch {close $fd}
120 return $mlist
123 proc parseviewargs {n arglist} {
124 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
125 global worddiff git_version
127 set vdatemode($n) 0
128 set vmergeonly($n) 0
129 set glflags {}
130 set diffargs {}
131 set nextisval 0
132 set revargs {}
133 set origargs $arglist
134 set allknown 1
135 set filtered 0
136 set i -1
137 foreach arg $arglist {
138 incr i
139 if {$nextisval} {
140 lappend glflags $arg
141 set nextisval 0
142 continue
144 switch -glob -- $arg {
145 "-d" -
146 "--date-order" {
147 set vdatemode($n) 1
148 # remove from origargs in case we hit an unknown option
149 set origargs [lreplace $origargs $i $i]
150 incr i -1
152 "-[puabwcrRBMC]" -
153 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
154 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
155 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
156 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
157 "--ignore-space-change" - "-U*" - "--unified=*" {
158 # These request or affect diff output, which we don't want.
159 # Some could be used to set our defaults for diff display.
160 lappend diffargs $arg
162 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
163 "--name-only" - "--name-status" - "--color" -
164 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
165 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
166 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
167 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
168 "--objects" - "--objects-edge" - "--reverse" {
169 # These cause our parsing of git log's output to fail, or else
170 # they're options we want to set ourselves, so ignore them.
172 "--color-words*" - "--word-diff=color" {
173 # These trigger a word diff in the console interface,
174 # so help the user by enabling our own support
175 if {[package vcompare $git_version "1.7.2"] >= 0} {
176 set worddiff [mc "Color words"]
179 "--word-diff*" {
180 if {[package vcompare $git_version "1.7.2"] >= 0} {
181 set worddiff [mc "Markup words"]
184 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
185 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
186 "--full-history" - "--dense" - "--sparse" -
187 "--follow" - "--left-right" - "--encoding=*" {
188 # These are harmless, and some are even useful
189 lappend glflags $arg
191 "--diff-filter=*" - "--no-merges" - "--unpacked" -
192 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
193 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
194 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
195 "--remove-empty" - "--first-parent" - "--cherry-pick" -
196 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
197 "--simplify-by-decoration" {
198 # These mean that we get a subset of the commits
199 set filtered 1
200 lappend glflags $arg
202 "-n" {
203 # This appears to be the only one that has a value as a
204 # separate word following it
205 set filtered 1
206 set nextisval 1
207 lappend glflags $arg
209 "--not" - "--all" {
210 lappend revargs $arg
212 "--merge" {
213 set vmergeonly($n) 1
214 # git rev-parse doesn't understand --merge
215 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
217 "--no-replace-objects" {
218 set env(GIT_NO_REPLACE_OBJECTS) "1"
220 "-*" {
221 # Other flag arguments including -<n>
222 if {[string is digit -strict [string range $arg 1 end]]} {
223 set filtered 1
224 } else {
225 # a flag argument that we don't recognize;
226 # that means we can't optimize
227 set allknown 0
229 lappend glflags $arg
231 default {
232 # Non-flag arguments specify commits or ranges of commits
233 if {[string match "*...*" $arg]} {
234 lappend revargs --gitk-symmetric-diff-marker
236 lappend revargs $arg
240 set vdflags($n) $diffargs
241 set vflags($n) $glflags
242 set vrevs($n) $revargs
243 set vfiltered($n) $filtered
244 set vorigargs($n) $origargs
245 return $allknown
248 proc parseviewrevs {view revs} {
249 global vposids vnegids
251 if {$revs eq {}} {
252 set revs HEAD
254 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
255 # we get stdout followed by stderr in $err
256 # for an unknown rev, git rev-parse echoes it and then errors out
257 set errlines [split $err "\n"]
258 set badrev {}
259 for {set l 0} {$l < [llength $errlines]} {incr l} {
260 set line [lindex $errlines $l]
261 if {!([string length $line] == 40 && [string is xdigit $line])} {
262 if {[string match "fatal:*" $line]} {
263 if {[string match "fatal: ambiguous argument*" $line]
264 && $badrev ne {}} {
265 if {[llength $badrev] == 1} {
266 set err "unknown revision $badrev"
267 } else {
268 set err "unknown revisions: [join $badrev ", "]"
270 } else {
271 set err [join [lrange $errlines $l end] "\n"]
273 break
275 lappend badrev $line
278 error_popup "[mc "Error parsing revisions:"] $err"
279 return {}
281 set ret {}
282 set pos {}
283 set neg {}
284 set sdm 0
285 foreach id [split $ids "\n"] {
286 if {$id eq "--gitk-symmetric-diff-marker"} {
287 set sdm 4
288 } elseif {[string match "^*" $id]} {
289 if {$sdm != 1} {
290 lappend ret $id
291 if {$sdm == 3} {
292 set sdm 0
295 lappend neg [string range $id 1 end]
296 } else {
297 if {$sdm != 2} {
298 lappend ret $id
299 } else {
300 lset ret end $id...[lindex $ret end]
302 lappend pos $id
304 incr sdm -1
306 set vposids($view) $pos
307 set vnegids($view) $neg
308 return $ret
311 # Start off a git log process and arrange to read its output
312 proc start_rev_list {view} {
313 global startmsecs commitidx viewcomplete curview
314 global tclencoding
315 global viewargs viewargscmd viewfiles vfilelimit
316 global showlocalchanges
317 global viewactive viewinstances vmergeonly
318 global mainheadid viewmainheadid viewmainheadid_orig
319 global vcanopt vflags vrevs vorigargs
320 global show_notes
322 set startmsecs [clock clicks -milliseconds]
323 set commitidx($view) 0
324 # these are set this way for the error exits
325 set viewcomplete($view) 1
326 set viewactive($view) 0
327 varcinit $view
329 set args $viewargs($view)
330 if {$viewargscmd($view) ne {}} {
331 if {[catch {
332 set str [exec sh -c $viewargscmd($view)]
333 } err]} {
334 error_popup "[mc "Error executing --argscmd command:"] $err"
335 return 0
337 set args [concat $args [split $str "\n"]]
339 set vcanopt($view) [parseviewargs $view $args]
341 set files $viewfiles($view)
342 if {$vmergeonly($view)} {
343 set files [unmerged_files $files]
344 if {$files eq {}} {
345 global nr_unmerged
346 if {$nr_unmerged == 0} {
347 error_popup [mc "No files selected: --merge specified but\
348 no files are unmerged."]
349 } else {
350 error_popup [mc "No files selected: --merge specified but\
351 no unmerged files are within file limit."]
353 return 0
356 set vfilelimit($view) $files
358 if {$vcanopt($view)} {
359 set revs [parseviewrevs $view $vrevs($view)]
360 if {$revs eq {}} {
361 return 0
363 set args [concat $vflags($view) $revs]
364 } else {
365 set args $vorigargs($view)
368 if {[catch {
369 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
370 --parents --boundary $args "--" $files] r]
371 } err]} {
372 error_popup "[mc "Error executing git log:"] $err"
373 return 0
375 set i [reg_instance $fd]
376 set viewinstances($view) [list $i]
377 set viewmainheadid($view) $mainheadid
378 set viewmainheadid_orig($view) $mainheadid
379 if {$files ne {} && $mainheadid ne {}} {
380 get_viewmainhead $view
382 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
383 interestedin $viewmainheadid($view) dodiffindex
385 fconfigure $fd -blocking 0 -translation lf -eofchar {}
386 if {$tclencoding != {}} {
387 fconfigure $fd -encoding $tclencoding
389 filerun $fd [list getcommitlines $fd $i $view 0]
390 nowbusy $view [mc "Reading"]
391 set viewcomplete($view) 0
392 set viewactive($view) 1
393 return 1
396 proc stop_instance {inst} {
397 global commfd leftover
399 set fd $commfd($inst)
400 catch {
401 set pid [pid $fd]
403 if {$::tcl_platform(platform) eq {windows}} {
404 exec kill -f $pid
405 } else {
406 exec kill $pid
409 catch {close $fd}
410 nukefile $fd
411 unset commfd($inst)
412 unset leftover($inst)
415 proc stop_backends {} {
416 global commfd
418 foreach inst [array names commfd] {
419 stop_instance $inst
423 proc stop_rev_list {view} {
424 global viewinstances
426 foreach inst $viewinstances($view) {
427 stop_instance $inst
429 set viewinstances($view) {}
432 proc reset_pending_select {selid} {
433 global pending_select mainheadid selectheadid
435 if {$selid ne {}} {
436 set pending_select $selid
437 } elseif {$selectheadid ne {}} {
438 set pending_select $selectheadid
439 } else {
440 set pending_select $mainheadid
444 proc getcommits {selid} {
445 global canv curview need_redisplay viewactive
447 initlayout
448 if {[start_rev_list $curview]} {
449 reset_pending_select $selid
450 show_status [mc "Reading commits..."]
451 set need_redisplay 1
452 } else {
453 show_status [mc "No commits selected"]
457 proc updatecommits {} {
458 global curview vcanopt vorigargs vfilelimit viewinstances
459 global viewactive viewcomplete tclencoding
460 global startmsecs showneartags showlocalchanges
461 global mainheadid viewmainheadid viewmainheadid_orig pending_select
462 global isworktree
463 global varcid vposids vnegids vflags vrevs
464 global show_notes
466 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
467 rereadrefs
468 set view $curview
469 if {$mainheadid ne $viewmainheadid_orig($view)} {
470 if {$showlocalchanges} {
471 dohidelocalchanges
473 set viewmainheadid($view) $mainheadid
474 set viewmainheadid_orig($view) $mainheadid
475 if {$vfilelimit($view) ne {}} {
476 get_viewmainhead $view
479 if {$showlocalchanges} {
480 doshowlocalchanges
482 if {$vcanopt($view)} {
483 set oldpos $vposids($view)
484 set oldneg $vnegids($view)
485 set revs [parseviewrevs $view $vrevs($view)]
486 if {$revs eq {}} {
487 return
489 # note: getting the delta when negative refs change is hard,
490 # and could require multiple git log invocations, so in that
491 # case we ask git log for all the commits (not just the delta)
492 if {$oldneg eq $vnegids($view)} {
493 set newrevs {}
494 set npos 0
495 # take out positive refs that we asked for before or
496 # that we have already seen
497 foreach rev $revs {
498 if {[string length $rev] == 40} {
499 if {[lsearch -exact $oldpos $rev] < 0
500 && ![info exists varcid($view,$rev)]} {
501 lappend newrevs $rev
502 incr npos
504 } else {
505 lappend $newrevs $rev
508 if {$npos == 0} return
509 set revs $newrevs
510 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
512 set args [concat $vflags($view) $revs --not $oldpos]
513 } else {
514 set args $vorigargs($view)
516 if {[catch {
517 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
518 --parents --boundary $args "--" $vfilelimit($view)] r]
519 } err]} {
520 error_popup "[mc "Error executing git log:"] $err"
521 return
523 if {$viewactive($view) == 0} {
524 set startmsecs [clock clicks -milliseconds]
526 set i [reg_instance $fd]
527 lappend viewinstances($view) $i
528 fconfigure $fd -blocking 0 -translation lf -eofchar {}
529 if {$tclencoding != {}} {
530 fconfigure $fd -encoding $tclencoding
532 filerun $fd [list getcommitlines $fd $i $view 1]
533 incr viewactive($view)
534 set viewcomplete($view) 0
535 reset_pending_select {}
536 nowbusy $view [mc "Reading"]
537 if {$showneartags} {
538 getallcommits
542 proc reloadcommits {} {
543 global curview viewcomplete selectedline currentid thickerline
544 global showneartags treediffs commitinterest cached_commitrow
545 global targetid
547 set selid {}
548 if {$selectedline ne {}} {
549 set selid $currentid
552 if {!$viewcomplete($curview)} {
553 stop_rev_list $curview
555 resetvarcs $curview
556 set selectedline {}
557 catch {unset currentid}
558 catch {unset thickerline}
559 catch {unset treediffs}
560 readrefs
561 changedrefs
562 if {$showneartags} {
563 getallcommits
565 clear_display
566 catch {unset commitinterest}
567 catch {unset cached_commitrow}
568 catch {unset targetid}
569 setcanvscroll
570 getcommits $selid
571 return 0
574 # This makes a string representation of a positive integer which
575 # sorts as a string in numerical order
576 proc strrep {n} {
577 if {$n < 16} {
578 return [format "%x" $n]
579 } elseif {$n < 256} {
580 return [format "x%.2x" $n]
581 } elseif {$n < 65536} {
582 return [format "y%.4x" $n]
584 return [format "z%.8x" $n]
587 # Procedures used in reordering commits from git log (without
588 # --topo-order) into the order for display.
590 proc varcinit {view} {
591 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
592 global vtokmod varcmod vrowmod varcix vlastins
594 set varcstart($view) {{}}
595 set vupptr($view) {0}
596 set vdownptr($view) {0}
597 set vleftptr($view) {0}
598 set vbackptr($view) {0}
599 set varctok($view) {{}}
600 set varcrow($view) {{}}
601 set vtokmod($view) {}
602 set varcmod($view) 0
603 set vrowmod($view) 0
604 set varcix($view) {{}}
605 set vlastins($view) {0}
608 proc resetvarcs {view} {
609 global varcid varccommits parents children vseedcount ordertok
611 foreach vid [array names varcid $view,*] {
612 unset varcid($vid)
613 unset children($vid)
614 unset parents($vid)
616 # some commits might have children but haven't been seen yet
617 foreach vid [array names children $view,*] {
618 unset children($vid)
620 foreach va [array names varccommits $view,*] {
621 unset varccommits($va)
623 foreach vd [array names vseedcount $view,*] {
624 unset vseedcount($vd)
626 catch {unset ordertok}
629 # returns a list of the commits with no children
630 proc seeds {v} {
631 global vdownptr vleftptr varcstart
633 set ret {}
634 set a [lindex $vdownptr($v) 0]
635 while {$a != 0} {
636 lappend ret [lindex $varcstart($v) $a]
637 set a [lindex $vleftptr($v) $a]
639 return $ret
642 proc newvarc {view id} {
643 global varcid varctok parents children vdatemode
644 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
645 global commitdata commitinfo vseedcount varccommits vlastins
647 set a [llength $varctok($view)]
648 set vid $view,$id
649 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
650 if {![info exists commitinfo($id)]} {
651 parsecommit $id $commitdata($id) 1
653 set cdate [lindex [lindex $commitinfo($id) 4] 0]
654 if {![string is integer -strict $cdate]} {
655 set cdate 0
657 if {![info exists vseedcount($view,$cdate)]} {
658 set vseedcount($view,$cdate) -1
660 set c [incr vseedcount($view,$cdate)]
661 set cdate [expr {$cdate ^ 0xffffffff}]
662 set tok "s[strrep $cdate][strrep $c]"
663 } else {
664 set tok {}
666 set ka 0
667 if {[llength $children($vid)] > 0} {
668 set kid [lindex $children($vid) end]
669 set k $varcid($view,$kid)
670 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
671 set ki $kid
672 set ka $k
673 set tok [lindex $varctok($view) $k]
676 if {$ka != 0} {
677 set i [lsearch -exact $parents($view,$ki) $id]
678 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
679 append tok [strrep $j]
681 set c [lindex $vlastins($view) $ka]
682 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
683 set c $ka
684 set b [lindex $vdownptr($view) $ka]
685 } else {
686 set b [lindex $vleftptr($view) $c]
688 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
689 set c $b
690 set b [lindex $vleftptr($view) $c]
692 if {$c == $ka} {
693 lset vdownptr($view) $ka $a
694 lappend vbackptr($view) 0
695 } else {
696 lset vleftptr($view) $c $a
697 lappend vbackptr($view) $c
699 lset vlastins($view) $ka $a
700 lappend vupptr($view) $ka
701 lappend vleftptr($view) $b
702 if {$b != 0} {
703 lset vbackptr($view) $b $a
705 lappend varctok($view) $tok
706 lappend varcstart($view) $id
707 lappend vdownptr($view) 0
708 lappend varcrow($view) {}
709 lappend varcix($view) {}
710 set varccommits($view,$a) {}
711 lappend vlastins($view) 0
712 return $a
715 proc splitvarc {p v} {
716 global varcid varcstart varccommits varctok vtokmod
717 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
719 set oa $varcid($v,$p)
720 set otok [lindex $varctok($v) $oa]
721 set ac $varccommits($v,$oa)
722 set i [lsearch -exact $varccommits($v,$oa) $p]
723 if {$i <= 0} return
724 set na [llength $varctok($v)]
725 # "%" sorts before "0"...
726 set tok "$otok%[strrep $i]"
727 lappend varctok($v) $tok
728 lappend varcrow($v) {}
729 lappend varcix($v) {}
730 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
731 set varccommits($v,$na) [lrange $ac $i end]
732 lappend varcstart($v) $p
733 foreach id $varccommits($v,$na) {
734 set varcid($v,$id) $na
736 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
737 lappend vlastins($v) [lindex $vlastins($v) $oa]
738 lset vdownptr($v) $oa $na
739 lset vlastins($v) $oa 0
740 lappend vupptr($v) $oa
741 lappend vleftptr($v) 0
742 lappend vbackptr($v) 0
743 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
744 lset vupptr($v) $b $na
746 if {[string compare $otok $vtokmod($v)] <= 0} {
747 modify_arc $v $oa
751 proc renumbervarc {a v} {
752 global parents children varctok varcstart varccommits
753 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
755 set t1 [clock clicks -milliseconds]
756 set todo {}
757 set isrelated($a) 1
758 set kidchanged($a) 1
759 set ntot 0
760 while {$a != 0} {
761 if {[info exists isrelated($a)]} {
762 lappend todo $a
763 set id [lindex $varccommits($v,$a) end]
764 foreach p $parents($v,$id) {
765 if {[info exists varcid($v,$p)]} {
766 set isrelated($varcid($v,$p)) 1
770 incr ntot
771 set b [lindex $vdownptr($v) $a]
772 if {$b == 0} {
773 while {$a != 0} {
774 set b [lindex $vleftptr($v) $a]
775 if {$b != 0} break
776 set a [lindex $vupptr($v) $a]
779 set a $b
781 foreach a $todo {
782 if {![info exists kidchanged($a)]} continue
783 set id [lindex $varcstart($v) $a]
784 if {[llength $children($v,$id)] > 1} {
785 set children($v,$id) [lsort -command [list vtokcmp $v] \
786 $children($v,$id)]
788 set oldtok [lindex $varctok($v) $a]
789 if {!$vdatemode($v)} {
790 set tok {}
791 } else {
792 set tok $oldtok
794 set ka 0
795 set kid [last_real_child $v,$id]
796 if {$kid ne {}} {
797 set k $varcid($v,$kid)
798 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
799 set ki $kid
800 set ka $k
801 set tok [lindex $varctok($v) $k]
804 if {$ka != 0} {
805 set i [lsearch -exact $parents($v,$ki) $id]
806 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
807 append tok [strrep $j]
809 if {$tok eq $oldtok} {
810 continue
812 set id [lindex $varccommits($v,$a) end]
813 foreach p $parents($v,$id) {
814 if {[info exists varcid($v,$p)]} {
815 set kidchanged($varcid($v,$p)) 1
816 } else {
817 set sortkids($p) 1
820 lset varctok($v) $a $tok
821 set b [lindex $vupptr($v) $a]
822 if {$b != $ka} {
823 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
824 modify_arc $v $ka
826 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
827 modify_arc $v $b
829 set c [lindex $vbackptr($v) $a]
830 set d [lindex $vleftptr($v) $a]
831 if {$c == 0} {
832 lset vdownptr($v) $b $d
833 } else {
834 lset vleftptr($v) $c $d
836 if {$d != 0} {
837 lset vbackptr($v) $d $c
839 if {[lindex $vlastins($v) $b] == $a} {
840 lset vlastins($v) $b $c
842 lset vupptr($v) $a $ka
843 set c [lindex $vlastins($v) $ka]
844 if {$c == 0 || \
845 [string compare $tok [lindex $varctok($v) $c]] < 0} {
846 set c $ka
847 set b [lindex $vdownptr($v) $ka]
848 } else {
849 set b [lindex $vleftptr($v) $c]
851 while {$b != 0 && \
852 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
853 set c $b
854 set b [lindex $vleftptr($v) $c]
856 if {$c == $ka} {
857 lset vdownptr($v) $ka $a
858 lset vbackptr($v) $a 0
859 } else {
860 lset vleftptr($v) $c $a
861 lset vbackptr($v) $a $c
863 lset vleftptr($v) $a $b
864 if {$b != 0} {
865 lset vbackptr($v) $b $a
867 lset vlastins($v) $ka $a
870 foreach id [array names sortkids] {
871 if {[llength $children($v,$id)] > 1} {
872 set children($v,$id) [lsort -command [list vtokcmp $v] \
873 $children($v,$id)]
876 set t2 [clock clicks -milliseconds]
877 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
880 # Fix up the graph after we have found out that in view $v,
881 # $p (a commit that we have already seen) is actually the parent
882 # of the last commit in arc $a.
883 proc fix_reversal {p a v} {
884 global varcid varcstart varctok vupptr
886 set pa $varcid($v,$p)
887 if {$p ne [lindex $varcstart($v) $pa]} {
888 splitvarc $p $v
889 set pa $varcid($v,$p)
891 # seeds always need to be renumbered
892 if {[lindex $vupptr($v) $pa] == 0 ||
893 [string compare [lindex $varctok($v) $a] \
894 [lindex $varctok($v) $pa]] > 0} {
895 renumbervarc $pa $v
899 proc insertrow {id p v} {
900 global cmitlisted children parents varcid varctok vtokmod
901 global varccommits ordertok commitidx numcommits curview
902 global targetid targetrow
904 readcommit $id
905 set vid $v,$id
906 set cmitlisted($vid) 1
907 set children($vid) {}
908 set parents($vid) [list $p]
909 set a [newvarc $v $id]
910 set varcid($vid) $a
911 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
912 modify_arc $v $a
914 lappend varccommits($v,$a) $id
915 set vp $v,$p
916 if {[llength [lappend children($vp) $id]] > 1} {
917 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
918 catch {unset ordertok}
920 fix_reversal $p $a $v
921 incr commitidx($v)
922 if {$v == $curview} {
923 set numcommits $commitidx($v)
924 setcanvscroll
925 if {[info exists targetid]} {
926 if {![comes_before $targetid $p]} {
927 incr targetrow
933 proc insertfakerow {id p} {
934 global varcid varccommits parents children cmitlisted
935 global commitidx varctok vtokmod targetid targetrow curview numcommits
937 set v $curview
938 set a $varcid($v,$p)
939 set i [lsearch -exact $varccommits($v,$a) $p]
940 if {$i < 0} {
941 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
942 return
944 set children($v,$id) {}
945 set parents($v,$id) [list $p]
946 set varcid($v,$id) $a
947 lappend children($v,$p) $id
948 set cmitlisted($v,$id) 1
949 set numcommits [incr commitidx($v)]
950 # note we deliberately don't update varcstart($v) even if $i == 0
951 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
952 modify_arc $v $a $i
953 if {[info exists targetid]} {
954 if {![comes_before $targetid $p]} {
955 incr targetrow
958 setcanvscroll
959 drawvisible
962 proc removefakerow {id} {
963 global varcid varccommits parents children commitidx
964 global varctok vtokmod cmitlisted currentid selectedline
965 global targetid curview numcommits
967 set v $curview
968 if {[llength $parents($v,$id)] != 1} {
969 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
970 return
972 set p [lindex $parents($v,$id) 0]
973 set a $varcid($v,$id)
974 set i [lsearch -exact $varccommits($v,$a) $id]
975 if {$i < 0} {
976 puts "oops: removefakerow can't find [shortids $id] on arc $a"
977 return
979 unset varcid($v,$id)
980 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
981 unset parents($v,$id)
982 unset children($v,$id)
983 unset cmitlisted($v,$id)
984 set numcommits [incr commitidx($v) -1]
985 set j [lsearch -exact $children($v,$p) $id]
986 if {$j >= 0} {
987 set children($v,$p) [lreplace $children($v,$p) $j $j]
989 modify_arc $v $a $i
990 if {[info exist currentid] && $id eq $currentid} {
991 unset currentid
992 set selectedline {}
994 if {[info exists targetid] && $targetid eq $id} {
995 set targetid $p
997 setcanvscroll
998 drawvisible
1001 proc real_children {vp} {
1002 global children nullid nullid2
1004 set kids {}
1005 foreach id $children($vp) {
1006 if {$id ne $nullid && $id ne $nullid2} {
1007 lappend kids $id
1010 return $kids
1013 proc first_real_child {vp} {
1014 global children nullid nullid2
1016 foreach id $children($vp) {
1017 if {$id ne $nullid && $id ne $nullid2} {
1018 return $id
1021 return {}
1024 proc last_real_child {vp} {
1025 global children nullid nullid2
1027 set kids $children($vp)
1028 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1029 set id [lindex $kids $i]
1030 if {$id ne $nullid && $id ne $nullid2} {
1031 return $id
1034 return {}
1037 proc vtokcmp {v a b} {
1038 global varctok varcid
1040 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1041 [lindex $varctok($v) $varcid($v,$b)]]
1044 # This assumes that if lim is not given, the caller has checked that
1045 # arc a's token is less than $vtokmod($v)
1046 proc modify_arc {v a {lim {}}} {
1047 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1049 if {$lim ne {}} {
1050 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1051 if {$c > 0} return
1052 if {$c == 0} {
1053 set r [lindex $varcrow($v) $a]
1054 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1057 set vtokmod($v) [lindex $varctok($v) $a]
1058 set varcmod($v) $a
1059 if {$v == $curview} {
1060 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1061 set a [lindex $vupptr($v) $a]
1062 set lim {}
1064 set r 0
1065 if {$a != 0} {
1066 if {$lim eq {}} {
1067 set lim [llength $varccommits($v,$a)]
1069 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1071 set vrowmod($v) $r
1072 undolayout $r
1076 proc update_arcrows {v} {
1077 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1078 global varcid vrownum varcorder varcix varccommits
1079 global vupptr vdownptr vleftptr varctok
1080 global displayorder parentlist curview cached_commitrow
1082 if {$vrowmod($v) == $commitidx($v)} return
1083 if {$v == $curview} {
1084 if {[llength $displayorder] > $vrowmod($v)} {
1085 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1086 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1088 catch {unset cached_commitrow}
1090 set narctot [expr {[llength $varctok($v)] - 1}]
1091 set a $varcmod($v)
1092 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1093 # go up the tree until we find something that has a row number,
1094 # or we get to a seed
1095 set a [lindex $vupptr($v) $a]
1097 if {$a == 0} {
1098 set a [lindex $vdownptr($v) 0]
1099 if {$a == 0} return
1100 set vrownum($v) {0}
1101 set varcorder($v) [list $a]
1102 lset varcix($v) $a 0
1103 lset varcrow($v) $a 0
1104 set arcn 0
1105 set row 0
1106 } else {
1107 set arcn [lindex $varcix($v) $a]
1108 if {[llength $vrownum($v)] > $arcn + 1} {
1109 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1110 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1112 set row [lindex $varcrow($v) $a]
1114 while {1} {
1115 set p $a
1116 incr row [llength $varccommits($v,$a)]
1117 # go down if possible
1118 set b [lindex $vdownptr($v) $a]
1119 if {$b == 0} {
1120 # if not, go left, or go up until we can go left
1121 while {$a != 0} {
1122 set b [lindex $vleftptr($v) $a]
1123 if {$b != 0} break
1124 set a [lindex $vupptr($v) $a]
1126 if {$a == 0} break
1128 set a $b
1129 incr arcn
1130 lappend vrownum($v) $row
1131 lappend varcorder($v) $a
1132 lset varcix($v) $a $arcn
1133 lset varcrow($v) $a $row
1135 set vtokmod($v) [lindex $varctok($v) $p]
1136 set varcmod($v) $p
1137 set vrowmod($v) $row
1138 if {[info exists currentid]} {
1139 set selectedline [rowofcommit $currentid]
1143 # Test whether view $v contains commit $id
1144 proc commitinview {id v} {
1145 global varcid
1147 return [info exists varcid($v,$id)]
1150 # Return the row number for commit $id in the current view
1151 proc rowofcommit {id} {
1152 global varcid varccommits varcrow curview cached_commitrow
1153 global varctok vtokmod
1155 set v $curview
1156 if {![info exists varcid($v,$id)]} {
1157 puts "oops rowofcommit no arc for [shortids $id]"
1158 return {}
1160 set a $varcid($v,$id)
1161 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1162 update_arcrows $v
1164 if {[info exists cached_commitrow($id)]} {
1165 return $cached_commitrow($id)
1167 set i [lsearch -exact $varccommits($v,$a) $id]
1168 if {$i < 0} {
1169 puts "oops didn't find commit [shortids $id] in arc $a"
1170 return {}
1172 incr i [lindex $varcrow($v) $a]
1173 set cached_commitrow($id) $i
1174 return $i
1177 # Returns 1 if a is on an earlier row than b, otherwise 0
1178 proc comes_before {a b} {
1179 global varcid varctok curview
1181 set v $curview
1182 if {$a eq $b || ![info exists varcid($v,$a)] || \
1183 ![info exists varcid($v,$b)]} {
1184 return 0
1186 if {$varcid($v,$a) != $varcid($v,$b)} {
1187 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1188 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1190 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1193 proc bsearch {l elt} {
1194 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1195 return 0
1197 set lo 0
1198 set hi [llength $l]
1199 while {$hi - $lo > 1} {
1200 set mid [expr {int(($lo + $hi) / 2)}]
1201 set t [lindex $l $mid]
1202 if {$elt < $t} {
1203 set hi $mid
1204 } elseif {$elt > $t} {
1205 set lo $mid
1206 } else {
1207 return $mid
1210 return $lo
1213 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1214 proc make_disporder {start end} {
1215 global vrownum curview commitidx displayorder parentlist
1216 global varccommits varcorder parents vrowmod varcrow
1217 global d_valid_start d_valid_end
1219 if {$end > $vrowmod($curview)} {
1220 update_arcrows $curview
1222 set ai [bsearch $vrownum($curview) $start]
1223 set start [lindex $vrownum($curview) $ai]
1224 set narc [llength $vrownum($curview)]
1225 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1226 set a [lindex $varcorder($curview) $ai]
1227 set l [llength $displayorder]
1228 set al [llength $varccommits($curview,$a)]
1229 if {$l < $r + $al} {
1230 if {$l < $r} {
1231 set pad [ntimes [expr {$r - $l}] {}]
1232 set displayorder [concat $displayorder $pad]
1233 set parentlist [concat $parentlist $pad]
1234 } elseif {$l > $r} {
1235 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1236 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1238 foreach id $varccommits($curview,$a) {
1239 lappend displayorder $id
1240 lappend parentlist $parents($curview,$id)
1242 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1243 set i $r
1244 foreach id $varccommits($curview,$a) {
1245 lset displayorder $i $id
1246 lset parentlist $i $parents($curview,$id)
1247 incr i
1250 incr r $al
1254 proc commitonrow {row} {
1255 global displayorder
1257 set id [lindex $displayorder $row]
1258 if {$id eq {}} {
1259 make_disporder $row [expr {$row + 1}]
1260 set id [lindex $displayorder $row]
1262 return $id
1265 proc closevarcs {v} {
1266 global varctok varccommits varcid parents children
1267 global cmitlisted commitidx vtokmod
1269 set missing_parents 0
1270 set scripts {}
1271 set narcs [llength $varctok($v)]
1272 for {set a 1} {$a < $narcs} {incr a} {
1273 set id [lindex $varccommits($v,$a) end]
1274 foreach p $parents($v,$id) {
1275 if {[info exists varcid($v,$p)]} continue
1276 # add p as a new commit
1277 incr missing_parents
1278 set cmitlisted($v,$p) 0
1279 set parents($v,$p) {}
1280 if {[llength $children($v,$p)] == 1 &&
1281 [llength $parents($v,$id)] == 1} {
1282 set b $a
1283 } else {
1284 set b [newvarc $v $p]
1286 set varcid($v,$p) $b
1287 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1288 modify_arc $v $b
1290 lappend varccommits($v,$b) $p
1291 incr commitidx($v)
1292 set scripts [check_interest $p $scripts]
1295 if {$missing_parents > 0} {
1296 foreach s $scripts {
1297 eval $s
1302 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1303 # Assumes we already have an arc for $rwid.
1304 proc rewrite_commit {v id rwid} {
1305 global children parents varcid varctok vtokmod varccommits
1307 foreach ch $children($v,$id) {
1308 # make $rwid be $ch's parent in place of $id
1309 set i [lsearch -exact $parents($v,$ch) $id]
1310 if {$i < 0} {
1311 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1313 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1314 # add $ch to $rwid's children and sort the list if necessary
1315 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1316 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1317 $children($v,$rwid)]
1319 # fix the graph after joining $id to $rwid
1320 set a $varcid($v,$ch)
1321 fix_reversal $rwid $a $v
1322 # parentlist is wrong for the last element of arc $a
1323 # even if displayorder is right, hence the 3rd arg here
1324 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1328 # Mechanism for registering a command to be executed when we come
1329 # across a particular commit. To handle the case when only the
1330 # prefix of the commit is known, the commitinterest array is now
1331 # indexed by the first 4 characters of the ID. Each element is a
1332 # list of id, cmd pairs.
1333 proc interestedin {id cmd} {
1334 global commitinterest
1336 lappend commitinterest([string range $id 0 3]) $id $cmd
1339 proc check_interest {id scripts} {
1340 global commitinterest
1342 set prefix [string range $id 0 3]
1343 if {[info exists commitinterest($prefix)]} {
1344 set newlist {}
1345 foreach {i script} $commitinterest($prefix) {
1346 if {[string match "$i*" $id]} {
1347 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1348 } else {
1349 lappend newlist $i $script
1352 if {$newlist ne {}} {
1353 set commitinterest($prefix) $newlist
1354 } else {
1355 unset commitinterest($prefix)
1358 return $scripts
1361 proc getcommitlines {fd inst view updating} {
1362 global cmitlisted leftover
1363 global commitidx commitdata vdatemode
1364 global parents children curview hlview
1365 global idpending ordertok
1366 global varccommits varcid varctok vtokmod vfilelimit
1368 set stuff [read $fd 500000]
1369 # git log doesn't terminate the last commit with a null...
1370 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1371 set stuff "\0"
1373 if {$stuff == {}} {
1374 if {![eof $fd]} {
1375 return 1
1377 global commfd viewcomplete viewactive viewname
1378 global viewinstances
1379 unset commfd($inst)
1380 set i [lsearch -exact $viewinstances($view) $inst]
1381 if {$i >= 0} {
1382 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1384 # set it blocking so we wait for the process to terminate
1385 fconfigure $fd -blocking 1
1386 if {[catch {close $fd} err]} {
1387 set fv {}
1388 if {$view != $curview} {
1389 set fv " for the \"$viewname($view)\" view"
1391 if {[string range $err 0 4] == "usage"} {
1392 set err "Gitk: error reading commits$fv:\
1393 bad arguments to git log."
1394 if {$viewname($view) eq "Command line"} {
1395 append err \
1396 " (Note: arguments to gitk are passed to git log\
1397 to allow selection of commits to be displayed.)"
1399 } else {
1400 set err "Error reading commits$fv: $err"
1402 error_popup $err
1404 if {[incr viewactive($view) -1] <= 0} {
1405 set viewcomplete($view) 1
1406 # Check if we have seen any ids listed as parents that haven't
1407 # appeared in the list
1408 closevarcs $view
1409 notbusy $view
1411 if {$view == $curview} {
1412 run chewcommits
1414 return 0
1416 set start 0
1417 set gotsome 0
1418 set scripts {}
1419 while 1 {
1420 set i [string first "\0" $stuff $start]
1421 if {$i < 0} {
1422 append leftover($inst) [string range $stuff $start end]
1423 break
1425 if {$start == 0} {
1426 set cmit $leftover($inst)
1427 append cmit [string range $stuff 0 [expr {$i - 1}]]
1428 set leftover($inst) {}
1429 } else {
1430 set cmit [string range $stuff $start [expr {$i - 1}]]
1432 set start [expr {$i + 1}]
1433 set j [string first "\n" $cmit]
1434 set ok 0
1435 set listed 1
1436 if {$j >= 0 && [string match "commit *" $cmit]} {
1437 set ids [string range $cmit 7 [expr {$j - 1}]]
1438 if {[string match {[-^<>]*} $ids]} {
1439 switch -- [string index $ids 0] {
1440 "-" {set listed 0}
1441 "^" {set listed 2}
1442 "<" {set listed 3}
1443 ">" {set listed 4}
1445 set ids [string range $ids 1 end]
1447 set ok 1
1448 foreach id $ids {
1449 if {[string length $id] != 40} {
1450 set ok 0
1451 break
1455 if {!$ok} {
1456 set shortcmit $cmit
1457 if {[string length $shortcmit] > 80} {
1458 set shortcmit "[string range $shortcmit 0 80]..."
1460 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1461 exit 1
1463 set id [lindex $ids 0]
1464 set vid $view,$id
1466 if {!$listed && $updating && ![info exists varcid($vid)] &&
1467 $vfilelimit($view) ne {}} {
1468 # git log doesn't rewrite parents for unlisted commits
1469 # when doing path limiting, so work around that here
1470 # by working out the rewritten parent with git rev-list
1471 # and if we already know about it, using the rewritten
1472 # parent as a substitute parent for $id's children.
1473 if {![catch {
1474 set rwid [exec git rev-list --first-parent --max-count=1 \
1475 $id -- $vfilelimit($view)]
1476 }]} {
1477 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1478 # use $rwid in place of $id
1479 rewrite_commit $view $id $rwid
1480 continue
1485 set a 0
1486 if {[info exists varcid($vid)]} {
1487 if {$cmitlisted($vid) || !$listed} continue
1488 set a $varcid($vid)
1490 if {$listed} {
1491 set olds [lrange $ids 1 end]
1492 } else {
1493 set olds {}
1495 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1496 set cmitlisted($vid) $listed
1497 set parents($vid) $olds
1498 if {![info exists children($vid)]} {
1499 set children($vid) {}
1500 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1501 set k [lindex $children($vid) 0]
1502 if {[llength $parents($view,$k)] == 1 &&
1503 (!$vdatemode($view) ||
1504 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1505 set a $varcid($view,$k)
1508 if {$a == 0} {
1509 # new arc
1510 set a [newvarc $view $id]
1512 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1513 modify_arc $view $a
1515 if {![info exists varcid($vid)]} {
1516 set varcid($vid) $a
1517 lappend varccommits($view,$a) $id
1518 incr commitidx($view)
1521 set i 0
1522 foreach p $olds {
1523 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1524 set vp $view,$p
1525 if {[llength [lappend children($vp) $id]] > 1 &&
1526 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1527 set children($vp) [lsort -command [list vtokcmp $view] \
1528 $children($vp)]
1529 catch {unset ordertok}
1531 if {[info exists varcid($view,$p)]} {
1532 fix_reversal $p $a $view
1535 incr i
1538 set scripts [check_interest $id $scripts]
1539 set gotsome 1
1541 if {$gotsome} {
1542 global numcommits hlview
1544 if {$view == $curview} {
1545 set numcommits $commitidx($view)
1546 run chewcommits
1548 if {[info exists hlview] && $view == $hlview} {
1549 # we never actually get here...
1550 run vhighlightmore
1552 foreach s $scripts {
1553 eval $s
1556 return 2
1559 proc chewcommits {} {
1560 global curview hlview viewcomplete
1561 global pending_select
1563 layoutmore
1564 if {$viewcomplete($curview)} {
1565 global commitidx varctok
1566 global numcommits startmsecs
1568 if {[info exists pending_select]} {
1569 update
1570 reset_pending_select {}
1572 if {[commitinview $pending_select $curview]} {
1573 selectline [rowofcommit $pending_select] 1
1574 } else {
1575 set row [first_real_row]
1576 selectline $row 1
1579 if {$commitidx($curview) > 0} {
1580 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1581 #puts "overall $ms ms for $numcommits commits"
1582 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1583 } else {
1584 show_status [mc "No commits selected"]
1586 notbusy layout
1588 return 0
1591 proc do_readcommit {id} {
1592 global tclencoding
1594 # Invoke git-log to handle automatic encoding conversion
1595 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1596 # Read the results using i18n.logoutputencoding
1597 fconfigure $fd -translation lf -eofchar {}
1598 if {$tclencoding != {}} {
1599 fconfigure $fd -encoding $tclencoding
1601 set contents [read $fd]
1602 close $fd
1603 # Remove the heading line
1604 regsub {^commit [0-9a-f]+\n} $contents {} contents
1606 return $contents
1609 proc readcommit {id} {
1610 if {[catch {set contents [do_readcommit $id]}]} return
1611 parsecommit $id $contents 1
1614 proc parsecommit {id contents listed} {
1615 global commitinfo
1617 set inhdr 1
1618 set comment {}
1619 set headline {}
1620 set auname {}
1621 set audate {}
1622 set comname {}
1623 set comdate {}
1624 set hdrend [string first "\n\n" $contents]
1625 if {$hdrend < 0} {
1626 # should never happen...
1627 set hdrend [string length $contents]
1629 set header [string range $contents 0 [expr {$hdrend - 1}]]
1630 set comment [string range $contents [expr {$hdrend + 2}] end]
1631 foreach line [split $header "\n"] {
1632 set line [split $line " "]
1633 set tag [lindex $line 0]
1634 if {$tag == "author"} {
1635 set audate [lrange $line end-1 end]
1636 set auname [join [lrange $line 1 end-2] " "]
1637 } elseif {$tag == "committer"} {
1638 set comdate [lrange $line end-1 end]
1639 set comname [join [lrange $line 1 end-2] " "]
1642 set headline {}
1643 # take the first non-blank line of the comment as the headline
1644 set headline [string trimleft $comment]
1645 set i [string first "\n" $headline]
1646 if {$i >= 0} {
1647 set headline [string range $headline 0 $i]
1649 set headline [string trimright $headline]
1650 set i [string first "\r" $headline]
1651 if {$i >= 0} {
1652 set headline [string trimright [string range $headline 0 $i]]
1654 if {!$listed} {
1655 # git log indents the comment by 4 spaces;
1656 # if we got this via git cat-file, add the indentation
1657 set newcomment {}
1658 foreach line [split $comment "\n"] {
1659 append newcomment " "
1660 append newcomment $line
1661 append newcomment "\n"
1663 set comment $newcomment
1665 set hasnote [string first "\nNotes:\n" $contents]
1666 set commitinfo($id) [list $headline $auname $audate \
1667 $comname $comdate $comment $hasnote]
1670 proc getcommit {id} {
1671 global commitdata commitinfo
1673 if {[info exists commitdata($id)]} {
1674 parsecommit $id $commitdata($id) 1
1675 } else {
1676 readcommit $id
1677 if {![info exists commitinfo($id)]} {
1678 set commitinfo($id) [list [mc "No commit information available"]]
1681 return 1
1684 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1685 # and are present in the current view.
1686 # This is fairly slow...
1687 proc longid {prefix} {
1688 global varcid curview
1690 set ids {}
1691 foreach match [array names varcid "$curview,$prefix*"] {
1692 lappend ids [lindex [split $match ","] 1]
1694 return $ids
1697 proc readrefs {} {
1698 global tagids idtags headids idheads tagobjid
1699 global otherrefids idotherrefs mainhead mainheadid
1700 global selecthead selectheadid
1701 global hideremotes
1703 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1704 catch {unset $v}
1706 set refd [open [list | git show-ref -d] r]
1707 while {[gets $refd line] >= 0} {
1708 if {[string index $line 40] ne " "} continue
1709 set id [string range $line 0 39]
1710 set ref [string range $line 41 end]
1711 if {![string match "refs/*" $ref]} continue
1712 set name [string range $ref 5 end]
1713 if {[string match "remotes/*" $name]} {
1714 if {![string match "*/HEAD" $name] && !$hideremotes} {
1715 set headids($name) $id
1716 lappend idheads($id) $name
1718 } elseif {[string match "heads/*" $name]} {
1719 set name [string range $name 6 end]
1720 set headids($name) $id
1721 lappend idheads($id) $name
1722 } elseif {[string match "tags/*" $name]} {
1723 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1724 # which is what we want since the former is the commit ID
1725 set name [string range $name 5 end]
1726 if {[string match "*^{}" $name]} {
1727 set name [string range $name 0 end-3]
1728 } else {
1729 set tagobjid($name) $id
1731 set tagids($name) $id
1732 lappend idtags($id) $name
1733 } else {
1734 set otherrefids($name) $id
1735 lappend idotherrefs($id) $name
1738 catch {close $refd}
1739 set mainhead {}
1740 set mainheadid {}
1741 catch {
1742 set mainheadid [exec git rev-parse HEAD]
1743 set thehead [exec git symbolic-ref HEAD]
1744 if {[string match "refs/heads/*" $thehead]} {
1745 set mainhead [string range $thehead 11 end]
1748 set selectheadid {}
1749 if {$selecthead ne {}} {
1750 catch {
1751 set selectheadid [exec git rev-parse --verify $selecthead]
1756 # skip over fake commits
1757 proc first_real_row {} {
1758 global nullid nullid2 numcommits
1760 for {set row 0} {$row < $numcommits} {incr row} {
1761 set id [commitonrow $row]
1762 if {$id ne $nullid && $id ne $nullid2} {
1763 break
1766 return $row
1769 # update things for a head moved to a child of its previous location
1770 proc movehead {id name} {
1771 global headids idheads
1773 removehead $headids($name) $name
1774 set headids($name) $id
1775 lappend idheads($id) $name
1778 # update things when a head has been removed
1779 proc removehead {id name} {
1780 global headids idheads
1782 if {$idheads($id) eq $name} {
1783 unset idheads($id)
1784 } else {
1785 set i [lsearch -exact $idheads($id) $name]
1786 if {$i >= 0} {
1787 set idheads($id) [lreplace $idheads($id) $i $i]
1790 unset headids($name)
1793 proc ttk_toplevel {w args} {
1794 global use_ttk
1795 eval [linsert $args 0 ::toplevel $w]
1796 if {$use_ttk} {
1797 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1799 return $w
1802 proc make_transient {window origin} {
1803 global have_tk85
1805 # In MacOS Tk 8.4 transient appears to work by setting
1806 # overrideredirect, which is utterly useless, since the
1807 # windows get no border, and are not even kept above
1808 # the parent.
1809 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1811 wm transient $window $origin
1813 # Windows fails to place transient windows normally, so
1814 # schedule a callback to center them on the parent.
1815 if {[tk windowingsystem] eq {win32}} {
1816 after idle [list tk::PlaceWindow $window widget $origin]
1820 proc show_error {w top msg {mc mc}} {
1821 global NS
1822 if {![info exists NS]} {set NS ""}
1823 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1824 message $w.m -text $msg -justify center -aspect 400
1825 pack $w.m -side top -fill x -padx 20 -pady 20
1826 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1827 pack $w.ok -side bottom -fill x
1828 bind $top <Visibility> "grab $top; focus $top"
1829 bind $top <Key-Return> "destroy $top"
1830 bind $top <Key-space> "destroy $top"
1831 bind $top <Key-Escape> "destroy $top"
1832 tkwait window $top
1835 proc error_popup {msg {owner .}} {
1836 if {[tk windowingsystem] eq "win32"} {
1837 tk_messageBox -icon error -type ok -title [wm title .] \
1838 -parent $owner -message $msg
1839 } else {
1840 set w .error
1841 ttk_toplevel $w
1842 make_transient $w $owner
1843 show_error $w $w $msg
1847 proc confirm_popup {msg {owner .}} {
1848 global confirm_ok NS
1849 set confirm_ok 0
1850 set w .confirm
1851 ttk_toplevel $w
1852 make_transient $w $owner
1853 message $w.m -text $msg -justify center -aspect 400
1854 pack $w.m -side top -fill x -padx 20 -pady 20
1855 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1856 pack $w.ok -side left -fill x
1857 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1858 pack $w.cancel -side right -fill x
1859 bind $w <Visibility> "grab $w; focus $w"
1860 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1861 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1862 bind $w <Key-Escape> "destroy $w"
1863 tk::PlaceWindow $w widget $owner
1864 tkwait window $w
1865 return $confirm_ok
1868 proc setoptions {} {
1869 if {[tk windowingsystem] ne "win32"} {
1870 option add *Panedwindow.showHandle 1 startupFile
1871 option add *Panedwindow.sashRelief raised startupFile
1872 if {[tk windowingsystem] ne "aqua"} {
1873 option add *Menu.font uifont startupFile
1875 } else {
1876 option add *Menu.TearOff 0 startupFile
1878 option add *Button.font uifont startupFile
1879 option add *Checkbutton.font uifont startupFile
1880 option add *Radiobutton.font uifont startupFile
1881 option add *Menubutton.font uifont startupFile
1882 option add *Label.font uifont startupFile
1883 option add *Message.font uifont startupFile
1884 option add *Entry.font textfont startupFile
1885 option add *Text.font textfont startupFile
1886 option add *Labelframe.font uifont startupFile
1887 option add *Spinbox.font textfont startupFile
1888 option add *Listbox.font mainfont startupFile
1891 # Make a menu and submenus.
1892 # m is the window name for the menu, items is the list of menu items to add.
1893 # Each item is a list {mc label type description options...}
1894 # mc is ignored; it's so we can put mc there to alert xgettext
1895 # label is the string that appears in the menu
1896 # type is cascade, command or radiobutton (should add checkbutton)
1897 # description depends on type; it's the sublist for cascade, the
1898 # command to invoke for command, or {variable value} for radiobutton
1899 proc makemenu {m items} {
1900 menu $m
1901 if {[tk windowingsystem] eq {aqua}} {
1902 set Meta1 Cmd
1903 } else {
1904 set Meta1 Ctrl
1906 foreach i $items {
1907 set name [mc [lindex $i 1]]
1908 set type [lindex $i 2]
1909 set thing [lindex $i 3]
1910 set params [list $type]
1911 if {$name ne {}} {
1912 set u [string first "&" [string map {&& x} $name]]
1913 lappend params -label [string map {&& & & {}} $name]
1914 if {$u >= 0} {
1915 lappend params -underline $u
1918 switch -- $type {
1919 "cascade" {
1920 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1921 lappend params -menu $m.$submenu
1923 "command" {
1924 lappend params -command $thing
1926 "radiobutton" {
1927 lappend params -variable [lindex $thing 0] \
1928 -value [lindex $thing 1]
1931 set tail [lrange $i 4 end]
1932 regsub -all {\yMeta1\y} $tail $Meta1 tail
1933 eval $m add $params $tail
1934 if {$type eq "cascade"} {
1935 makemenu $m.$submenu $thing
1940 # translate string and remove ampersands
1941 proc mca {str} {
1942 return [string map {&& & & {}} [mc $str]]
1945 proc makedroplist {w varname args} {
1946 global use_ttk
1947 if {$use_ttk} {
1948 set width 0
1949 foreach label $args {
1950 set cx [string length $label]
1951 if {$cx > $width} {set width $cx}
1953 set gm [ttk::combobox $w -width $width -state readonly\
1954 -textvariable $varname -values $args]
1955 } else {
1956 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
1958 return $gm
1961 proc makewindow {} {
1962 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1963 global tabstop
1964 global findtype findtypemenu findloc findstring fstring geometry
1965 global entries sha1entry sha1string sha1but
1966 global diffcontextstring diffcontext
1967 global ignorespace
1968 global maincursor textcursor curtextcursor
1969 global rowctxmenu fakerowmenu mergemax wrapcomment
1970 global highlight_files gdttype
1971 global searchstring sstring
1972 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1973 global headctxmenu progresscanv progressitem progresscoords statusw
1974 global fprogitem fprogcoord lastprogupdate progupdatepending
1975 global rprogitem rprogcoord rownumsel numcommits
1976 global have_tk85 use_ttk NS
1977 global git_version
1978 global worddiff
1980 # The "mc" arguments here are purely so that xgettext
1981 # sees the following string as needing to be translated
1982 set file {
1983 mc "File" cascade {
1984 {mc "Update" command updatecommits -accelerator F5}
1985 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1986 {mc "Reread references" command rereadrefs}
1987 {mc "List references" command showrefs -accelerator F2}
1988 {xx "" separator}
1989 {mc "Start git gui" command {exec git gui &}}
1990 {xx "" separator}
1991 {mc "Quit" command doquit -accelerator Meta1-Q}
1993 set edit {
1994 mc "Edit" cascade {
1995 {mc "Preferences" command doprefs}
1997 set view {
1998 mc "View" cascade {
1999 {mc "New view..." command {newview 0} -accelerator Shift-F4}
2000 {mc "Edit view..." command editview -state disabled -accelerator F4}
2001 {mc "Delete view" command delview -state disabled}
2002 {xx "" separator}
2003 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2005 if {[tk windowingsystem] ne "aqua"} {
2006 set help {
2007 mc "Help" cascade {
2008 {mc "About gitk" command about}
2009 {mc "Key bindings" command keys}
2011 set bar [list $file $edit $view $help]
2012 } else {
2013 proc ::tk::mac::ShowPreferences {} {doprefs}
2014 proc ::tk::mac::Quit {} {doquit}
2015 lset file end [lreplace [lindex $file end] end-1 end]
2016 set apple {
2017 xx "Apple" cascade {
2018 {mc "About gitk" command about}
2019 {xx "" separator}
2021 set help {
2022 mc "Help" cascade {
2023 {mc "Key bindings" command keys}
2025 set bar [list $apple $file $view $help]
2027 makemenu .bar $bar
2028 . configure -menu .bar
2030 if {$use_ttk} {
2031 # cover the non-themed toplevel with a themed frame.
2032 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2035 # the gui has upper and lower half, parts of a paned window.
2036 ${NS}::panedwindow .ctop -orient vertical
2038 # possibly use assumed geometry
2039 if {![info exists geometry(pwsash0)]} {
2040 set geometry(topheight) [expr {15 * $linespc}]
2041 set geometry(topwidth) [expr {80 * $charspc}]
2042 set geometry(botheight) [expr {15 * $linespc}]
2043 set geometry(botwidth) [expr {50 * $charspc}]
2044 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2045 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2048 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2049 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2050 ${NS}::frame .tf.histframe
2051 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2052 if {!$use_ttk} {
2053 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2056 # create three canvases
2057 set cscroll .tf.histframe.csb
2058 set canv .tf.histframe.pwclist.canv
2059 canvas $canv \
2060 -selectbackground $selectbgcolor \
2061 -background $bgcolor -bd 0 \
2062 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2063 .tf.histframe.pwclist add $canv
2064 set canv2 .tf.histframe.pwclist.canv2
2065 canvas $canv2 \
2066 -selectbackground $selectbgcolor \
2067 -background $bgcolor -bd 0 -yscrollincr $linespc
2068 .tf.histframe.pwclist add $canv2
2069 set canv3 .tf.histframe.pwclist.canv3
2070 canvas $canv3 \
2071 -selectbackground $selectbgcolor \
2072 -background $bgcolor -bd 0 -yscrollincr $linespc
2073 .tf.histframe.pwclist add $canv3
2074 if {$use_ttk} {
2075 bind .tf.histframe.pwclist <Map> {
2076 bind %W <Map> {}
2077 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2078 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2080 } else {
2081 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2082 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2085 # a scroll bar to rule them
2086 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2087 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2088 pack $cscroll -side right -fill y
2089 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2090 lappend bglist $canv $canv2 $canv3
2091 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2093 # we have two button bars at bottom of top frame. Bar 1
2094 ${NS}::frame .tf.bar
2095 ${NS}::frame .tf.lbar -height 15
2097 set sha1entry .tf.bar.sha1
2098 set entries $sha1entry
2099 set sha1but .tf.bar.sha1label
2100 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2101 -command gotocommit -width 8
2102 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2103 pack .tf.bar.sha1label -side left
2104 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2105 trace add variable sha1string write sha1change
2106 pack $sha1entry -side left -pady 2
2108 image create bitmap bm-left -data {
2109 #define left_width 16
2110 #define left_height 16
2111 static unsigned char left_bits[] = {
2112 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2113 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2114 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2116 image create bitmap bm-right -data {
2117 #define right_width 16
2118 #define right_height 16
2119 static unsigned char right_bits[] = {
2120 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2121 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2122 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2124 ${NS}::button .tf.bar.leftbut -image bm-left -command goback \
2125 -state disabled -width 26
2126 pack .tf.bar.leftbut -side left -fill y
2127 ${NS}::button .tf.bar.rightbut -image bm-right -command goforw \
2128 -state disabled -width 26
2129 pack .tf.bar.rightbut -side left -fill y
2131 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2132 set rownumsel {}
2133 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2134 -relief sunken -anchor e
2135 ${NS}::label .tf.bar.rowlabel2 -text "/"
2136 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2137 -relief sunken -anchor e
2138 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2139 -side left
2140 if {!$use_ttk} {
2141 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2143 global selectedline
2144 trace add variable selectedline write selectedline_change
2146 # Status label and progress bar
2147 set statusw .tf.bar.status
2148 ${NS}::label $statusw -width 15 -relief sunken
2149 pack $statusw -side left -padx 5
2150 if {$use_ttk} {
2151 set progresscanv [ttk::progressbar .tf.bar.progress]
2152 } else {
2153 set h [expr {[font metrics uifont -linespace] + 2}]
2154 set progresscanv .tf.bar.progress
2155 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2156 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2157 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2158 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2160 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2161 set progresscoords {0 0}
2162 set fprogcoord 0
2163 set rprogcoord 0
2164 bind $progresscanv <Configure> adjustprogress
2165 set lastprogupdate [clock clicks -milliseconds]
2166 set progupdatepending 0
2168 # build up the bottom bar of upper window
2169 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2170 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2171 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2172 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2173 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2174 -side left -fill y
2175 set gdttype [mc "containing:"]
2176 set gm [makedroplist .tf.lbar.gdttype gdttype \
2177 [mc "containing:"] \
2178 [mc "touching paths:"] \
2179 [mc "adding/removing string:"]]
2180 trace add variable gdttype write gdttype_change
2181 pack .tf.lbar.gdttype -side left -fill y
2183 set findstring {}
2184 set fstring .tf.lbar.findstring
2185 lappend entries $fstring
2186 ${NS}::entry $fstring -width 30 -textvariable findstring
2187 trace add variable findstring write find_change
2188 set findtype [mc "Exact"]
2189 set findtypemenu [makedroplist .tf.lbar.findtype \
2190 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2191 trace add variable findtype write findcom_change
2192 set findloc [mc "All fields"]
2193 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2194 [mc "Comments"] [mc "Author"] [mc "Committer"]
2195 trace add variable findloc write find_change
2196 pack .tf.lbar.findloc -side right
2197 pack .tf.lbar.findtype -side right
2198 pack $fstring -side left -expand 1 -fill x
2200 # Finish putting the upper half of the viewer together
2201 pack .tf.lbar -in .tf -side bottom -fill x
2202 pack .tf.bar -in .tf -side bottom -fill x
2203 pack .tf.histframe -fill both -side top -expand 1
2204 .ctop add .tf
2205 if {!$use_ttk} {
2206 .ctop paneconfigure .tf -height $geometry(topheight)
2207 .ctop paneconfigure .tf -width $geometry(topwidth)
2210 # now build up the bottom
2211 ${NS}::panedwindow .pwbottom -orient horizontal
2213 # lower left, a text box over search bar, scroll bar to the right
2214 # if we know window height, then that will set the lower text height, otherwise
2215 # we set lower text height which will drive window height
2216 if {[info exists geometry(main)]} {
2217 ${NS}::frame .bleft -width $geometry(botwidth)
2218 } else {
2219 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2221 ${NS}::frame .bleft.top
2222 ${NS}::frame .bleft.mid
2223 ${NS}::frame .bleft.bottom
2225 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2226 pack .bleft.top.search -side left -padx 5
2227 set sstring .bleft.top.sstring
2228 set searchstring ""
2229 ${NS}::entry $sstring -width 20 -textvariable searchstring
2230 lappend entries $sstring
2231 trace add variable searchstring write incrsearch
2232 pack $sstring -side left -expand 1 -fill x
2233 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2234 -command changediffdisp -variable diffelide -value {0 0}
2235 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2236 -command changediffdisp -variable diffelide -value {0 1}
2237 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2238 -command changediffdisp -variable diffelide -value {1 0}
2239 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2240 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2241 spinbox .bleft.mid.diffcontext -width 5 \
2242 -from 0 -increment 1 -to 10000000 \
2243 -validate all -validatecommand "diffcontextvalidate %P" \
2244 -textvariable diffcontextstring
2245 .bleft.mid.diffcontext set $diffcontext
2246 trace add variable diffcontextstring write diffcontextchange
2247 lappend entries .bleft.mid.diffcontext
2248 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2249 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2250 -command changeignorespace -variable ignorespace
2251 pack .bleft.mid.ignspace -side left -padx 5
2253 set worddiff [mc "Line diff"]
2254 if {[package vcompare $git_version "1.7.2"] >= 0} {
2255 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2256 [mc "Markup words"] [mc "Color words"]
2257 trace add variable worddiff write changeworddiff
2258 pack .bleft.mid.worddiff -side left -padx 5
2261 set ctext .bleft.bottom.ctext
2262 text $ctext -background $bgcolor -foreground $fgcolor \
2263 -state disabled -font textfont \
2264 -yscrollcommand scrolltext -wrap none \
2265 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2266 if {$have_tk85} {
2267 $ctext conf -tabstyle wordprocessor
2269 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2270 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2271 pack .bleft.top -side top -fill x
2272 pack .bleft.mid -side top -fill x
2273 grid $ctext .bleft.bottom.sb -sticky nsew
2274 grid .bleft.bottom.sbhorizontal -sticky ew
2275 grid columnconfigure .bleft.bottom 0 -weight 1
2276 grid rowconfigure .bleft.bottom 0 -weight 1
2277 grid rowconfigure .bleft.bottom 1 -weight 0
2278 pack .bleft.bottom -side top -fill both -expand 1
2279 lappend bglist $ctext
2280 lappend fglist $ctext
2282 $ctext tag conf comment -wrap $wrapcomment
2283 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2284 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2285 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2286 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2287 $ctext tag conf m0 -fore red
2288 $ctext tag conf m1 -fore blue
2289 $ctext tag conf m2 -fore green
2290 $ctext tag conf m3 -fore purple
2291 $ctext tag conf m4 -fore brown
2292 $ctext tag conf m5 -fore "#009090"
2293 $ctext tag conf m6 -fore magenta
2294 $ctext tag conf m7 -fore "#808000"
2295 $ctext tag conf m8 -fore "#009000"
2296 $ctext tag conf m9 -fore "#ff0080"
2297 $ctext tag conf m10 -fore cyan
2298 $ctext tag conf m11 -fore "#b07070"
2299 $ctext tag conf m12 -fore "#70b0f0"
2300 $ctext tag conf m13 -fore "#70f0b0"
2301 $ctext tag conf m14 -fore "#f0b070"
2302 $ctext tag conf m15 -fore "#ff70b0"
2303 $ctext tag conf mmax -fore darkgrey
2304 set mergemax 16
2305 $ctext tag conf mresult -font textfontbold
2306 $ctext tag conf msep -font textfontbold
2307 $ctext tag conf found -back yellow
2309 .pwbottom add .bleft
2310 if {!$use_ttk} {
2311 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2314 # lower right
2315 ${NS}::frame .bright
2316 ${NS}::frame .bright.mode
2317 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2318 -command reselectline -variable cmitmode -value "patch"
2319 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2320 -command reselectline -variable cmitmode -value "tree"
2321 grid .bright.mode.patch .bright.mode.tree -sticky ew
2322 pack .bright.mode -side top -fill x
2323 set cflist .bright.cfiles
2324 set indent [font measure mainfont "nn"]
2325 text $cflist \
2326 -selectbackground $selectbgcolor \
2327 -background $bgcolor -foreground $fgcolor \
2328 -font mainfont \
2329 -tabs [list $indent [expr {2 * $indent}]] \
2330 -yscrollcommand ".bright.sb set" \
2331 -cursor [. cget -cursor] \
2332 -spacing1 1 -spacing3 1
2333 lappend bglist $cflist
2334 lappend fglist $cflist
2335 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2336 pack .bright.sb -side right -fill y
2337 pack $cflist -side left -fill both -expand 1
2338 $cflist tag configure highlight \
2339 -background [$cflist cget -selectbackground]
2340 $cflist tag configure bold -font mainfontbold
2342 .pwbottom add .bright
2343 .ctop add .pwbottom
2345 # restore window width & height if known
2346 if {[info exists geometry(main)]} {
2347 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2348 if {$w > [winfo screenwidth .]} {
2349 set w [winfo screenwidth .]
2351 if {$h > [winfo screenheight .]} {
2352 set h [winfo screenheight .]
2354 wm geometry . "${w}x$h"
2358 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2359 wm state . $geometry(state)
2362 if {[tk windowingsystem] eq {aqua}} {
2363 set M1B M1
2364 set ::BM "3"
2365 } else {
2366 set M1B Control
2367 set ::BM "2"
2370 if {$use_ttk} {
2371 bind .ctop <Map> {
2372 bind %W <Map> {}
2373 %W sashpos 0 $::geometry(topheight)
2375 bind .pwbottom <Map> {
2376 bind %W <Map> {}
2377 %W sashpos 0 $::geometry(botwidth)
2381 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2382 pack .ctop -fill both -expand 1
2383 bindall <1> {selcanvline %W %x %y}
2384 #bindall <B1-Motion> {selcanvline %W %x %y}
2385 if {[tk windowingsystem] == "win32"} {
2386 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2387 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2388 } else {
2389 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2390 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2391 if {[tk windowingsystem] eq "aqua"} {
2392 bindall <MouseWheel> {
2393 set delta [expr {- (%D)}]
2394 allcanvs yview scroll $delta units
2396 bindall <Shift-MouseWheel> {
2397 set delta [expr {- (%D)}]
2398 $canv xview scroll $delta units
2402 bindall <$::BM> "canvscan mark %W %x %y"
2403 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2404 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2405 bind . <$M1B-Key-w> doquit
2406 bindkey <Home> selfirstline
2407 bindkey <End> sellastline
2408 bind . <Key-Up> "selnextline -1"
2409 bind . <Key-Down> "selnextline 1"
2410 bind . <Shift-Key-Up> "dofind -1 0"
2411 bind . <Shift-Key-Down> "dofind 1 0"
2412 bindkey <Key-Right> "goforw"
2413 bindkey <Key-Left> "goback"
2414 bind . <Key-Prior> "selnextpage -1"
2415 bind . <Key-Next> "selnextpage 1"
2416 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2417 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2418 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2419 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2420 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2421 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2422 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2423 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2424 bindkey <Key-space> "$ctext yview scroll 1 pages"
2425 bindkey p "selnextline -1"
2426 bindkey n "selnextline 1"
2427 bindkey z "goback"
2428 bindkey x "goforw"
2429 bindkey i "selnextline -1"
2430 bindkey k "selnextline 1"
2431 bindkey j "goback"
2432 bindkey l "goforw"
2433 bindkey b prevfile
2434 bindkey d "$ctext yview scroll 18 units"
2435 bindkey u "$ctext yview scroll -18 units"
2436 bindkey / {focus $fstring}
2437 bindkey <Key-KP_Divide> {focus $fstring}
2438 bindkey <Key-Return> {dofind 1 1}
2439 bindkey ? {dofind -1 1}
2440 bindkey f nextfile
2441 bind . <F5> updatecommits
2442 bind . <$M1B-F5> reloadcommits
2443 bind . <F2> showrefs
2444 bind . <Shift-F4> {newview 0}
2445 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2446 bind . <F4> edit_or_newview
2447 bind . <$M1B-q> doquit
2448 bind . <$M1B-f> {dofind 1 1}
2449 bind . <$M1B-g> {dofind 1 0}
2450 bind . <$M1B-r> dosearchback
2451 bind . <$M1B-s> dosearch
2452 bind . <$M1B-equal> {incrfont 1}
2453 bind . <$M1B-plus> {incrfont 1}
2454 bind . <$M1B-KP_Add> {incrfont 1}
2455 bind . <$M1B-minus> {incrfont -1}
2456 bind . <$M1B-KP_Subtract> {incrfont -1}
2457 wm protocol . WM_DELETE_WINDOW doquit
2458 bind . <Destroy> {stop_backends}
2459 bind . <Button-1> "click %W"
2460 bind $fstring <Key-Return> {dofind 1 1}
2461 bind $sha1entry <Key-Return> {gotocommit; break}
2462 bind $sha1entry <<PasteSelection>> clearsha1
2463 bind $cflist <1> {sel_flist %W %x %y; break}
2464 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2465 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2466 global ctxbut
2467 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2468 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2469 bind $ctext <Button-1> {focus %W}
2471 set maincursor [. cget -cursor]
2472 set textcursor [$ctext cget -cursor]
2473 set curtextcursor $textcursor
2475 set rowctxmenu .rowctxmenu
2476 makemenu $rowctxmenu {
2477 {mc "Diff this -> selected" command {diffvssel 0}}
2478 {mc "Diff selected -> this" command {diffvssel 1}}
2479 {mc "Make patch" command mkpatch}
2480 {mc "Create tag" command mktag}
2481 {mc "Write commit to file" command writecommit}
2482 {mc "Create new branch" command mkbranch}
2483 {mc "Cherry-pick this commit" command cherrypick}
2484 {mc "Reset HEAD branch to here" command resethead}
2485 {mc "Mark this commit" command markhere}
2486 {mc "Return to mark" command gotomark}
2487 {mc "Find descendant of this and mark" command find_common_desc}
2488 {mc "Compare with marked commit" command compare_commits}
2490 $rowctxmenu configure -tearoff 0
2492 set fakerowmenu .fakerowmenu
2493 makemenu $fakerowmenu {
2494 {mc "Diff this -> selected" command {diffvssel 0}}
2495 {mc "Diff selected -> this" command {diffvssel 1}}
2496 {mc "Make patch" command mkpatch}
2498 $fakerowmenu configure -tearoff 0
2500 set headctxmenu .headctxmenu
2501 makemenu $headctxmenu {
2502 {mc "Check out this branch" command cobranch}
2503 {mc "Remove this branch" command rmbranch}
2505 $headctxmenu configure -tearoff 0
2507 global flist_menu
2508 set flist_menu .flistctxmenu
2509 makemenu $flist_menu {
2510 {mc "Highlight this too" command {flist_hl 0}}
2511 {mc "Highlight this only" command {flist_hl 1}}
2512 {mc "External diff" command {external_diff}}
2513 {mc "Blame parent commit" command {external_blame 1}}
2515 $flist_menu configure -tearoff 0
2517 global diff_menu
2518 set diff_menu .diffctxmenu
2519 makemenu $diff_menu {
2520 {mc "Show origin of this line" command show_line_source}
2521 {mc "Run git gui blame on this line" command {external_blame_diff}}
2523 $diff_menu configure -tearoff 0
2526 # Windows sends all mouse wheel events to the current focused window, not
2527 # the one where the mouse hovers, so bind those events here and redirect
2528 # to the correct window
2529 proc windows_mousewheel_redirector {W X Y D} {
2530 global canv canv2 canv3
2531 set w [winfo containing -displayof $W $X $Y]
2532 if {$w ne ""} {
2533 set u [expr {$D < 0 ? 5 : -5}]
2534 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2535 allcanvs yview scroll $u units
2536 } else {
2537 catch {
2538 $w yview scroll $u units
2544 # Update row number label when selectedline changes
2545 proc selectedline_change {n1 n2 op} {
2546 global selectedline rownumsel
2548 if {$selectedline eq {}} {
2549 set rownumsel {}
2550 } else {
2551 set rownumsel [expr {$selectedline + 1}]
2555 # mouse-2 makes all windows scan vertically, but only the one
2556 # the cursor is in scans horizontally
2557 proc canvscan {op w x y} {
2558 global canv canv2 canv3
2559 foreach c [list $canv $canv2 $canv3] {
2560 if {$c == $w} {
2561 $c scan $op $x $y
2562 } else {
2563 $c scan $op 0 $y
2568 proc scrollcanv {cscroll f0 f1} {
2569 $cscroll set $f0 $f1
2570 drawvisible
2571 flushhighlights
2574 # when we make a key binding for the toplevel, make sure
2575 # it doesn't get triggered when that key is pressed in the
2576 # find string entry widget.
2577 proc bindkey {ev script} {
2578 global entries
2579 bind . $ev $script
2580 set escript [bind Entry $ev]
2581 if {$escript == {}} {
2582 set escript [bind Entry <Key>]
2584 foreach e $entries {
2585 bind $e $ev "$escript; break"
2589 # set the focus back to the toplevel for any click outside
2590 # the entry widgets
2591 proc click {w} {
2592 global ctext entries
2593 foreach e [concat $entries $ctext] {
2594 if {$w == $e} return
2596 focus .
2599 # Adjust the progress bar for a change in requested extent or canvas size
2600 proc adjustprogress {} {
2601 global progresscanv progressitem progresscoords
2602 global fprogitem fprogcoord lastprogupdate progupdatepending
2603 global rprogitem rprogcoord use_ttk
2605 if {$use_ttk} {
2606 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2607 return
2610 set w [expr {[winfo width $progresscanv] - 4}]
2611 set x0 [expr {$w * [lindex $progresscoords 0]}]
2612 set x1 [expr {$w * [lindex $progresscoords 1]}]
2613 set h [winfo height $progresscanv]
2614 $progresscanv coords $progressitem $x0 0 $x1 $h
2615 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2616 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2617 set now [clock clicks -milliseconds]
2618 if {$now >= $lastprogupdate + 100} {
2619 set progupdatepending 0
2620 update
2621 } elseif {!$progupdatepending} {
2622 set progupdatepending 1
2623 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2627 proc doprogupdate {} {
2628 global lastprogupdate progupdatepending
2630 if {$progupdatepending} {
2631 set progupdatepending 0
2632 set lastprogupdate [clock clicks -milliseconds]
2633 update
2637 proc savestuff {w} {
2638 global canv canv2 canv3 mainfont textfont uifont tabstop
2639 global stuffsaved findmergefiles maxgraphpct
2640 global maxwidth showneartags showlocalchanges
2641 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2642 global cmitmode wrapcomment datetimeformat limitdiffs
2643 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2644 global autoselect autosellen extdifftool perfile_attrs markbgcolor use_ttk
2645 global hideremotes want_ttk
2647 if {$stuffsaved} return
2648 if {![winfo viewable .]} return
2649 catch {
2650 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2651 set f [open "~/.gitk-new" w]
2652 if {$::tcl_platform(platform) eq {windows}} {
2653 file attributes "~/.gitk-new" -hidden true
2655 puts $f [list set mainfont $mainfont]
2656 puts $f [list set textfont $textfont]
2657 puts $f [list set uifont $uifont]
2658 puts $f [list set tabstop $tabstop]
2659 puts $f [list set findmergefiles $findmergefiles]
2660 puts $f [list set maxgraphpct $maxgraphpct]
2661 puts $f [list set maxwidth $maxwidth]
2662 puts $f [list set cmitmode $cmitmode]
2663 puts $f [list set wrapcomment $wrapcomment]
2664 puts $f [list set autoselect $autoselect]
2665 puts $f [list set autosellen $autosellen]
2666 puts $f [list set showneartags $showneartags]
2667 puts $f [list set hideremotes $hideremotes]
2668 puts $f [list set showlocalchanges $showlocalchanges]
2669 puts $f [list set datetimeformat $datetimeformat]
2670 puts $f [list set limitdiffs $limitdiffs]
2671 puts $f [list set uicolor $uicolor]
2672 puts $f [list set want_ttk $want_ttk]
2673 puts $f [list set bgcolor $bgcolor]
2674 puts $f [list set fgcolor $fgcolor]
2675 puts $f [list set colors $colors]
2676 puts $f [list set diffcolors $diffcolors]
2677 puts $f [list set markbgcolor $markbgcolor]
2678 puts $f [list set diffcontext $diffcontext]
2679 puts $f [list set selectbgcolor $selectbgcolor]
2680 puts $f [list set extdifftool $extdifftool]
2681 puts $f [list set perfile_attrs $perfile_attrs]
2683 puts $f "set geometry(main) [wm geometry .]"
2684 puts $f "set geometry(state) [wm state .]"
2685 puts $f "set geometry(topwidth) [winfo width .tf]"
2686 puts $f "set geometry(topheight) [winfo height .tf]"
2687 if {$use_ttk} {
2688 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2689 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2690 } else {
2691 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2692 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2694 puts $f "set geometry(botwidth) [winfo width .bleft]"
2695 puts $f "set geometry(botheight) [winfo height .bleft]"
2697 puts -nonewline $f "set permviews {"
2698 for {set v 0} {$v < $nextviewnum} {incr v} {
2699 if {$viewperm($v)} {
2700 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2703 puts $f "}"
2704 close $f
2705 file rename -force "~/.gitk-new" "~/.gitk"
2707 set stuffsaved 1
2710 proc resizeclistpanes {win w} {
2711 global oldwidth use_ttk
2712 if {[info exists oldwidth($win)]} {
2713 if {$use_ttk} {
2714 set s0 [$win sashpos 0]
2715 set s1 [$win sashpos 1]
2716 } else {
2717 set s0 [$win sash coord 0]
2718 set s1 [$win sash coord 1]
2720 if {$w < 60} {
2721 set sash0 [expr {int($w/2 - 2)}]
2722 set sash1 [expr {int($w*5/6 - 2)}]
2723 } else {
2724 set factor [expr {1.0 * $w / $oldwidth($win)}]
2725 set sash0 [expr {int($factor * [lindex $s0 0])}]
2726 set sash1 [expr {int($factor * [lindex $s1 0])}]
2727 if {$sash0 < 30} {
2728 set sash0 30
2730 if {$sash1 < $sash0 + 20} {
2731 set sash1 [expr {$sash0 + 20}]
2733 if {$sash1 > $w - 10} {
2734 set sash1 [expr {$w - 10}]
2735 if {$sash0 > $sash1 - 20} {
2736 set sash0 [expr {$sash1 - 20}]
2740 if {$use_ttk} {
2741 $win sashpos 0 $sash0
2742 $win sashpos 1 $sash1
2743 } else {
2744 $win sash place 0 $sash0 [lindex $s0 1]
2745 $win sash place 1 $sash1 [lindex $s1 1]
2748 set oldwidth($win) $w
2751 proc resizecdetpanes {win w} {
2752 global oldwidth use_ttk
2753 if {[info exists oldwidth($win)]} {
2754 if {$use_ttk} {
2755 set s0 [$win sashpos 0]
2756 } else {
2757 set s0 [$win sash coord 0]
2759 if {$w < 60} {
2760 set sash0 [expr {int($w*3/4 - 2)}]
2761 } else {
2762 set factor [expr {1.0 * $w / $oldwidth($win)}]
2763 set sash0 [expr {int($factor * [lindex $s0 0])}]
2764 if {$sash0 < 45} {
2765 set sash0 45
2767 if {$sash0 > $w - 15} {
2768 set sash0 [expr {$w - 15}]
2771 if {$use_ttk} {
2772 $win sashpos 0 $sash0
2773 } else {
2774 $win sash place 0 $sash0 [lindex $s0 1]
2777 set oldwidth($win) $w
2780 proc allcanvs args {
2781 global canv canv2 canv3
2782 eval $canv $args
2783 eval $canv2 $args
2784 eval $canv3 $args
2787 proc bindall {event action} {
2788 global canv canv2 canv3
2789 bind $canv $event $action
2790 bind $canv2 $event $action
2791 bind $canv3 $event $action
2794 proc about {} {
2795 global uifont NS
2796 set w .about
2797 if {[winfo exists $w]} {
2798 raise $w
2799 return
2801 ttk_toplevel $w
2802 wm title $w [mc "About gitk"]
2803 make_transient $w .
2804 message $w.m -text [mc "
2805 Gitk - a commit viewer for git
2807 Copyright \u00a9 2005-2011 Paul Mackerras
2809 Use and redistribute under the terms of the GNU General Public License"] \
2810 -justify center -aspect 400 -border 2 -bg white -relief groove
2811 pack $w.m -side top -fill x -padx 2 -pady 2
2812 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2813 pack $w.ok -side bottom
2814 bind $w <Visibility> "focus $w.ok"
2815 bind $w <Key-Escape> "destroy $w"
2816 bind $w <Key-Return> "destroy $w"
2817 tk::PlaceWindow $w widget .
2820 proc keys {} {
2821 global NS
2822 set w .keys
2823 if {[winfo exists $w]} {
2824 raise $w
2825 return
2827 if {[tk windowingsystem] eq {aqua}} {
2828 set M1T Cmd
2829 } else {
2830 set M1T Ctrl
2832 ttk_toplevel $w
2833 wm title $w [mc "Gitk key bindings"]
2834 make_transient $w .
2835 message $w.m -text "
2836 [mc "Gitk key bindings:"]
2838 [mc "<%s-Q> Quit" $M1T]
2839 [mc "<%s-W> Close window" $M1T]
2840 [mc "<Home> Move to first commit"]
2841 [mc "<End> Move to last commit"]
2842 [mc "<Up>, p, i Move up one commit"]
2843 [mc "<Down>, n, k Move down one commit"]
2844 [mc "<Left>, z, j Go back in history list"]
2845 [mc "<Right>, x, l Go forward in history list"]
2846 [mc "<PageUp> Move up one page in commit list"]
2847 [mc "<PageDown> Move down one page in commit list"]
2848 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2849 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2850 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2851 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2852 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2853 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2854 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2855 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2856 [mc "<Delete>, b Scroll diff view up one page"]
2857 [mc "<Backspace> Scroll diff view up one page"]
2858 [mc "<Space> Scroll diff view down one page"]
2859 [mc "u Scroll diff view up 18 lines"]
2860 [mc "d Scroll diff view down 18 lines"]
2861 [mc "<%s-F> Find" $M1T]
2862 [mc "<%s-G> Move to next find hit" $M1T]
2863 [mc "<Return> Move to next find hit"]
2864 [mc "/ Focus the search box"]
2865 [mc "? Move to previous find hit"]
2866 [mc "f Scroll diff view to next file"]
2867 [mc "<%s-S> Search for next hit in diff view" $M1T]
2868 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2869 [mc "<%s-KP+> Increase font size" $M1T]
2870 [mc "<%s-plus> Increase font size" $M1T]
2871 [mc "<%s-KP-> Decrease font size" $M1T]
2872 [mc "<%s-minus> Decrease font size" $M1T]
2873 [mc "<F5> Update"]
2875 -justify left -bg white -border 2 -relief groove
2876 pack $w.m -side top -fill both -padx 2 -pady 2
2877 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2878 bind $w <Key-Escape> [list destroy $w]
2879 pack $w.ok -side bottom
2880 bind $w <Visibility> "focus $w.ok"
2881 bind $w <Key-Escape> "destroy $w"
2882 bind $w <Key-Return> "destroy $w"
2885 # Procedures for manipulating the file list window at the
2886 # bottom right of the overall window.
2888 proc treeview {w l openlevs} {
2889 global treecontents treediropen treeheight treeparent treeindex
2891 set ix 0
2892 set treeindex() 0
2893 set lev 0
2894 set prefix {}
2895 set prefixend -1
2896 set prefendstack {}
2897 set htstack {}
2898 set ht 0
2899 set treecontents() {}
2900 $w conf -state normal
2901 foreach f $l {
2902 while {[string range $f 0 $prefixend] ne $prefix} {
2903 if {$lev <= $openlevs} {
2904 $w mark set e:$treeindex($prefix) "end -1c"
2905 $w mark gravity e:$treeindex($prefix) left
2907 set treeheight($prefix) $ht
2908 incr ht [lindex $htstack end]
2909 set htstack [lreplace $htstack end end]
2910 set prefixend [lindex $prefendstack end]
2911 set prefendstack [lreplace $prefendstack end end]
2912 set prefix [string range $prefix 0 $prefixend]
2913 incr lev -1
2915 set tail [string range $f [expr {$prefixend+1}] end]
2916 while {[set slash [string first "/" $tail]] >= 0} {
2917 lappend htstack $ht
2918 set ht 0
2919 lappend prefendstack $prefixend
2920 incr prefixend [expr {$slash + 1}]
2921 set d [string range $tail 0 $slash]
2922 lappend treecontents($prefix) $d
2923 set oldprefix $prefix
2924 append prefix $d
2925 set treecontents($prefix) {}
2926 set treeindex($prefix) [incr ix]
2927 set treeparent($prefix) $oldprefix
2928 set tail [string range $tail [expr {$slash+1}] end]
2929 if {$lev <= $openlevs} {
2930 set ht 1
2931 set treediropen($prefix) [expr {$lev < $openlevs}]
2932 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2933 $w mark set d:$ix "end -1c"
2934 $w mark gravity d:$ix left
2935 set str "\n"
2936 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2937 $w insert end $str
2938 $w image create end -align center -image $bm -padx 1 \
2939 -name a:$ix
2940 $w insert end $d [highlight_tag $prefix]
2941 $w mark set s:$ix "end -1c"
2942 $w mark gravity s:$ix left
2944 incr lev
2946 if {$tail ne {}} {
2947 if {$lev <= $openlevs} {
2948 incr ht
2949 set str "\n"
2950 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2951 $w insert end $str
2952 $w insert end $tail [highlight_tag $f]
2954 lappend treecontents($prefix) $tail
2957 while {$htstack ne {}} {
2958 set treeheight($prefix) $ht
2959 incr ht [lindex $htstack end]
2960 set htstack [lreplace $htstack end end]
2961 set prefixend [lindex $prefendstack end]
2962 set prefendstack [lreplace $prefendstack end end]
2963 set prefix [string range $prefix 0 $prefixend]
2965 $w conf -state disabled
2968 proc linetoelt {l} {
2969 global treeheight treecontents
2971 set y 2
2972 set prefix {}
2973 while {1} {
2974 foreach e $treecontents($prefix) {
2975 if {$y == $l} {
2976 return "$prefix$e"
2978 set n 1
2979 if {[string index $e end] eq "/"} {
2980 set n $treeheight($prefix$e)
2981 if {$y + $n > $l} {
2982 append prefix $e
2983 incr y
2984 break
2987 incr y $n
2992 proc highlight_tree {y prefix} {
2993 global treeheight treecontents cflist
2995 foreach e $treecontents($prefix) {
2996 set path $prefix$e
2997 if {[highlight_tag $path] ne {}} {
2998 $cflist tag add bold $y.0 "$y.0 lineend"
3000 incr y
3001 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3002 set y [highlight_tree $y $path]
3005 return $y
3008 proc treeclosedir {w dir} {
3009 global treediropen treeheight treeparent treeindex
3011 set ix $treeindex($dir)
3012 $w conf -state normal
3013 $w delete s:$ix e:$ix
3014 set treediropen($dir) 0
3015 $w image configure a:$ix -image tri-rt
3016 $w conf -state disabled
3017 set n [expr {1 - $treeheight($dir)}]
3018 while {$dir ne {}} {
3019 incr treeheight($dir) $n
3020 set dir $treeparent($dir)
3024 proc treeopendir {w dir} {
3025 global treediropen treeheight treeparent treecontents treeindex
3027 set ix $treeindex($dir)
3028 $w conf -state normal
3029 $w image configure a:$ix -image tri-dn
3030 $w mark set e:$ix s:$ix
3031 $w mark gravity e:$ix right
3032 set lev 0
3033 set str "\n"
3034 set n [llength $treecontents($dir)]
3035 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3036 incr lev
3037 append str "\t"
3038 incr treeheight($x) $n
3040 foreach e $treecontents($dir) {
3041 set de $dir$e
3042 if {[string index $e end] eq "/"} {
3043 set iy $treeindex($de)
3044 $w mark set d:$iy e:$ix
3045 $w mark gravity d:$iy left
3046 $w insert e:$ix $str
3047 set treediropen($de) 0
3048 $w image create e:$ix -align center -image tri-rt -padx 1 \
3049 -name a:$iy
3050 $w insert e:$ix $e [highlight_tag $de]
3051 $w mark set s:$iy e:$ix
3052 $w mark gravity s:$iy left
3053 set treeheight($de) 1
3054 } else {
3055 $w insert e:$ix $str
3056 $w insert e:$ix $e [highlight_tag $de]
3059 $w mark gravity e:$ix right
3060 $w conf -state disabled
3061 set treediropen($dir) 1
3062 set top [lindex [split [$w index @0,0] .] 0]
3063 set ht [$w cget -height]
3064 set l [lindex [split [$w index s:$ix] .] 0]
3065 if {$l < $top} {
3066 $w yview $l.0
3067 } elseif {$l + $n + 1 > $top + $ht} {
3068 set top [expr {$l + $n + 2 - $ht}]
3069 if {$l < $top} {
3070 set top $l
3072 $w yview $top.0
3076 proc treeclick {w x y} {
3077 global treediropen cmitmode ctext cflist cflist_top
3079 if {$cmitmode ne "tree"} return
3080 if {![info exists cflist_top]} return
3081 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3082 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3083 $cflist tag add highlight $l.0 "$l.0 lineend"
3084 set cflist_top $l
3085 if {$l == 1} {
3086 $ctext yview 1.0
3087 return
3089 set e [linetoelt $l]
3090 if {[string index $e end] ne "/"} {
3091 showfile $e
3092 } elseif {$treediropen($e)} {
3093 treeclosedir $w $e
3094 } else {
3095 treeopendir $w $e
3099 proc setfilelist {id} {
3100 global treefilelist cflist jump_to_here
3102 treeview $cflist $treefilelist($id) 0
3103 if {$jump_to_here ne {}} {
3104 set f [lindex $jump_to_here 0]
3105 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3106 showfile $f
3111 image create bitmap tri-rt -background black -foreground blue -data {
3112 #define tri-rt_width 13
3113 #define tri-rt_height 13
3114 static unsigned char tri-rt_bits[] = {
3115 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3116 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3117 0x00, 0x00};
3118 } -maskdata {
3119 #define tri-rt-mask_width 13
3120 #define tri-rt-mask_height 13
3121 static unsigned char tri-rt-mask_bits[] = {
3122 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3123 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3124 0x08, 0x00};
3126 image create bitmap tri-dn -background black -foreground blue -data {
3127 #define tri-dn_width 13
3128 #define tri-dn_height 13
3129 static unsigned char tri-dn_bits[] = {
3130 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3131 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3132 0x00, 0x00};
3133 } -maskdata {
3134 #define tri-dn-mask_width 13
3135 #define tri-dn-mask_height 13
3136 static unsigned char tri-dn-mask_bits[] = {
3137 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3138 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3139 0x00, 0x00};
3142 image create bitmap reficon-T -background black -foreground yellow -data {
3143 #define tagicon_width 13
3144 #define tagicon_height 9
3145 static unsigned char tagicon_bits[] = {
3146 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3147 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3148 } -maskdata {
3149 #define tagicon-mask_width 13
3150 #define tagicon-mask_height 9
3151 static unsigned char tagicon-mask_bits[] = {
3152 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3153 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3155 set rectdata {
3156 #define headicon_width 13
3157 #define headicon_height 9
3158 static unsigned char headicon_bits[] = {
3159 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3160 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3162 set rectmask {
3163 #define headicon-mask_width 13
3164 #define headicon-mask_height 9
3165 static unsigned char headicon-mask_bits[] = {
3166 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3167 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3169 image create bitmap reficon-H -background black -foreground green \
3170 -data $rectdata -maskdata $rectmask
3171 image create bitmap reficon-o -background black -foreground "#ddddff" \
3172 -data $rectdata -maskdata $rectmask
3174 proc init_flist {first} {
3175 global cflist cflist_top difffilestart
3177 $cflist conf -state normal
3178 $cflist delete 0.0 end
3179 if {$first ne {}} {
3180 $cflist insert end $first
3181 set cflist_top 1
3182 $cflist tag add highlight 1.0 "1.0 lineend"
3183 } else {
3184 catch {unset cflist_top}
3186 $cflist conf -state disabled
3187 set difffilestart {}
3190 proc highlight_tag {f} {
3191 global highlight_paths
3193 foreach p $highlight_paths {
3194 if {[string match $p $f]} {
3195 return "bold"
3198 return {}
3201 proc highlight_filelist {} {
3202 global cmitmode cflist
3204 $cflist conf -state normal
3205 if {$cmitmode ne "tree"} {
3206 set end [lindex [split [$cflist index end] .] 0]
3207 for {set l 2} {$l < $end} {incr l} {
3208 set line [$cflist get $l.0 "$l.0 lineend"]
3209 if {[highlight_tag $line] ne {}} {
3210 $cflist tag add bold $l.0 "$l.0 lineend"
3213 } else {
3214 highlight_tree 2 {}
3216 $cflist conf -state disabled
3219 proc unhighlight_filelist {} {
3220 global cflist
3222 $cflist conf -state normal
3223 $cflist tag remove bold 1.0 end
3224 $cflist conf -state disabled
3227 proc add_flist {fl} {
3228 global cflist
3230 $cflist conf -state normal
3231 foreach f $fl {
3232 $cflist insert end "\n"
3233 $cflist insert end $f [highlight_tag $f]
3235 $cflist conf -state disabled
3238 proc sel_flist {w x y} {
3239 global ctext difffilestart cflist cflist_top cmitmode
3241 if {$cmitmode eq "tree"} return
3242 if {![info exists cflist_top]} return
3243 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3244 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3245 $cflist tag add highlight $l.0 "$l.0 lineend"
3246 set cflist_top $l
3247 if {$l == 1} {
3248 $ctext yview 1.0
3249 } else {
3250 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3254 proc pop_flist_menu {w X Y x y} {
3255 global ctext cflist cmitmode flist_menu flist_menu_file
3256 global treediffs diffids
3258 stopfinding
3259 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3260 if {$l <= 1} return
3261 if {$cmitmode eq "tree"} {
3262 set e [linetoelt $l]
3263 if {[string index $e end] eq "/"} return
3264 } else {
3265 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3267 set flist_menu_file $e
3268 set xdiffstate "normal"
3269 if {$cmitmode eq "tree"} {
3270 set xdiffstate "disabled"
3272 # Disable "External diff" item in tree mode
3273 $flist_menu entryconf 2 -state $xdiffstate
3274 tk_popup $flist_menu $X $Y
3277 proc find_ctext_fileinfo {line} {
3278 global ctext_file_names ctext_file_lines
3280 set ok [bsearch $ctext_file_lines $line]
3281 set tline [lindex $ctext_file_lines $ok]
3283 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3284 return {}
3285 } else {
3286 return [list [lindex $ctext_file_names $ok] $tline]
3290 proc pop_diff_menu {w X Y x y} {
3291 global ctext diff_menu flist_menu_file
3292 global diff_menu_txtpos diff_menu_line
3293 global diff_menu_filebase
3295 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3296 set diff_menu_line [lindex $diff_menu_txtpos 0]
3297 # don't pop up the menu on hunk-separator or file-separator lines
3298 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3299 return
3301 stopfinding
3302 set f [find_ctext_fileinfo $diff_menu_line]
3303 if {$f eq {}} return
3304 set flist_menu_file [lindex $f 0]
3305 set diff_menu_filebase [lindex $f 1]
3306 tk_popup $diff_menu $X $Y
3309 proc flist_hl {only} {
3310 global flist_menu_file findstring gdttype
3312 set x [shellquote $flist_menu_file]
3313 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3314 set findstring $x
3315 } else {
3316 append findstring " " $x
3318 set gdttype [mc "touching paths:"]
3321 proc gitknewtmpdir {} {
3322 global diffnum gitktmpdir gitdir
3324 if {![info exists gitktmpdir]} {
3325 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3326 if {[catch {file mkdir $gitktmpdir} err]} {
3327 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3328 unset gitktmpdir
3329 return {}
3331 set diffnum 0
3333 incr diffnum
3334 set diffdir [file join $gitktmpdir $diffnum]
3335 if {[catch {file mkdir $diffdir} err]} {
3336 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3337 return {}
3339 return $diffdir
3342 proc save_file_from_commit {filename output what} {
3343 global nullfile
3345 if {[catch {exec git show $filename -- > $output} err]} {
3346 if {[string match "fatal: bad revision *" $err]} {
3347 return $nullfile
3349 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3350 return {}
3352 return $output
3355 proc external_diff_get_one_file {diffid filename diffdir} {
3356 global nullid nullid2 nullfile
3357 global worktree
3359 if {$diffid == $nullid} {
3360 set difffile [file join $worktree $filename]
3361 if {[file exists $difffile]} {
3362 return $difffile
3364 return $nullfile
3366 if {$diffid == $nullid2} {
3367 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3368 return [save_file_from_commit :$filename $difffile index]
3370 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3371 return [save_file_from_commit $diffid:$filename $difffile \
3372 "revision $diffid"]
3375 proc external_diff {} {
3376 global nullid nullid2
3377 global flist_menu_file
3378 global diffids
3379 global extdifftool
3381 if {[llength $diffids] == 1} {
3382 # no reference commit given
3383 set diffidto [lindex $diffids 0]
3384 if {$diffidto eq $nullid} {
3385 # diffing working copy with index
3386 set diffidfrom $nullid2
3387 } elseif {$diffidto eq $nullid2} {
3388 # diffing index with HEAD
3389 set diffidfrom "HEAD"
3390 } else {
3391 # use first parent commit
3392 global parentlist selectedline
3393 set diffidfrom [lindex $parentlist $selectedline 0]
3395 } else {
3396 set diffidfrom [lindex $diffids 0]
3397 set diffidto [lindex $diffids 1]
3400 # make sure that several diffs wont collide
3401 set diffdir [gitknewtmpdir]
3402 if {$diffdir eq {}} return
3404 # gather files to diff
3405 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3406 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3408 if {$difffromfile ne {} && $difftofile ne {}} {
3409 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3410 if {[catch {set fl [open |$cmd r]} err]} {
3411 file delete -force $diffdir
3412 error_popup "$extdifftool: [mc "command failed:"] $err"
3413 } else {
3414 fconfigure $fl -blocking 0
3415 filerun $fl [list delete_at_eof $fl $diffdir]
3420 proc find_hunk_blamespec {base line} {
3421 global ctext
3423 # Find and parse the hunk header
3424 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3425 if {$s_lix eq {}} return
3427 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3428 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3429 s_line old_specs osz osz1 new_line nsz]} {
3430 return
3433 # base lines for the parents
3434 set base_lines [list $new_line]
3435 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3436 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3437 old_spec old_line osz]} {
3438 return
3440 lappend base_lines $old_line
3443 # Now scan the lines to determine offset within the hunk
3444 set max_parent [expr {[llength $base_lines]-2}]
3445 set dline 0
3446 set s_lno [lindex [split $s_lix "."] 0]
3448 # Determine if the line is removed
3449 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3450 if {[string match {[-+ ]*} $chunk]} {
3451 set removed_idx [string first "-" $chunk]
3452 # Choose a parent index
3453 if {$removed_idx >= 0} {
3454 set parent $removed_idx
3455 } else {
3456 set unchanged_idx [string first " " $chunk]
3457 if {$unchanged_idx >= 0} {
3458 set parent $unchanged_idx
3459 } else {
3460 # blame the current commit
3461 set parent -1
3464 # then count other lines that belong to it
3465 for {set i $line} {[incr i -1] > $s_lno} {} {
3466 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3467 # Determine if the line is removed
3468 set removed_idx [string first "-" $chunk]
3469 if {$parent >= 0} {
3470 set code [string index $chunk $parent]
3471 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3472 incr dline
3474 } else {
3475 if {$removed_idx < 0} {
3476 incr dline
3480 incr parent
3481 } else {
3482 set parent 0
3485 incr dline [lindex $base_lines $parent]
3486 return [list $parent $dline]
3489 proc external_blame_diff {} {
3490 global currentid cmitmode
3491 global diff_menu_txtpos diff_menu_line
3492 global diff_menu_filebase flist_menu_file
3494 if {$cmitmode eq "tree"} {
3495 set parent_idx 0
3496 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3497 } else {
3498 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3499 if {$hinfo ne {}} {
3500 set parent_idx [lindex $hinfo 0]
3501 set line [lindex $hinfo 1]
3502 } else {
3503 set parent_idx 0
3504 set line 0
3508 external_blame $parent_idx $line
3511 # Find the SHA1 ID of the blob for file $fname in the index
3512 # at stage 0 or 2
3513 proc index_sha1 {fname} {
3514 set f [open [list | git ls-files -s $fname] r]
3515 while {[gets $f line] >= 0} {
3516 set info [lindex [split $line "\t"] 0]
3517 set stage [lindex $info 2]
3518 if {$stage eq "0" || $stage eq "2"} {
3519 close $f
3520 return [lindex $info 1]
3523 close $f
3524 return {}
3527 # Turn an absolute path into one relative to the current directory
3528 proc make_relative {f} {
3529 if {[file pathtype $f] eq "relative"} {
3530 return $f
3532 set elts [file split $f]
3533 set here [file split [pwd]]
3534 set ei 0
3535 set hi 0
3536 set res {}
3537 foreach d $here {
3538 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3539 lappend res ".."
3540 } else {
3541 incr ei
3543 incr hi
3545 set elts [concat $res [lrange $elts $ei end]]
3546 return [eval file join $elts]
3549 proc external_blame {parent_idx {line {}}} {
3550 global flist_menu_file cdup
3551 global nullid nullid2
3552 global parentlist selectedline currentid
3554 if {$parent_idx > 0} {
3555 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3556 } else {
3557 set base_commit $currentid
3560 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3561 error_popup [mc "No such commit"]
3562 return
3565 set cmdline [list git gui blame]
3566 if {$line ne {} && $line > 1} {
3567 lappend cmdline "--line=$line"
3569 set f [file join $cdup $flist_menu_file]
3570 # Unfortunately it seems git gui blame doesn't like
3571 # being given an absolute path...
3572 set f [make_relative $f]
3573 lappend cmdline $base_commit $f
3574 if {[catch {eval exec $cmdline &} err]} {
3575 error_popup "[mc "git gui blame: command failed:"] $err"
3579 proc show_line_source {} {
3580 global cmitmode currentid parents curview blamestuff blameinst
3581 global diff_menu_line diff_menu_filebase flist_menu_file
3582 global nullid nullid2 gitdir cdup
3584 set from_index {}
3585 if {$cmitmode eq "tree"} {
3586 set id $currentid
3587 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3588 } else {
3589 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3590 if {$h eq {}} return
3591 set pi [lindex $h 0]
3592 if {$pi == 0} {
3593 mark_ctext_line $diff_menu_line
3594 return
3596 incr pi -1
3597 if {$currentid eq $nullid} {
3598 if {$pi > 0} {
3599 # must be a merge in progress...
3600 if {[catch {
3601 # get the last line from .git/MERGE_HEAD
3602 set f [open [file join $gitdir MERGE_HEAD] r]
3603 set id [lindex [split [read $f] "\n"] end-1]
3604 close $f
3605 } err]} {
3606 error_popup [mc "Couldn't read merge head: %s" $err]
3607 return
3609 } elseif {$parents($curview,$currentid) eq $nullid2} {
3610 # need to do the blame from the index
3611 if {[catch {
3612 set from_index [index_sha1 $flist_menu_file]
3613 } err]} {
3614 error_popup [mc "Error reading index: %s" $err]
3615 return
3617 } else {
3618 set id $parents($curview,$currentid)
3620 } else {
3621 set id [lindex $parents($curview,$currentid) $pi]
3623 set line [lindex $h 1]
3625 set blameargs {}
3626 if {$from_index ne {}} {
3627 lappend blameargs | git cat-file blob $from_index
3629 lappend blameargs | git blame -p -L$line,+1
3630 if {$from_index ne {}} {
3631 lappend blameargs --contents -
3632 } else {
3633 lappend blameargs $id
3635 lappend blameargs -- [file join $cdup $flist_menu_file]
3636 if {[catch {
3637 set f [open $blameargs r]
3638 } err]} {
3639 error_popup [mc "Couldn't start git blame: %s" $err]
3640 return
3642 nowbusy blaming [mc "Searching"]
3643 fconfigure $f -blocking 0
3644 set i [reg_instance $f]
3645 set blamestuff($i) {}
3646 set blameinst $i
3647 filerun $f [list read_line_source $f $i]
3650 proc stopblaming {} {
3651 global blameinst
3653 if {[info exists blameinst]} {
3654 stop_instance $blameinst
3655 unset blameinst
3656 notbusy blaming
3660 proc read_line_source {fd inst} {
3661 global blamestuff curview commfd blameinst nullid nullid2
3663 while {[gets $fd line] >= 0} {
3664 lappend blamestuff($inst) $line
3666 if {![eof $fd]} {
3667 return 1
3669 unset commfd($inst)
3670 unset blameinst
3671 notbusy blaming
3672 fconfigure $fd -blocking 1
3673 if {[catch {close $fd} err]} {
3674 error_popup [mc "Error running git blame: %s" $err]
3675 return 0
3678 set fname {}
3679 set line [split [lindex $blamestuff($inst) 0] " "]
3680 set id [lindex $line 0]
3681 set lnum [lindex $line 1]
3682 if {[string length $id] == 40 && [string is xdigit $id] &&
3683 [string is digit -strict $lnum]} {
3684 # look for "filename" line
3685 foreach l $blamestuff($inst) {
3686 if {[string match "filename *" $l]} {
3687 set fname [string range $l 9 end]
3688 break
3692 if {$fname ne {}} {
3693 # all looks good, select it
3694 if {$id eq $nullid} {
3695 # blame uses all-zeroes to mean not committed,
3696 # which would mean a change in the index
3697 set id $nullid2
3699 if {[commitinview $id $curview]} {
3700 selectline [rowofcommit $id] 1 [list $fname $lnum]
3701 } else {
3702 error_popup [mc "That line comes from commit %s, \
3703 which is not in this view" [shortids $id]]
3705 } else {
3706 puts "oops couldn't parse git blame output"
3708 return 0
3711 # delete $dir when we see eof on $f (presumably because the child has exited)
3712 proc delete_at_eof {f dir} {
3713 while {[gets $f line] >= 0} {}
3714 if {[eof $f]} {
3715 if {[catch {close $f} err]} {
3716 error_popup "[mc "External diff viewer failed:"] $err"
3718 file delete -force $dir
3719 return 0
3721 return 1
3724 # Functions for adding and removing shell-type quoting
3726 proc shellquote {str} {
3727 if {![string match "*\['\"\\ \t]*" $str]} {
3728 return $str
3730 if {![string match "*\['\"\\]*" $str]} {
3731 return "\"$str\""
3733 if {![string match "*'*" $str]} {
3734 return "'$str'"
3736 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3739 proc shellarglist {l} {
3740 set str {}
3741 foreach a $l {
3742 if {$str ne {}} {
3743 append str " "
3745 append str [shellquote $a]
3747 return $str
3750 proc shelldequote {str} {
3751 set ret {}
3752 set used -1
3753 while {1} {
3754 incr used
3755 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3756 append ret [string range $str $used end]
3757 set used [string length $str]
3758 break
3760 set first [lindex $first 0]
3761 set ch [string index $str $first]
3762 if {$first > $used} {
3763 append ret [string range $str $used [expr {$first - 1}]]
3764 set used $first
3766 if {$ch eq " " || $ch eq "\t"} break
3767 incr used
3768 if {$ch eq "'"} {
3769 set first [string first "'" $str $used]
3770 if {$first < 0} {
3771 error "unmatched single-quote"
3773 append ret [string range $str $used [expr {$first - 1}]]
3774 set used $first
3775 continue
3777 if {$ch eq "\\"} {
3778 if {$used >= [string length $str]} {
3779 error "trailing backslash"
3781 append ret [string index $str $used]
3782 continue
3784 # here ch == "\""
3785 while {1} {
3786 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3787 error "unmatched double-quote"
3789 set first [lindex $first 0]
3790 set ch [string index $str $first]
3791 if {$first > $used} {
3792 append ret [string range $str $used [expr {$first - 1}]]
3793 set used $first
3795 if {$ch eq "\""} break
3796 incr used
3797 append ret [string index $str $used]
3798 incr used
3801 return [list $used $ret]
3804 proc shellsplit {str} {
3805 set l {}
3806 while {1} {
3807 set str [string trimleft $str]
3808 if {$str eq {}} break
3809 set dq [shelldequote $str]
3810 set n [lindex $dq 0]
3811 set word [lindex $dq 1]
3812 set str [string range $str $n end]
3813 lappend l $word
3815 return $l
3818 # Code to implement multiple views
3820 proc newview {ishighlight} {
3821 global nextviewnum newviewname newishighlight
3822 global revtreeargs viewargscmd newviewopts curview
3824 set newishighlight $ishighlight
3825 set top .gitkview
3826 if {[winfo exists $top]} {
3827 raise $top
3828 return
3830 decode_view_opts $nextviewnum $revtreeargs
3831 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3832 set newviewopts($nextviewnum,perm) 0
3833 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3834 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3837 set known_view_options {
3838 {perm b . {} {mc "Remember this view"}}
3839 {reflabel l + {} {mc "References (space separated list):"}}
3840 {refs t15 .. {} {mc "Branches & tags:"}}
3841 {allrefs b *. "--all" {mc "All refs"}}
3842 {branches b . "--branches" {mc "All (local) branches"}}
3843 {tags b . "--tags" {mc "All tags"}}
3844 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3845 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3846 {author t15 .. "--author=*" {mc "Author:"}}
3847 {committer t15 . "--committer=*" {mc "Committer:"}}
3848 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3849 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3850 {changes_l l + {} {mc "Changes to Files:"}}
3851 {pickaxe_s r0 . {} {mc "Fixed String"}}
3852 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3853 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3854 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3855 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3856 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3857 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3858 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3859 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3860 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3861 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3862 {lright b . "--left-right" {mc "Mark branch sides"}}
3863 {first b . "--first-parent" {mc "Limit to first parent"}}
3864 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3865 {args t50 *. {} {mc "Additional arguments to git log:"}}
3866 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3867 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3870 # Convert $newviewopts($n, ...) into args for git log.
3871 proc encode_view_opts {n} {
3872 global known_view_options newviewopts
3874 set rargs [list]
3875 foreach opt $known_view_options {
3876 set patterns [lindex $opt 3]
3877 if {$patterns eq {}} continue
3878 set pattern [lindex $patterns 0]
3880 if {[lindex $opt 1] eq "b"} {
3881 set val $newviewopts($n,[lindex $opt 0])
3882 if {$val} {
3883 lappend rargs $pattern
3885 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3886 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3887 set val $newviewopts($n,$button_id)
3888 if {$val eq $value} {
3889 lappend rargs $pattern
3891 } else {
3892 set val $newviewopts($n,[lindex $opt 0])
3893 set val [string trim $val]
3894 if {$val ne {}} {
3895 set pfix [string range $pattern 0 end-1]
3896 lappend rargs $pfix$val
3900 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3901 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3904 # Fill $newviewopts($n, ...) based on args for git log.
3905 proc decode_view_opts {n view_args} {
3906 global known_view_options newviewopts
3908 foreach opt $known_view_options {
3909 set id [lindex $opt 0]
3910 if {[lindex $opt 1] eq "b"} {
3911 # Checkboxes
3912 set val 0
3913 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3914 # Radiobuttons
3915 regexp {^(.*_)} $id uselessvar id
3916 set val 0
3917 } else {
3918 # Text fields
3919 set val {}
3921 set newviewopts($n,$id) $val
3923 set oargs [list]
3924 set refargs [list]
3925 foreach arg $view_args {
3926 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3927 && ![info exists found(limit)]} {
3928 set newviewopts($n,limit) $cnt
3929 set found(limit) 1
3930 continue
3932 catch { unset val }
3933 foreach opt $known_view_options {
3934 set id [lindex $opt 0]
3935 if {[info exists found($id)]} continue
3936 foreach pattern [lindex $opt 3] {
3937 if {![string match $pattern $arg]} continue
3938 if {[lindex $opt 1] eq "b"} {
3939 # Check buttons
3940 set val 1
3941 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3942 # Radio buttons
3943 regexp {^(.*_)} $id uselessvar id
3944 set val $num
3945 } else {
3946 # Text input fields
3947 set size [string length $pattern]
3948 set val [string range $arg [expr {$size-1}] end]
3950 set newviewopts($n,$id) $val
3951 set found($id) 1
3952 break
3954 if {[info exists val]} break
3956 if {[info exists val]} continue
3957 if {[regexp {^-} $arg]} {
3958 lappend oargs $arg
3959 } else {
3960 lappend refargs $arg
3963 set newviewopts($n,refs) [shellarglist $refargs]
3964 set newviewopts($n,args) [shellarglist $oargs]
3967 proc edit_or_newview {} {
3968 global curview
3970 if {$curview > 0} {
3971 editview
3972 } else {
3973 newview 0
3977 proc editview {} {
3978 global curview
3979 global viewname viewperm newviewname newviewopts
3980 global viewargs viewargscmd
3982 set top .gitkvedit-$curview
3983 if {[winfo exists $top]} {
3984 raise $top
3985 return
3987 decode_view_opts $curview $viewargs($curview)
3988 set newviewname($curview) $viewname($curview)
3989 set newviewopts($curview,perm) $viewperm($curview)
3990 set newviewopts($curview,cmd) $viewargscmd($curview)
3991 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3994 proc vieweditor {top n title} {
3995 global newviewname newviewopts viewfiles bgcolor
3996 global known_view_options NS
3998 ttk_toplevel $top
3999 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4000 make_transient $top .
4002 # View name
4003 ${NS}::frame $top.nfr
4004 ${NS}::label $top.nl -text [mc "View Name"]
4005 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4006 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4007 pack $top.nl -in $top.nfr -side left -padx {0 5}
4008 pack $top.name -in $top.nfr -side left -padx {0 25}
4010 # View options
4011 set cframe $top.nfr
4012 set cexpand 0
4013 set cnt 0
4014 foreach opt $known_view_options {
4015 set id [lindex $opt 0]
4016 set type [lindex $opt 1]
4017 set flags [lindex $opt 2]
4018 set title [eval [lindex $opt 4]]
4019 set lxpad 0
4021 if {$flags eq "+" || $flags eq "*"} {
4022 set cframe $top.fr$cnt
4023 incr cnt
4024 ${NS}::frame $cframe
4025 pack $cframe -in $top -fill x -pady 3 -padx 3
4026 set cexpand [expr {$flags eq "*"}]
4027 } elseif {$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 [list 15 3]
4032 set cexpand [expr {$flags eq "*."}]
4033 } else {
4034 set lxpad 5
4037 if {$type eq "l"} {
4038 ${NS}::label $cframe.l_$id -text $title
4039 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4040 } elseif {$type eq "b"} {
4041 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4042 pack $cframe.c_$id -in $cframe -side left \
4043 -padx [list $lxpad 0] -expand $cexpand -anchor w
4044 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4045 regexp {^(.*_)} $id uselessvar button_id
4046 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4047 pack $cframe.c_$id -in $cframe -side left \
4048 -padx [list $lxpad 0] -expand $cexpand -anchor w
4049 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4050 ${NS}::label $cframe.l_$id -text $title
4051 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4052 -textvariable newviewopts($n,$id)
4053 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4054 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
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 top -pady [list 3 0] -anchor w
4060 pack $cframe.e_$id -in $cframe -side top -fill x
4061 } elseif {$type eq "path"} {
4062 ${NS}::label $top.l -text $title
4063 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4064 text $top.t -width 40 -height 5 -background $bgcolor
4065 if {[info exists viewfiles($n)]} {
4066 foreach f $viewfiles($n) {
4067 $top.t insert end $f
4068 $top.t insert end "\n"
4070 $top.t delete {end - 1c} end
4071 $top.t mark set insert 0.0
4073 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4077 ${NS}::frame $top.buts
4078 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4079 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4080 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4081 bind $top <Control-Return> [list newviewok $top $n]
4082 bind $top <F5> [list newviewok $top $n 1]
4083 bind $top <Escape> [list destroy $top]
4084 grid $top.buts.ok $top.buts.apply $top.buts.can
4085 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4086 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4087 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4088 pack $top.buts -in $top -side top -fill x
4089 focus $top.t
4092 proc doviewmenu {m first cmd op argv} {
4093 set nmenu [$m index end]
4094 for {set i $first} {$i <= $nmenu} {incr i} {
4095 if {[$m entrycget $i -command] eq $cmd} {
4096 eval $m $op $i $argv
4097 break
4102 proc allviewmenus {n op args} {
4103 # global viewhlmenu
4105 doviewmenu .bar.view 5 [list showview $n] $op $args
4106 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4109 proc newviewok {top n {apply 0}} {
4110 global nextviewnum newviewperm newviewname newishighlight
4111 global viewname viewfiles viewperm selectedview curview
4112 global viewargs viewargscmd newviewopts viewhlmenu
4114 if {[catch {
4115 set newargs [encode_view_opts $n]
4116 } err]} {
4117 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4118 return
4120 set files {}
4121 foreach f [split [$top.t get 0.0 end] "\n"] {
4122 set ft [string trim $f]
4123 if {$ft ne {}} {
4124 lappend files $ft
4127 if {![info exists viewfiles($n)]} {
4128 # creating a new view
4129 incr nextviewnum
4130 set viewname($n) $newviewname($n)
4131 set viewperm($n) $newviewopts($n,perm)
4132 set viewfiles($n) $files
4133 set viewargs($n) $newargs
4134 set viewargscmd($n) $newviewopts($n,cmd)
4135 addviewmenu $n
4136 if {!$newishighlight} {
4137 run showview $n
4138 } else {
4139 run addvhighlight $n
4141 } else {
4142 # editing an existing view
4143 set viewperm($n) $newviewopts($n,perm)
4144 if {$newviewname($n) ne $viewname($n)} {
4145 set viewname($n) $newviewname($n)
4146 doviewmenu .bar.view 5 [list showview $n] \
4147 entryconf [list -label $viewname($n)]
4148 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4149 # entryconf [list -label $viewname($n) -value $viewname($n)]
4151 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4152 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4153 set viewfiles($n) $files
4154 set viewargs($n) $newargs
4155 set viewargscmd($n) $newviewopts($n,cmd)
4156 if {$curview == $n} {
4157 run reloadcommits
4161 if {$apply} return
4162 catch {destroy $top}
4165 proc delview {} {
4166 global curview viewperm hlview selectedhlview
4168 if {$curview == 0} return
4169 if {[info exists hlview] && $hlview == $curview} {
4170 set selectedhlview [mc "None"]
4171 unset hlview
4173 allviewmenus $curview delete
4174 set viewperm($curview) 0
4175 showview 0
4178 proc addviewmenu {n} {
4179 global viewname viewhlmenu
4181 .bar.view add radiobutton -label $viewname($n) \
4182 -command [list showview $n] -variable selectedview -value $n
4183 #$viewhlmenu add radiobutton -label $viewname($n) \
4184 # -command [list addvhighlight $n] -variable selectedhlview
4187 proc showview {n} {
4188 global curview cached_commitrow ordertok
4189 global displayorder parentlist rowidlist rowisopt rowfinal
4190 global colormap rowtextx nextcolor canvxmax
4191 global numcommits viewcomplete
4192 global selectedline currentid canv canvy0
4193 global treediffs
4194 global pending_select mainheadid
4195 global commitidx
4196 global selectedview
4197 global hlview selectedhlview commitinterest
4199 if {$n == $curview} return
4200 set selid {}
4201 set ymax [lindex [$canv cget -scrollregion] 3]
4202 set span [$canv yview]
4203 set ytop [expr {[lindex $span 0] * $ymax}]
4204 set ybot [expr {[lindex $span 1] * $ymax}]
4205 set yscreen [expr {($ybot - $ytop) / 2}]
4206 if {$selectedline ne {}} {
4207 set selid $currentid
4208 set y [yc $selectedline]
4209 if {$ytop < $y && $y < $ybot} {
4210 set yscreen [expr {$y - $ytop}]
4212 } elseif {[info exists pending_select]} {
4213 set selid $pending_select
4214 unset pending_select
4216 unselectline
4217 normalline
4218 catch {unset treediffs}
4219 clear_display
4220 if {[info exists hlview] && $hlview == $n} {
4221 unset hlview
4222 set selectedhlview [mc "None"]
4224 catch {unset commitinterest}
4225 catch {unset cached_commitrow}
4226 catch {unset ordertok}
4228 set curview $n
4229 set selectedview $n
4230 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4231 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4233 run refill_reflist
4234 if {![info exists viewcomplete($n)]} {
4235 getcommits $selid
4236 return
4239 set displayorder {}
4240 set parentlist {}
4241 set rowidlist {}
4242 set rowisopt {}
4243 set rowfinal {}
4244 set numcommits $commitidx($n)
4246 catch {unset colormap}
4247 catch {unset rowtextx}
4248 set nextcolor 0
4249 set canvxmax [$canv cget -width]
4250 set curview $n
4251 set row 0
4252 setcanvscroll
4253 set yf 0
4254 set row {}
4255 if {$selid ne {} && [commitinview $selid $n]} {
4256 set row [rowofcommit $selid]
4257 # try to get the selected row in the same position on the screen
4258 set ymax [lindex [$canv cget -scrollregion] 3]
4259 set ytop [expr {[yc $row] - $yscreen}]
4260 if {$ytop < 0} {
4261 set ytop 0
4263 set yf [expr {$ytop * 1.0 / $ymax}]
4265 allcanvs yview moveto $yf
4266 drawvisible
4267 if {$row ne {}} {
4268 selectline $row 0
4269 } elseif {!$viewcomplete($n)} {
4270 reset_pending_select $selid
4271 } else {
4272 reset_pending_select {}
4274 if {[commitinview $pending_select $curview]} {
4275 selectline [rowofcommit $pending_select] 1
4276 } else {
4277 set row [first_real_row]
4278 if {$row < $numcommits} {
4279 selectline $row 0
4283 if {!$viewcomplete($n)} {
4284 if {$numcommits == 0} {
4285 show_status [mc "Reading commits..."]
4287 } elseif {$numcommits == 0} {
4288 show_status [mc "No commits selected"]
4292 # Stuff relating to the highlighting facility
4294 proc ishighlighted {id} {
4295 global vhighlights fhighlights nhighlights rhighlights
4297 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4298 return $nhighlights($id)
4300 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4301 return $vhighlights($id)
4303 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4304 return $fhighlights($id)
4306 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4307 return $rhighlights($id)
4309 return 0
4312 proc bolden {id font} {
4313 global canv linehtag currentid boldids need_redisplay markedid
4315 # need_redisplay = 1 means the display is stale and about to be redrawn
4316 if {$need_redisplay} return
4317 lappend boldids $id
4318 $canv itemconf $linehtag($id) -font $font
4319 if {[info exists currentid] && $id eq $currentid} {
4320 $canv delete secsel
4321 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4322 -outline {{}} -tags secsel \
4323 -fill [$canv cget -selectbackground]]
4324 $canv lower $t
4326 if {[info exists markedid] && $id eq $markedid} {
4327 make_idmark $id
4331 proc bolden_name {id font} {
4332 global canv2 linentag currentid boldnameids need_redisplay
4334 if {$need_redisplay} return
4335 lappend boldnameids $id
4336 $canv2 itemconf $linentag($id) -font $font
4337 if {[info exists currentid] && $id eq $currentid} {
4338 $canv2 delete secsel
4339 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4340 -outline {{}} -tags secsel \
4341 -fill [$canv2 cget -selectbackground]]
4342 $canv2 lower $t
4346 proc unbolden {} {
4347 global boldids
4349 set stillbold {}
4350 foreach id $boldids {
4351 if {![ishighlighted $id]} {
4352 bolden $id mainfont
4353 } else {
4354 lappend stillbold $id
4357 set boldids $stillbold
4360 proc addvhighlight {n} {
4361 global hlview viewcomplete curview vhl_done commitidx
4363 if {[info exists hlview]} {
4364 delvhighlight
4366 set hlview $n
4367 if {$n != $curview && ![info exists viewcomplete($n)]} {
4368 start_rev_list $n
4370 set vhl_done $commitidx($hlview)
4371 if {$vhl_done > 0} {
4372 drawvisible
4376 proc delvhighlight {} {
4377 global hlview vhighlights
4379 if {![info exists hlview]} return
4380 unset hlview
4381 catch {unset vhighlights}
4382 unbolden
4385 proc vhighlightmore {} {
4386 global hlview vhl_done commitidx vhighlights curview
4388 set max $commitidx($hlview)
4389 set vr [visiblerows]
4390 set r0 [lindex $vr 0]
4391 set r1 [lindex $vr 1]
4392 for {set i $vhl_done} {$i < $max} {incr i} {
4393 set id [commitonrow $i $hlview]
4394 if {[commitinview $id $curview]} {
4395 set row [rowofcommit $id]
4396 if {$r0 <= $row && $row <= $r1} {
4397 if {![highlighted $row]} {
4398 bolden $id mainfontbold
4400 set vhighlights($id) 1
4404 set vhl_done $max
4405 return 0
4408 proc askvhighlight {row id} {
4409 global hlview vhighlights iddrawn
4411 if {[commitinview $id $hlview]} {
4412 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4413 bolden $id mainfontbold
4415 set vhighlights($id) 1
4416 } else {
4417 set vhighlights($id) 0
4421 proc hfiles_change {} {
4422 global highlight_files filehighlight fhighlights fh_serial
4423 global highlight_paths
4425 if {[info exists filehighlight]} {
4426 # delete previous highlights
4427 catch {close $filehighlight}
4428 unset filehighlight
4429 catch {unset fhighlights}
4430 unbolden
4431 unhighlight_filelist
4433 set highlight_paths {}
4434 after cancel do_file_hl $fh_serial
4435 incr fh_serial
4436 if {$highlight_files ne {}} {
4437 after 300 do_file_hl $fh_serial
4441 proc gdttype_change {name ix op} {
4442 global gdttype highlight_files findstring findpattern
4444 stopfinding
4445 if {$findstring ne {}} {
4446 if {$gdttype eq [mc "containing:"]} {
4447 if {$highlight_files ne {}} {
4448 set highlight_files {}
4449 hfiles_change
4451 findcom_change
4452 } else {
4453 if {$findpattern ne {}} {
4454 set findpattern {}
4455 findcom_change
4457 set highlight_files $findstring
4458 hfiles_change
4460 drawvisible
4462 # enable/disable findtype/findloc menus too
4465 proc find_change {name ix op} {
4466 global gdttype findstring highlight_files
4468 stopfinding
4469 if {$gdttype eq [mc "containing:"]} {
4470 findcom_change
4471 } else {
4472 if {$highlight_files ne $findstring} {
4473 set highlight_files $findstring
4474 hfiles_change
4477 drawvisible
4480 proc findcom_change args {
4481 global nhighlights boldnameids
4482 global findpattern findtype findstring gdttype
4484 stopfinding
4485 # delete previous highlights, if any
4486 foreach id $boldnameids {
4487 bolden_name $id mainfont
4489 set boldnameids {}
4490 catch {unset nhighlights}
4491 unbolden
4492 unmarkmatches
4493 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4494 set findpattern {}
4495 } elseif {$findtype eq [mc "Regexp"]} {
4496 set findpattern $findstring
4497 } else {
4498 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4499 $findstring]
4500 set findpattern "*$e*"
4504 proc makepatterns {l} {
4505 set ret {}
4506 foreach e $l {
4507 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4508 if {[string index $ee end] eq "/"} {
4509 lappend ret "$ee*"
4510 } else {
4511 lappend ret $ee
4512 lappend ret "$ee/*"
4515 return $ret
4518 proc do_file_hl {serial} {
4519 global highlight_files filehighlight highlight_paths gdttype fhl_list
4520 global cdup
4522 if {$gdttype eq [mc "touching paths:"]} {
4523 if {[catch {set paths [shellsplit $highlight_files]}]} return
4524 set highlight_paths [makepatterns $paths]
4525 highlight_filelist
4526 set relative_paths {}
4527 foreach path $paths {
4528 lappend relative_paths [file join $cdup $path]
4530 set gdtargs [concat -- $relative_paths]
4531 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4532 set gdtargs [list "-S$highlight_files"]
4533 } else {
4534 # must be "containing:", i.e. we're searching commit info
4535 return
4537 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4538 set filehighlight [open $cmd r+]
4539 fconfigure $filehighlight -blocking 0
4540 filerun $filehighlight readfhighlight
4541 set fhl_list {}
4542 drawvisible
4543 flushhighlights
4546 proc flushhighlights {} {
4547 global filehighlight fhl_list
4549 if {[info exists filehighlight]} {
4550 lappend fhl_list {}
4551 puts $filehighlight ""
4552 flush $filehighlight
4556 proc askfilehighlight {row id} {
4557 global filehighlight fhighlights fhl_list
4559 lappend fhl_list $id
4560 set fhighlights($id) -1
4561 puts $filehighlight $id
4564 proc readfhighlight {} {
4565 global filehighlight fhighlights curview iddrawn
4566 global fhl_list find_dirn
4568 if {![info exists filehighlight]} {
4569 return 0
4571 set nr 0
4572 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4573 set line [string trim $line]
4574 set i [lsearch -exact $fhl_list $line]
4575 if {$i < 0} continue
4576 for {set j 0} {$j < $i} {incr j} {
4577 set id [lindex $fhl_list $j]
4578 set fhighlights($id) 0
4580 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4581 if {$line eq {}} continue
4582 if {![commitinview $line $curview]} continue
4583 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4584 bolden $line mainfontbold
4586 set fhighlights($line) 1
4588 if {[eof $filehighlight]} {
4589 # strange...
4590 puts "oops, git diff-tree died"
4591 catch {close $filehighlight}
4592 unset filehighlight
4593 return 0
4595 if {[info exists find_dirn]} {
4596 run findmore
4598 return 1
4601 proc doesmatch {f} {
4602 global findtype findpattern
4604 if {$findtype eq [mc "Regexp"]} {
4605 return [regexp $findpattern $f]
4606 } elseif {$findtype eq [mc "IgnCase"]} {
4607 return [string match -nocase $findpattern $f]
4608 } else {
4609 return [string match $findpattern $f]
4613 proc askfindhighlight {row id} {
4614 global nhighlights commitinfo iddrawn
4615 global findloc
4616 global markingmatches
4618 if {![info exists commitinfo($id)]} {
4619 getcommit $id
4621 set info $commitinfo($id)
4622 set isbold 0
4623 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4624 foreach f $info ty $fldtypes {
4625 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4626 [doesmatch $f]} {
4627 if {$ty eq [mc "Author"]} {
4628 set isbold 2
4629 break
4631 set isbold 1
4634 if {$isbold && [info exists iddrawn($id)]} {
4635 if {![ishighlighted $id]} {
4636 bolden $id mainfontbold
4637 if {$isbold > 1} {
4638 bolden_name $id mainfontbold
4641 if {$markingmatches} {
4642 markrowmatches $row $id
4645 set nhighlights($id) $isbold
4648 proc markrowmatches {row id} {
4649 global canv canv2 linehtag linentag commitinfo findloc
4651 set headline [lindex $commitinfo($id) 0]
4652 set author [lindex $commitinfo($id) 1]
4653 $canv delete match$row
4654 $canv2 delete match$row
4655 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4656 set m [findmatches $headline]
4657 if {$m ne {}} {
4658 markmatches $canv $row $headline $linehtag($id) $m \
4659 [$canv itemcget $linehtag($id) -font] $row
4662 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4663 set m [findmatches $author]
4664 if {$m ne {}} {
4665 markmatches $canv2 $row $author $linentag($id) $m \
4666 [$canv2 itemcget $linentag($id) -font] $row
4671 proc vrel_change {name ix op} {
4672 global highlight_related
4674 rhighlight_none
4675 if {$highlight_related ne [mc "None"]} {
4676 run drawvisible
4680 # prepare for testing whether commits are descendents or ancestors of a
4681 proc rhighlight_sel {a} {
4682 global descendent desc_todo ancestor anc_todo
4683 global highlight_related
4685 catch {unset descendent}
4686 set desc_todo [list $a]
4687 catch {unset ancestor}
4688 set anc_todo [list $a]
4689 if {$highlight_related ne [mc "None"]} {
4690 rhighlight_none
4691 run drawvisible
4695 proc rhighlight_none {} {
4696 global rhighlights
4698 catch {unset rhighlights}
4699 unbolden
4702 proc is_descendent {a} {
4703 global curview children descendent desc_todo
4705 set v $curview
4706 set la [rowofcommit $a]
4707 set todo $desc_todo
4708 set leftover {}
4709 set done 0
4710 for {set i 0} {$i < [llength $todo]} {incr i} {
4711 set do [lindex $todo $i]
4712 if {[rowofcommit $do] < $la} {
4713 lappend leftover $do
4714 continue
4716 foreach nk $children($v,$do) {
4717 if {![info exists descendent($nk)]} {
4718 set descendent($nk) 1
4719 lappend todo $nk
4720 if {$nk eq $a} {
4721 set done 1
4725 if {$done} {
4726 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4727 return
4730 set descendent($a) 0
4731 set desc_todo $leftover
4734 proc is_ancestor {a} {
4735 global curview parents ancestor anc_todo
4737 set v $curview
4738 set la [rowofcommit $a]
4739 set todo $anc_todo
4740 set leftover {}
4741 set done 0
4742 for {set i 0} {$i < [llength $todo]} {incr i} {
4743 set do [lindex $todo $i]
4744 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4745 lappend leftover $do
4746 continue
4748 foreach np $parents($v,$do) {
4749 if {![info exists ancestor($np)]} {
4750 set ancestor($np) 1
4751 lappend todo $np
4752 if {$np eq $a} {
4753 set done 1
4757 if {$done} {
4758 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4759 return
4762 set ancestor($a) 0
4763 set anc_todo $leftover
4766 proc askrelhighlight {row id} {
4767 global descendent highlight_related iddrawn rhighlights
4768 global selectedline ancestor
4770 if {$selectedline eq {}} return
4771 set isbold 0
4772 if {$highlight_related eq [mc "Descendant"] ||
4773 $highlight_related eq [mc "Not descendant"]} {
4774 if {![info exists descendent($id)]} {
4775 is_descendent $id
4777 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4778 set isbold 1
4780 } elseif {$highlight_related eq [mc "Ancestor"] ||
4781 $highlight_related eq [mc "Not ancestor"]} {
4782 if {![info exists ancestor($id)]} {
4783 is_ancestor $id
4785 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4786 set isbold 1
4789 if {[info exists iddrawn($id)]} {
4790 if {$isbold && ![ishighlighted $id]} {
4791 bolden $id mainfontbold
4794 set rhighlights($id) $isbold
4797 # Graph layout functions
4799 proc shortids {ids} {
4800 set res {}
4801 foreach id $ids {
4802 if {[llength $id] > 1} {
4803 lappend res [shortids $id]
4804 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4805 lappend res [string range $id 0 7]
4806 } else {
4807 lappend res $id
4810 return $res
4813 proc ntimes {n o} {
4814 set ret {}
4815 set o [list $o]
4816 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4817 if {($n & $mask) != 0} {
4818 set ret [concat $ret $o]
4820 set o [concat $o $o]
4822 return $ret
4825 proc ordertoken {id} {
4826 global ordertok curview varcid varcstart varctok curview parents children
4827 global nullid nullid2
4829 if {[info exists ordertok($id)]} {
4830 return $ordertok($id)
4832 set origid $id
4833 set todo {}
4834 while {1} {
4835 if {[info exists varcid($curview,$id)]} {
4836 set a $varcid($curview,$id)
4837 set p [lindex $varcstart($curview) $a]
4838 } else {
4839 set p [lindex $children($curview,$id) 0]
4841 if {[info exists ordertok($p)]} {
4842 set tok $ordertok($p)
4843 break
4845 set id [first_real_child $curview,$p]
4846 if {$id eq {}} {
4847 # it's a root
4848 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4849 break
4851 if {[llength $parents($curview,$id)] == 1} {
4852 lappend todo [list $p {}]
4853 } else {
4854 set j [lsearch -exact $parents($curview,$id) $p]
4855 if {$j < 0} {
4856 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4858 lappend todo [list $p [strrep $j]]
4861 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4862 set p [lindex $todo $i 0]
4863 append tok [lindex $todo $i 1]
4864 set ordertok($p) $tok
4866 set ordertok($origid) $tok
4867 return $tok
4870 # Work out where id should go in idlist so that order-token
4871 # values increase from left to right
4872 proc idcol {idlist id {i 0}} {
4873 set t [ordertoken $id]
4874 if {$i < 0} {
4875 set i 0
4877 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4878 if {$i > [llength $idlist]} {
4879 set i [llength $idlist]
4881 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4882 incr i
4883 } else {
4884 if {$t > [ordertoken [lindex $idlist $i]]} {
4885 while {[incr i] < [llength $idlist] &&
4886 $t >= [ordertoken [lindex $idlist $i]]} {}
4889 return $i
4892 proc initlayout {} {
4893 global rowidlist rowisopt rowfinal displayorder parentlist
4894 global numcommits canvxmax canv
4895 global nextcolor
4896 global colormap rowtextx
4898 set numcommits 0
4899 set displayorder {}
4900 set parentlist {}
4901 set nextcolor 0
4902 set rowidlist {}
4903 set rowisopt {}
4904 set rowfinal {}
4905 set canvxmax [$canv cget -width]
4906 catch {unset colormap}
4907 catch {unset rowtextx}
4908 setcanvscroll
4911 proc setcanvscroll {} {
4912 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4913 global lastscrollset lastscrollrows
4915 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4916 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4917 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4918 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4919 set lastscrollset [clock clicks -milliseconds]
4920 set lastscrollrows $numcommits
4923 proc visiblerows {} {
4924 global canv numcommits linespc
4926 set ymax [lindex [$canv cget -scrollregion] 3]
4927 if {$ymax eq {} || $ymax == 0} return
4928 set f [$canv yview]
4929 set y0 [expr {int([lindex $f 0] * $ymax)}]
4930 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4931 if {$r0 < 0} {
4932 set r0 0
4934 set y1 [expr {int([lindex $f 1] * $ymax)}]
4935 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4936 if {$r1 >= $numcommits} {
4937 set r1 [expr {$numcommits - 1}]
4939 return [list $r0 $r1]
4942 proc layoutmore {} {
4943 global commitidx viewcomplete curview
4944 global numcommits pending_select curview
4945 global lastscrollset lastscrollrows
4947 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4948 [clock clicks -milliseconds] - $lastscrollset > 500} {
4949 setcanvscroll
4951 if {[info exists pending_select] &&
4952 [commitinview $pending_select $curview]} {
4953 update
4954 selectline [rowofcommit $pending_select] 1
4956 drawvisible
4959 # With path limiting, we mightn't get the actual HEAD commit,
4960 # so ask git rev-list what is the first ancestor of HEAD that
4961 # touches a file in the path limit.
4962 proc get_viewmainhead {view} {
4963 global viewmainheadid vfilelimit viewinstances mainheadid
4965 catch {
4966 set rfd [open [concat | git rev-list -1 $mainheadid \
4967 -- $vfilelimit($view)] r]
4968 set j [reg_instance $rfd]
4969 lappend viewinstances($view) $j
4970 fconfigure $rfd -blocking 0
4971 filerun $rfd [list getviewhead $rfd $j $view]
4972 set viewmainheadid($curview) {}
4976 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4977 proc getviewhead {fd inst view} {
4978 global viewmainheadid commfd curview viewinstances showlocalchanges
4980 set id {}
4981 if {[gets $fd line] < 0} {
4982 if {![eof $fd]} {
4983 return 1
4985 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4986 set id $line
4988 set viewmainheadid($view) $id
4989 close $fd
4990 unset commfd($inst)
4991 set i [lsearch -exact $viewinstances($view) $inst]
4992 if {$i >= 0} {
4993 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4995 if {$showlocalchanges && $id ne {} && $view == $curview} {
4996 doshowlocalchanges
4998 return 0
5001 proc doshowlocalchanges {} {
5002 global curview viewmainheadid
5004 if {$viewmainheadid($curview) eq {}} return
5005 if {[commitinview $viewmainheadid($curview) $curview]} {
5006 dodiffindex
5007 } else {
5008 interestedin $viewmainheadid($curview) dodiffindex
5012 proc dohidelocalchanges {} {
5013 global nullid nullid2 lserial curview
5015 if {[commitinview $nullid $curview]} {
5016 removefakerow $nullid
5018 if {[commitinview $nullid2 $curview]} {
5019 removefakerow $nullid2
5021 incr lserial
5024 # spawn off a process to do git diff-index --cached HEAD
5025 proc dodiffindex {} {
5026 global lserial showlocalchanges vfilelimit curview
5027 global isworktree
5029 if {!$showlocalchanges || !$isworktree} return
5030 incr lserial
5031 set cmd "|git diff-index --cached HEAD"
5032 if {$vfilelimit($curview) ne {}} {
5033 set cmd [concat $cmd -- $vfilelimit($curview)]
5035 set fd [open $cmd r]
5036 fconfigure $fd -blocking 0
5037 set i [reg_instance $fd]
5038 filerun $fd [list readdiffindex $fd $lserial $i]
5041 proc readdiffindex {fd serial inst} {
5042 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5043 global vfilelimit
5045 set isdiff 1
5046 if {[gets $fd line] < 0} {
5047 if {![eof $fd]} {
5048 return 1
5050 set isdiff 0
5052 # we only need to see one line and we don't really care what it says...
5053 stop_instance $inst
5055 if {$serial != $lserial} {
5056 return 0
5059 # now see if there are any local changes not checked in to the index
5060 set cmd "|git diff-files"
5061 if {$vfilelimit($curview) ne {}} {
5062 set cmd [concat $cmd -- $vfilelimit($curview)]
5064 set fd [open $cmd r]
5065 fconfigure $fd -blocking 0
5066 set i [reg_instance $fd]
5067 filerun $fd [list readdifffiles $fd $serial $i]
5069 if {$isdiff && ![commitinview $nullid2 $curview]} {
5070 # add the line for the changes in the index to the graph
5071 set hl [mc "Local changes checked in to index but not committed"]
5072 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5073 set commitdata($nullid2) "\n $hl\n"
5074 if {[commitinview $nullid $curview]} {
5075 removefakerow $nullid
5077 insertfakerow $nullid2 $viewmainheadid($curview)
5078 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5079 if {[commitinview $nullid $curview]} {
5080 removefakerow $nullid
5082 removefakerow $nullid2
5084 return 0
5087 proc readdifffiles {fd serial inst} {
5088 global viewmainheadid nullid nullid2 curview
5089 global commitinfo commitdata lserial
5091 set isdiff 1
5092 if {[gets $fd line] < 0} {
5093 if {![eof $fd]} {
5094 return 1
5096 set isdiff 0
5098 # we only need to see one line and we don't really care what it says...
5099 stop_instance $inst
5101 if {$serial != $lserial} {
5102 return 0
5105 if {$isdiff && ![commitinview $nullid $curview]} {
5106 # add the line for the local diff to the graph
5107 set hl [mc "Local uncommitted changes, not checked in to index"]
5108 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5109 set commitdata($nullid) "\n $hl\n"
5110 if {[commitinview $nullid2 $curview]} {
5111 set p $nullid2
5112 } else {
5113 set p $viewmainheadid($curview)
5115 insertfakerow $nullid $p
5116 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5117 removefakerow $nullid
5119 return 0
5122 proc nextuse {id row} {
5123 global curview children
5125 if {[info exists children($curview,$id)]} {
5126 foreach kid $children($curview,$id) {
5127 if {![commitinview $kid $curview]} {
5128 return -1
5130 if {[rowofcommit $kid] > $row} {
5131 return [rowofcommit $kid]
5135 if {[commitinview $id $curview]} {
5136 return [rowofcommit $id]
5138 return -1
5141 proc prevuse {id row} {
5142 global curview children
5144 set ret -1
5145 if {[info exists children($curview,$id)]} {
5146 foreach kid $children($curview,$id) {
5147 if {![commitinview $kid $curview]} break
5148 if {[rowofcommit $kid] < $row} {
5149 set ret [rowofcommit $kid]
5153 return $ret
5156 proc make_idlist {row} {
5157 global displayorder parentlist uparrowlen downarrowlen mingaplen
5158 global commitidx curview children
5160 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5161 if {$r < 0} {
5162 set r 0
5164 set ra [expr {$row - $downarrowlen}]
5165 if {$ra < 0} {
5166 set ra 0
5168 set rb [expr {$row + $uparrowlen}]
5169 if {$rb > $commitidx($curview)} {
5170 set rb $commitidx($curview)
5172 make_disporder $r [expr {$rb + 1}]
5173 set ids {}
5174 for {} {$r < $ra} {incr r} {
5175 set nextid [lindex $displayorder [expr {$r + 1}]]
5176 foreach p [lindex $parentlist $r] {
5177 if {$p eq $nextid} continue
5178 set rn [nextuse $p $r]
5179 if {$rn >= $row &&
5180 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5181 lappend ids [list [ordertoken $p] $p]
5185 for {} {$r < $row} {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 < 0 || $rn >= $row} {
5191 lappend ids [list [ordertoken $p] $p]
5195 set id [lindex $displayorder $row]
5196 lappend ids [list [ordertoken $id] $id]
5197 while {$r < $rb} {
5198 foreach p [lindex $parentlist $r] {
5199 set firstkid [lindex $children($curview,$p) 0]
5200 if {[rowofcommit $firstkid] < $row} {
5201 lappend ids [list [ordertoken $p] $p]
5204 incr r
5205 set id [lindex $displayorder $r]
5206 if {$id ne {}} {
5207 set firstkid [lindex $children($curview,$id) 0]
5208 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5209 lappend ids [list [ordertoken $id] $id]
5213 set idlist {}
5214 foreach idx [lsort -unique $ids] {
5215 lappend idlist [lindex $idx 1]
5217 return $idlist
5220 proc rowsequal {a b} {
5221 while {[set i [lsearch -exact $a {}]] >= 0} {
5222 set a [lreplace $a $i $i]
5224 while {[set i [lsearch -exact $b {}]] >= 0} {
5225 set b [lreplace $b $i $i]
5227 return [expr {$a eq $b}]
5230 proc makeupline {id row rend col} {
5231 global rowidlist uparrowlen downarrowlen mingaplen
5233 for {set r $rend} {1} {set r $rstart} {
5234 set rstart [prevuse $id $r]
5235 if {$rstart < 0} return
5236 if {$rstart < $row} break
5238 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5239 set rstart [expr {$rend - $uparrowlen - 1}]
5241 for {set r $rstart} {[incr r] <= $row} {} {
5242 set idlist [lindex $rowidlist $r]
5243 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5244 set col [idcol $idlist $id $col]
5245 lset rowidlist $r [linsert $idlist $col $id]
5246 changedrow $r
5251 proc layoutrows {row endrow} {
5252 global rowidlist rowisopt rowfinal displayorder
5253 global uparrowlen downarrowlen maxwidth mingaplen
5254 global children parentlist
5255 global commitidx viewcomplete curview
5257 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5258 set idlist {}
5259 if {$row > 0} {
5260 set rm1 [expr {$row - 1}]
5261 foreach id [lindex $rowidlist $rm1] {
5262 if {$id ne {}} {
5263 lappend idlist $id
5266 set final [lindex $rowfinal $rm1]
5268 for {} {$row < $endrow} {incr row} {
5269 set rm1 [expr {$row - 1}]
5270 if {$rm1 < 0 || $idlist eq {}} {
5271 set idlist [make_idlist $row]
5272 set final 1
5273 } else {
5274 set id [lindex $displayorder $rm1]
5275 set col [lsearch -exact $idlist $id]
5276 set idlist [lreplace $idlist $col $col]
5277 foreach p [lindex $parentlist $rm1] {
5278 if {[lsearch -exact $idlist $p] < 0} {
5279 set col [idcol $idlist $p $col]
5280 set idlist [linsert $idlist $col $p]
5281 # if not the first child, we have to insert a line going up
5282 if {$id ne [lindex $children($curview,$p) 0]} {
5283 makeupline $p $rm1 $row $col
5287 set id [lindex $displayorder $row]
5288 if {$row > $downarrowlen} {
5289 set termrow [expr {$row - $downarrowlen - 1}]
5290 foreach p [lindex $parentlist $termrow] {
5291 set i [lsearch -exact $idlist $p]
5292 if {$i < 0} continue
5293 set nr [nextuse $p $termrow]
5294 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5295 set idlist [lreplace $idlist $i $i]
5299 set col [lsearch -exact $idlist $id]
5300 if {$col < 0} {
5301 set col [idcol $idlist $id]
5302 set idlist [linsert $idlist $col $id]
5303 if {$children($curview,$id) ne {}} {
5304 makeupline $id $rm1 $row $col
5307 set r [expr {$row + $uparrowlen - 1}]
5308 if {$r < $commitidx($curview)} {
5309 set x $col
5310 foreach p [lindex $parentlist $r] {
5311 if {[lsearch -exact $idlist $p] >= 0} continue
5312 set fk [lindex $children($curview,$p) 0]
5313 if {[rowofcommit $fk] < $row} {
5314 set x [idcol $idlist $p $x]
5315 set idlist [linsert $idlist $x $p]
5318 if {[incr r] < $commitidx($curview)} {
5319 set p [lindex $displayorder $r]
5320 if {[lsearch -exact $idlist $p] < 0} {
5321 set fk [lindex $children($curview,$p) 0]
5322 if {$fk ne {} && [rowofcommit $fk] < $row} {
5323 set x [idcol $idlist $p $x]
5324 set idlist [linsert $idlist $x $p]
5330 if {$final && !$viewcomplete($curview) &&
5331 $row + $uparrowlen + $mingaplen + $downarrowlen
5332 >= $commitidx($curview)} {
5333 set final 0
5335 set l [llength $rowidlist]
5336 if {$row == $l} {
5337 lappend rowidlist $idlist
5338 lappend rowisopt 0
5339 lappend rowfinal $final
5340 } elseif {$row < $l} {
5341 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5342 lset rowidlist $row $idlist
5343 changedrow $row
5345 lset rowfinal $row $final
5346 } else {
5347 set pad [ntimes [expr {$row - $l}] {}]
5348 set rowidlist [concat $rowidlist $pad]
5349 lappend rowidlist $idlist
5350 set rowfinal [concat $rowfinal $pad]
5351 lappend rowfinal $final
5352 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5355 return $row
5358 proc changedrow {row} {
5359 global displayorder iddrawn rowisopt need_redisplay
5361 set l [llength $rowisopt]
5362 if {$row < $l} {
5363 lset rowisopt $row 0
5364 if {$row + 1 < $l} {
5365 lset rowisopt [expr {$row + 1}] 0
5366 if {$row + 2 < $l} {
5367 lset rowisopt [expr {$row + 2}] 0
5371 set id [lindex $displayorder $row]
5372 if {[info exists iddrawn($id)]} {
5373 set need_redisplay 1
5377 proc insert_pad {row col npad} {
5378 global rowidlist
5380 set pad [ntimes $npad {}]
5381 set idlist [lindex $rowidlist $row]
5382 set bef [lrange $idlist 0 [expr {$col - 1}]]
5383 set aft [lrange $idlist $col end]
5384 set i [lsearch -exact $aft {}]
5385 if {$i > 0} {
5386 set aft [lreplace $aft $i $i]
5388 lset rowidlist $row [concat $bef $pad $aft]
5389 changedrow $row
5392 proc optimize_rows {row col endrow} {
5393 global rowidlist rowisopt displayorder curview children
5395 if {$row < 1} {
5396 set row 1
5398 for {} {$row < $endrow} {incr row; set col 0} {
5399 if {[lindex $rowisopt $row]} continue
5400 set haspad 0
5401 set y0 [expr {$row - 1}]
5402 set ym [expr {$row - 2}]
5403 set idlist [lindex $rowidlist $row]
5404 set previdlist [lindex $rowidlist $y0]
5405 if {$idlist eq {} || $previdlist eq {}} continue
5406 if {$ym >= 0} {
5407 set pprevidlist [lindex $rowidlist $ym]
5408 if {$pprevidlist eq {}} continue
5409 } else {
5410 set pprevidlist {}
5412 set x0 -1
5413 set xm -1
5414 for {} {$col < [llength $idlist]} {incr col} {
5415 set id [lindex $idlist $col]
5416 if {[lindex $previdlist $col] eq $id} continue
5417 if {$id eq {}} {
5418 set haspad 1
5419 continue
5421 set x0 [lsearch -exact $previdlist $id]
5422 if {$x0 < 0} continue
5423 set z [expr {$x0 - $col}]
5424 set isarrow 0
5425 set z0 {}
5426 if {$ym >= 0} {
5427 set xm [lsearch -exact $pprevidlist $id]
5428 if {$xm >= 0} {
5429 set z0 [expr {$xm - $x0}]
5432 if {$z0 eq {}} {
5433 # if row y0 is the first child of $id then it's not an arrow
5434 if {[lindex $children($curview,$id) 0] ne
5435 [lindex $displayorder $y0]} {
5436 set isarrow 1
5439 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5440 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5441 set isarrow 1
5443 # Looking at lines from this row to the previous row,
5444 # make them go straight up if they end in an arrow on
5445 # the previous row; otherwise make them go straight up
5446 # or at 45 degrees.
5447 if {$z < -1 || ($z < 0 && $isarrow)} {
5448 # Line currently goes left too much;
5449 # insert pads in the previous row, then optimize it
5450 set npad [expr {-1 - $z + $isarrow}]
5451 insert_pad $y0 $x0 $npad
5452 if {$y0 > 0} {
5453 optimize_rows $y0 $x0 $row
5455 set previdlist [lindex $rowidlist $y0]
5456 set x0 [lsearch -exact $previdlist $id]
5457 set z [expr {$x0 - $col}]
5458 if {$z0 ne {}} {
5459 set pprevidlist [lindex $rowidlist $ym]
5460 set xm [lsearch -exact $pprevidlist $id]
5461 set z0 [expr {$xm - $x0}]
5463 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5464 # Line currently goes right too much;
5465 # insert pads in this line
5466 set npad [expr {$z - 1 + $isarrow}]
5467 insert_pad $row $col $npad
5468 set idlist [lindex $rowidlist $row]
5469 incr col $npad
5470 set z [expr {$x0 - $col}]
5471 set haspad 1
5473 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5474 # this line links to its first child on row $row-2
5475 set id [lindex $displayorder $ym]
5476 set xc [lsearch -exact $pprevidlist $id]
5477 if {$xc >= 0} {
5478 set z0 [expr {$xc - $x0}]
5481 # avoid lines jigging left then immediately right
5482 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5483 insert_pad $y0 $x0 1
5484 incr x0
5485 optimize_rows $y0 $x0 $row
5486 set previdlist [lindex $rowidlist $y0]
5489 if {!$haspad} {
5490 # Find the first column that doesn't have a line going right
5491 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5492 set id [lindex $idlist $col]
5493 if {$id eq {}} break
5494 set x0 [lsearch -exact $previdlist $id]
5495 if {$x0 < 0} {
5496 # check if this is the link to the first child
5497 set kid [lindex $displayorder $y0]
5498 if {[lindex $children($curview,$id) 0] eq $kid} {
5499 # it is, work out offset to child
5500 set x0 [lsearch -exact $previdlist $kid]
5503 if {$x0 <= $col} break
5505 # Insert a pad at that column as long as it has a line and
5506 # isn't the last column
5507 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5508 set idlist [linsert $idlist $col {}]
5509 lset rowidlist $row $idlist
5510 changedrow $row
5516 proc xc {row col} {
5517 global canvx0 linespc
5518 return [expr {$canvx0 + $col * $linespc}]
5521 proc yc {row} {
5522 global canvy0 linespc
5523 return [expr {$canvy0 + $row * $linespc}]
5526 proc linewidth {id} {
5527 global thickerline lthickness
5529 set wid $lthickness
5530 if {[info exists thickerline] && $id eq $thickerline} {
5531 set wid [expr {2 * $lthickness}]
5533 return $wid
5536 proc rowranges {id} {
5537 global curview children uparrowlen downarrowlen
5538 global rowidlist
5540 set kids $children($curview,$id)
5541 if {$kids eq {}} {
5542 return {}
5544 set ret {}
5545 lappend kids $id
5546 foreach child $kids {
5547 if {![commitinview $child $curview]} break
5548 set row [rowofcommit $child]
5549 if {![info exists prev]} {
5550 lappend ret [expr {$row + 1}]
5551 } else {
5552 if {$row <= $prevrow} {
5553 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5555 # see if the line extends the whole way from prevrow to row
5556 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5557 [lsearch -exact [lindex $rowidlist \
5558 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5559 # it doesn't, see where it ends
5560 set r [expr {$prevrow + $downarrowlen}]
5561 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5562 while {[incr r -1] > $prevrow &&
5563 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5564 } else {
5565 while {[incr r] <= $row &&
5566 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5567 incr r -1
5569 lappend ret $r
5570 # see where it starts up again
5571 set r [expr {$row - $uparrowlen}]
5572 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5573 while {[incr r] < $row &&
5574 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5575 } else {
5576 while {[incr r -1] >= $prevrow &&
5577 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5578 incr r
5580 lappend ret $r
5583 if {$child eq $id} {
5584 lappend ret $row
5586 set prev $child
5587 set prevrow $row
5589 return $ret
5592 proc drawlineseg {id row endrow arrowlow} {
5593 global rowidlist displayorder iddrawn linesegs
5594 global canv colormap linespc curview maxlinelen parentlist
5596 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5597 set le [expr {$row + 1}]
5598 set arrowhigh 1
5599 while {1} {
5600 set c [lsearch -exact [lindex $rowidlist $le] $id]
5601 if {$c < 0} {
5602 incr le -1
5603 break
5605 lappend cols $c
5606 set x [lindex $displayorder $le]
5607 if {$x eq $id} {
5608 set arrowhigh 0
5609 break
5611 if {[info exists iddrawn($x)] || $le == $endrow} {
5612 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5613 if {$c >= 0} {
5614 lappend cols $c
5615 set arrowhigh 0
5617 break
5619 incr le
5621 if {$le <= $row} {
5622 return $row
5625 set lines {}
5626 set i 0
5627 set joinhigh 0
5628 if {[info exists linesegs($id)]} {
5629 set lines $linesegs($id)
5630 foreach li $lines {
5631 set r0 [lindex $li 0]
5632 if {$r0 > $row} {
5633 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5634 set joinhigh 1
5636 break
5638 incr i
5641 set joinlow 0
5642 if {$i > 0} {
5643 set li [lindex $lines [expr {$i-1}]]
5644 set r1 [lindex $li 1]
5645 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5646 set joinlow 1
5650 set x [lindex $cols [expr {$le - $row}]]
5651 set xp [lindex $cols [expr {$le - 1 - $row}]]
5652 set dir [expr {$xp - $x}]
5653 if {$joinhigh} {
5654 set ith [lindex $lines $i 2]
5655 set coords [$canv coords $ith]
5656 set ah [$canv itemcget $ith -arrow]
5657 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5658 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5659 if {$x2 ne {} && $x - $x2 == $dir} {
5660 set coords [lrange $coords 0 end-2]
5662 } else {
5663 set coords [list [xc $le $x] [yc $le]]
5665 if {$joinlow} {
5666 set itl [lindex $lines [expr {$i-1}] 2]
5667 set al [$canv itemcget $itl -arrow]
5668 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5669 } elseif {$arrowlow} {
5670 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5671 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5672 set arrowlow 0
5675 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5676 for {set y $le} {[incr y -1] > $row} {} {
5677 set x $xp
5678 set xp [lindex $cols [expr {$y - 1 - $row}]]
5679 set ndir [expr {$xp - $x}]
5680 if {$dir != $ndir || $xp < 0} {
5681 lappend coords [xc $y $x] [yc $y]
5683 set dir $ndir
5685 if {!$joinlow} {
5686 if {$xp < 0} {
5687 # join parent line to first child
5688 set ch [lindex $displayorder $row]
5689 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5690 if {$xc < 0} {
5691 puts "oops: drawlineseg: child $ch not on row $row"
5692 } elseif {$xc != $x} {
5693 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5694 set d [expr {int(0.5 * $linespc)}]
5695 set x1 [xc $row $x]
5696 if {$xc < $x} {
5697 set x2 [expr {$x1 - $d}]
5698 } else {
5699 set x2 [expr {$x1 + $d}]
5701 set y2 [yc $row]
5702 set y1 [expr {$y2 + $d}]
5703 lappend coords $x1 $y1 $x2 $y2
5704 } elseif {$xc < $x - 1} {
5705 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5706 } elseif {$xc > $x + 1} {
5707 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5709 set x $xc
5711 lappend coords [xc $row $x] [yc $row]
5712 } else {
5713 set xn [xc $row $xp]
5714 set yn [yc $row]
5715 lappend coords $xn $yn
5717 if {!$joinhigh} {
5718 assigncolor $id
5719 set t [$canv create line $coords -width [linewidth $id] \
5720 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5721 $canv lower $t
5722 bindline $t $id
5723 set lines [linsert $lines $i [list $row $le $t]]
5724 } else {
5725 $canv coords $ith $coords
5726 if {$arrow ne $ah} {
5727 $canv itemconf $ith -arrow $arrow
5729 lset lines $i 0 $row
5731 } else {
5732 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5733 set ndir [expr {$xo - $xp}]
5734 set clow [$canv coords $itl]
5735 if {$dir == $ndir} {
5736 set clow [lrange $clow 2 end]
5738 set coords [concat $coords $clow]
5739 if {!$joinhigh} {
5740 lset lines [expr {$i-1}] 1 $le
5741 } else {
5742 # coalesce two pieces
5743 $canv delete $ith
5744 set b [lindex $lines [expr {$i-1}] 0]
5745 set e [lindex $lines $i 1]
5746 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5748 $canv coords $itl $coords
5749 if {$arrow ne $al} {
5750 $canv itemconf $itl -arrow $arrow
5754 set linesegs($id) $lines
5755 return $le
5758 proc drawparentlinks {id row} {
5759 global rowidlist canv colormap curview parentlist
5760 global idpos linespc
5762 set rowids [lindex $rowidlist $row]
5763 set col [lsearch -exact $rowids $id]
5764 if {$col < 0} return
5765 set olds [lindex $parentlist $row]
5766 set row2 [expr {$row + 1}]
5767 set x [xc $row $col]
5768 set y [yc $row]
5769 set y2 [yc $row2]
5770 set d [expr {int(0.5 * $linespc)}]
5771 set ymid [expr {$y + $d}]
5772 set ids [lindex $rowidlist $row2]
5773 # rmx = right-most X coord used
5774 set rmx 0
5775 foreach p $olds {
5776 set i [lsearch -exact $ids $p]
5777 if {$i < 0} {
5778 puts "oops, parent $p of $id not in list"
5779 continue
5781 set x2 [xc $row2 $i]
5782 if {$x2 > $rmx} {
5783 set rmx $x2
5785 set j [lsearch -exact $rowids $p]
5786 if {$j < 0} {
5787 # drawlineseg will do this one for us
5788 continue
5790 assigncolor $p
5791 # should handle duplicated parents here...
5792 set coords [list $x $y]
5793 if {$i != $col} {
5794 # if attaching to a vertical segment, draw a smaller
5795 # slant for visual distinctness
5796 if {$i == $j} {
5797 if {$i < $col} {
5798 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5799 } else {
5800 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5802 } elseif {$i < $col && $i < $j} {
5803 # segment slants towards us already
5804 lappend coords [xc $row $j] $y
5805 } else {
5806 if {$i < $col - 1} {
5807 lappend coords [expr {$x2 + $linespc}] $y
5808 } elseif {$i > $col + 1} {
5809 lappend coords [expr {$x2 - $linespc}] $y
5811 lappend coords $x2 $y2
5813 } else {
5814 lappend coords $x2 $y2
5816 set t [$canv create line $coords -width [linewidth $p] \
5817 -fill $colormap($p) -tags lines.$p]
5818 $canv lower $t
5819 bindline $t $p
5821 if {$rmx > [lindex $idpos($id) 1]} {
5822 lset idpos($id) 1 $rmx
5823 redrawtags $id
5827 proc drawlines {id} {
5828 global canv
5830 $canv itemconf lines.$id -width [linewidth $id]
5833 proc drawcmittext {id row col} {
5834 global linespc canv canv2 canv3 fgcolor curview
5835 global cmitlisted commitinfo rowidlist parentlist
5836 global rowtextx idpos idtags idheads idotherrefs
5837 global linehtag linentag linedtag selectedline
5838 global canvxmax boldids boldnameids fgcolor markedid
5839 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5841 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5842 set listed $cmitlisted($curview,$id)
5843 if {$id eq $nullid} {
5844 set ofill red
5845 } elseif {$id eq $nullid2} {
5846 set ofill green
5847 } elseif {$id eq $mainheadid} {
5848 set ofill yellow
5849 } else {
5850 set ofill [lindex $circlecolors $listed]
5852 set x [xc $row $col]
5853 set y [yc $row]
5854 set orad [expr {$linespc / 3}]
5855 if {$listed <= 2} {
5856 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5857 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5858 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5859 } elseif {$listed == 3} {
5860 # triangle pointing left for left-side commits
5861 set t [$canv create polygon \
5862 [expr {$x - $orad}] $y \
5863 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5864 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5865 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5866 } else {
5867 # triangle pointing right for right-side commits
5868 set t [$canv create polygon \
5869 [expr {$x + $orad - 1}] $y \
5870 [expr {$x - $orad}] [expr {$y - $orad}] \
5871 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5872 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5874 set circleitem($row) $t
5875 $canv raise $t
5876 $canv bind $t <1> {selcanvline {} %x %y}
5877 set rmx [llength [lindex $rowidlist $row]]
5878 set olds [lindex $parentlist $row]
5879 if {$olds ne {}} {
5880 set nextids [lindex $rowidlist [expr {$row + 1}]]
5881 foreach p $olds {
5882 set i [lsearch -exact $nextids $p]
5883 if {$i > $rmx} {
5884 set rmx $i
5888 set xt [xc $row $rmx]
5889 set rowtextx($row) $xt
5890 set idpos($id) [list $x $xt $y]
5891 if {[info exists idtags($id)] || [info exists idheads($id)]
5892 || [info exists idotherrefs($id)]} {
5893 set xt [drawtags $id $x $xt $y]
5895 if {[lindex $commitinfo($id) 6] > 0} {
5896 set xt [drawnotesign $xt $y]
5898 set headline [lindex $commitinfo($id) 0]
5899 set name [lindex $commitinfo($id) 1]
5900 set date [lindex $commitinfo($id) 2]
5901 set date [formatdate $date]
5902 set font mainfont
5903 set nfont mainfont
5904 set isbold [ishighlighted $id]
5905 if {$isbold > 0} {
5906 lappend boldids $id
5907 set font mainfontbold
5908 if {$isbold > 1} {
5909 lappend boldnameids $id
5910 set nfont mainfontbold
5913 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5914 -text $headline -font $font -tags text]
5915 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5916 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5917 -text $name -font $nfont -tags text]
5918 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5919 -text $date -font mainfont -tags text]
5920 if {$selectedline == $row} {
5921 make_secsel $id
5923 if {[info exists markedid] && $markedid eq $id} {
5924 make_idmark $id
5926 set xr [expr {$xt + [font measure $font $headline]}]
5927 if {$xr > $canvxmax} {
5928 set canvxmax $xr
5929 setcanvscroll
5933 proc drawcmitrow {row} {
5934 global displayorder rowidlist nrows_drawn
5935 global iddrawn markingmatches
5936 global commitinfo numcommits
5937 global filehighlight fhighlights findpattern nhighlights
5938 global hlview vhighlights
5939 global highlight_related rhighlights
5941 if {$row >= $numcommits} return
5943 set id [lindex $displayorder $row]
5944 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5945 askvhighlight $row $id
5947 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5948 askfilehighlight $row $id
5950 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5951 askfindhighlight $row $id
5953 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5954 askrelhighlight $row $id
5956 if {![info exists iddrawn($id)]} {
5957 set col [lsearch -exact [lindex $rowidlist $row] $id]
5958 if {$col < 0} {
5959 puts "oops, row $row id $id not in list"
5960 return
5962 if {![info exists commitinfo($id)]} {
5963 getcommit $id
5965 assigncolor $id
5966 drawcmittext $id $row $col
5967 set iddrawn($id) 1
5968 incr nrows_drawn
5970 if {$markingmatches} {
5971 markrowmatches $row $id
5975 proc drawcommits {row {endrow {}}} {
5976 global numcommits iddrawn displayorder curview need_redisplay
5977 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5979 if {$row < 0} {
5980 set row 0
5982 if {$endrow eq {}} {
5983 set endrow $row
5985 if {$endrow >= $numcommits} {
5986 set endrow [expr {$numcommits - 1}]
5989 set rl1 [expr {$row - $downarrowlen - 3}]
5990 if {$rl1 < 0} {
5991 set rl1 0
5993 set ro1 [expr {$row - 3}]
5994 if {$ro1 < 0} {
5995 set ro1 0
5997 set r2 [expr {$endrow + $uparrowlen + 3}]
5998 if {$r2 > $numcommits} {
5999 set r2 $numcommits
6001 for {set r $rl1} {$r < $r2} {incr r} {
6002 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6003 if {$rl1 < $r} {
6004 layoutrows $rl1 $r
6006 set rl1 [expr {$r + 1}]
6009 if {$rl1 < $r} {
6010 layoutrows $rl1 $r
6012 optimize_rows $ro1 0 $r2
6013 if {$need_redisplay || $nrows_drawn > 2000} {
6014 clear_display
6017 # make the lines join to already-drawn rows either side
6018 set r [expr {$row - 1}]
6019 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6020 set r $row
6022 set er [expr {$endrow + 1}]
6023 if {$er >= $numcommits ||
6024 ![info exists iddrawn([lindex $displayorder $er])]} {
6025 set er $endrow
6027 for {} {$r <= $er} {incr r} {
6028 set id [lindex $displayorder $r]
6029 set wasdrawn [info exists iddrawn($id)]
6030 drawcmitrow $r
6031 if {$r == $er} break
6032 set nextid [lindex $displayorder [expr {$r + 1}]]
6033 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6034 drawparentlinks $id $r
6036 set rowids [lindex $rowidlist $r]
6037 foreach lid $rowids {
6038 if {$lid eq {}} continue
6039 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6040 if {$lid eq $id} {
6041 # see if this is the first child of any of its parents
6042 foreach p [lindex $parentlist $r] {
6043 if {[lsearch -exact $rowids $p] < 0} {
6044 # make this line extend up to the child
6045 set lineend($p) [drawlineseg $p $r $er 0]
6048 } else {
6049 set lineend($lid) [drawlineseg $lid $r $er 1]
6055 proc undolayout {row} {
6056 global uparrowlen mingaplen downarrowlen
6057 global rowidlist rowisopt rowfinal need_redisplay
6059 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6060 if {$r < 0} {
6061 set r 0
6063 if {[llength $rowidlist] > $r} {
6064 incr r -1
6065 set rowidlist [lrange $rowidlist 0 $r]
6066 set rowfinal [lrange $rowfinal 0 $r]
6067 set rowisopt [lrange $rowisopt 0 $r]
6068 set need_redisplay 1
6069 run drawvisible
6073 proc drawvisible {} {
6074 global canv linespc curview vrowmod selectedline targetrow targetid
6075 global need_redisplay cscroll numcommits
6077 set fs [$canv yview]
6078 set ymax [lindex [$canv cget -scrollregion] 3]
6079 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6080 set f0 [lindex $fs 0]
6081 set f1 [lindex $fs 1]
6082 set y0 [expr {int($f0 * $ymax)}]
6083 set y1 [expr {int($f1 * $ymax)}]
6085 if {[info exists targetid]} {
6086 if {[commitinview $targetid $curview]} {
6087 set r [rowofcommit $targetid]
6088 if {$r != $targetrow} {
6089 # Fix up the scrollregion and change the scrolling position
6090 # now that our target row has moved.
6091 set diff [expr {($r - $targetrow) * $linespc}]
6092 set targetrow $r
6093 setcanvscroll
6094 set ymax [lindex [$canv cget -scrollregion] 3]
6095 incr y0 $diff
6096 incr y1 $diff
6097 set f0 [expr {$y0 / $ymax}]
6098 set f1 [expr {$y1 / $ymax}]
6099 allcanvs yview moveto $f0
6100 $cscroll set $f0 $f1
6101 set need_redisplay 1
6103 } else {
6104 unset targetid
6108 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6109 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6110 if {$endrow >= $vrowmod($curview)} {
6111 update_arcrows $curview
6113 if {$selectedline ne {} &&
6114 $row <= $selectedline && $selectedline <= $endrow} {
6115 set targetrow $selectedline
6116 } elseif {[info exists targetid]} {
6117 set targetrow [expr {int(($row + $endrow) / 2)}]
6119 if {[info exists targetrow]} {
6120 if {$targetrow >= $numcommits} {
6121 set targetrow [expr {$numcommits - 1}]
6123 set targetid [commitonrow $targetrow]
6125 drawcommits $row $endrow
6128 proc clear_display {} {
6129 global iddrawn linesegs need_redisplay nrows_drawn
6130 global vhighlights fhighlights nhighlights rhighlights
6131 global linehtag linentag linedtag boldids boldnameids
6133 allcanvs delete all
6134 catch {unset iddrawn}
6135 catch {unset linesegs}
6136 catch {unset linehtag}
6137 catch {unset linentag}
6138 catch {unset linedtag}
6139 set boldids {}
6140 set boldnameids {}
6141 catch {unset vhighlights}
6142 catch {unset fhighlights}
6143 catch {unset nhighlights}
6144 catch {unset rhighlights}
6145 set need_redisplay 0
6146 set nrows_drawn 0
6149 proc findcrossings {id} {
6150 global rowidlist parentlist numcommits displayorder
6152 set cross {}
6153 set ccross {}
6154 foreach {s e} [rowranges $id] {
6155 if {$e >= $numcommits} {
6156 set e [expr {$numcommits - 1}]
6158 if {$e <= $s} continue
6159 for {set row $e} {[incr row -1] >= $s} {} {
6160 set x [lsearch -exact [lindex $rowidlist $row] $id]
6161 if {$x < 0} break
6162 set olds [lindex $parentlist $row]
6163 set kid [lindex $displayorder $row]
6164 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6165 if {$kidx < 0} continue
6166 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6167 foreach p $olds {
6168 set px [lsearch -exact $nextrow $p]
6169 if {$px < 0} continue
6170 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6171 if {[lsearch -exact $ccross $p] >= 0} continue
6172 if {$x == $px + ($kidx < $px? -1: 1)} {
6173 lappend ccross $p
6174 } elseif {[lsearch -exact $cross $p] < 0} {
6175 lappend cross $p
6181 return [concat $ccross {{}} $cross]
6184 proc assigncolor {id} {
6185 global colormap colors nextcolor
6186 global parents children children curview
6188 if {[info exists colormap($id)]} return
6189 set ncolors [llength $colors]
6190 if {[info exists children($curview,$id)]} {
6191 set kids $children($curview,$id)
6192 } else {
6193 set kids {}
6195 if {[llength $kids] == 1} {
6196 set child [lindex $kids 0]
6197 if {[info exists colormap($child)]
6198 && [llength $parents($curview,$child)] == 1} {
6199 set colormap($id) $colormap($child)
6200 return
6203 set badcolors {}
6204 set origbad {}
6205 foreach x [findcrossings $id] {
6206 if {$x eq {}} {
6207 # delimiter between corner crossings and other crossings
6208 if {[llength $badcolors] >= $ncolors - 1} break
6209 set origbad $badcolors
6211 if {[info exists colormap($x)]
6212 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6213 lappend badcolors $colormap($x)
6216 if {[llength $badcolors] >= $ncolors} {
6217 set badcolors $origbad
6219 set origbad $badcolors
6220 if {[llength $badcolors] < $ncolors - 1} {
6221 foreach child $kids {
6222 if {[info exists colormap($child)]
6223 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6224 lappend badcolors $colormap($child)
6226 foreach p $parents($curview,$child) {
6227 if {[info exists colormap($p)]
6228 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6229 lappend badcolors $colormap($p)
6233 if {[llength $badcolors] >= $ncolors} {
6234 set badcolors $origbad
6237 for {set i 0} {$i <= $ncolors} {incr i} {
6238 set c [lindex $colors $nextcolor]
6239 if {[incr nextcolor] >= $ncolors} {
6240 set nextcolor 0
6242 if {[lsearch -exact $badcolors $c]} break
6244 set colormap($id) $c
6247 proc bindline {t id} {
6248 global canv
6250 $canv bind $t <Enter> "lineenter %x %y $id"
6251 $canv bind $t <Motion> "linemotion %x %y $id"
6252 $canv bind $t <Leave> "lineleave $id"
6253 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6256 proc drawtags {id x xt y1} {
6257 global idtags idheads idotherrefs mainhead
6258 global linespc lthickness
6259 global canv rowtextx curview fgcolor bgcolor ctxbut
6261 set marks {}
6262 set ntags 0
6263 set nheads 0
6264 if {[info exists idtags($id)]} {
6265 set marks $idtags($id)
6266 set ntags [llength $marks]
6268 if {[info exists idheads($id)]} {
6269 set marks [concat $marks $idheads($id)]
6270 set nheads [llength $idheads($id)]
6272 if {[info exists idotherrefs($id)]} {
6273 set marks [concat $marks $idotherrefs($id)]
6275 if {$marks eq {}} {
6276 return $xt
6279 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6280 set yt [expr {$y1 - 0.5 * $linespc}]
6281 set yb [expr {$yt + $linespc - 1}]
6282 set xvals {}
6283 set wvals {}
6284 set i -1
6285 foreach tag $marks {
6286 incr i
6287 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6288 set wid [font measure mainfontbold $tag]
6289 } else {
6290 set wid [font measure mainfont $tag]
6292 lappend xvals $xt
6293 lappend wvals $wid
6294 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6296 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6297 -width $lthickness -fill black -tags tag.$id]
6298 $canv lower $t
6299 foreach tag $marks x $xvals wid $wvals {
6300 set tag_quoted [string map {% %%} $tag]
6301 set xl [expr {$x + $delta}]
6302 set xr [expr {$x + $delta + $wid + $lthickness}]
6303 set font mainfont
6304 if {[incr ntags -1] >= 0} {
6305 # draw a tag
6306 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6307 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6308 -width 1 -outline black -fill yellow -tags tag.$id]
6309 $canv bind $t <1> [list showtag $tag_quoted 1]
6310 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6311 } else {
6312 # draw a head or other ref
6313 if {[incr nheads -1] >= 0} {
6314 set col green
6315 if {$tag eq $mainhead} {
6316 set font mainfontbold
6318 } else {
6319 set col "#ddddff"
6321 set xl [expr {$xl - $delta/2}]
6322 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6323 -width 1 -outline black -fill $col -tags tag.$id
6324 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6325 set rwid [font measure mainfont $remoteprefix]
6326 set xi [expr {$x + 1}]
6327 set yti [expr {$yt + 1}]
6328 set xri [expr {$x + $rwid}]
6329 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6330 -width 0 -fill "#ffddaa" -tags tag.$id
6333 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6334 -font $font -tags [list tag.$id text]]
6335 if {$ntags >= 0} {
6336 $canv bind $t <1> [list showtag $tag_quoted 1]
6337 } elseif {$nheads >= 0} {
6338 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6341 return $xt
6344 proc drawnotesign {xt y} {
6345 global linespc canv fgcolor
6347 set orad [expr {$linespc / 3}]
6348 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6349 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6350 -fill yellow -outline $fgcolor -width 1 -tags circle]
6351 set xt [expr {$xt + $orad * 3}]
6352 return $xt
6355 proc xcoord {i level ln} {
6356 global canvx0 xspc1 xspc2
6358 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6359 if {$i > 0 && $i == $level} {
6360 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6361 } elseif {$i > $level} {
6362 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6364 return $x
6367 proc show_status {msg} {
6368 global canv fgcolor
6370 clear_display
6371 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6372 -tags text -fill $fgcolor
6375 # Don't change the text pane cursor if it is currently the hand cursor,
6376 # showing that we are over a sha1 ID link.
6377 proc settextcursor {c} {
6378 global ctext curtextcursor
6380 if {[$ctext cget -cursor] == $curtextcursor} {
6381 $ctext config -cursor $c
6383 set curtextcursor $c
6386 proc nowbusy {what {name {}}} {
6387 global isbusy busyname statusw
6389 if {[array names isbusy] eq {}} {
6390 . config -cursor watch
6391 settextcursor watch
6393 set isbusy($what) 1
6394 set busyname($what) $name
6395 if {$name ne {}} {
6396 $statusw conf -text $name
6400 proc notbusy {what} {
6401 global isbusy maincursor textcursor busyname statusw
6403 catch {
6404 unset isbusy($what)
6405 if {$busyname($what) ne {} &&
6406 [$statusw cget -text] eq $busyname($what)} {
6407 $statusw conf -text {}
6410 if {[array names isbusy] eq {}} {
6411 . config -cursor $maincursor
6412 settextcursor $textcursor
6416 proc findmatches {f} {
6417 global findtype findstring
6418 if {$findtype == [mc "Regexp"]} {
6419 set matches [regexp -indices -all -inline $findstring $f]
6420 } else {
6421 set fs $findstring
6422 if {$findtype == [mc "IgnCase"]} {
6423 set f [string tolower $f]
6424 set fs [string tolower $fs]
6426 set matches {}
6427 set i 0
6428 set l [string length $fs]
6429 while {[set j [string first $fs $f $i]] >= 0} {
6430 lappend matches [list $j [expr {$j+$l-1}]]
6431 set i [expr {$j + $l}]
6434 return $matches
6437 proc dofind {{dirn 1} {wrap 1}} {
6438 global findstring findstartline findcurline selectedline numcommits
6439 global gdttype filehighlight fh_serial find_dirn findallowwrap
6441 if {[info exists find_dirn]} {
6442 if {$find_dirn == $dirn} return
6443 stopfinding
6445 focus .
6446 if {$findstring eq {} || $numcommits == 0} return
6447 if {$selectedline eq {}} {
6448 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6449 } else {
6450 set findstartline $selectedline
6452 set findcurline $findstartline
6453 nowbusy finding [mc "Searching"]
6454 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6455 after cancel do_file_hl $fh_serial
6456 do_file_hl $fh_serial
6458 set find_dirn $dirn
6459 set findallowwrap $wrap
6460 run findmore
6463 proc stopfinding {} {
6464 global find_dirn findcurline fprogcoord
6466 if {[info exists find_dirn]} {
6467 unset find_dirn
6468 unset findcurline
6469 notbusy finding
6470 set fprogcoord 0
6471 adjustprogress
6473 stopblaming
6476 proc findmore {} {
6477 global commitdata commitinfo numcommits findpattern findloc
6478 global findstartline findcurline findallowwrap
6479 global find_dirn gdttype fhighlights fprogcoord
6480 global curview varcorder vrownum varccommits vrowmod
6482 if {![info exists find_dirn]} {
6483 return 0
6485 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6486 set l $findcurline
6487 set moretodo 0
6488 if {$find_dirn > 0} {
6489 incr l
6490 if {$l >= $numcommits} {
6491 set l 0
6493 if {$l <= $findstartline} {
6494 set lim [expr {$findstartline + 1}]
6495 } else {
6496 set lim $numcommits
6497 set moretodo $findallowwrap
6499 } else {
6500 if {$l == 0} {
6501 set l $numcommits
6503 incr l -1
6504 if {$l >= $findstartline} {
6505 set lim [expr {$findstartline - 1}]
6506 } else {
6507 set lim -1
6508 set moretodo $findallowwrap
6511 set n [expr {($lim - $l) * $find_dirn}]
6512 if {$n > 500} {
6513 set n 500
6514 set moretodo 1
6516 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6517 update_arcrows $curview
6519 set found 0
6520 set domore 1
6521 set ai [bsearch $vrownum($curview) $l]
6522 set a [lindex $varcorder($curview) $ai]
6523 set arow [lindex $vrownum($curview) $ai]
6524 set ids [lindex $varccommits($curview,$a)]
6525 set arowend [expr {$arow + [llength $ids]}]
6526 if {$gdttype eq [mc "containing:"]} {
6527 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6528 if {$l < $arow || $l >= $arowend} {
6529 incr ai $find_dirn
6530 set a [lindex $varcorder($curview) $ai]
6531 set arow [lindex $vrownum($curview) $ai]
6532 set ids [lindex $varccommits($curview,$a)]
6533 set arowend [expr {$arow + [llength $ids]}]
6535 set id [lindex $ids [expr {$l - $arow}]]
6536 # shouldn't happen unless git log doesn't give all the commits...
6537 if {![info exists commitdata($id)] ||
6538 ![doesmatch $commitdata($id)]} {
6539 continue
6541 if {![info exists commitinfo($id)]} {
6542 getcommit $id
6544 set info $commitinfo($id)
6545 foreach f $info ty $fldtypes {
6546 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6547 [doesmatch $f]} {
6548 set found 1
6549 break
6552 if {$found} break
6554 } else {
6555 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6556 if {$l < $arow || $l >= $arowend} {
6557 incr ai $find_dirn
6558 set a [lindex $varcorder($curview) $ai]
6559 set arow [lindex $vrownum($curview) $ai]
6560 set ids [lindex $varccommits($curview,$a)]
6561 set arowend [expr {$arow + [llength $ids]}]
6563 set id [lindex $ids [expr {$l - $arow}]]
6564 if {![info exists fhighlights($id)]} {
6565 # this sets fhighlights($id) to -1
6566 askfilehighlight $l $id
6568 if {$fhighlights($id) > 0} {
6569 set found $domore
6570 break
6572 if {$fhighlights($id) < 0} {
6573 if {$domore} {
6574 set domore 0
6575 set findcurline [expr {$l - $find_dirn}]
6580 if {$found || ($domore && !$moretodo)} {
6581 unset findcurline
6582 unset find_dirn
6583 notbusy finding
6584 set fprogcoord 0
6585 adjustprogress
6586 if {$found} {
6587 findselectline $l
6588 } else {
6589 bell
6591 return 0
6593 if {!$domore} {
6594 flushhighlights
6595 } else {
6596 set findcurline [expr {$l - $find_dirn}]
6598 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6599 if {$n < 0} {
6600 incr n $numcommits
6602 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6603 adjustprogress
6604 return $domore
6607 proc findselectline {l} {
6608 global findloc commentend ctext findcurline markingmatches gdttype
6610 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6611 set findcurline $l
6612 selectline $l 1
6613 if {$markingmatches &&
6614 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6615 # highlight the matches in the comments
6616 set f [$ctext get 1.0 $commentend]
6617 set matches [findmatches $f]
6618 foreach match $matches {
6619 set start [lindex $match 0]
6620 set end [expr {[lindex $match 1] + 1}]
6621 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6624 drawvisible
6627 # mark the bits of a headline or author that match a find string
6628 proc markmatches {canv l str tag matches font row} {
6629 global selectedline
6631 set bbox [$canv bbox $tag]
6632 set x0 [lindex $bbox 0]
6633 set y0 [lindex $bbox 1]
6634 set y1 [lindex $bbox 3]
6635 foreach match $matches {
6636 set start [lindex $match 0]
6637 set end [lindex $match 1]
6638 if {$start > $end} continue
6639 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6640 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6641 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6642 [expr {$x0+$xlen+2}] $y1 \
6643 -outline {} -tags [list match$l matches] -fill yellow]
6644 $canv lower $t
6645 if {$row == $selectedline} {
6646 $canv raise $t secsel
6651 proc unmarkmatches {} {
6652 global markingmatches
6654 allcanvs delete matches
6655 set markingmatches 0
6656 stopfinding
6659 proc selcanvline {w x y} {
6660 global canv canvy0 ctext linespc
6661 global rowtextx
6662 set ymax [lindex [$canv cget -scrollregion] 3]
6663 if {$ymax == {}} return
6664 set yfrac [lindex [$canv yview] 0]
6665 set y [expr {$y + $yfrac * $ymax}]
6666 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6667 if {$l < 0} {
6668 set l 0
6670 if {$w eq $canv} {
6671 set xmax [lindex [$canv cget -scrollregion] 2]
6672 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6673 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6675 unmarkmatches
6676 selectline $l 1
6679 proc commit_descriptor {p} {
6680 global commitinfo
6681 if {![info exists commitinfo($p)]} {
6682 getcommit $p
6684 set l "..."
6685 if {[llength $commitinfo($p)] > 1} {
6686 set l [lindex $commitinfo($p) 0]
6688 return "$p ($l)\n"
6691 # append some text to the ctext widget, and make any SHA1 ID
6692 # that we know about be a clickable link.
6693 proc appendwithlinks {text tags} {
6694 global ctext linknum curview
6696 set start [$ctext index "end - 1c"]
6697 $ctext insert end $text $tags
6698 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6699 foreach l $links {
6700 set s [lindex $l 0]
6701 set e [lindex $l 1]
6702 set linkid [string range $text $s $e]
6703 incr e
6704 $ctext tag delete link$linknum
6705 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6706 setlink $linkid link$linknum
6707 incr linknum
6711 proc setlink {id lk} {
6712 global curview ctext pendinglinks
6714 set known 0
6715 if {[string length $id] < 40} {
6716 set matches [longid $id]
6717 if {[llength $matches] > 0} {
6718 if {[llength $matches] > 1} return
6719 set known 1
6720 set id [lindex $matches 0]
6722 } else {
6723 set known [commitinview $id $curview]
6725 if {$known} {
6726 $ctext tag conf $lk -foreground blue -underline 1
6727 $ctext tag bind $lk <1> [list selbyid $id]
6728 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6729 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6730 } else {
6731 lappend pendinglinks($id) $lk
6732 interestedin $id {makelink %P}
6736 proc appendshortlink {id {pre {}} {post {}}} {
6737 global ctext linknum
6739 $ctext insert end $pre
6740 $ctext tag delete link$linknum
6741 $ctext insert end [string range $id 0 7] link$linknum
6742 $ctext insert end $post
6743 setlink $id link$linknum
6744 incr linknum
6747 proc makelink {id} {
6748 global pendinglinks
6750 if {![info exists pendinglinks($id)]} return
6751 foreach lk $pendinglinks($id) {
6752 setlink $id $lk
6754 unset pendinglinks($id)
6757 proc linkcursor {w inc} {
6758 global linkentercount curtextcursor
6760 if {[incr linkentercount $inc] > 0} {
6761 $w configure -cursor hand2
6762 } else {
6763 $w configure -cursor $curtextcursor
6764 if {$linkentercount < 0} {
6765 set linkentercount 0
6770 proc viewnextline {dir} {
6771 global canv linespc
6773 $canv delete hover
6774 set ymax [lindex [$canv cget -scrollregion] 3]
6775 set wnow [$canv yview]
6776 set wtop [expr {[lindex $wnow 0] * $ymax}]
6777 set newtop [expr {$wtop + $dir * $linespc}]
6778 if {$newtop < 0} {
6779 set newtop 0
6780 } elseif {$newtop > $ymax} {
6781 set newtop $ymax
6783 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6786 # add a list of tag or branch names at position pos
6787 # returns the number of names inserted
6788 proc appendrefs {pos ids var} {
6789 global ctext linknum curview $var maxrefs
6791 if {[catch {$ctext index $pos}]} {
6792 return 0
6794 $ctext conf -state normal
6795 $ctext delete $pos "$pos lineend"
6796 set tags {}
6797 foreach id $ids {
6798 foreach tag [set $var\($id\)] {
6799 lappend tags [list $tag $id]
6802 if {[llength $tags] > $maxrefs} {
6803 $ctext insert $pos "[mc "many"] ([llength $tags])"
6804 } else {
6805 set tags [lsort -index 0 -decreasing $tags]
6806 set sep {}
6807 foreach ti $tags {
6808 set id [lindex $ti 1]
6809 set lk link$linknum
6810 incr linknum
6811 $ctext tag delete $lk
6812 $ctext insert $pos $sep
6813 $ctext insert $pos [lindex $ti 0] $lk
6814 setlink $id $lk
6815 set sep ", "
6818 $ctext conf -state disabled
6819 return [llength $tags]
6822 # called when we have finished computing the nearby tags
6823 proc dispneartags {delay} {
6824 global selectedline currentid showneartags tagphase
6826 if {$selectedline eq {} || !$showneartags} return
6827 after cancel dispnexttag
6828 if {$delay} {
6829 after 200 dispnexttag
6830 set tagphase -1
6831 } else {
6832 after idle dispnexttag
6833 set tagphase 0
6837 proc dispnexttag {} {
6838 global selectedline currentid showneartags tagphase ctext
6840 if {$selectedline eq {} || !$showneartags} return
6841 switch -- $tagphase {
6843 set dtags [desctags $currentid]
6844 if {$dtags ne {}} {
6845 appendrefs precedes $dtags idtags
6849 set atags [anctags $currentid]
6850 if {$atags ne {}} {
6851 appendrefs follows $atags idtags
6855 set dheads [descheads $currentid]
6856 if {$dheads ne {}} {
6857 if {[appendrefs branch $dheads idheads] > 1
6858 && [$ctext get "branch -3c"] eq "h"} {
6859 # turn "Branch" into "Branches"
6860 $ctext conf -state normal
6861 $ctext insert "branch -2c" "es"
6862 $ctext conf -state disabled
6867 if {[incr tagphase] <= 2} {
6868 after idle dispnexttag
6872 proc make_secsel {id} {
6873 global linehtag linentag linedtag canv canv2 canv3
6875 if {![info exists linehtag($id)]} return
6876 $canv delete secsel
6877 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6878 -tags secsel -fill [$canv cget -selectbackground]]
6879 $canv lower $t
6880 $canv2 delete secsel
6881 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6882 -tags secsel -fill [$canv2 cget -selectbackground]]
6883 $canv2 lower $t
6884 $canv3 delete secsel
6885 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6886 -tags secsel -fill [$canv3 cget -selectbackground]]
6887 $canv3 lower $t
6890 proc make_idmark {id} {
6891 global linehtag canv fgcolor
6893 if {![info exists linehtag($id)]} return
6894 $canv delete markid
6895 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6896 -tags markid -outline $fgcolor]
6897 $canv raise $t
6900 proc selectline {l isnew {desired_loc {}}} {
6901 global canv ctext commitinfo selectedline
6902 global canvy0 linespc parents children curview
6903 global currentid sha1entry
6904 global commentend idtags linknum
6905 global mergemax numcommits pending_select
6906 global cmitmode showneartags allcommits
6907 global targetrow targetid lastscrollrows
6908 global autoselect autosellen jump_to_here
6910 catch {unset pending_select}
6911 $canv delete hover
6912 normalline
6913 unsel_reflist
6914 stopfinding
6915 if {$l < 0 || $l >= $numcommits} return
6916 set id [commitonrow $l]
6917 set targetid $id
6918 set targetrow $l
6919 set selectedline $l
6920 set currentid $id
6921 if {$lastscrollrows < $numcommits} {
6922 setcanvscroll
6925 set y [expr {$canvy0 + $l * $linespc}]
6926 set ymax [lindex [$canv cget -scrollregion] 3]
6927 set ytop [expr {$y - $linespc - 1}]
6928 set ybot [expr {$y + $linespc + 1}]
6929 set wnow [$canv yview]
6930 set wtop [expr {[lindex $wnow 0] * $ymax}]
6931 set wbot [expr {[lindex $wnow 1] * $ymax}]
6932 set wh [expr {$wbot - $wtop}]
6933 set newtop $wtop
6934 if {$ytop < $wtop} {
6935 if {$ybot < $wtop} {
6936 set newtop [expr {$y - $wh / 2.0}]
6937 } else {
6938 set newtop $ytop
6939 if {$newtop > $wtop - $linespc} {
6940 set newtop [expr {$wtop - $linespc}]
6943 } elseif {$ybot > $wbot} {
6944 if {$ytop > $wbot} {
6945 set newtop [expr {$y - $wh / 2.0}]
6946 } else {
6947 set newtop [expr {$ybot - $wh}]
6948 if {$newtop < $wtop + $linespc} {
6949 set newtop [expr {$wtop + $linespc}]
6953 if {$newtop != $wtop} {
6954 if {$newtop < 0} {
6955 set newtop 0
6957 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6958 drawvisible
6961 make_secsel $id
6963 if {$isnew} {
6964 addtohistory [list selbyid $id 0] savecmitpos
6967 $sha1entry delete 0 end
6968 $sha1entry insert 0 $id
6969 if {$autoselect} {
6970 $sha1entry selection range 0 $autosellen
6972 rhighlight_sel $id
6974 $ctext conf -state normal
6975 clear_ctext
6976 set linknum 0
6977 if {![info exists commitinfo($id)]} {
6978 getcommit $id
6980 set info $commitinfo($id)
6981 set date [formatdate [lindex $info 2]]
6982 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6983 set date [formatdate [lindex $info 4]]
6984 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6985 if {[info exists idtags($id)]} {
6986 $ctext insert end [mc "Tags:"]
6987 foreach tag $idtags($id) {
6988 $ctext insert end " $tag"
6990 $ctext insert end "\n"
6993 set headers {}
6994 set olds $parents($curview,$id)
6995 if {[llength $olds] > 1} {
6996 set np 0
6997 foreach p $olds {
6998 if {$np >= $mergemax} {
6999 set tag mmax
7000 } else {
7001 set tag m$np
7003 $ctext insert end "[mc "Parent"]: " $tag
7004 appendwithlinks [commit_descriptor $p] {}
7005 incr np
7007 } else {
7008 foreach p $olds {
7009 append headers "[mc "Parent"]: [commit_descriptor $p]"
7013 foreach c $children($curview,$id) {
7014 append headers "[mc "Child"]: [commit_descriptor $c]"
7017 # make anything that looks like a SHA1 ID be a clickable link
7018 appendwithlinks $headers {}
7019 if {$showneartags} {
7020 if {![info exists allcommits]} {
7021 getallcommits
7023 $ctext insert end "[mc "Branch"]: "
7024 $ctext mark set branch "end -1c"
7025 $ctext mark gravity branch left
7026 $ctext insert end "\n[mc "Follows"]: "
7027 $ctext mark set follows "end -1c"
7028 $ctext mark gravity follows left
7029 $ctext insert end "\n[mc "Precedes"]: "
7030 $ctext mark set precedes "end -1c"
7031 $ctext mark gravity precedes left
7032 $ctext insert end "\n"
7033 dispneartags 1
7035 $ctext insert end "\n"
7036 set comment [lindex $info 5]
7037 if {[string first "\r" $comment] >= 0} {
7038 set comment [string map {"\r" "\n "} $comment]
7040 appendwithlinks $comment {comment}
7042 $ctext tag remove found 1.0 end
7043 $ctext conf -state disabled
7044 set commentend [$ctext index "end - 1c"]
7046 set jump_to_here $desired_loc
7047 init_flist [mc "Comments"]
7048 if {$cmitmode eq "tree"} {
7049 gettree $id
7050 } elseif {[llength $olds] <= 1} {
7051 startdiff $id
7052 } else {
7053 mergediff $id
7057 proc selfirstline {} {
7058 unmarkmatches
7059 selectline 0 1
7062 proc sellastline {} {
7063 global numcommits
7064 unmarkmatches
7065 set l [expr {$numcommits - 1}]
7066 selectline $l 1
7069 proc selnextline {dir} {
7070 global selectedline
7071 focus .
7072 if {$selectedline eq {}} return
7073 set l [expr {$selectedline + $dir}]
7074 unmarkmatches
7075 selectline $l 1
7078 proc selnextpage {dir} {
7079 global canv linespc selectedline numcommits
7081 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7082 if {$lpp < 1} {
7083 set lpp 1
7085 allcanvs yview scroll [expr {$dir * $lpp}] units
7086 drawvisible
7087 if {$selectedline eq {}} return
7088 set l [expr {$selectedline + $dir * $lpp}]
7089 if {$l < 0} {
7090 set l 0
7091 } elseif {$l >= $numcommits} {
7092 set l [expr $numcommits - 1]
7094 unmarkmatches
7095 selectline $l 1
7098 proc unselectline {} {
7099 global selectedline currentid
7101 set selectedline {}
7102 catch {unset currentid}
7103 allcanvs delete secsel
7104 rhighlight_none
7107 proc reselectline {} {
7108 global selectedline
7110 if {$selectedline ne {}} {
7111 selectline $selectedline 0
7115 proc addtohistory {cmd {saveproc {}}} {
7116 global history historyindex curview
7118 unset_posvars
7119 save_position
7120 set elt [list $curview $cmd $saveproc {}]
7121 if {$historyindex > 0
7122 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7123 return
7126 if {$historyindex < [llength $history]} {
7127 set history [lreplace $history $historyindex end $elt]
7128 } else {
7129 lappend history $elt
7131 incr historyindex
7132 if {$historyindex > 1} {
7133 .tf.bar.leftbut conf -state normal
7134 } else {
7135 .tf.bar.leftbut conf -state disabled
7137 .tf.bar.rightbut conf -state disabled
7140 # save the scrolling position of the diff display pane
7141 proc save_position {} {
7142 global historyindex history
7144 if {$historyindex < 1} return
7145 set hi [expr {$historyindex - 1}]
7146 set fn [lindex $history $hi 2]
7147 if {$fn ne {}} {
7148 lset history $hi 3 [eval $fn]
7152 proc unset_posvars {} {
7153 global last_posvars
7155 if {[info exists last_posvars]} {
7156 foreach {var val} $last_posvars {
7157 global $var
7158 catch {unset $var}
7160 unset last_posvars
7164 proc godo {elt} {
7165 global curview last_posvars
7167 set view [lindex $elt 0]
7168 set cmd [lindex $elt 1]
7169 set pv [lindex $elt 3]
7170 if {$curview != $view} {
7171 showview $view
7173 unset_posvars
7174 foreach {var val} $pv {
7175 global $var
7176 set $var $val
7178 set last_posvars $pv
7179 eval $cmd
7182 proc goback {} {
7183 global history historyindex
7184 focus .
7186 if {$historyindex > 1} {
7187 save_position
7188 incr historyindex -1
7189 godo [lindex $history [expr {$historyindex - 1}]]
7190 .tf.bar.rightbut conf -state normal
7192 if {$historyindex <= 1} {
7193 .tf.bar.leftbut conf -state disabled
7197 proc goforw {} {
7198 global history historyindex
7199 focus .
7201 if {$historyindex < [llength $history]} {
7202 save_position
7203 set cmd [lindex $history $historyindex]
7204 incr historyindex
7205 godo $cmd
7206 .tf.bar.leftbut conf -state normal
7208 if {$historyindex >= [llength $history]} {
7209 .tf.bar.rightbut conf -state disabled
7213 proc gettree {id} {
7214 global treefilelist treeidlist diffids diffmergeid treepending
7215 global nullid nullid2
7217 set diffids $id
7218 catch {unset diffmergeid}
7219 if {![info exists treefilelist($id)]} {
7220 if {![info exists treepending]} {
7221 if {$id eq $nullid} {
7222 set cmd [list | git ls-files]
7223 } elseif {$id eq $nullid2} {
7224 set cmd [list | git ls-files --stage -t]
7225 } else {
7226 set cmd [list | git ls-tree -r $id]
7228 if {[catch {set gtf [open $cmd r]}]} {
7229 return
7231 set treepending $id
7232 set treefilelist($id) {}
7233 set treeidlist($id) {}
7234 fconfigure $gtf -blocking 0 -encoding binary
7235 filerun $gtf [list gettreeline $gtf $id]
7237 } else {
7238 setfilelist $id
7242 proc gettreeline {gtf id} {
7243 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7245 set nl 0
7246 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7247 if {$diffids eq $nullid} {
7248 set fname $line
7249 } else {
7250 set i [string first "\t" $line]
7251 if {$i < 0} continue
7252 set fname [string range $line [expr {$i+1}] end]
7253 set line [string range $line 0 [expr {$i-1}]]
7254 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7255 set sha1 [lindex $line 2]
7256 lappend treeidlist($id) $sha1
7258 if {[string index $fname 0] eq "\""} {
7259 set fname [lindex $fname 0]
7261 set fname [encoding convertfrom $fname]
7262 lappend treefilelist($id) $fname
7264 if {![eof $gtf]} {
7265 return [expr {$nl >= 1000? 2: 1}]
7267 close $gtf
7268 unset treepending
7269 if {$cmitmode ne "tree"} {
7270 if {![info exists diffmergeid]} {
7271 gettreediffs $diffids
7273 } elseif {$id ne $diffids} {
7274 gettree $diffids
7275 } else {
7276 setfilelist $id
7278 return 0
7281 proc showfile {f} {
7282 global treefilelist treeidlist diffids nullid nullid2
7283 global ctext_file_names ctext_file_lines
7284 global ctext commentend
7286 set i [lsearch -exact $treefilelist($diffids) $f]
7287 if {$i < 0} {
7288 puts "oops, $f not in list for id $diffids"
7289 return
7291 if {$diffids eq $nullid} {
7292 if {[catch {set bf [open $f r]} err]} {
7293 puts "oops, can't read $f: $err"
7294 return
7296 } else {
7297 set blob [lindex $treeidlist($diffids) $i]
7298 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7299 puts "oops, error reading blob $blob: $err"
7300 return
7303 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7304 filerun $bf [list getblobline $bf $diffids]
7305 $ctext config -state normal
7306 clear_ctext $commentend
7307 lappend ctext_file_names $f
7308 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7309 $ctext insert end "\n"
7310 $ctext insert end "$f\n" filesep
7311 $ctext config -state disabled
7312 $ctext yview $commentend
7313 settabs 0
7316 proc getblobline {bf id} {
7317 global diffids cmitmode ctext
7319 if {$id ne $diffids || $cmitmode ne "tree"} {
7320 catch {close $bf}
7321 return 0
7323 $ctext config -state normal
7324 set nl 0
7325 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7326 $ctext insert end "$line\n"
7328 if {[eof $bf]} {
7329 global jump_to_here ctext_file_names commentend
7331 # delete last newline
7332 $ctext delete "end - 2c" "end - 1c"
7333 close $bf
7334 if {$jump_to_here ne {} &&
7335 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7336 set lnum [expr {[lindex $jump_to_here 1] +
7337 [lindex [split $commentend .] 0]}]
7338 mark_ctext_line $lnum
7340 $ctext config -state disabled
7341 return 0
7343 $ctext config -state disabled
7344 return [expr {$nl >= 1000? 2: 1}]
7347 proc mark_ctext_line {lnum} {
7348 global ctext markbgcolor
7350 $ctext tag delete omark
7351 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7352 $ctext tag conf omark -background $markbgcolor
7353 $ctext see $lnum.0
7356 proc mergediff {id} {
7357 global diffmergeid
7358 global diffids treediffs
7359 global parents curview
7361 set diffmergeid $id
7362 set diffids $id
7363 set treediffs($id) {}
7364 set np [llength $parents($curview,$id)]
7365 settabs $np
7366 getblobdiffs $id
7369 proc startdiff {ids} {
7370 global treediffs diffids treepending diffmergeid nullid nullid2
7372 settabs 1
7373 set diffids $ids
7374 catch {unset diffmergeid}
7375 if {![info exists treediffs($ids)] ||
7376 [lsearch -exact $ids $nullid] >= 0 ||
7377 [lsearch -exact $ids $nullid2] >= 0} {
7378 if {![info exists treepending]} {
7379 gettreediffs $ids
7381 } else {
7382 addtocflist $ids
7386 proc path_filter {filter name} {
7387 foreach p $filter {
7388 set l [string length $p]
7389 if {[string index $p end] eq "/"} {
7390 if {[string compare -length $l $p $name] == 0} {
7391 return 1
7393 } else {
7394 if {[string compare -length $l $p $name] == 0 &&
7395 ([string length $name] == $l ||
7396 [string index $name $l] eq "/")} {
7397 return 1
7401 return 0
7404 proc addtocflist {ids} {
7405 global treediffs
7407 add_flist $treediffs($ids)
7408 getblobdiffs $ids
7411 proc diffcmd {ids flags} {
7412 global nullid nullid2
7414 set i [lsearch -exact $ids $nullid]
7415 set j [lsearch -exact $ids $nullid2]
7416 if {$i >= 0} {
7417 if {[llength $ids] > 1 && $j < 0} {
7418 # comparing working directory with some specific revision
7419 set cmd [concat | git diff-index $flags]
7420 if {$i == 0} {
7421 lappend cmd -R [lindex $ids 1]
7422 } else {
7423 lappend cmd [lindex $ids 0]
7425 } else {
7426 # comparing working directory with index
7427 set cmd [concat | git diff-files $flags]
7428 if {$j == 1} {
7429 lappend cmd -R
7432 } elseif {$j >= 0} {
7433 set cmd [concat | git diff-index --cached $flags]
7434 if {[llength $ids] > 1} {
7435 # comparing index with specific revision
7436 if {$j == 0} {
7437 lappend cmd -R [lindex $ids 1]
7438 } else {
7439 lappend cmd [lindex $ids 0]
7441 } else {
7442 # comparing index with HEAD
7443 lappend cmd HEAD
7445 } else {
7446 set cmd [concat | git diff-tree -r $flags $ids]
7448 return $cmd
7451 proc gettreediffs {ids} {
7452 global treediff treepending
7454 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7456 set treepending $ids
7457 set treediff {}
7458 fconfigure $gdtf -blocking 0 -encoding binary
7459 filerun $gdtf [list gettreediffline $gdtf $ids]
7462 proc gettreediffline {gdtf ids} {
7463 global treediff treediffs treepending diffids diffmergeid
7464 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7466 set nr 0
7467 set sublist {}
7468 set max 1000
7469 if {$perfile_attrs} {
7470 # cache_gitattr is slow, and even slower on win32 where we
7471 # have to invoke it for only about 30 paths at a time
7472 set max 500
7473 if {[tk windowingsystem] == "win32"} {
7474 set max 120
7477 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7478 set i [string first "\t" $line]
7479 if {$i >= 0} {
7480 set file [string range $line [expr {$i+1}] end]
7481 if {[string index $file 0] eq "\""} {
7482 set file [lindex $file 0]
7484 set file [encoding convertfrom $file]
7485 if {$file ne [lindex $treediff end]} {
7486 lappend treediff $file
7487 lappend sublist $file
7491 if {$perfile_attrs} {
7492 cache_gitattr encoding $sublist
7494 if {![eof $gdtf]} {
7495 return [expr {$nr >= $max? 2: 1}]
7497 close $gdtf
7498 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7499 set flist {}
7500 foreach f $treediff {
7501 if {[path_filter $vfilelimit($curview) $f]} {
7502 lappend flist $f
7505 set treediffs($ids) $flist
7506 } else {
7507 set treediffs($ids) $treediff
7509 unset treepending
7510 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7511 gettree $diffids
7512 } elseif {$ids != $diffids} {
7513 if {![info exists diffmergeid]} {
7514 gettreediffs $diffids
7516 } else {
7517 addtocflist $ids
7519 return 0
7522 # empty string or positive integer
7523 proc diffcontextvalidate {v} {
7524 return [regexp {^(|[1-9][0-9]*)$} $v]
7527 proc diffcontextchange {n1 n2 op} {
7528 global diffcontextstring diffcontext
7530 if {[string is integer -strict $diffcontextstring]} {
7531 if {$diffcontextstring >= 0} {
7532 set diffcontext $diffcontextstring
7533 reselectline
7538 proc changeignorespace {} {
7539 reselectline
7542 proc changeworddiff {name ix op} {
7543 reselectline
7546 proc getblobdiffs {ids} {
7547 global blobdifffd diffids env
7548 global diffinhdr treediffs
7549 global diffcontext
7550 global ignorespace
7551 global worddiff
7552 global limitdiffs vfilelimit curview
7553 global diffencoding targetline diffnparents
7554 global git_version currdiffsubmod
7556 set textconv {}
7557 if {[package vcompare $git_version "1.6.1"] >= 0} {
7558 set textconv "--textconv"
7560 set submodule {}
7561 if {[package vcompare $git_version "1.6.6"] >= 0} {
7562 set submodule "--submodule"
7564 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7565 if {$ignorespace} {
7566 append cmd " -w"
7568 if {$worddiff ne [mc "Line diff"]} {
7569 append cmd " --word-diff=porcelain"
7571 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7572 set cmd [concat $cmd -- $vfilelimit($curview)]
7574 if {[catch {set bdf [open $cmd r]} err]} {
7575 error_popup [mc "Error getting diffs: %s" $err]
7576 return
7578 set targetline {}
7579 set diffnparents 0
7580 set diffinhdr 0
7581 set diffencoding [get_path_encoding {}]
7582 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7583 set blobdifffd($ids) $bdf
7584 set currdiffsubmod ""
7585 filerun $bdf [list getblobdiffline $bdf $diffids]
7588 proc savecmitpos {} {
7589 global ctext cmitmode
7591 if {$cmitmode eq "tree"} {
7592 return {}
7594 return [list target_scrollpos [$ctext index @0,0]]
7597 proc savectextpos {} {
7598 global ctext
7600 return [list target_scrollpos [$ctext index @0,0]]
7603 proc maybe_scroll_ctext {ateof} {
7604 global ctext target_scrollpos
7606 if {![info exists target_scrollpos]} return
7607 if {!$ateof} {
7608 set nlines [expr {[winfo height $ctext]
7609 / [font metrics textfont -linespace]}]
7610 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7612 $ctext yview $target_scrollpos
7613 unset target_scrollpos
7616 proc setinlist {var i val} {
7617 global $var
7619 while {[llength [set $var]] < $i} {
7620 lappend $var {}
7622 if {[llength [set $var]] == $i} {
7623 lappend $var $val
7624 } else {
7625 lset $var $i $val
7629 proc makediffhdr {fname ids} {
7630 global ctext curdiffstart treediffs diffencoding
7631 global ctext_file_names jump_to_here targetline diffline
7633 set fname [encoding convertfrom $fname]
7634 set diffencoding [get_path_encoding $fname]
7635 set i [lsearch -exact $treediffs($ids) $fname]
7636 if {$i >= 0} {
7637 setinlist difffilestart $i $curdiffstart
7639 lset ctext_file_names end $fname
7640 set l [expr {(78 - [string length $fname]) / 2}]
7641 set pad [string range "----------------------------------------" 1 $l]
7642 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7643 set targetline {}
7644 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7645 set targetline [lindex $jump_to_here 1]
7647 set diffline 0
7650 proc getblobdiffline {bdf ids} {
7651 global diffids blobdifffd ctext curdiffstart
7652 global diffnexthead diffnextnote difffilestart
7653 global ctext_file_names ctext_file_lines
7654 global diffinhdr treediffs mergemax diffnparents
7655 global diffencoding jump_to_here targetline diffline currdiffsubmod
7656 global worddiff
7658 set nr 0
7659 $ctext conf -state normal
7660 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7661 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7662 catch {close $bdf}
7663 return 0
7665 if {![string compare -length 5 "diff " $line]} {
7666 if {![regexp {^diff (--cc|--git) } $line m type]} {
7667 set line [encoding convertfrom $line]
7668 $ctext insert end "$line\n" hunksep
7669 continue
7671 # start of a new file
7672 set diffinhdr 1
7673 $ctext insert end "\n"
7674 set curdiffstart [$ctext index "end - 1c"]
7675 lappend ctext_file_names ""
7676 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7677 $ctext insert end "\n" filesep
7679 if {$type eq "--cc"} {
7680 # start of a new file in a merge diff
7681 set fname [string range $line 10 end]
7682 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7683 lappend treediffs($ids) $fname
7684 add_flist [list $fname]
7687 } else {
7688 set line [string range $line 11 end]
7689 # If the name hasn't changed the length will be odd,
7690 # the middle char will be a space, and the two bits either
7691 # side will be a/name and b/name, or "a/name" and "b/name".
7692 # If the name has changed we'll get "rename from" and
7693 # "rename to" or "copy from" and "copy to" lines following
7694 # this, and we'll use them to get the filenames.
7695 # This complexity is necessary because spaces in the
7696 # filename(s) don't get escaped.
7697 set l [string length $line]
7698 set i [expr {$l / 2}]
7699 if {!(($l & 1) && [string index $line $i] eq " " &&
7700 [string range $line 2 [expr {$i - 1}]] eq \
7701 [string range $line [expr {$i + 3}] end])} {
7702 continue
7704 # unescape if quoted and chop off the a/ from the front
7705 if {[string index $line 0] eq "\""} {
7706 set fname [string range [lindex $line 0] 2 end]
7707 } else {
7708 set fname [string range $line 2 [expr {$i - 1}]]
7711 makediffhdr $fname $ids
7713 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7714 set fname [encoding convertfrom [string range $line 16 end]]
7715 $ctext insert end "\n"
7716 set curdiffstart [$ctext index "end - 1c"]
7717 lappend ctext_file_names $fname
7718 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7719 $ctext insert end "$line\n" filesep
7720 set i [lsearch -exact $treediffs($ids) $fname]
7721 if {$i >= 0} {
7722 setinlist difffilestart $i $curdiffstart
7725 } elseif {![string compare -length 2 "@@" $line]} {
7726 regexp {^@@+} $line ats
7727 set line [encoding convertfrom $diffencoding $line]
7728 $ctext insert end "$line\n" hunksep
7729 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7730 set diffline $nl
7732 set diffnparents [expr {[string length $ats] - 1}]
7733 set diffinhdr 0
7735 } elseif {![string compare -length 10 "Submodule " $line]} {
7736 # start of a new submodule
7737 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
7738 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
7739 } else {
7740 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
7742 if {$currdiffsubmod != $fname} {
7743 $ctext insert end "\n"; # Add newline after commit message
7745 set curdiffstart [$ctext index "end - 1c"]
7746 lappend ctext_file_names ""
7747 if {$currdiffsubmod != $fname} {
7748 lappend ctext_file_lines $fname
7749 makediffhdr $fname $ids
7750 set currdiffsubmod $fname
7751 $ctext insert end "\n$line\n" filesep
7752 } else {
7753 $ctext insert end "$line\n" filesep
7755 } elseif {![string compare -length 3 " >" $line]} {
7756 set $currdiffsubmod ""
7757 set line [encoding convertfrom $diffencoding $line]
7758 $ctext insert end "$line\n" dresult
7759 } elseif {![string compare -length 3 " <" $line]} {
7760 set $currdiffsubmod ""
7761 set line [encoding convertfrom $diffencoding $line]
7762 $ctext insert end "$line\n" d0
7763 } elseif {$diffinhdr} {
7764 if {![string compare -length 12 "rename from " $line]} {
7765 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7766 if {[string index $fname 0] eq "\""} {
7767 set fname [lindex $fname 0]
7769 set fname [encoding convertfrom $fname]
7770 set i [lsearch -exact $treediffs($ids) $fname]
7771 if {$i >= 0} {
7772 setinlist difffilestart $i $curdiffstart
7774 } elseif {![string compare -length 10 $line "rename to "] ||
7775 ![string compare -length 8 $line "copy to "]} {
7776 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7777 if {[string index $fname 0] eq "\""} {
7778 set fname [lindex $fname 0]
7780 makediffhdr $fname $ids
7781 } elseif {[string compare -length 3 $line "---"] == 0} {
7782 # do nothing
7783 continue
7784 } elseif {[string compare -length 3 $line "+++"] == 0} {
7785 set diffinhdr 0
7786 continue
7788 $ctext insert end "$line\n" filesep
7790 } else {
7791 set line [string map {\x1A ^Z} \
7792 [encoding convertfrom $diffencoding $line]]
7793 # parse the prefix - one ' ', '-' or '+' for each parent
7794 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7795 set tag [expr {$diffnparents > 1? "m": "d"}]
7796 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
7797 set words_pre_markup ""
7798 set words_post_markup ""
7799 if {[string trim $prefix " -+"] eq {}} {
7800 # prefix only has " ", "-" and "+" in it: normal diff line
7801 set num [string first "-" $prefix]
7802 if {$dowords} {
7803 set line [string range $line 1 end]
7805 if {$num >= 0} {
7806 # removed line, first parent with line is $num
7807 if {$num >= $mergemax} {
7808 set num "max"
7810 if {$dowords && $worddiff eq [mc "Markup words"]} {
7811 $ctext insert end "\[-$line-\]" $tag$num
7812 } else {
7813 $ctext insert end "$line" $tag$num
7815 if {!$dowords} {
7816 $ctext insert end "\n" $tag$num
7818 } else {
7819 set tags {}
7820 if {[string first "+" $prefix] >= 0} {
7821 # added line
7822 lappend tags ${tag}result
7823 if {$diffnparents > 1} {
7824 set num [string first " " $prefix]
7825 if {$num >= 0} {
7826 if {$num >= $mergemax} {
7827 set num "max"
7829 lappend tags m$num
7832 set words_pre_markup "{+"
7833 set words_post_markup "+}"
7835 if {$targetline ne {}} {
7836 if {$diffline == $targetline} {
7837 set seehere [$ctext index "end - 1 chars"]
7838 set targetline {}
7839 } else {
7840 incr diffline
7843 if {$dowords && $worddiff eq [mc "Markup words"]} {
7844 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
7845 } else {
7846 $ctext insert end "$line" $tags
7848 if {!$dowords} {
7849 $ctext insert end "\n" $tags
7852 } elseif {$dowords && $prefix eq "~"} {
7853 $ctext insert end "\n" {}
7854 } else {
7855 # "\ No newline at end of file",
7856 # or something else we don't recognize
7857 $ctext insert end "$line\n" hunksep
7861 if {[info exists seehere]} {
7862 mark_ctext_line [lindex [split $seehere .] 0]
7864 maybe_scroll_ctext [eof $bdf]
7865 $ctext conf -state disabled
7866 if {[eof $bdf]} {
7867 catch {close $bdf}
7868 return 0
7870 return [expr {$nr >= 1000? 2: 1}]
7873 proc changediffdisp {} {
7874 global ctext diffelide
7876 $ctext tag conf d0 -elide [lindex $diffelide 0]
7877 $ctext tag conf dresult -elide [lindex $diffelide 1]
7880 proc highlightfile {loc cline} {
7881 global ctext cflist cflist_top
7883 $ctext yview $loc
7884 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7885 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7886 $cflist see $cline.0
7887 set cflist_top $cline
7890 proc prevfile {} {
7891 global difffilestart ctext cmitmode
7893 if {$cmitmode eq "tree"} return
7894 set prev 0.0
7895 set prevline 1
7896 set here [$ctext index @0,0]
7897 foreach loc $difffilestart {
7898 if {[$ctext compare $loc >= $here]} {
7899 highlightfile $prev $prevline
7900 return
7902 set prev $loc
7903 incr prevline
7905 highlightfile $prev $prevline
7908 proc nextfile {} {
7909 global difffilestart ctext cmitmode
7911 if {$cmitmode eq "tree"} return
7912 set here [$ctext index @0,0]
7913 set line 1
7914 foreach loc $difffilestart {
7915 incr line
7916 if {[$ctext compare $loc > $here]} {
7917 highlightfile $loc $line
7918 return
7923 proc clear_ctext {{first 1.0}} {
7924 global ctext smarktop smarkbot
7925 global ctext_file_names ctext_file_lines
7926 global pendinglinks
7928 set l [lindex [split $first .] 0]
7929 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7930 set smarktop $l
7932 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7933 set smarkbot $l
7935 $ctext delete $first end
7936 if {$first eq "1.0"} {
7937 catch {unset pendinglinks}
7939 set ctext_file_names {}
7940 set ctext_file_lines {}
7943 proc settabs {{firstab {}}} {
7944 global firsttabstop tabstop ctext have_tk85
7946 if {$firstab ne {} && $have_tk85} {
7947 set firsttabstop $firstab
7949 set w [font measure textfont "0"]
7950 if {$firsttabstop != 0} {
7951 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7952 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7953 } elseif {$have_tk85 || $tabstop != 8} {
7954 $ctext conf -tabs [expr {$tabstop * $w}]
7955 } else {
7956 $ctext conf -tabs {}
7960 proc incrsearch {name ix op} {
7961 global ctext searchstring searchdirn
7963 $ctext tag remove found 1.0 end
7964 if {[catch {$ctext index anchor}]} {
7965 # no anchor set, use start of selection, or of visible area
7966 set sel [$ctext tag ranges sel]
7967 if {$sel ne {}} {
7968 $ctext mark set anchor [lindex $sel 0]
7969 } elseif {$searchdirn eq "-forwards"} {
7970 $ctext mark set anchor @0,0
7971 } else {
7972 $ctext mark set anchor @0,[winfo height $ctext]
7975 if {$searchstring ne {}} {
7976 set here [$ctext search $searchdirn -- $searchstring anchor]
7977 if {$here ne {}} {
7978 $ctext see $here
7980 searchmarkvisible 1
7984 proc dosearch {} {
7985 global sstring ctext searchstring searchdirn
7987 focus $sstring
7988 $sstring icursor end
7989 set searchdirn -forwards
7990 if {$searchstring ne {}} {
7991 set sel [$ctext tag ranges sel]
7992 if {$sel ne {}} {
7993 set start "[lindex $sel 0] + 1c"
7994 } elseif {[catch {set start [$ctext index anchor]}]} {
7995 set start "@0,0"
7997 set match [$ctext search -count mlen -- $searchstring $start]
7998 $ctext tag remove sel 1.0 end
7999 if {$match eq {}} {
8000 bell
8001 return
8003 $ctext see $match
8004 set mend "$match + $mlen c"
8005 $ctext tag add sel $match $mend
8006 $ctext mark unset anchor
8010 proc dosearchback {} {
8011 global sstring ctext searchstring searchdirn
8013 focus $sstring
8014 $sstring icursor end
8015 set searchdirn -backwards
8016 if {$searchstring ne {}} {
8017 set sel [$ctext tag ranges sel]
8018 if {$sel ne {}} {
8019 set start [lindex $sel 0]
8020 } elseif {[catch {set start [$ctext index anchor]}]} {
8021 set start @0,[winfo height $ctext]
8023 set match [$ctext search -backwards -count ml -- $searchstring $start]
8024 $ctext tag remove sel 1.0 end
8025 if {$match eq {}} {
8026 bell
8027 return
8029 $ctext see $match
8030 set mend "$match + $ml c"
8031 $ctext tag add sel $match $mend
8032 $ctext mark unset anchor
8036 proc searchmark {first last} {
8037 global ctext searchstring
8039 set mend $first.0
8040 while {1} {
8041 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8042 if {$match eq {}} break
8043 set mend "$match + $mlen c"
8044 $ctext tag add found $match $mend
8048 proc searchmarkvisible {doall} {
8049 global ctext smarktop smarkbot
8051 set topline [lindex [split [$ctext index @0,0] .] 0]
8052 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8053 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8054 # no overlap with previous
8055 searchmark $topline $botline
8056 set smarktop $topline
8057 set smarkbot $botline
8058 } else {
8059 if {$topline < $smarktop} {
8060 searchmark $topline [expr {$smarktop-1}]
8061 set smarktop $topline
8063 if {$botline > $smarkbot} {
8064 searchmark [expr {$smarkbot+1}] $botline
8065 set smarkbot $botline
8070 proc scrolltext {f0 f1} {
8071 global searchstring
8073 .bleft.bottom.sb set $f0 $f1
8074 if {$searchstring ne {}} {
8075 searchmarkvisible 0
8079 proc setcoords {} {
8080 global linespc charspc canvx0 canvy0
8081 global xspc1 xspc2 lthickness
8083 set linespc [font metrics mainfont -linespace]
8084 set charspc [font measure mainfont "m"]
8085 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8086 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8087 set lthickness [expr {int($linespc / 9) + 1}]
8088 set xspc1(0) $linespc
8089 set xspc2 $linespc
8092 proc redisplay {} {
8093 global canv
8094 global selectedline
8096 set ymax [lindex [$canv cget -scrollregion] 3]
8097 if {$ymax eq {} || $ymax == 0} return
8098 set span [$canv yview]
8099 clear_display
8100 setcanvscroll
8101 allcanvs yview moveto [lindex $span 0]
8102 drawvisible
8103 if {$selectedline ne {}} {
8104 selectline $selectedline 0
8105 allcanvs yview moveto [lindex $span 0]
8109 proc parsefont {f n} {
8110 global fontattr
8112 set fontattr($f,family) [lindex $n 0]
8113 set s [lindex $n 1]
8114 if {$s eq {} || $s == 0} {
8115 set s 10
8116 } elseif {$s < 0} {
8117 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8119 set fontattr($f,size) $s
8120 set fontattr($f,weight) normal
8121 set fontattr($f,slant) roman
8122 foreach style [lrange $n 2 end] {
8123 switch -- $style {
8124 "normal" -
8125 "bold" {set fontattr($f,weight) $style}
8126 "roman" -
8127 "italic" {set fontattr($f,slant) $style}
8132 proc fontflags {f {isbold 0}} {
8133 global fontattr
8135 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8136 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8137 -slant $fontattr($f,slant)]
8140 proc fontname {f} {
8141 global fontattr
8143 set n [list $fontattr($f,family) $fontattr($f,size)]
8144 if {$fontattr($f,weight) eq "bold"} {
8145 lappend n "bold"
8147 if {$fontattr($f,slant) eq "italic"} {
8148 lappend n "italic"
8150 return $n
8153 proc incrfont {inc} {
8154 global mainfont textfont ctext canv cflist showrefstop
8155 global stopped entries fontattr
8157 unmarkmatches
8158 set s $fontattr(mainfont,size)
8159 incr s $inc
8160 if {$s < 1} {
8161 set s 1
8163 set fontattr(mainfont,size) $s
8164 font config mainfont -size $s
8165 font config mainfontbold -size $s
8166 set mainfont [fontname mainfont]
8167 set s $fontattr(textfont,size)
8168 incr s $inc
8169 if {$s < 1} {
8170 set s 1
8172 set fontattr(textfont,size) $s
8173 font config textfont -size $s
8174 font config textfontbold -size $s
8175 set textfont [fontname textfont]
8176 setcoords
8177 settabs
8178 redisplay
8181 proc clearsha1 {} {
8182 global sha1entry sha1string
8183 if {[string length $sha1string] == 40} {
8184 $sha1entry delete 0 end
8188 proc sha1change {n1 n2 op} {
8189 global sha1string currentid sha1but
8190 if {$sha1string == {}
8191 || ([info exists currentid] && $sha1string == $currentid)} {
8192 set state disabled
8193 } else {
8194 set state normal
8196 if {[$sha1but cget -state] == $state} return
8197 if {$state == "normal"} {
8198 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8199 } else {
8200 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8204 proc gotocommit {} {
8205 global sha1string tagids headids curview varcid
8207 if {$sha1string == {}
8208 || ([info exists currentid] && $sha1string == $currentid)} return
8209 if {[info exists tagids($sha1string)]} {
8210 set id $tagids($sha1string)
8211 } elseif {[info exists headids($sha1string)]} {
8212 set id $headids($sha1string)
8213 } else {
8214 set id [string tolower $sha1string]
8215 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8216 set matches [longid $id]
8217 if {$matches ne {}} {
8218 if {[llength $matches] > 1} {
8219 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8220 return
8222 set id [lindex $matches 0]
8224 } else {
8225 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8226 error_popup [mc "Revision %s is not known" $sha1string]
8227 return
8231 if {[commitinview $id $curview]} {
8232 selectline [rowofcommit $id] 1
8233 return
8235 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8236 set msg [mc "SHA1 id %s is not known" $sha1string]
8237 } else {
8238 set msg [mc "Revision %s is not in the current view" $sha1string]
8240 error_popup $msg
8243 proc lineenter {x y id} {
8244 global hoverx hovery hoverid hovertimer
8245 global commitinfo canv
8247 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8248 set hoverx $x
8249 set hovery $y
8250 set hoverid $id
8251 if {[info exists hovertimer]} {
8252 after cancel $hovertimer
8254 set hovertimer [after 500 linehover]
8255 $canv delete hover
8258 proc linemotion {x y id} {
8259 global hoverx hovery hoverid hovertimer
8261 if {[info exists hoverid] && $id == $hoverid} {
8262 set hoverx $x
8263 set hovery $y
8264 if {[info exists hovertimer]} {
8265 after cancel $hovertimer
8267 set hovertimer [after 500 linehover]
8271 proc lineleave {id} {
8272 global hoverid hovertimer canv
8274 if {[info exists hoverid] && $id == $hoverid} {
8275 $canv delete hover
8276 if {[info exists hovertimer]} {
8277 after cancel $hovertimer
8278 unset hovertimer
8280 unset hoverid
8284 proc linehover {} {
8285 global hoverx hovery hoverid hovertimer
8286 global canv linespc lthickness
8287 global commitinfo
8289 set text [lindex $commitinfo($hoverid) 0]
8290 set ymax [lindex [$canv cget -scrollregion] 3]
8291 if {$ymax == {}} return
8292 set yfrac [lindex [$canv yview] 0]
8293 set x [expr {$hoverx + 2 * $linespc}]
8294 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8295 set x0 [expr {$x - 2 * $lthickness}]
8296 set y0 [expr {$y - 2 * $lthickness}]
8297 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8298 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8299 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8300 -fill \#ffff80 -outline black -width 1 -tags hover]
8301 $canv raise $t
8302 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8303 -font mainfont]
8304 $canv raise $t
8307 proc clickisonarrow {id y} {
8308 global lthickness
8310 set ranges [rowranges $id]
8311 set thresh [expr {2 * $lthickness + 6}]
8312 set n [expr {[llength $ranges] - 1}]
8313 for {set i 1} {$i < $n} {incr i} {
8314 set row [lindex $ranges $i]
8315 if {abs([yc $row] - $y) < $thresh} {
8316 return $i
8319 return {}
8322 proc arrowjump {id n y} {
8323 global canv
8325 # 1 <-> 2, 3 <-> 4, etc...
8326 set n [expr {(($n - 1) ^ 1) + 1}]
8327 set row [lindex [rowranges $id] $n]
8328 set yt [yc $row]
8329 set ymax [lindex [$canv cget -scrollregion] 3]
8330 if {$ymax eq {} || $ymax <= 0} return
8331 set view [$canv yview]
8332 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8333 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8334 if {$yfrac < 0} {
8335 set yfrac 0
8337 allcanvs yview moveto $yfrac
8340 proc lineclick {x y id isnew} {
8341 global ctext commitinfo children canv thickerline curview
8343 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8344 unmarkmatches
8345 unselectline
8346 normalline
8347 $canv delete hover
8348 # draw this line thicker than normal
8349 set thickerline $id
8350 drawlines $id
8351 if {$isnew} {
8352 set ymax [lindex [$canv cget -scrollregion] 3]
8353 if {$ymax eq {}} return
8354 set yfrac [lindex [$canv yview] 0]
8355 set y [expr {$y + $yfrac * $ymax}]
8357 set dirn [clickisonarrow $id $y]
8358 if {$dirn ne {}} {
8359 arrowjump $id $dirn $y
8360 return
8363 if {$isnew} {
8364 addtohistory [list lineclick $x $y $id 0] savectextpos
8366 # fill the details pane with info about this line
8367 $ctext conf -state normal
8368 clear_ctext
8369 settabs 0
8370 $ctext insert end "[mc "Parent"]:\t"
8371 $ctext insert end $id link0
8372 setlink $id link0
8373 set info $commitinfo($id)
8374 $ctext insert end "\n\t[lindex $info 0]\n"
8375 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8376 set date [formatdate [lindex $info 2]]
8377 $ctext insert end "\t[mc "Date"]:\t$date\n"
8378 set kids $children($curview,$id)
8379 if {$kids ne {}} {
8380 $ctext insert end "\n[mc "Children"]:"
8381 set i 0
8382 foreach child $kids {
8383 incr i
8384 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8385 set info $commitinfo($child)
8386 $ctext insert end "\n\t"
8387 $ctext insert end $child link$i
8388 setlink $child link$i
8389 $ctext insert end "\n\t[lindex $info 0]"
8390 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8391 set date [formatdate [lindex $info 2]]
8392 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8395 maybe_scroll_ctext 1
8396 $ctext conf -state disabled
8397 init_flist {}
8400 proc normalline {} {
8401 global thickerline
8402 if {[info exists thickerline]} {
8403 set id $thickerline
8404 unset thickerline
8405 drawlines $id
8409 proc selbyid {id {isnew 1}} {
8410 global curview
8411 if {[commitinview $id $curview]} {
8412 selectline [rowofcommit $id] $isnew
8416 proc mstime {} {
8417 global startmstime
8418 if {![info exists startmstime]} {
8419 set startmstime [clock clicks -milliseconds]
8421 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8424 proc rowmenu {x y id} {
8425 global rowctxmenu selectedline rowmenuid curview
8426 global nullid nullid2 fakerowmenu mainhead markedid
8428 stopfinding
8429 set rowmenuid $id
8430 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8431 set state disabled
8432 } else {
8433 set state normal
8435 if {$id ne $nullid && $id ne $nullid2} {
8436 set menu $rowctxmenu
8437 if {$mainhead ne {}} {
8438 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8439 } else {
8440 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8442 if {[info exists markedid] && $markedid ne $id} {
8443 $menu entryconfigure 9 -state normal
8444 $menu entryconfigure 10 -state normal
8445 $menu entryconfigure 11 -state normal
8446 } else {
8447 $menu entryconfigure 9 -state disabled
8448 $menu entryconfigure 10 -state disabled
8449 $menu entryconfigure 11 -state disabled
8451 } else {
8452 set menu $fakerowmenu
8454 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8455 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8456 $menu entryconfigure [mca "Make patch"] -state $state
8457 tk_popup $menu $x $y
8460 proc markhere {} {
8461 global rowmenuid markedid canv
8463 set markedid $rowmenuid
8464 make_idmark $markedid
8467 proc gotomark {} {
8468 global markedid
8470 if {[info exists markedid]} {
8471 selbyid $markedid
8475 proc replace_by_kids {l r} {
8476 global curview children
8478 set id [commitonrow $r]
8479 set l [lreplace $l 0 0]
8480 foreach kid $children($curview,$id) {
8481 lappend l [rowofcommit $kid]
8483 return [lsort -integer -decreasing -unique $l]
8486 proc find_common_desc {} {
8487 global markedid rowmenuid curview children
8489 if {![info exists markedid]} return
8490 if {![commitinview $markedid $curview] ||
8491 ![commitinview $rowmenuid $curview]} return
8492 #set t1 [clock clicks -milliseconds]
8493 set l1 [list [rowofcommit $markedid]]
8494 set l2 [list [rowofcommit $rowmenuid]]
8495 while 1 {
8496 set r1 [lindex $l1 0]
8497 set r2 [lindex $l2 0]
8498 if {$r1 eq {} || $r2 eq {}} break
8499 if {$r1 == $r2} {
8500 selectline $r1 1
8501 break
8503 if {$r1 > $r2} {
8504 set l1 [replace_by_kids $l1 $r1]
8505 } else {
8506 set l2 [replace_by_kids $l2 $r2]
8509 #set t2 [clock clicks -milliseconds]
8510 #puts "took [expr {$t2-$t1}]ms"
8513 proc compare_commits {} {
8514 global markedid rowmenuid curview children
8516 if {![info exists markedid]} return
8517 if {![commitinview $markedid $curview]} return
8518 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8519 do_cmp_commits $markedid $rowmenuid
8522 proc getpatchid {id} {
8523 global patchids
8525 if {![info exists patchids($id)]} {
8526 set cmd [diffcmd [list $id] {-p --root}]
8527 # trim off the initial "|"
8528 set cmd [lrange $cmd 1 end]
8529 if {[catch {
8530 set x [eval exec $cmd | git patch-id]
8531 set patchids($id) [lindex $x 0]
8532 }]} {
8533 set patchids($id) "error"
8536 return $patchids($id)
8539 proc do_cmp_commits {a b} {
8540 global ctext curview parents children patchids commitinfo
8542 $ctext conf -state normal
8543 clear_ctext
8544 init_flist {}
8545 for {set i 0} {$i < 100} {incr i} {
8546 set skipa 0
8547 set skipb 0
8548 if {[llength $parents($curview,$a)] > 1} {
8549 appendshortlink $a [mc "Skipping merge commit "] "\n"
8550 set skipa 1
8551 } else {
8552 set patcha [getpatchid $a]
8554 if {[llength $parents($curview,$b)] > 1} {
8555 appendshortlink $b [mc "Skipping merge commit "] "\n"
8556 set skipb 1
8557 } else {
8558 set patchb [getpatchid $b]
8560 if {!$skipa && !$skipb} {
8561 set heada [lindex $commitinfo($a) 0]
8562 set headb [lindex $commitinfo($b) 0]
8563 if {$patcha eq "error"} {
8564 appendshortlink $a [mc "Error getting patch ID for "] \
8565 [mc " - stopping\n"]
8566 break
8568 if {$patchb eq "error"} {
8569 appendshortlink $b [mc "Error getting patch ID for "] \
8570 [mc " - stopping\n"]
8571 break
8573 if {$patcha eq $patchb} {
8574 if {$heada eq $headb} {
8575 appendshortlink $a [mc "Commit "]
8576 appendshortlink $b " == " " $heada\n"
8577 } else {
8578 appendshortlink $a [mc "Commit "] " $heada\n"
8579 appendshortlink $b [mc " is the same patch as\n "] \
8580 " $headb\n"
8582 set skipa 1
8583 set skipb 1
8584 } else {
8585 $ctext insert end "\n"
8586 appendshortlink $a [mc "Commit "] " $heada\n"
8587 appendshortlink $b [mc " differs from\n "] \
8588 " $headb\n"
8589 $ctext insert end [mc "Diff of commits:\n\n"]
8590 $ctext conf -state disabled
8591 update
8592 diffcommits $a $b
8593 return
8596 if {$skipa} {
8597 set kids [real_children $curview,$a]
8598 if {[llength $kids] != 1} {
8599 $ctext insert end "\n"
8600 appendshortlink $a [mc "Commit "] \
8601 [mc " has %s children - stopping\n" [llength $kids]]
8602 break
8604 set a [lindex $kids 0]
8606 if {$skipb} {
8607 set kids [real_children $curview,$b]
8608 if {[llength $kids] != 1} {
8609 appendshortlink $b [mc "Commit "] \
8610 [mc " has %s children - stopping\n" [llength $kids]]
8611 break
8613 set b [lindex $kids 0]
8616 $ctext conf -state disabled
8619 proc diffcommits {a b} {
8620 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
8622 set tmpdir [gitknewtmpdir]
8623 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8624 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8625 if {[catch {
8626 exec git diff-tree -p --pretty $a >$fna
8627 exec git diff-tree -p --pretty $b >$fnb
8628 } err]} {
8629 error_popup [mc "Error writing commit to file: %s" $err]
8630 return
8632 if {[catch {
8633 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8634 } err]} {
8635 error_popup [mc "Error diffing commits: %s" $err]
8636 return
8638 set diffids [list commits $a $b]
8639 set blobdifffd($diffids) $fd
8640 set diffinhdr 0
8641 set currdiffsubmod ""
8642 filerun $fd [list getblobdiffline $fd $diffids]
8645 proc diffvssel {dirn} {
8646 global rowmenuid selectedline
8648 if {$selectedline eq {}} return
8649 if {$dirn} {
8650 set oldid [commitonrow $selectedline]
8651 set newid $rowmenuid
8652 } else {
8653 set oldid $rowmenuid
8654 set newid [commitonrow $selectedline]
8656 addtohistory [list doseldiff $oldid $newid] savectextpos
8657 doseldiff $oldid $newid
8660 proc doseldiff {oldid newid} {
8661 global ctext
8662 global commitinfo
8664 $ctext conf -state normal
8665 clear_ctext
8666 init_flist [mc "Top"]
8667 $ctext insert end "[mc "From"] "
8668 $ctext insert end $oldid link0
8669 setlink $oldid link0
8670 $ctext insert end "\n "
8671 $ctext insert end [lindex $commitinfo($oldid) 0]
8672 $ctext insert end "\n\n[mc "To"] "
8673 $ctext insert end $newid link1
8674 setlink $newid link1
8675 $ctext insert end "\n "
8676 $ctext insert end [lindex $commitinfo($newid) 0]
8677 $ctext insert end "\n"
8678 $ctext conf -state disabled
8679 $ctext tag remove found 1.0 end
8680 startdiff [list $oldid $newid]
8683 proc mkpatch {} {
8684 global rowmenuid currentid commitinfo patchtop patchnum NS
8686 if {![info exists currentid]} return
8687 set oldid $currentid
8688 set oldhead [lindex $commitinfo($oldid) 0]
8689 set newid $rowmenuid
8690 set newhead [lindex $commitinfo($newid) 0]
8691 set top .patch
8692 set patchtop $top
8693 catch {destroy $top}
8694 ttk_toplevel $top
8695 make_transient $top .
8696 ${NS}::label $top.title -text [mc "Generate patch"]
8697 grid $top.title - -pady 10
8698 ${NS}::label $top.from -text [mc "From:"]
8699 ${NS}::entry $top.fromsha1 -width 40
8700 $top.fromsha1 insert 0 $oldid
8701 $top.fromsha1 conf -state readonly
8702 grid $top.from $top.fromsha1 -sticky w
8703 ${NS}::entry $top.fromhead -width 60
8704 $top.fromhead insert 0 $oldhead
8705 $top.fromhead conf -state readonly
8706 grid x $top.fromhead -sticky w
8707 ${NS}::label $top.to -text [mc "To:"]
8708 ${NS}::entry $top.tosha1 -width 40
8709 $top.tosha1 insert 0 $newid
8710 $top.tosha1 conf -state readonly
8711 grid $top.to $top.tosha1 -sticky w
8712 ${NS}::entry $top.tohead -width 60
8713 $top.tohead insert 0 $newhead
8714 $top.tohead conf -state readonly
8715 grid x $top.tohead -sticky w
8716 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8717 grid $top.rev x -pady 10 -padx 5
8718 ${NS}::label $top.flab -text [mc "Output file:"]
8719 ${NS}::entry $top.fname -width 60
8720 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8721 incr patchnum
8722 grid $top.flab $top.fname -sticky w
8723 ${NS}::frame $top.buts
8724 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8725 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8726 bind $top <Key-Return> mkpatchgo
8727 bind $top <Key-Escape> mkpatchcan
8728 grid $top.buts.gen $top.buts.can
8729 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8730 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8731 grid $top.buts - -pady 10 -sticky ew
8732 focus $top.fname
8735 proc mkpatchrev {} {
8736 global patchtop
8738 set oldid [$patchtop.fromsha1 get]
8739 set oldhead [$patchtop.fromhead get]
8740 set newid [$patchtop.tosha1 get]
8741 set newhead [$patchtop.tohead get]
8742 foreach e [list fromsha1 fromhead tosha1 tohead] \
8743 v [list $newid $newhead $oldid $oldhead] {
8744 $patchtop.$e conf -state normal
8745 $patchtop.$e delete 0 end
8746 $patchtop.$e insert 0 $v
8747 $patchtop.$e conf -state readonly
8751 proc mkpatchgo {} {
8752 global patchtop nullid nullid2
8754 set oldid [$patchtop.fromsha1 get]
8755 set newid [$patchtop.tosha1 get]
8756 set fname [$patchtop.fname get]
8757 set cmd [diffcmd [list $oldid $newid] -p]
8758 # trim off the initial "|"
8759 set cmd [lrange $cmd 1 end]
8760 lappend cmd >$fname &
8761 if {[catch {eval exec $cmd} err]} {
8762 error_popup "[mc "Error creating patch:"] $err" $patchtop
8764 catch {destroy $patchtop}
8765 unset patchtop
8768 proc mkpatchcan {} {
8769 global patchtop
8771 catch {destroy $patchtop}
8772 unset patchtop
8775 proc mktag {} {
8776 global rowmenuid mktagtop commitinfo NS
8778 set top .maketag
8779 set mktagtop $top
8780 catch {destroy $top}
8781 ttk_toplevel $top
8782 make_transient $top .
8783 ${NS}::label $top.title -text [mc "Create tag"]
8784 grid $top.title - -pady 10
8785 ${NS}::label $top.id -text [mc "ID:"]
8786 ${NS}::entry $top.sha1 -width 40
8787 $top.sha1 insert 0 $rowmenuid
8788 $top.sha1 conf -state readonly
8789 grid $top.id $top.sha1 -sticky w
8790 ${NS}::entry $top.head -width 60
8791 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8792 $top.head conf -state readonly
8793 grid x $top.head -sticky w
8794 ${NS}::label $top.tlab -text [mc "Tag name:"]
8795 ${NS}::entry $top.tag -width 60
8796 grid $top.tlab $top.tag -sticky w
8797 ${NS}::label $top.op -text [mc "Tag message is optional"]
8798 grid $top.op -columnspan 2 -sticky we
8799 ${NS}::label $top.mlab -text [mc "Tag message:"]
8800 ${NS}::entry $top.msg -width 60
8801 grid $top.mlab $top.msg -sticky w
8802 ${NS}::frame $top.buts
8803 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8804 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8805 bind $top <Key-Return> mktaggo
8806 bind $top <Key-Escape> mktagcan
8807 grid $top.buts.gen $top.buts.can
8808 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8809 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8810 grid $top.buts - -pady 10 -sticky ew
8811 focus $top.tag
8814 proc domktag {} {
8815 global mktagtop env tagids idtags
8817 set id [$mktagtop.sha1 get]
8818 set tag [$mktagtop.tag get]
8819 set msg [$mktagtop.msg get]
8820 if {$tag == {}} {
8821 error_popup [mc "No tag name specified"] $mktagtop
8822 return 0
8824 if {[info exists tagids($tag)]} {
8825 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8826 return 0
8828 if {[catch {
8829 if {$msg != {}} {
8830 exec git tag -a -m $msg $tag $id
8831 } else {
8832 exec git tag $tag $id
8834 } err]} {
8835 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8836 return 0
8839 set tagids($tag) $id
8840 lappend idtags($id) $tag
8841 redrawtags $id
8842 addedtag $id
8843 dispneartags 0
8844 run refill_reflist
8845 return 1
8848 proc redrawtags {id} {
8849 global canv linehtag idpos currentid curview cmitlisted markedid
8850 global canvxmax iddrawn circleitem mainheadid circlecolors
8852 if {![commitinview $id $curview]} return
8853 if {![info exists iddrawn($id)]} return
8854 set row [rowofcommit $id]
8855 if {$id eq $mainheadid} {
8856 set ofill yellow
8857 } else {
8858 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8860 $canv itemconf $circleitem($row) -fill $ofill
8861 $canv delete tag.$id
8862 set xt [eval drawtags $id $idpos($id)]
8863 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8864 set text [$canv itemcget $linehtag($id) -text]
8865 set font [$canv itemcget $linehtag($id) -font]
8866 set xr [expr {$xt + [font measure $font $text]}]
8867 if {$xr > $canvxmax} {
8868 set canvxmax $xr
8869 setcanvscroll
8871 if {[info exists currentid] && $currentid == $id} {
8872 make_secsel $id
8874 if {[info exists markedid] && $markedid eq $id} {
8875 make_idmark $id
8879 proc mktagcan {} {
8880 global mktagtop
8882 catch {destroy $mktagtop}
8883 unset mktagtop
8886 proc mktaggo {} {
8887 if {![domktag]} return
8888 mktagcan
8891 proc writecommit {} {
8892 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8894 set top .writecommit
8895 set wrcomtop $top
8896 catch {destroy $top}
8897 ttk_toplevel $top
8898 make_transient $top .
8899 ${NS}::label $top.title -text [mc "Write commit to file"]
8900 grid $top.title - -pady 10
8901 ${NS}::label $top.id -text [mc "ID:"]
8902 ${NS}::entry $top.sha1 -width 40
8903 $top.sha1 insert 0 $rowmenuid
8904 $top.sha1 conf -state readonly
8905 grid $top.id $top.sha1 -sticky w
8906 ${NS}::entry $top.head -width 60
8907 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8908 $top.head conf -state readonly
8909 grid x $top.head -sticky w
8910 ${NS}::label $top.clab -text [mc "Command:"]
8911 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8912 grid $top.clab $top.cmd -sticky w -pady 10
8913 ${NS}::label $top.flab -text [mc "Output file:"]
8914 ${NS}::entry $top.fname -width 60
8915 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8916 grid $top.flab $top.fname -sticky w
8917 ${NS}::frame $top.buts
8918 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8919 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8920 bind $top <Key-Return> wrcomgo
8921 bind $top <Key-Escape> wrcomcan
8922 grid $top.buts.gen $top.buts.can
8923 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8924 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8925 grid $top.buts - -pady 10 -sticky ew
8926 focus $top.fname
8929 proc wrcomgo {} {
8930 global wrcomtop
8932 set id [$wrcomtop.sha1 get]
8933 set cmd "echo $id | [$wrcomtop.cmd get]"
8934 set fname [$wrcomtop.fname get]
8935 if {[catch {exec sh -c $cmd >$fname &} err]} {
8936 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8938 catch {destroy $wrcomtop}
8939 unset wrcomtop
8942 proc wrcomcan {} {
8943 global wrcomtop
8945 catch {destroy $wrcomtop}
8946 unset wrcomtop
8949 proc mkbranch {} {
8950 global rowmenuid mkbrtop NS
8952 set top .makebranch
8953 catch {destroy $top}
8954 ttk_toplevel $top
8955 make_transient $top .
8956 ${NS}::label $top.title -text [mc "Create new branch"]
8957 grid $top.title - -pady 10
8958 ${NS}::label $top.id -text [mc "ID:"]
8959 ${NS}::entry $top.sha1 -width 40
8960 $top.sha1 insert 0 $rowmenuid
8961 $top.sha1 conf -state readonly
8962 grid $top.id $top.sha1 -sticky w
8963 ${NS}::label $top.nlab -text [mc "Name:"]
8964 ${NS}::entry $top.name -width 40
8965 grid $top.nlab $top.name -sticky w
8966 ${NS}::frame $top.buts
8967 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8968 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8969 bind $top <Key-Return> [list mkbrgo $top]
8970 bind $top <Key-Escape> "catch {destroy $top}"
8971 grid $top.buts.go $top.buts.can
8972 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8973 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8974 grid $top.buts - -pady 10 -sticky ew
8975 focus $top.name
8978 proc mkbrgo {top} {
8979 global headids idheads
8981 set name [$top.name get]
8982 set id [$top.sha1 get]
8983 set cmdargs {}
8984 set old_id {}
8985 if {$name eq {}} {
8986 error_popup [mc "Please specify a name for the new branch"] $top
8987 return
8989 if {[info exists headids($name)]} {
8990 if {![confirm_popup [mc \
8991 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8992 return
8994 set old_id $headids($name)
8995 lappend cmdargs -f
8997 catch {destroy $top}
8998 lappend cmdargs $name $id
8999 nowbusy newbranch
9000 update
9001 if {[catch {
9002 eval exec git branch $cmdargs
9003 } err]} {
9004 notbusy newbranch
9005 error_popup $err
9006 } else {
9007 notbusy newbranch
9008 if {$old_id ne {}} {
9009 movehead $id $name
9010 movedhead $id $name
9011 redrawtags $old_id
9012 redrawtags $id
9013 } else {
9014 set headids($name) $id
9015 lappend idheads($id) $name
9016 addedhead $id $name
9017 redrawtags $id
9019 dispneartags 0
9020 run refill_reflist
9024 proc exec_citool {tool_args {baseid {}}} {
9025 global commitinfo env
9027 set save_env [array get env GIT_AUTHOR_*]
9029 if {$baseid ne {}} {
9030 if {![info exists commitinfo($baseid)]} {
9031 getcommit $baseid
9033 set author [lindex $commitinfo($baseid) 1]
9034 set date [lindex $commitinfo($baseid) 2]
9035 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9036 $author author name email]
9037 && $date ne {}} {
9038 set env(GIT_AUTHOR_NAME) $name
9039 set env(GIT_AUTHOR_EMAIL) $email
9040 set env(GIT_AUTHOR_DATE) $date
9044 eval exec git citool $tool_args &
9046 array unset env GIT_AUTHOR_*
9047 array set env $save_env
9050 proc cherrypick {} {
9051 global rowmenuid curview
9052 global mainhead mainheadid
9053 global gitdir
9055 set oldhead [exec git rev-parse HEAD]
9056 set dheads [descheads $rowmenuid]
9057 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9058 set ok [confirm_popup [mc "Commit %s is already\
9059 included in branch %s -- really re-apply it?" \
9060 [string range $rowmenuid 0 7] $mainhead]]
9061 if {!$ok} return
9063 nowbusy cherrypick [mc "Cherry-picking"]
9064 update
9065 # Unfortunately git-cherry-pick writes stuff to stderr even when
9066 # no error occurs, and exec takes that as an indication of error...
9067 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9068 notbusy cherrypick
9069 if {[regexp -line \
9070 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9071 $err msg fname]} {
9072 error_popup [mc "Cherry-pick failed because of local changes\
9073 to file '%s'.\nPlease commit, reset or stash\
9074 your changes and try again." $fname]
9075 } elseif {[regexp -line \
9076 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9077 $err]} {
9078 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9079 conflict.\nDo you wish to run git citool to\
9080 resolve it?"]]} {
9081 # Force citool to read MERGE_MSG
9082 file delete [file join $gitdir "GITGUI_MSG"]
9083 exec_citool {} $rowmenuid
9085 } else {
9086 error_popup $err
9088 run updatecommits
9089 return
9091 set newhead [exec git rev-parse HEAD]
9092 if {$newhead eq $oldhead} {
9093 notbusy cherrypick
9094 error_popup [mc "No changes committed"]
9095 return
9097 addnewchild $newhead $oldhead
9098 if {[commitinview $oldhead $curview]} {
9099 # XXX this isn't right if we have a path limit...
9100 insertrow $newhead $oldhead $curview
9101 if {$mainhead ne {}} {
9102 movehead $newhead $mainhead
9103 movedhead $newhead $mainhead
9105 set mainheadid $newhead
9106 redrawtags $oldhead
9107 redrawtags $newhead
9108 selbyid $newhead
9110 notbusy cherrypick
9113 proc resethead {} {
9114 global mainhead rowmenuid confirm_ok resettype NS
9116 set confirm_ok 0
9117 set w ".confirmreset"
9118 ttk_toplevel $w
9119 make_transient $w .
9120 wm title $w [mc "Confirm reset"]
9121 ${NS}::label $w.m -text \
9122 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9123 pack $w.m -side top -fill x -padx 20 -pady 20
9124 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9125 set resettype mixed
9126 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9127 -text [mc "Soft: Leave working tree and index untouched"]
9128 grid $w.f.soft -sticky w
9129 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9130 -text [mc "Mixed: Leave working tree untouched, reset index"]
9131 grid $w.f.mixed -sticky w
9132 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9133 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9134 grid $w.f.hard -sticky w
9135 pack $w.f -side top -fill x -padx 4
9136 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9137 pack $w.ok -side left -fill x -padx 20 -pady 20
9138 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9139 bind $w <Key-Escape> [list destroy $w]
9140 pack $w.cancel -side right -fill x -padx 20 -pady 20
9141 bind $w <Visibility> "grab $w; focus $w"
9142 tkwait window $w
9143 if {!$confirm_ok} return
9144 if {[catch {set fd [open \
9145 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9146 error_popup $err
9147 } else {
9148 dohidelocalchanges
9149 filerun $fd [list readresetstat $fd]
9150 nowbusy reset [mc "Resetting"]
9151 selbyid $rowmenuid
9155 proc readresetstat {fd} {
9156 global mainhead mainheadid showlocalchanges rprogcoord
9158 if {[gets $fd line] >= 0} {
9159 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9160 set rprogcoord [expr {1.0 * $m / $n}]
9161 adjustprogress
9163 return 1
9165 set rprogcoord 0
9166 adjustprogress
9167 notbusy reset
9168 if {[catch {close $fd} err]} {
9169 error_popup $err
9171 set oldhead $mainheadid
9172 set newhead [exec git rev-parse HEAD]
9173 if {$newhead ne $oldhead} {
9174 movehead $newhead $mainhead
9175 movedhead $newhead $mainhead
9176 set mainheadid $newhead
9177 redrawtags $oldhead
9178 redrawtags $newhead
9180 if {$showlocalchanges} {
9181 doshowlocalchanges
9183 return 0
9186 # context menu for a head
9187 proc headmenu {x y id head} {
9188 global headmenuid headmenuhead headctxmenu mainhead
9190 stopfinding
9191 set headmenuid $id
9192 set headmenuhead $head
9193 set state normal
9194 if {[string match "remotes/*" $head]} {
9195 set state disabled
9197 if {$head eq $mainhead} {
9198 set state disabled
9200 $headctxmenu entryconfigure 0 -state $state
9201 $headctxmenu entryconfigure 1 -state $state
9202 tk_popup $headctxmenu $x $y
9205 proc cobranch {} {
9206 global headmenuid headmenuhead headids
9207 global showlocalchanges
9209 # check the tree is clean first??
9210 nowbusy checkout [mc "Checking out"]
9211 update
9212 dohidelocalchanges
9213 if {[catch {
9214 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9215 } err]} {
9216 notbusy checkout
9217 error_popup $err
9218 if {$showlocalchanges} {
9219 dodiffindex
9221 } else {
9222 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9226 proc readcheckoutstat {fd newhead newheadid} {
9227 global mainhead mainheadid headids showlocalchanges progresscoords
9228 global viewmainheadid curview
9230 if {[gets $fd line] >= 0} {
9231 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9232 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9233 adjustprogress
9235 return 1
9237 set progresscoords {0 0}
9238 adjustprogress
9239 notbusy checkout
9240 if {[catch {close $fd} err]} {
9241 error_popup $err
9243 set oldmainid $mainheadid
9244 set mainhead $newhead
9245 set mainheadid $newheadid
9246 set viewmainheadid($curview) $newheadid
9247 redrawtags $oldmainid
9248 redrawtags $newheadid
9249 selbyid $newheadid
9250 if {$showlocalchanges} {
9251 dodiffindex
9255 proc rmbranch {} {
9256 global headmenuid headmenuhead mainhead
9257 global idheads
9259 set head $headmenuhead
9260 set id $headmenuid
9261 # this check shouldn't be needed any more...
9262 if {$head eq $mainhead} {
9263 error_popup [mc "Cannot delete the currently checked-out branch"]
9264 return
9266 set dheads [descheads $id]
9267 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9268 # the stuff on this branch isn't on any other branch
9269 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9270 branch.\nReally delete branch %s?" $head $head]]} return
9272 nowbusy rmbranch
9273 update
9274 if {[catch {exec git branch -D $head} err]} {
9275 notbusy rmbranch
9276 error_popup $err
9277 return
9279 removehead $id $head
9280 removedhead $id $head
9281 redrawtags $id
9282 notbusy rmbranch
9283 dispneartags 0
9284 run refill_reflist
9287 # Display a list of tags and heads
9288 proc showrefs {} {
9289 global showrefstop bgcolor fgcolor selectbgcolor NS
9290 global bglist fglist reflistfilter reflist maincursor
9292 set top .showrefs
9293 set showrefstop $top
9294 if {[winfo exists $top]} {
9295 raise $top
9296 refill_reflist
9297 return
9299 ttk_toplevel $top
9300 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9301 make_transient $top .
9302 text $top.list -background $bgcolor -foreground $fgcolor \
9303 -selectbackground $selectbgcolor -font mainfont \
9304 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9305 -width 30 -height 20 -cursor $maincursor \
9306 -spacing1 1 -spacing3 1 -state disabled
9307 $top.list tag configure highlight -background $selectbgcolor
9308 lappend bglist $top.list
9309 lappend fglist $top.list
9310 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9311 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9312 grid $top.list $top.ysb -sticky nsew
9313 grid $top.xsb x -sticky ew
9314 ${NS}::frame $top.f
9315 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9316 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9317 set reflistfilter "*"
9318 trace add variable reflistfilter write reflistfilter_change
9319 pack $top.f.e -side right -fill x -expand 1
9320 pack $top.f.l -side left
9321 grid $top.f - -sticky ew -pady 2
9322 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9323 bind $top <Key-Escape> [list destroy $top]
9324 grid $top.close -
9325 grid columnconfigure $top 0 -weight 1
9326 grid rowconfigure $top 0 -weight 1
9327 bind $top.list <1> {break}
9328 bind $top.list <B1-Motion> {break}
9329 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9330 set reflist {}
9331 refill_reflist
9334 proc sel_reflist {w x y} {
9335 global showrefstop reflist headids tagids otherrefids
9337 if {![winfo exists $showrefstop]} return
9338 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9339 set ref [lindex $reflist [expr {$l-1}]]
9340 set n [lindex $ref 0]
9341 switch -- [lindex $ref 1] {
9342 "H" {selbyid $headids($n)}
9343 "T" {selbyid $tagids($n)}
9344 "o" {selbyid $otherrefids($n)}
9346 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9349 proc unsel_reflist {} {
9350 global showrefstop
9352 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9353 $showrefstop.list tag remove highlight 0.0 end
9356 proc reflistfilter_change {n1 n2 op} {
9357 global reflistfilter
9359 after cancel refill_reflist
9360 after 200 refill_reflist
9363 proc refill_reflist {} {
9364 global reflist reflistfilter showrefstop headids tagids otherrefids
9365 global curview
9367 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9368 set refs {}
9369 foreach n [array names headids] {
9370 if {[string match $reflistfilter $n]} {
9371 if {[commitinview $headids($n) $curview]} {
9372 lappend refs [list $n H]
9373 } else {
9374 interestedin $headids($n) {run refill_reflist}
9378 foreach n [array names tagids] {
9379 if {[string match $reflistfilter $n]} {
9380 if {[commitinview $tagids($n) $curview]} {
9381 lappend refs [list $n T]
9382 } else {
9383 interestedin $tagids($n) {run refill_reflist}
9387 foreach n [array names otherrefids] {
9388 if {[string match $reflistfilter $n]} {
9389 if {[commitinview $otherrefids($n) $curview]} {
9390 lappend refs [list $n o]
9391 } else {
9392 interestedin $otherrefids($n) {run refill_reflist}
9396 set refs [lsort -index 0 $refs]
9397 if {$refs eq $reflist} return
9399 # Update the contents of $showrefstop.list according to the
9400 # differences between $reflist (old) and $refs (new)
9401 $showrefstop.list conf -state normal
9402 $showrefstop.list insert end "\n"
9403 set i 0
9404 set j 0
9405 while {$i < [llength $reflist] || $j < [llength $refs]} {
9406 if {$i < [llength $reflist]} {
9407 if {$j < [llength $refs]} {
9408 set cmp [string compare [lindex $reflist $i 0] \
9409 [lindex $refs $j 0]]
9410 if {$cmp == 0} {
9411 set cmp [string compare [lindex $reflist $i 1] \
9412 [lindex $refs $j 1]]
9414 } else {
9415 set cmp -1
9417 } else {
9418 set cmp 1
9420 switch -- $cmp {
9421 -1 {
9422 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9423 incr i
9426 incr i
9427 incr j
9430 set l [expr {$j + 1}]
9431 $showrefstop.list image create $l.0 -align baseline \
9432 -image reficon-[lindex $refs $j 1] -padx 2
9433 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9434 incr j
9438 set reflist $refs
9439 # delete last newline
9440 $showrefstop.list delete end-2c end-1c
9441 $showrefstop.list conf -state disabled
9444 # Stuff for finding nearby tags
9445 proc getallcommits {} {
9446 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9447 global idheads idtags idotherrefs allparents tagobjid
9448 global gitdir
9450 if {![info exists allcommits]} {
9451 set nextarc 0
9452 set allcommits 0
9453 set seeds {}
9454 set allcwait 0
9455 set cachedarcs 0
9456 set allccache [file join $gitdir "gitk.cache"]
9457 if {![catch {
9458 set f [open $allccache r]
9459 set allcwait 1
9460 getcache $f
9461 }]} return
9464 if {$allcwait} {
9465 return
9467 set cmd [list | git rev-list --parents]
9468 set allcupdate [expr {$seeds ne {}}]
9469 if {!$allcupdate} {
9470 set ids "--all"
9471 } else {
9472 set refs [concat [array names idheads] [array names idtags] \
9473 [array names idotherrefs]]
9474 set ids {}
9475 set tagobjs {}
9476 foreach name [array names tagobjid] {
9477 lappend tagobjs $tagobjid($name)
9479 foreach id [lsort -unique $refs] {
9480 if {![info exists allparents($id)] &&
9481 [lsearch -exact $tagobjs $id] < 0} {
9482 lappend ids $id
9485 if {$ids ne {}} {
9486 foreach id $seeds {
9487 lappend ids "^$id"
9491 if {$ids ne {}} {
9492 set fd [open [concat $cmd $ids] r]
9493 fconfigure $fd -blocking 0
9494 incr allcommits
9495 nowbusy allcommits
9496 filerun $fd [list getallclines $fd]
9497 } else {
9498 dispneartags 0
9502 # Since most commits have 1 parent and 1 child, we group strings of
9503 # such commits into "arcs" joining branch/merge points (BMPs), which
9504 # are commits that either don't have 1 parent or don't have 1 child.
9506 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9507 # arcout(id) - outgoing arcs for BMP
9508 # arcids(a) - list of IDs on arc including end but not start
9509 # arcstart(a) - BMP ID at start of arc
9510 # arcend(a) - BMP ID at end of arc
9511 # growing(a) - arc a is still growing
9512 # arctags(a) - IDs out of arcids (excluding end) that have tags
9513 # archeads(a) - IDs out of arcids (excluding end) that have heads
9514 # The start of an arc is at the descendent end, so "incoming" means
9515 # coming from descendents, and "outgoing" means going towards ancestors.
9517 proc getallclines {fd} {
9518 global allparents allchildren idtags idheads nextarc
9519 global arcnos arcids arctags arcout arcend arcstart archeads growing
9520 global seeds allcommits cachedarcs allcupdate
9522 set nid 0
9523 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9524 set id [lindex $line 0]
9525 if {[info exists allparents($id)]} {
9526 # seen it already
9527 continue
9529 set cachedarcs 0
9530 set olds [lrange $line 1 end]
9531 set allparents($id) $olds
9532 if {![info exists allchildren($id)]} {
9533 set allchildren($id) {}
9534 set arcnos($id) {}
9535 lappend seeds $id
9536 } else {
9537 set a $arcnos($id)
9538 if {[llength $olds] == 1 && [llength $a] == 1} {
9539 lappend arcids($a) $id
9540 if {[info exists idtags($id)]} {
9541 lappend arctags($a) $id
9543 if {[info exists idheads($id)]} {
9544 lappend archeads($a) $id
9546 if {[info exists allparents($olds)]} {
9547 # seen parent already
9548 if {![info exists arcout($olds)]} {
9549 splitarc $olds
9551 lappend arcids($a) $olds
9552 set arcend($a) $olds
9553 unset growing($a)
9555 lappend allchildren($olds) $id
9556 lappend arcnos($olds) $a
9557 continue
9560 foreach a $arcnos($id) {
9561 lappend arcids($a) $id
9562 set arcend($a) $id
9563 unset growing($a)
9566 set ao {}
9567 foreach p $olds {
9568 lappend allchildren($p) $id
9569 set a [incr nextarc]
9570 set arcstart($a) $id
9571 set archeads($a) {}
9572 set arctags($a) {}
9573 set archeads($a) {}
9574 set arcids($a) {}
9575 lappend ao $a
9576 set growing($a) 1
9577 if {[info exists allparents($p)]} {
9578 # seen it already, may need to make a new branch
9579 if {![info exists arcout($p)]} {
9580 splitarc $p
9582 lappend arcids($a) $p
9583 set arcend($a) $p
9584 unset growing($a)
9586 lappend arcnos($p) $a
9588 set arcout($id) $ao
9590 if {$nid > 0} {
9591 global cached_dheads cached_dtags cached_atags
9592 catch {unset cached_dheads}
9593 catch {unset cached_dtags}
9594 catch {unset cached_atags}
9596 if {![eof $fd]} {
9597 return [expr {$nid >= 1000? 2: 1}]
9599 set cacheok 1
9600 if {[catch {
9601 fconfigure $fd -blocking 1
9602 close $fd
9603 } err]} {
9604 # got an error reading the list of commits
9605 # if we were updating, try rereading the whole thing again
9606 if {$allcupdate} {
9607 incr allcommits -1
9608 dropcache $err
9609 return
9611 error_popup "[mc "Error reading commit topology information;\
9612 branch and preceding/following tag information\
9613 will be incomplete."]\n($err)"
9614 set cacheok 0
9616 if {[incr allcommits -1] == 0} {
9617 notbusy allcommits
9618 if {$cacheok} {
9619 run savecache
9622 dispneartags 0
9623 return 0
9626 proc recalcarc {a} {
9627 global arctags archeads arcids idtags idheads
9629 set at {}
9630 set ah {}
9631 foreach id [lrange $arcids($a) 0 end-1] {
9632 if {[info exists idtags($id)]} {
9633 lappend at $id
9635 if {[info exists idheads($id)]} {
9636 lappend ah $id
9639 set arctags($a) $at
9640 set archeads($a) $ah
9643 proc splitarc {p} {
9644 global arcnos arcids nextarc arctags archeads idtags idheads
9645 global arcstart arcend arcout allparents growing
9647 set a $arcnos($p)
9648 if {[llength $a] != 1} {
9649 puts "oops splitarc called but [llength $a] arcs already"
9650 return
9652 set a [lindex $a 0]
9653 set i [lsearch -exact $arcids($a) $p]
9654 if {$i < 0} {
9655 puts "oops splitarc $p not in arc $a"
9656 return
9658 set na [incr nextarc]
9659 if {[info exists arcend($a)]} {
9660 set arcend($na) $arcend($a)
9661 } else {
9662 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9663 set j [lsearch -exact $arcnos($l) $a]
9664 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9666 set tail [lrange $arcids($a) [expr {$i+1}] end]
9667 set arcids($a) [lrange $arcids($a) 0 $i]
9668 set arcend($a) $p
9669 set arcstart($na) $p
9670 set arcout($p) $na
9671 set arcids($na) $tail
9672 if {[info exists growing($a)]} {
9673 set growing($na) 1
9674 unset growing($a)
9677 foreach id $tail {
9678 if {[llength $arcnos($id)] == 1} {
9679 set arcnos($id) $na
9680 } else {
9681 set j [lsearch -exact $arcnos($id) $a]
9682 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9686 # reconstruct tags and heads lists
9687 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9688 recalcarc $a
9689 recalcarc $na
9690 } else {
9691 set arctags($na) {}
9692 set archeads($na) {}
9696 # Update things for a new commit added that is a child of one
9697 # existing commit. Used when cherry-picking.
9698 proc addnewchild {id p} {
9699 global allparents allchildren idtags nextarc
9700 global arcnos arcids arctags arcout arcend arcstart archeads growing
9701 global seeds allcommits
9703 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9704 set allparents($id) [list $p]
9705 set allchildren($id) {}
9706 set arcnos($id) {}
9707 lappend seeds $id
9708 lappend allchildren($p) $id
9709 set a [incr nextarc]
9710 set arcstart($a) $id
9711 set archeads($a) {}
9712 set arctags($a) {}
9713 set arcids($a) [list $p]
9714 set arcend($a) $p
9715 if {![info exists arcout($p)]} {
9716 splitarc $p
9718 lappend arcnos($p) $a
9719 set arcout($id) [list $a]
9722 # This implements a cache for the topology information.
9723 # The cache saves, for each arc, the start and end of the arc,
9724 # the ids on the arc, and the outgoing arcs from the end.
9725 proc readcache {f} {
9726 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9727 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9728 global allcwait
9730 set a $nextarc
9731 set lim $cachedarcs
9732 if {$lim - $a > 500} {
9733 set lim [expr {$a + 500}]
9735 if {[catch {
9736 if {$a == $lim} {
9737 # finish reading the cache and setting up arctags, etc.
9738 set line [gets $f]
9739 if {$line ne "1"} {error "bad final version"}
9740 close $f
9741 foreach id [array names idtags] {
9742 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9743 [llength $allparents($id)] == 1} {
9744 set a [lindex $arcnos($id) 0]
9745 if {$arctags($a) eq {}} {
9746 recalcarc $a
9750 foreach id [array names idheads] {
9751 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9752 [llength $allparents($id)] == 1} {
9753 set a [lindex $arcnos($id) 0]
9754 if {$archeads($a) eq {}} {
9755 recalcarc $a
9759 foreach id [lsort -unique $possible_seeds] {
9760 if {$arcnos($id) eq {}} {
9761 lappend seeds $id
9764 set allcwait 0
9765 } else {
9766 while {[incr a] <= $lim} {
9767 set line [gets $f]
9768 if {[llength $line] != 3} {error "bad line"}
9769 set s [lindex $line 0]
9770 set arcstart($a) $s
9771 lappend arcout($s) $a
9772 if {![info exists arcnos($s)]} {
9773 lappend possible_seeds $s
9774 set arcnos($s) {}
9776 set e [lindex $line 1]
9777 if {$e eq {}} {
9778 set growing($a) 1
9779 } else {
9780 set arcend($a) $e
9781 if {![info exists arcout($e)]} {
9782 set arcout($e) {}
9785 set arcids($a) [lindex $line 2]
9786 foreach id $arcids($a) {
9787 lappend allparents($s) $id
9788 set s $id
9789 lappend arcnos($id) $a
9791 if {![info exists allparents($s)]} {
9792 set allparents($s) {}
9794 set arctags($a) {}
9795 set archeads($a) {}
9797 set nextarc [expr {$a - 1}]
9799 } err]} {
9800 dropcache $err
9801 return 0
9803 if {!$allcwait} {
9804 getallcommits
9806 return $allcwait
9809 proc getcache {f} {
9810 global nextarc cachedarcs possible_seeds
9812 if {[catch {
9813 set line [gets $f]
9814 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9815 # make sure it's an integer
9816 set cachedarcs [expr {int([lindex $line 1])}]
9817 if {$cachedarcs < 0} {error "bad number of arcs"}
9818 set nextarc 0
9819 set possible_seeds {}
9820 run readcache $f
9821 } err]} {
9822 dropcache $err
9824 return 0
9827 proc dropcache {err} {
9828 global allcwait nextarc cachedarcs seeds
9830 #puts "dropping cache ($err)"
9831 foreach v {arcnos arcout arcids arcstart arcend growing \
9832 arctags archeads allparents allchildren} {
9833 global $v
9834 catch {unset $v}
9836 set allcwait 0
9837 set nextarc 0
9838 set cachedarcs 0
9839 set seeds {}
9840 getallcommits
9843 proc writecache {f} {
9844 global cachearc cachedarcs allccache
9845 global arcstart arcend arcnos arcids arcout
9847 set a $cachearc
9848 set lim $cachedarcs
9849 if {$lim - $a > 1000} {
9850 set lim [expr {$a + 1000}]
9852 if {[catch {
9853 while {[incr a] <= $lim} {
9854 if {[info exists arcend($a)]} {
9855 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9856 } else {
9857 puts $f [list $arcstart($a) {} $arcids($a)]
9860 } err]} {
9861 catch {close $f}
9862 catch {file delete $allccache}
9863 #puts "writing cache failed ($err)"
9864 return 0
9866 set cachearc [expr {$a - 1}]
9867 if {$a > $cachedarcs} {
9868 puts $f "1"
9869 close $f
9870 return 0
9872 return 1
9875 proc savecache {} {
9876 global nextarc cachedarcs cachearc allccache
9878 if {$nextarc == $cachedarcs} return
9879 set cachearc 0
9880 set cachedarcs $nextarc
9881 catch {
9882 set f [open $allccache w]
9883 puts $f [list 1 $cachedarcs]
9884 run writecache $f
9888 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9889 # or 0 if neither is true.
9890 proc anc_or_desc {a b} {
9891 global arcout arcstart arcend arcnos cached_isanc
9893 if {$arcnos($a) eq $arcnos($b)} {
9894 # Both are on the same arc(s); either both are the same BMP,
9895 # or if one is not a BMP, the other is also not a BMP or is
9896 # the BMP at end of the arc (and it only has 1 incoming arc).
9897 # Or both can be BMPs with no incoming arcs.
9898 if {$a eq $b || $arcnos($a) eq {}} {
9899 return 0
9901 # assert {[llength $arcnos($a)] == 1}
9902 set arc [lindex $arcnos($a) 0]
9903 set i [lsearch -exact $arcids($arc) $a]
9904 set j [lsearch -exact $arcids($arc) $b]
9905 if {$i < 0 || $i > $j} {
9906 return 1
9907 } else {
9908 return -1
9912 if {![info exists arcout($a)]} {
9913 set arc [lindex $arcnos($a) 0]
9914 if {[info exists arcend($arc)]} {
9915 set aend $arcend($arc)
9916 } else {
9917 set aend {}
9919 set a $arcstart($arc)
9920 } else {
9921 set aend $a
9923 if {![info exists arcout($b)]} {
9924 set arc [lindex $arcnos($b) 0]
9925 if {[info exists arcend($arc)]} {
9926 set bend $arcend($arc)
9927 } else {
9928 set bend {}
9930 set b $arcstart($arc)
9931 } else {
9932 set bend $b
9934 if {$a eq $bend} {
9935 return 1
9937 if {$b eq $aend} {
9938 return -1
9940 if {[info exists cached_isanc($a,$bend)]} {
9941 if {$cached_isanc($a,$bend)} {
9942 return 1
9945 if {[info exists cached_isanc($b,$aend)]} {
9946 if {$cached_isanc($b,$aend)} {
9947 return -1
9949 if {[info exists cached_isanc($a,$bend)]} {
9950 return 0
9954 set todo [list $a $b]
9955 set anc($a) a
9956 set anc($b) b
9957 for {set i 0} {$i < [llength $todo]} {incr i} {
9958 set x [lindex $todo $i]
9959 if {$anc($x) eq {}} {
9960 continue
9962 foreach arc $arcnos($x) {
9963 set xd $arcstart($arc)
9964 if {$xd eq $bend} {
9965 set cached_isanc($a,$bend) 1
9966 set cached_isanc($b,$aend) 0
9967 return 1
9968 } elseif {$xd eq $aend} {
9969 set cached_isanc($b,$aend) 1
9970 set cached_isanc($a,$bend) 0
9971 return -1
9973 if {![info exists anc($xd)]} {
9974 set anc($xd) $anc($x)
9975 lappend todo $xd
9976 } elseif {$anc($xd) ne $anc($x)} {
9977 set anc($xd) {}
9981 set cached_isanc($a,$bend) 0
9982 set cached_isanc($b,$aend) 0
9983 return 0
9986 # This identifies whether $desc has an ancestor that is
9987 # a growing tip of the graph and which is not an ancestor of $anc
9988 # and returns 0 if so and 1 if not.
9989 # If we subsequently discover a tag on such a growing tip, and that
9990 # turns out to be a descendent of $anc (which it could, since we
9991 # don't necessarily see children before parents), then $desc
9992 # isn't a good choice to display as a descendent tag of
9993 # $anc (since it is the descendent of another tag which is
9994 # a descendent of $anc). Similarly, $anc isn't a good choice to
9995 # display as a ancestor tag of $desc.
9997 proc is_certain {desc anc} {
9998 global arcnos arcout arcstart arcend growing problems
10000 set certain {}
10001 if {[llength $arcnos($anc)] == 1} {
10002 # tags on the same arc are certain
10003 if {$arcnos($desc) eq $arcnos($anc)} {
10004 return 1
10006 if {![info exists arcout($anc)]} {
10007 # if $anc is partway along an arc, use the start of the arc instead
10008 set a [lindex $arcnos($anc) 0]
10009 set anc $arcstart($a)
10012 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10013 set x $desc
10014 } else {
10015 set a [lindex $arcnos($desc) 0]
10016 set x $arcend($a)
10018 if {$x == $anc} {
10019 return 1
10021 set anclist [list $x]
10022 set dl($x) 1
10023 set nnh 1
10024 set ngrowanc 0
10025 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10026 set x [lindex $anclist $i]
10027 if {$dl($x)} {
10028 incr nnh -1
10030 set done($x) 1
10031 foreach a $arcout($x) {
10032 if {[info exists growing($a)]} {
10033 if {![info exists growanc($x)] && $dl($x)} {
10034 set growanc($x) 1
10035 incr ngrowanc
10037 } else {
10038 set y $arcend($a)
10039 if {[info exists dl($y)]} {
10040 if {$dl($y)} {
10041 if {!$dl($x)} {
10042 set dl($y) 0
10043 if {![info exists done($y)]} {
10044 incr nnh -1
10046 if {[info exists growanc($x)]} {
10047 incr ngrowanc -1
10049 set xl [list $y]
10050 for {set k 0} {$k < [llength $xl]} {incr k} {
10051 set z [lindex $xl $k]
10052 foreach c $arcout($z) {
10053 if {[info exists arcend($c)]} {
10054 set v $arcend($c)
10055 if {[info exists dl($v)] && $dl($v)} {
10056 set dl($v) 0
10057 if {![info exists done($v)]} {
10058 incr nnh -1
10060 if {[info exists growanc($v)]} {
10061 incr ngrowanc -1
10063 lappend xl $v
10070 } elseif {$y eq $anc || !$dl($x)} {
10071 set dl($y) 0
10072 lappend anclist $y
10073 } else {
10074 set dl($y) 1
10075 lappend anclist $y
10076 incr nnh
10081 foreach x [array names growanc] {
10082 if {$dl($x)} {
10083 return 0
10085 return 0
10087 return 1
10090 proc validate_arctags {a} {
10091 global arctags idtags
10093 set i -1
10094 set na $arctags($a)
10095 foreach id $arctags($a) {
10096 incr i
10097 if {![info exists idtags($id)]} {
10098 set na [lreplace $na $i $i]
10099 incr i -1
10102 set arctags($a) $na
10105 proc validate_archeads {a} {
10106 global archeads idheads
10108 set i -1
10109 set na $archeads($a)
10110 foreach id $archeads($a) {
10111 incr i
10112 if {![info exists idheads($id)]} {
10113 set na [lreplace $na $i $i]
10114 incr i -1
10117 set archeads($a) $na
10120 # Return the list of IDs that have tags that are descendents of id,
10121 # ignoring IDs that are descendents of IDs already reported.
10122 proc desctags {id} {
10123 global arcnos arcstart arcids arctags idtags allparents
10124 global growing cached_dtags
10126 if {![info exists allparents($id)]} {
10127 return {}
10129 set t1 [clock clicks -milliseconds]
10130 set argid $id
10131 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10132 # part-way along an arc; check that arc first
10133 set a [lindex $arcnos($id) 0]
10134 if {$arctags($a) ne {}} {
10135 validate_arctags $a
10136 set i [lsearch -exact $arcids($a) $id]
10137 set tid {}
10138 foreach t $arctags($a) {
10139 set j [lsearch -exact $arcids($a) $t]
10140 if {$j >= $i} break
10141 set tid $t
10143 if {$tid ne {}} {
10144 return $tid
10147 set id $arcstart($a)
10148 if {[info exists idtags($id)]} {
10149 return $id
10152 if {[info exists cached_dtags($id)]} {
10153 return $cached_dtags($id)
10156 set origid $id
10157 set todo [list $id]
10158 set queued($id) 1
10159 set nc 1
10160 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10161 set id [lindex $todo $i]
10162 set done($id) 1
10163 set ta [info exists hastaggedancestor($id)]
10164 if {!$ta} {
10165 incr nc -1
10167 # ignore tags on starting node
10168 if {!$ta && $i > 0} {
10169 if {[info exists idtags($id)]} {
10170 set tagloc($id) $id
10171 set ta 1
10172 } elseif {[info exists cached_dtags($id)]} {
10173 set tagloc($id) $cached_dtags($id)
10174 set ta 1
10177 foreach a $arcnos($id) {
10178 set d $arcstart($a)
10179 if {!$ta && $arctags($a) ne {}} {
10180 validate_arctags $a
10181 if {$arctags($a) ne {}} {
10182 lappend tagloc($id) [lindex $arctags($a) end]
10185 if {$ta || $arctags($a) ne {}} {
10186 set tomark [list $d]
10187 for {set j 0} {$j < [llength $tomark]} {incr j} {
10188 set dd [lindex $tomark $j]
10189 if {![info exists hastaggedancestor($dd)]} {
10190 if {[info exists done($dd)]} {
10191 foreach b $arcnos($dd) {
10192 lappend tomark $arcstart($b)
10194 if {[info exists tagloc($dd)]} {
10195 unset tagloc($dd)
10197 } elseif {[info exists queued($dd)]} {
10198 incr nc -1
10200 set hastaggedancestor($dd) 1
10204 if {![info exists queued($d)]} {
10205 lappend todo $d
10206 set queued($d) 1
10207 if {![info exists hastaggedancestor($d)]} {
10208 incr nc
10213 set tags {}
10214 foreach id [array names tagloc] {
10215 if {![info exists hastaggedancestor($id)]} {
10216 foreach t $tagloc($id) {
10217 if {[lsearch -exact $tags $t] < 0} {
10218 lappend tags $t
10223 set t2 [clock clicks -milliseconds]
10224 set loopix $i
10226 # remove tags that are descendents of other tags
10227 for {set i 0} {$i < [llength $tags]} {incr i} {
10228 set a [lindex $tags $i]
10229 for {set j 0} {$j < $i} {incr j} {
10230 set b [lindex $tags $j]
10231 set r [anc_or_desc $a $b]
10232 if {$r == 1} {
10233 set tags [lreplace $tags $j $j]
10234 incr j -1
10235 incr i -1
10236 } elseif {$r == -1} {
10237 set tags [lreplace $tags $i $i]
10238 incr i -1
10239 break
10244 if {[array names growing] ne {}} {
10245 # graph isn't finished, need to check if any tag could get
10246 # eclipsed by another tag coming later. Simply ignore any
10247 # tags that could later get eclipsed.
10248 set ctags {}
10249 foreach t $tags {
10250 if {[is_certain $t $origid]} {
10251 lappend ctags $t
10254 if {$tags eq $ctags} {
10255 set cached_dtags($origid) $tags
10256 } else {
10257 set tags $ctags
10259 } else {
10260 set cached_dtags($origid) $tags
10262 set t3 [clock clicks -milliseconds]
10263 if {0 && $t3 - $t1 >= 100} {
10264 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10265 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10267 return $tags
10270 proc anctags {id} {
10271 global arcnos arcids arcout arcend arctags idtags allparents
10272 global growing cached_atags
10274 if {![info exists allparents($id)]} {
10275 return {}
10277 set t1 [clock clicks -milliseconds]
10278 set argid $id
10279 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10280 # part-way along an arc; check that arc first
10281 set a [lindex $arcnos($id) 0]
10282 if {$arctags($a) ne {}} {
10283 validate_arctags $a
10284 set i [lsearch -exact $arcids($a) $id]
10285 foreach t $arctags($a) {
10286 set j [lsearch -exact $arcids($a) $t]
10287 if {$j > $i} {
10288 return $t
10292 if {![info exists arcend($a)]} {
10293 return {}
10295 set id $arcend($a)
10296 if {[info exists idtags($id)]} {
10297 return $id
10300 if {[info exists cached_atags($id)]} {
10301 return $cached_atags($id)
10304 set origid $id
10305 set todo [list $id]
10306 set queued($id) 1
10307 set taglist {}
10308 set nc 1
10309 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10310 set id [lindex $todo $i]
10311 set done($id) 1
10312 set td [info exists hastaggeddescendent($id)]
10313 if {!$td} {
10314 incr nc -1
10316 # ignore tags on starting node
10317 if {!$td && $i > 0} {
10318 if {[info exists idtags($id)]} {
10319 set tagloc($id) $id
10320 set td 1
10321 } elseif {[info exists cached_atags($id)]} {
10322 set tagloc($id) $cached_atags($id)
10323 set td 1
10326 foreach a $arcout($id) {
10327 if {!$td && $arctags($a) ne {}} {
10328 validate_arctags $a
10329 if {$arctags($a) ne {}} {
10330 lappend tagloc($id) [lindex $arctags($a) 0]
10333 if {![info exists arcend($a)]} continue
10334 set d $arcend($a)
10335 if {$td || $arctags($a) ne {}} {
10336 set tomark [list $d]
10337 for {set j 0} {$j < [llength $tomark]} {incr j} {
10338 set dd [lindex $tomark $j]
10339 if {![info exists hastaggeddescendent($dd)]} {
10340 if {[info exists done($dd)]} {
10341 foreach b $arcout($dd) {
10342 if {[info exists arcend($b)]} {
10343 lappend tomark $arcend($b)
10346 if {[info exists tagloc($dd)]} {
10347 unset tagloc($dd)
10349 } elseif {[info exists queued($dd)]} {
10350 incr nc -1
10352 set hastaggeddescendent($dd) 1
10356 if {![info exists queued($d)]} {
10357 lappend todo $d
10358 set queued($d) 1
10359 if {![info exists hastaggeddescendent($d)]} {
10360 incr nc
10365 set t2 [clock clicks -milliseconds]
10366 set loopix $i
10367 set tags {}
10368 foreach id [array names tagloc] {
10369 if {![info exists hastaggeddescendent($id)]} {
10370 foreach t $tagloc($id) {
10371 if {[lsearch -exact $tags $t] < 0} {
10372 lappend tags $t
10378 # remove tags that are ancestors of other tags
10379 for {set i 0} {$i < [llength $tags]} {incr i} {
10380 set a [lindex $tags $i]
10381 for {set j 0} {$j < $i} {incr j} {
10382 set b [lindex $tags $j]
10383 set r [anc_or_desc $a $b]
10384 if {$r == -1} {
10385 set tags [lreplace $tags $j $j]
10386 incr j -1
10387 incr i -1
10388 } elseif {$r == 1} {
10389 set tags [lreplace $tags $i $i]
10390 incr i -1
10391 break
10396 if {[array names growing] ne {}} {
10397 # graph isn't finished, need to check if any tag could get
10398 # eclipsed by another tag coming later. Simply ignore any
10399 # tags that could later get eclipsed.
10400 set ctags {}
10401 foreach t $tags {
10402 if {[is_certain $origid $t]} {
10403 lappend ctags $t
10406 if {$tags eq $ctags} {
10407 set cached_atags($origid) $tags
10408 } else {
10409 set tags $ctags
10411 } else {
10412 set cached_atags($origid) $tags
10414 set t3 [clock clicks -milliseconds]
10415 if {0 && $t3 - $t1 >= 100} {
10416 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10417 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10419 return $tags
10422 # Return the list of IDs that have heads that are descendents of id,
10423 # including id itself if it has a head.
10424 proc descheads {id} {
10425 global arcnos arcstart arcids archeads idheads cached_dheads
10426 global allparents
10428 if {![info exists allparents($id)]} {
10429 return {}
10431 set aret {}
10432 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10433 # part-way along an arc; check it first
10434 set a [lindex $arcnos($id) 0]
10435 if {$archeads($a) ne {}} {
10436 validate_archeads $a
10437 set i [lsearch -exact $arcids($a) $id]
10438 foreach t $archeads($a) {
10439 set j [lsearch -exact $arcids($a) $t]
10440 if {$j > $i} break
10441 lappend aret $t
10444 set id $arcstart($a)
10446 set origid $id
10447 set todo [list $id]
10448 set seen($id) 1
10449 set ret {}
10450 for {set i 0} {$i < [llength $todo]} {incr i} {
10451 set id [lindex $todo $i]
10452 if {[info exists cached_dheads($id)]} {
10453 set ret [concat $ret $cached_dheads($id)]
10454 } else {
10455 if {[info exists idheads($id)]} {
10456 lappend ret $id
10458 foreach a $arcnos($id) {
10459 if {$archeads($a) ne {}} {
10460 validate_archeads $a
10461 if {$archeads($a) ne {}} {
10462 set ret [concat $ret $archeads($a)]
10465 set d $arcstart($a)
10466 if {![info exists seen($d)]} {
10467 lappend todo $d
10468 set seen($d) 1
10473 set ret [lsort -unique $ret]
10474 set cached_dheads($origid) $ret
10475 return [concat $ret $aret]
10478 proc addedtag {id} {
10479 global arcnos arcout cached_dtags cached_atags
10481 if {![info exists arcnos($id)]} return
10482 if {![info exists arcout($id)]} {
10483 recalcarc [lindex $arcnos($id) 0]
10485 catch {unset cached_dtags}
10486 catch {unset cached_atags}
10489 proc addedhead {hid head} {
10490 global arcnos arcout cached_dheads
10492 if {![info exists arcnos($hid)]} return
10493 if {![info exists arcout($hid)]} {
10494 recalcarc [lindex $arcnos($hid) 0]
10496 catch {unset cached_dheads}
10499 proc removedhead {hid head} {
10500 global cached_dheads
10502 catch {unset cached_dheads}
10505 proc movedhead {hid head} {
10506 global arcnos arcout cached_dheads
10508 if {![info exists arcnos($hid)]} return
10509 if {![info exists arcout($hid)]} {
10510 recalcarc [lindex $arcnos($hid) 0]
10512 catch {unset cached_dheads}
10515 proc changedrefs {} {
10516 global cached_dheads cached_dtags cached_atags
10517 global arctags archeads arcnos arcout idheads idtags
10519 foreach id [concat [array names idheads] [array names idtags]] {
10520 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10521 set a [lindex $arcnos($id) 0]
10522 if {![info exists donearc($a)]} {
10523 recalcarc $a
10524 set donearc($a) 1
10528 catch {unset cached_dtags}
10529 catch {unset cached_atags}
10530 catch {unset cached_dheads}
10533 proc rereadrefs {} {
10534 global idtags idheads idotherrefs mainheadid
10536 set refids [concat [array names idtags] \
10537 [array names idheads] [array names idotherrefs]]
10538 foreach id $refids {
10539 if {![info exists ref($id)]} {
10540 set ref($id) [listrefs $id]
10543 set oldmainhead $mainheadid
10544 readrefs
10545 changedrefs
10546 set refids [lsort -unique [concat $refids [array names idtags] \
10547 [array names idheads] [array names idotherrefs]]]
10548 foreach id $refids {
10549 set v [listrefs $id]
10550 if {![info exists ref($id)] || $ref($id) != $v} {
10551 redrawtags $id
10554 if {$oldmainhead ne $mainheadid} {
10555 redrawtags $oldmainhead
10556 redrawtags $mainheadid
10558 run refill_reflist
10561 proc listrefs {id} {
10562 global idtags idheads idotherrefs
10564 set x {}
10565 if {[info exists idtags($id)]} {
10566 set x $idtags($id)
10568 set y {}
10569 if {[info exists idheads($id)]} {
10570 set y $idheads($id)
10572 set z {}
10573 if {[info exists idotherrefs($id)]} {
10574 set z $idotherrefs($id)
10576 return [list $x $y $z]
10579 proc showtag {tag isnew} {
10580 global ctext tagcontents tagids linknum tagobjid
10582 if {$isnew} {
10583 addtohistory [list showtag $tag 0] savectextpos
10585 $ctext conf -state normal
10586 clear_ctext
10587 settabs 0
10588 set linknum 0
10589 if {![info exists tagcontents($tag)]} {
10590 catch {
10591 set tagcontents($tag) [exec git cat-file tag $tag]
10594 if {[info exists tagcontents($tag)]} {
10595 set text $tagcontents($tag)
10596 } else {
10597 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10599 appendwithlinks $text {}
10600 maybe_scroll_ctext 1
10601 $ctext conf -state disabled
10602 init_flist {}
10605 proc doquit {} {
10606 global stopped
10607 global gitktmpdir
10609 set stopped 100
10610 savestuff .
10611 destroy .
10613 if {[info exists gitktmpdir]} {
10614 catch {file delete -force $gitktmpdir}
10618 proc mkfontdisp {font top which} {
10619 global fontattr fontpref $font NS use_ttk
10621 set fontpref($font) [set $font]
10622 ${NS}::button $top.${font}but -text $which \
10623 -command [list choosefont $font $which]
10624 ${NS}::label $top.$font -relief flat -font $font \
10625 -text $fontattr($font,family) -justify left
10626 grid x $top.${font}but $top.$font -sticky w
10629 proc choosefont {font which} {
10630 global fontparam fontlist fonttop fontattr
10631 global prefstop NS
10633 set fontparam(which) $which
10634 set fontparam(font) $font
10635 set fontparam(family) [font actual $font -family]
10636 set fontparam(size) $fontattr($font,size)
10637 set fontparam(weight) $fontattr($font,weight)
10638 set fontparam(slant) $fontattr($font,slant)
10639 set top .gitkfont
10640 set fonttop $top
10641 if {![winfo exists $top]} {
10642 font create sample
10643 eval font config sample [font actual $font]
10644 ttk_toplevel $top
10645 make_transient $top $prefstop
10646 wm title $top [mc "Gitk font chooser"]
10647 ${NS}::label $top.l -textvariable fontparam(which)
10648 pack $top.l -side top
10649 set fontlist [lsort [font families]]
10650 ${NS}::frame $top.f
10651 listbox $top.f.fam -listvariable fontlist \
10652 -yscrollcommand [list $top.f.sb set]
10653 bind $top.f.fam <<ListboxSelect>> selfontfam
10654 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10655 pack $top.f.sb -side right -fill y
10656 pack $top.f.fam -side left -fill both -expand 1
10657 pack $top.f -side top -fill both -expand 1
10658 ${NS}::frame $top.g
10659 spinbox $top.g.size -from 4 -to 40 -width 4 \
10660 -textvariable fontparam(size) \
10661 -validatecommand {string is integer -strict %s}
10662 checkbutton $top.g.bold -padx 5 \
10663 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10664 -variable fontparam(weight) -onvalue bold -offvalue normal
10665 checkbutton $top.g.ital -padx 5 \
10666 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10667 -variable fontparam(slant) -onvalue italic -offvalue roman
10668 pack $top.g.size $top.g.bold $top.g.ital -side left
10669 pack $top.g -side top
10670 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10671 -background white
10672 $top.c create text 100 25 -anchor center -text $which -font sample \
10673 -fill black -tags text
10674 bind $top.c <Configure> [list centertext $top.c]
10675 pack $top.c -side top -fill x
10676 ${NS}::frame $top.buts
10677 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10678 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10679 bind $top <Key-Return> fontok
10680 bind $top <Key-Escape> fontcan
10681 grid $top.buts.ok $top.buts.can
10682 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10683 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10684 pack $top.buts -side bottom -fill x
10685 trace add variable fontparam write chg_fontparam
10686 } else {
10687 raise $top
10688 $top.c itemconf text -text $which
10690 set i [lsearch -exact $fontlist $fontparam(family)]
10691 if {$i >= 0} {
10692 $top.f.fam selection set $i
10693 $top.f.fam see $i
10697 proc centertext {w} {
10698 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10701 proc fontok {} {
10702 global fontparam fontpref prefstop
10704 set f $fontparam(font)
10705 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10706 if {$fontparam(weight) eq "bold"} {
10707 lappend fontpref($f) "bold"
10709 if {$fontparam(slant) eq "italic"} {
10710 lappend fontpref($f) "italic"
10712 set w $prefstop.$f
10713 $w conf -text $fontparam(family) -font $fontpref($f)
10715 fontcan
10718 proc fontcan {} {
10719 global fonttop fontparam
10721 if {[info exists fonttop]} {
10722 catch {destroy $fonttop}
10723 catch {font delete sample}
10724 unset fonttop
10725 unset fontparam
10729 if {[package vsatisfies [package provide Tk] 8.6]} {
10730 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10731 # function to make use of it.
10732 proc choosefont {font which} {
10733 tk fontchooser configure -title $which -font $font \
10734 -command [list on_choosefont $font $which]
10735 tk fontchooser show
10737 proc on_choosefont {font which newfont} {
10738 global fontparam
10739 puts stderr "$font $newfont"
10740 array set f [font actual $newfont]
10741 set fontparam(which) $which
10742 set fontparam(font) $font
10743 set fontparam(family) $f(-family)
10744 set fontparam(size) $f(-size)
10745 set fontparam(weight) $f(-weight)
10746 set fontparam(slant) $f(-slant)
10747 fontok
10751 proc selfontfam {} {
10752 global fonttop fontparam
10754 set i [$fonttop.f.fam curselection]
10755 if {$i ne {}} {
10756 set fontparam(family) [$fonttop.f.fam get $i]
10760 proc chg_fontparam {v sub op} {
10761 global fontparam
10763 font config sample -$sub $fontparam($sub)
10766 proc doprefs {} {
10767 global maxwidth maxgraphpct use_ttk NS
10768 global oldprefs prefstop showneartags showlocalchanges
10769 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10770 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
10771 global hideremotes want_ttk have_ttk
10773 set top .gitkprefs
10774 set prefstop $top
10775 if {[winfo exists $top]} {
10776 raise $top
10777 return
10779 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10780 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10781 set oldprefs($v) [set $v]
10783 ttk_toplevel $top
10784 wm title $top [mc "Gitk preferences"]
10785 make_transient $top .
10786 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10787 grid $top.ldisp - -sticky w -pady 10
10788 ${NS}::label $top.spacer -text " "
10789 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10790 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10791 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10792 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10793 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10794 grid x $top.maxpctl $top.maxpct -sticky w
10795 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10796 -variable showlocalchanges
10797 grid x $top.showlocal -sticky w
10798 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1 (length)"] \
10799 -variable autoselect
10800 spinbox $top.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
10801 grid x $top.autoselect $top.autosellen -sticky w
10802 ${NS}::checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10803 -variable hideremotes
10804 grid x $top.hideremotes -sticky w
10806 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10807 grid $top.ddisp - -sticky w -pady 10
10808 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10809 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10810 grid x $top.tabstopl $top.tabstop -sticky w
10811 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10812 -variable showneartags
10813 grid x $top.ntag -sticky w
10814 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10815 -variable limitdiffs
10816 grid x $top.ldiff -sticky w
10817 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10818 -variable perfile_attrs
10819 grid x $top.lattr -sticky w
10821 ${NS}::entry $top.extdifft -textvariable extdifftool
10822 ${NS}::frame $top.extdifff
10823 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10824 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10825 pack $top.extdifff.l $top.extdifff.b -side left
10826 pack configure $top.extdifff.l -padx 10
10827 grid x $top.extdifff $top.extdifft -sticky ew
10829 ${NS}::label $top.lgen -text [mc "General options"]
10830 grid $top.lgen - -sticky w -pady 10
10831 ${NS}::checkbutton $top.want_ttk -variable want_ttk \
10832 -text [mc "Use themed widgets"]
10833 if {$have_ttk} {
10834 ${NS}::label $top.ttk_note -text [mc "(change requires restart)"]
10835 } else {
10836 ${NS}::label $top.ttk_note -text [mc "(currently unavailable)"]
10838 grid x $top.want_ttk $top.ttk_note -sticky w
10840 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10841 grid $top.cdisp - -sticky w -pady 10
10842 label $top.ui -padx 40 -relief sunk -background $uicolor
10843 ${NS}::button $top.uibut -text [mc "Interface"] \
10844 -command [list choosecolor uicolor {} $top.ui [mc "interface"] setui]
10845 grid x $top.uibut $top.ui -sticky w
10846 label $top.bg -padx 40 -relief sunk -background $bgcolor
10847 ${NS}::button $top.bgbut -text [mc "Background"] \
10848 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10849 grid x $top.bgbut $top.bg -sticky w
10850 label $top.fg -padx 40 -relief sunk -background $fgcolor
10851 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10852 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10853 grid x $top.fgbut $top.fg -sticky w
10854 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10855 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10856 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10857 [list $ctext tag conf d0 -foreground]]
10858 grid x $top.diffoldbut $top.diffold -sticky w
10859 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10860 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10861 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10862 [list $ctext tag conf dresult -foreground]]
10863 grid x $top.diffnewbut $top.diffnew -sticky w
10864 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10865 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10866 -command [list choosecolor diffcolors 2 $top.hunksep \
10867 [mc "diff hunk header"] \
10868 [list $ctext tag conf hunksep -foreground]]
10869 grid x $top.hunksepbut $top.hunksep -sticky w
10870 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10871 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10872 -command [list choosecolor markbgcolor {} $top.markbgsep \
10873 [mc "marked line background"] \
10874 [list $ctext tag conf omark -background]]
10875 grid x $top.markbgbut $top.markbgsep -sticky w
10876 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10877 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10878 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10879 grid x $top.selbgbut $top.selbgsep -sticky w
10881 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10882 grid $top.cfont - -sticky w -pady 10
10883 mkfontdisp mainfont $top [mc "Main font"]
10884 mkfontdisp textfont $top [mc "Diff display font"]
10885 mkfontdisp uifont $top [mc "User interface font"]
10887 ${NS}::frame $top.buts
10888 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10889 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10890 bind $top <Key-Return> prefsok
10891 bind $top <Key-Escape> prefscan
10892 grid $top.buts.ok $top.buts.can
10893 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10894 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10895 grid $top.buts - - -pady 10 -sticky ew
10896 grid columnconfigure $top 2 -weight 1
10897 bind $top <Visibility> "focus $top.buts.ok"
10900 proc choose_extdiff {} {
10901 global extdifftool
10903 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10904 if {$prog ne {}} {
10905 set extdifftool $prog
10909 proc choosecolor {v vi w x cmd} {
10910 global $v
10912 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10913 -title [mc "Gitk: choose color for %s" $x]]
10914 if {$c eq {}} return
10915 $w conf -background $c
10916 lset $v $vi $c
10917 eval $cmd $c
10920 proc setselbg {c} {
10921 global bglist cflist
10922 foreach w $bglist {
10923 $w configure -selectbackground $c
10925 $cflist tag configure highlight \
10926 -background [$cflist cget -selectbackground]
10927 allcanvs itemconf secsel -fill $c
10930 # This sets the background color and the color scheme for the whole UI.
10931 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
10932 # if we don't specify one ourselves, which makes the checkbuttons and
10933 # radiobuttons look bad. This chooses white for selectColor if the
10934 # background color is light, or black if it is dark.
10935 proc setui {c} {
10936 if {[tk windowingsystem] eq "win32"} { return }
10937 set bg [winfo rgb . $c]
10938 set selc black
10939 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
10940 set selc white
10942 tk_setPalette background $c selectColor $selc
10945 proc setbg {c} {
10946 global bglist
10948 foreach w $bglist {
10949 $w conf -background $c
10953 proc setfg {c} {
10954 global fglist canv
10956 foreach w $fglist {
10957 $w conf -foreground $c
10959 allcanvs itemconf text -fill $c
10960 $canv itemconf circle -outline $c
10961 $canv itemconf markid -outline $c
10964 proc prefscan {} {
10965 global oldprefs prefstop
10967 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10968 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10969 global $v
10970 set $v $oldprefs($v)
10972 catch {destroy $prefstop}
10973 unset prefstop
10974 fontcan
10977 proc prefsok {} {
10978 global maxwidth maxgraphpct
10979 global oldprefs prefstop showneartags showlocalchanges
10980 global fontpref mainfont textfont uifont
10981 global limitdiffs treediffs perfile_attrs
10982 global hideremotes
10984 catch {destroy $prefstop}
10985 unset prefstop
10986 fontcan
10987 set fontchanged 0
10988 if {$mainfont ne $fontpref(mainfont)} {
10989 set mainfont $fontpref(mainfont)
10990 parsefont mainfont $mainfont
10991 eval font configure mainfont [fontflags mainfont]
10992 eval font configure mainfontbold [fontflags mainfont 1]
10993 setcoords
10994 set fontchanged 1
10996 if {$textfont ne $fontpref(textfont)} {
10997 set textfont $fontpref(textfont)
10998 parsefont textfont $textfont
10999 eval font configure textfont [fontflags textfont]
11000 eval font configure textfontbold [fontflags textfont 1]
11002 if {$uifont ne $fontpref(uifont)} {
11003 set uifont $fontpref(uifont)
11004 parsefont uifont $uifont
11005 eval font configure uifont [fontflags uifont]
11007 settabs
11008 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11009 if {$showlocalchanges} {
11010 doshowlocalchanges
11011 } else {
11012 dohidelocalchanges
11015 if {$limitdiffs != $oldprefs(limitdiffs) ||
11016 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11017 # treediffs elements are limited by path;
11018 # won't have encodings cached if perfile_attrs was just turned on
11019 catch {unset treediffs}
11021 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11022 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11023 redisplay
11024 } elseif {$showneartags != $oldprefs(showneartags) ||
11025 $limitdiffs != $oldprefs(limitdiffs)} {
11026 reselectline
11028 if {$hideremotes != $oldprefs(hideremotes)} {
11029 rereadrefs
11033 proc formatdate {d} {
11034 global datetimeformat
11035 if {$d ne {}} {
11036 set d [clock format [lindex $d 0] -format $datetimeformat]
11038 return $d
11041 # This list of encoding names and aliases is distilled from
11042 # http://www.iana.org/assignments/character-sets.
11043 # Not all of them are supported by Tcl.
11044 set encoding_aliases {
11045 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11046 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11047 { ISO-10646-UTF-1 csISO10646UTF1 }
11048 { ISO_646.basic:1983 ref csISO646basic1983 }
11049 { INVARIANT csINVARIANT }
11050 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11051 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11052 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11053 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11054 { NATS-DANO iso-ir-9-1 csNATSDANO }
11055 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11056 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11057 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11058 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11059 { ISO-2022-KR csISO2022KR }
11060 { EUC-KR csEUCKR }
11061 { ISO-2022-JP csISO2022JP }
11062 { ISO-2022-JP-2 csISO2022JP2 }
11063 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11064 csISO13JISC6220jp }
11065 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11066 { IT iso-ir-15 ISO646-IT csISO15Italian }
11067 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11068 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11069 { greek7-old iso-ir-18 csISO18Greek7Old }
11070 { latin-greek iso-ir-19 csISO19LatinGreek }
11071 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11072 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11073 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11074 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11075 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11076 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11077 { INIS iso-ir-49 csISO49INIS }
11078 { INIS-8 iso-ir-50 csISO50INIS8 }
11079 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11080 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11081 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11082 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11083 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11084 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11085 csISO60Norwegian1 }
11086 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11087 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11088 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11089 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11090 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11091 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11092 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11093 { greek7 iso-ir-88 csISO88Greek7 }
11094 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11095 { iso-ir-90 csISO90 }
11096 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11097 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11098 csISO92JISC62991984b }
11099 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11100 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11101 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11102 csISO95JIS62291984handadd }
11103 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11104 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11105 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11106 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11107 CP819 csISOLatin1 }
11108 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11109 { T.61-7bit iso-ir-102 csISO102T617bit }
11110 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11111 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11112 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11113 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11114 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11115 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11116 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11117 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11118 arabic csISOLatinArabic }
11119 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11120 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11121 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11122 greek greek8 csISOLatinGreek }
11123 { T.101-G2 iso-ir-128 csISO128T101G2 }
11124 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11125 csISOLatinHebrew }
11126 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11127 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11128 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11129 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11130 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11131 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11132 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11133 csISOLatinCyrillic }
11134 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11135 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11136 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11137 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11138 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11139 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11140 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11141 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11142 { ISO_10367-box iso-ir-155 csISO10367Box }
11143 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11144 { latin-lap lap iso-ir-158 csISO158Lap }
11145 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11146 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11147 { us-dk csUSDK }
11148 { dk-us csDKUS }
11149 { JIS_X0201 X0201 csHalfWidthKatakana }
11150 { KSC5636 ISO646-KR csKSC5636 }
11151 { ISO-10646-UCS-2 csUnicode }
11152 { ISO-10646-UCS-4 csUCS4 }
11153 { DEC-MCS dec csDECMCS }
11154 { hp-roman8 roman8 r8 csHPRoman8 }
11155 { macintosh mac csMacintosh }
11156 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11157 csIBM037 }
11158 { IBM038 EBCDIC-INT cp038 csIBM038 }
11159 { IBM273 CP273 csIBM273 }
11160 { IBM274 EBCDIC-BE CP274 csIBM274 }
11161 { IBM275 EBCDIC-BR cp275 csIBM275 }
11162 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11163 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11164 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11165 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11166 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11167 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11168 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11169 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11170 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11171 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11172 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11173 { IBM437 cp437 437 csPC8CodePage437 }
11174 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11175 { IBM775 cp775 csPC775Baltic }
11176 { IBM850 cp850 850 csPC850Multilingual }
11177 { IBM851 cp851 851 csIBM851 }
11178 { IBM852 cp852 852 csPCp852 }
11179 { IBM855 cp855 855 csIBM855 }
11180 { IBM857 cp857 857 csIBM857 }
11181 { IBM860 cp860 860 csIBM860 }
11182 { IBM861 cp861 861 cp-is csIBM861 }
11183 { IBM862 cp862 862 csPC862LatinHebrew }
11184 { IBM863 cp863 863 csIBM863 }
11185 { IBM864 cp864 csIBM864 }
11186 { IBM865 cp865 865 csIBM865 }
11187 { IBM866 cp866 866 csIBM866 }
11188 { IBM868 CP868 cp-ar csIBM868 }
11189 { IBM869 cp869 869 cp-gr csIBM869 }
11190 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11191 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11192 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11193 { IBM891 cp891 csIBM891 }
11194 { IBM903 cp903 csIBM903 }
11195 { IBM904 cp904 904 csIBBM904 }
11196 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11197 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11198 { IBM1026 CP1026 csIBM1026 }
11199 { EBCDIC-AT-DE csIBMEBCDICATDE }
11200 { EBCDIC-AT-DE-A csEBCDICATDEA }
11201 { EBCDIC-CA-FR csEBCDICCAFR }
11202 { EBCDIC-DK-NO csEBCDICDKNO }
11203 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11204 { EBCDIC-FI-SE csEBCDICFISE }
11205 { EBCDIC-FI-SE-A csEBCDICFISEA }
11206 { EBCDIC-FR csEBCDICFR }
11207 { EBCDIC-IT csEBCDICIT }
11208 { EBCDIC-PT csEBCDICPT }
11209 { EBCDIC-ES csEBCDICES }
11210 { EBCDIC-ES-A csEBCDICESA }
11211 { EBCDIC-ES-S csEBCDICESS }
11212 { EBCDIC-UK csEBCDICUK }
11213 { EBCDIC-US csEBCDICUS }
11214 { UNKNOWN-8BIT csUnknown8BiT }
11215 { MNEMONIC csMnemonic }
11216 { MNEM csMnem }
11217 { VISCII csVISCII }
11218 { VIQR csVIQR }
11219 { KOI8-R csKOI8R }
11220 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11221 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11222 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11223 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11224 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11225 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11226 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11227 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11228 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11229 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11230 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11231 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11232 { IBM1047 IBM-1047 }
11233 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11234 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11235 { UNICODE-1-1 csUnicode11 }
11236 { CESU-8 csCESU-8 }
11237 { BOCU-1 csBOCU-1 }
11238 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11239 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11240 l8 }
11241 { ISO-8859-15 ISO_8859-15 Latin-9 }
11242 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11243 { GBK CP936 MS936 windows-936 }
11244 { JIS_Encoding csJISEncoding }
11245 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11246 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11247 EUC-JP }
11248 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11249 { ISO-10646-UCS-Basic csUnicodeASCII }
11250 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11251 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11252 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11253 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11254 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11255 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11256 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11257 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11258 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11259 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11260 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11261 { Ventura-US csVenturaUS }
11262 { Ventura-International csVenturaInternational }
11263 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11264 { PC8-Turkish csPC8Turkish }
11265 { IBM-Symbols csIBMSymbols }
11266 { IBM-Thai csIBMThai }
11267 { HP-Legal csHPLegal }
11268 { HP-Pi-font csHPPiFont }
11269 { HP-Math8 csHPMath8 }
11270 { Adobe-Symbol-Encoding csHPPSMath }
11271 { HP-DeskTop csHPDesktop }
11272 { Ventura-Math csVenturaMath }
11273 { Microsoft-Publishing csMicrosoftPublishing }
11274 { Windows-31J csWindows31J }
11275 { GB2312 csGB2312 }
11276 { Big5 csBig5 }
11279 proc tcl_encoding {enc} {
11280 global encoding_aliases tcl_encoding_cache
11281 if {[info exists tcl_encoding_cache($enc)]} {
11282 return $tcl_encoding_cache($enc)
11284 set names [encoding names]
11285 set lcnames [string tolower $names]
11286 set enc [string tolower $enc]
11287 set i [lsearch -exact $lcnames $enc]
11288 if {$i < 0} {
11289 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11290 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11291 set i [lsearch -exact $lcnames $encx]
11294 if {$i < 0} {
11295 foreach l $encoding_aliases {
11296 set ll [string tolower $l]
11297 if {[lsearch -exact $ll $enc] < 0} continue
11298 # look through the aliases for one that tcl knows about
11299 foreach e $ll {
11300 set i [lsearch -exact $lcnames $e]
11301 if {$i < 0} {
11302 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11303 set i [lsearch -exact $lcnames $ex]
11306 if {$i >= 0} break
11308 break
11311 set tclenc {}
11312 if {$i >= 0} {
11313 set tclenc [lindex $names $i]
11315 set tcl_encoding_cache($enc) $tclenc
11316 return $tclenc
11319 proc gitattr {path attr default} {
11320 global path_attr_cache
11321 if {[info exists path_attr_cache($attr,$path)]} {
11322 set r $path_attr_cache($attr,$path)
11323 } else {
11324 set r "unspecified"
11325 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11326 regexp "(.*): $attr: (.*)" $line m f r
11328 set path_attr_cache($attr,$path) $r
11330 if {$r eq "unspecified"} {
11331 return $default
11333 return $r
11336 proc cache_gitattr {attr pathlist} {
11337 global path_attr_cache
11338 set newlist {}
11339 foreach path $pathlist {
11340 if {![info exists path_attr_cache($attr,$path)]} {
11341 lappend newlist $path
11344 set lim 1000
11345 if {[tk windowingsystem] == "win32"} {
11346 # windows has a 32k limit on the arguments to a command...
11347 set lim 30
11349 while {$newlist ne {}} {
11350 set head [lrange $newlist 0 [expr {$lim - 1}]]
11351 set newlist [lrange $newlist $lim end]
11352 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11353 foreach row [split $rlist "\n"] {
11354 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11355 if {[string index $path 0] eq "\""} {
11356 set path [encoding convertfrom [lindex $path 0]]
11358 set path_attr_cache($attr,$path) $value
11365 proc get_path_encoding {path} {
11366 global gui_encoding perfile_attrs
11367 set tcl_enc $gui_encoding
11368 if {$path ne {} && $perfile_attrs} {
11369 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11370 if {$enc2 ne {}} {
11371 set tcl_enc $enc2
11374 return $tcl_enc
11377 # First check that Tcl/Tk is recent enough
11378 if {[catch {package require Tk 8.4} err]} {
11379 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11380 Gitk requires at least Tcl/Tk 8.4." list
11381 exit 1
11384 # defaults...
11385 set wrcomcmd "git diff-tree --stdin -p --pretty"
11387 set gitencoding {}
11388 catch {
11389 set gitencoding [exec git config --get i18n.commitencoding]
11391 catch {
11392 set gitencoding [exec git config --get i18n.logoutputencoding]
11394 if {$gitencoding == ""} {
11395 set gitencoding "utf-8"
11397 set tclencoding [tcl_encoding $gitencoding]
11398 if {$tclencoding == {}} {
11399 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11402 set gui_encoding [encoding system]
11403 catch {
11404 set enc [exec git config --get gui.encoding]
11405 if {$enc ne {}} {
11406 set tclenc [tcl_encoding $enc]
11407 if {$tclenc ne {}} {
11408 set gui_encoding $tclenc
11409 } else {
11410 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11415 if {[tk windowingsystem] eq "aqua"} {
11416 set mainfont {{Lucida Grande} 9}
11417 set textfont {Monaco 9}
11418 set uifont {{Lucida Grande} 9 bold}
11419 } else {
11420 set mainfont {Helvetica 9}
11421 set textfont {Courier 9}
11422 set uifont {Helvetica 9 bold}
11424 set tabstop 8
11425 set findmergefiles 0
11426 set maxgraphpct 50
11427 set maxwidth 16
11428 set revlistorder 0
11429 set fastdate 0
11430 set uparrowlen 5
11431 set downarrowlen 5
11432 set mingaplen 100
11433 set cmitmode "patch"
11434 set wrapcomment "none"
11435 set showneartags 1
11436 set hideremotes 0
11437 set maxrefs 20
11438 set maxlinelen 200
11439 set showlocalchanges 1
11440 set limitdiffs 1
11441 set datetimeformat "%Y-%m-%d %H:%M:%S"
11442 set autoselect 1
11443 set autosellen 40
11444 set perfile_attrs 0
11445 set want_ttk 1
11447 if {[tk windowingsystem] eq "aqua"} {
11448 set extdifftool "opendiff"
11449 } else {
11450 set extdifftool "meld"
11453 set colors {green red blue magenta darkgrey brown orange}
11454 if {[tk windowingsystem] eq "win32"} {
11455 set uicolor SystemButtonFace
11456 set bgcolor SystemWindow
11457 set fgcolor SystemButtonText
11458 set selectbgcolor SystemHighlight
11459 } else {
11460 set uicolor grey85
11461 set bgcolor white
11462 set fgcolor black
11463 set selectbgcolor gray85
11465 set diffcolors {red "#00a000" blue}
11466 set diffcontext 3
11467 set ignorespace 0
11468 set worddiff ""
11469 set markbgcolor "#e0e0ff"
11471 set circlecolors {white blue gray blue blue}
11473 # button for popping up context menus
11474 if {[tk windowingsystem] eq "aqua"} {
11475 set ctxbut <Button-2>
11476 } else {
11477 set ctxbut <Button-3>
11480 ## For msgcat loading, first locate the installation location.
11481 if { [info exists ::env(GITK_MSGSDIR)] } {
11482 ## Msgsdir was manually set in the environment.
11483 set gitk_msgsdir $::env(GITK_MSGSDIR)
11484 } else {
11485 ## Let's guess the prefix from argv0.
11486 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11487 set gitk_libdir [file join $gitk_prefix share gitk lib]
11488 set gitk_msgsdir [file join $gitk_libdir msgs]
11489 unset gitk_prefix
11492 ## Internationalization (i18n) through msgcat and gettext. See
11493 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11494 package require msgcat
11495 namespace import ::msgcat::mc
11496 ## And eventually load the actual message catalog
11497 ::msgcat::mcload $gitk_msgsdir
11499 catch {source ~/.gitk}
11501 parsefont mainfont $mainfont
11502 eval font create mainfont [fontflags mainfont]
11503 eval font create mainfontbold [fontflags mainfont 1]
11505 parsefont textfont $textfont
11506 eval font create textfont [fontflags textfont]
11507 eval font create textfontbold [fontflags textfont 1]
11509 parsefont uifont $uifont
11510 eval font create uifont [fontflags uifont]
11512 setui $uicolor
11514 setoptions
11516 # check that we can find a .git directory somewhere...
11517 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
11518 show_error {} . [mc "Cannot find a git repository here."]
11519 exit 1
11522 set selecthead {}
11523 set selectheadid {}
11525 set revtreeargs {}
11526 set cmdline_files {}
11527 set i 0
11528 set revtreeargscmd {}
11529 foreach arg $argv {
11530 switch -glob -- $arg {
11531 "" { }
11532 "--" {
11533 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11534 break
11536 "--select-commit=*" {
11537 set selecthead [string range $arg 16 end]
11539 "--argscmd=*" {
11540 set revtreeargscmd [string range $arg 10 end]
11542 default {
11543 lappend revtreeargs $arg
11546 incr i
11549 if {$selecthead eq "HEAD"} {
11550 set selecthead {}
11553 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11554 # no -- on command line, but some arguments (other than --argscmd)
11555 if {[catch {
11556 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11557 set cmdline_files [split $f "\n"]
11558 set n [llength $cmdline_files]
11559 set revtreeargs [lrange $revtreeargs 0 end-$n]
11560 # Unfortunately git rev-parse doesn't produce an error when
11561 # something is both a revision and a filename. To be consistent
11562 # with git log and git rev-list, check revtreeargs for filenames.
11563 foreach arg $revtreeargs {
11564 if {[file exists $arg]} {
11565 show_error {} . [mc "Ambiguous argument '%s': both revision\
11566 and filename" $arg]
11567 exit 1
11570 } err]} {
11571 # unfortunately we get both stdout and stderr in $err,
11572 # so look for "fatal:".
11573 set i [string first "fatal:" $err]
11574 if {$i > 0} {
11575 set err [string range $err [expr {$i + 6}] end]
11577 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11578 exit 1
11582 set nullid "0000000000000000000000000000000000000000"
11583 set nullid2 "0000000000000000000000000000000000000001"
11584 set nullfile "/dev/null"
11586 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11587 if {![info exists have_ttk]} {
11588 set have_ttk [llength [info commands ::ttk::style]]
11590 set use_ttk [expr {$have_ttk && $want_ttk}]
11591 set NS [expr {$use_ttk ? "ttk" : ""}]
11593 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
11595 set show_notes {}
11596 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
11597 set show_notes "--show-notes"
11600 set runq {}
11601 set history {}
11602 set historyindex 0
11603 set fh_serial 0
11604 set nhl_names {}
11605 set highlight_paths {}
11606 set findpattern {}
11607 set searchdirn -forwards
11608 set boldids {}
11609 set boldnameids {}
11610 set diffelide {0 0}
11611 set markingmatches 0
11612 set linkentercount 0
11613 set need_redisplay 0
11614 set nrows_drawn 0
11615 set firsttabstop 0
11617 set nextviewnum 1
11618 set curview 0
11619 set selectedview 0
11620 set selectedhlview [mc "None"]
11621 set highlight_related [mc "None"]
11622 set highlight_files {}
11623 set viewfiles(0) {}
11624 set viewperm(0) 0
11625 set viewargs(0) {}
11626 set viewargscmd(0) {}
11628 set selectedline {}
11629 set numcommits 0
11630 set loginstance 0
11631 set cmdlineok 0
11632 set stopped 0
11633 set stuffsaved 0
11634 set patchnum 0
11635 set lserial 0
11636 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11637 set cdup {}
11638 if {$isworktree} {
11639 set cdup [exec git rev-parse --show-cdup]
11641 set worktree [exec git rev-parse --show-toplevel]
11642 setcoords
11643 makewindow
11644 catch {
11645 image create photo gitlogo -width 16 -height 16
11647 image create photo gitlogominus -width 4 -height 2
11648 gitlogominus put #C00000 -to 0 0 4 2
11649 gitlogo copy gitlogominus -to 1 5
11650 gitlogo copy gitlogominus -to 6 5
11651 gitlogo copy gitlogominus -to 11 5
11652 image delete gitlogominus
11654 image create photo gitlogoplus -width 4 -height 4
11655 gitlogoplus put #008000 -to 1 0 3 4
11656 gitlogoplus put #008000 -to 0 1 4 3
11657 gitlogo copy gitlogoplus -to 1 9
11658 gitlogo copy gitlogoplus -to 6 9
11659 gitlogo copy gitlogoplus -to 11 9
11660 image delete gitlogoplus
11662 image create photo gitlogo32 -width 32 -height 32
11663 gitlogo32 copy gitlogo -zoom 2 2
11665 wm iconphoto . -default gitlogo gitlogo32
11667 # wait for the window to become visible
11668 tkwait visibility .
11669 wm title . "[file tail $argv0]: [file tail [pwd]]"
11670 update
11671 readrefs
11673 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11674 # create a view for the files/dirs specified on the command line
11675 set curview 1
11676 set selectedview 1
11677 set nextviewnum 2
11678 set viewname(1) [mc "Command line"]
11679 set viewfiles(1) $cmdline_files
11680 set viewargs(1) $revtreeargs
11681 set viewargscmd(1) $revtreeargscmd
11682 set viewperm(1) 0
11683 set vdatemode(1) 0
11684 addviewmenu 1
11685 .bar.view entryconf [mca "Edit view..."] -state normal
11686 .bar.view entryconf [mca "Delete view"] -state normal
11689 if {[info exists permviews]} {
11690 foreach v $permviews {
11691 set n $nextviewnum
11692 incr nextviewnum
11693 set viewname($n) [lindex $v 0]
11694 set viewfiles($n) [lindex $v 1]
11695 set viewargs($n) [lindex $v 2]
11696 set viewargscmd($n) [lindex $v 3]
11697 set viewperm($n) 1
11698 addviewmenu $n
11702 if {[tk windowingsystem] eq "win32"} {
11703 focus -force .
11706 getcommits {}
11708 # Local variables:
11709 # mode: tcl
11710 # indent-tabs-mode: t
11711 # tab-width: 8
11712 # End: