send-pack: demultiplex a sideband stream with status data
[git.git] / gitk-git / gitk
blob364c7a84cbcf923deb72c2a91b4ec5f5d75bf4c3
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2009 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 package require Tk
12 proc gitdir {} {
13 global env
14 if {[info exists env(GIT_DIR)]} {
15 return $env(GIT_DIR)
16 } else {
17 return [exec git rev-parse --git-dir]
21 # A simple scheduler for compute-intensive stuff.
22 # The aim is to make sure that event handlers for GUI actions can
23 # run at least every 50-100 ms. Unfortunately fileevent handlers are
24 # run before X event handlers, so reading from a fast source can
25 # make the GUI completely unresponsive.
26 proc run args {
27 global isonrunq runq currunq
29 set script $args
30 if {[info exists isonrunq($script)]} return
31 if {$runq eq {} && ![info exists currunq]} {
32 after idle dorunq
34 lappend runq [list {} $script]
35 set isonrunq($script) 1
38 proc filerun {fd script} {
39 fileevent $fd readable [list filereadable $fd $script]
42 proc filereadable {fd script} {
43 global runq currunq
45 fileevent $fd readable {}
46 if {$runq eq {} && ![info exists currunq]} {
47 after idle dorunq
49 lappend runq [list $fd $script]
52 proc nukefile {fd} {
53 global runq
55 for {set i 0} {$i < [llength $runq]} {} {
56 if {[lindex $runq $i 0] eq $fd} {
57 set runq [lreplace $runq $i $i]
58 } else {
59 incr i
64 proc dorunq {} {
65 global isonrunq runq currunq
67 set tstart [clock clicks -milliseconds]
68 set t0 $tstart
69 while {[llength $runq] > 0} {
70 set fd [lindex $runq 0 0]
71 set script [lindex $runq 0 1]
72 set currunq [lindex $runq 0]
73 set runq [lrange $runq 1 end]
74 set repeat [eval $script]
75 unset currunq
76 set t1 [clock clicks -milliseconds]
77 set t [expr {$t1 - $t0}]
78 if {$repeat ne {} && $repeat} {
79 if {$fd eq {} || $repeat == 2} {
80 # script returns 1 if it wants to be readded
81 # file readers return 2 if they could do more straight away
82 lappend runq [list $fd $script]
83 } else {
84 fileevent $fd readable [list filereadable $fd $script]
86 } elseif {$fd eq {}} {
87 unset isonrunq($script)
89 set t0 $t1
90 if {$t1 - $tstart >= 80} break
92 if {$runq ne {}} {
93 after idle dorunq
97 proc reg_instance {fd} {
98 global commfd leftover loginstance
100 set i [incr loginstance]
101 set commfd($i) $fd
102 set leftover($i) {}
103 return $i
106 proc unmerged_files {files} {
107 global nr_unmerged
109 # find the list of unmerged files
110 set mlist {}
111 set nr_unmerged 0
112 if {[catch {
113 set fd [open "| git ls-files -u" r]
114 } err]} {
115 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
116 exit 1
118 while {[gets $fd line] >= 0} {
119 set i [string first "\t" $line]
120 if {$i < 0} continue
121 set fname [string range $line [expr {$i+1}] end]
122 if {[lsearch -exact $mlist $fname] >= 0} continue
123 incr nr_unmerged
124 if {$files eq {} || [path_filter $files $fname]} {
125 lappend mlist $fname
128 catch {close $fd}
129 return $mlist
132 proc parseviewargs {n arglist} {
133 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
135 set vdatemode($n) 0
136 set vmergeonly($n) 0
137 set glflags {}
138 set diffargs {}
139 set nextisval 0
140 set revargs {}
141 set origargs $arglist
142 set allknown 1
143 set filtered 0
144 set i -1
145 foreach arg $arglist {
146 incr i
147 if {$nextisval} {
148 lappend glflags $arg
149 set nextisval 0
150 continue
152 switch -glob -- $arg {
153 "-d" -
154 "--date-order" {
155 set vdatemode($n) 1
156 # remove from origargs in case we hit an unknown option
157 set origargs [lreplace $origargs $i $i]
158 incr i -1
160 "-[puabwcrRBMC]" -
161 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165 "--ignore-space-change" - "-U*" - "--unified=*" {
166 # These request or affect diff output, which we don't want.
167 # Some could be used to set our defaults for diff display.
168 lappend diffargs $arg
170 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171 "--name-only" - "--name-status" - "--color" - "--color-words" -
172 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176 "--objects" - "--objects-edge" - "--reverse" {
177 # These cause our parsing of git log's output to fail, or else
178 # they're options we want to set ourselves, so ignore them.
180 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
181 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
182 "--full-history" - "--dense" - "--sparse" -
183 "--follow" - "--left-right" - "--encoding=*" {
184 # These are harmless, and some are even useful
185 lappend glflags $arg
187 "--diff-filter=*" - "--no-merges" - "--unpacked" -
188 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
189 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
190 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
191 "--remove-empty" - "--first-parent" - "--cherry-pick" -
192 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
193 "--simplify-by-decoration" {
194 # These mean that we get a subset of the commits
195 set filtered 1
196 lappend glflags $arg
198 "-n" {
199 # This appears to be the only one that has a value as a
200 # separate word following it
201 set filtered 1
202 set nextisval 1
203 lappend glflags $arg
205 "--not" - "--all" {
206 lappend revargs $arg
208 "--merge" {
209 set vmergeonly($n) 1
210 # git rev-parse doesn't understand --merge
211 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
213 "-*" {
214 # Other flag arguments including -<n>
215 if {[string is digit -strict [string range $arg 1 end]]} {
216 set filtered 1
217 } else {
218 # a flag argument that we don't recognize;
219 # that means we can't optimize
220 set allknown 0
222 lappend glflags $arg
224 default {
225 # Non-flag arguments specify commits or ranges of commits
226 if {[string match "*...*" $arg]} {
227 lappend revargs --gitk-symmetric-diff-marker
229 lappend revargs $arg
233 set vdflags($n) $diffargs
234 set vflags($n) $glflags
235 set vrevs($n) $revargs
236 set vfiltered($n) $filtered
237 set vorigargs($n) $origargs
238 return $allknown
241 proc parseviewrevs {view revs} {
242 global vposids vnegids
244 if {$revs eq {}} {
245 set revs HEAD
247 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
248 # we get stdout followed by stderr in $err
249 # for an unknown rev, git rev-parse echoes it and then errors out
250 set errlines [split $err "\n"]
251 set badrev {}
252 for {set l 0} {$l < [llength $errlines]} {incr l} {
253 set line [lindex $errlines $l]
254 if {!([string length $line] == 40 && [string is xdigit $line])} {
255 if {[string match "fatal:*" $line]} {
256 if {[string match "fatal: ambiguous argument*" $line]
257 && $badrev ne {}} {
258 if {[llength $badrev] == 1} {
259 set err "unknown revision $badrev"
260 } else {
261 set err "unknown revisions: [join $badrev ", "]"
263 } else {
264 set err [join [lrange $errlines $l end] "\n"]
266 break
268 lappend badrev $line
271 error_popup "[mc "Error parsing revisions:"] $err"
272 return {}
274 set ret {}
275 set pos {}
276 set neg {}
277 set sdm 0
278 foreach id [split $ids "\n"] {
279 if {$id eq "--gitk-symmetric-diff-marker"} {
280 set sdm 4
281 } elseif {[string match "^*" $id]} {
282 if {$sdm != 1} {
283 lappend ret $id
284 if {$sdm == 3} {
285 set sdm 0
288 lappend neg [string range $id 1 end]
289 } else {
290 if {$sdm != 2} {
291 lappend ret $id
292 } else {
293 lset ret end $id...[lindex $ret end]
295 lappend pos $id
297 incr sdm -1
299 set vposids($view) $pos
300 set vnegids($view) $neg
301 return $ret
304 # Start off a git log process and arrange to read its output
305 proc start_rev_list {view} {
306 global startmsecs commitidx viewcomplete curview
307 global tclencoding
308 global viewargs viewargscmd viewfiles vfilelimit
309 global showlocalchanges
310 global viewactive viewinstances vmergeonly
311 global mainheadid viewmainheadid viewmainheadid_orig
312 global vcanopt vflags vrevs vorigargs
314 set startmsecs [clock clicks -milliseconds]
315 set commitidx($view) 0
316 # these are set this way for the error exits
317 set viewcomplete($view) 1
318 set viewactive($view) 0
319 varcinit $view
321 set args $viewargs($view)
322 if {$viewargscmd($view) ne {}} {
323 if {[catch {
324 set str [exec sh -c $viewargscmd($view)]
325 } err]} {
326 error_popup "[mc "Error executing --argscmd command:"] $err"
327 return 0
329 set args [concat $args [split $str "\n"]]
331 set vcanopt($view) [parseviewargs $view $args]
333 set files $viewfiles($view)
334 if {$vmergeonly($view)} {
335 set files [unmerged_files $files]
336 if {$files eq {}} {
337 global nr_unmerged
338 if {$nr_unmerged == 0} {
339 error_popup [mc "No files selected: --merge specified but\
340 no files are unmerged."]
341 } else {
342 error_popup [mc "No files selected: --merge specified but\
343 no unmerged files are within file limit."]
345 return 0
348 set vfilelimit($view) $files
350 if {$vcanopt($view)} {
351 set revs [parseviewrevs $view $vrevs($view)]
352 if {$revs eq {}} {
353 return 0
355 set args [concat $vflags($view) $revs]
356 } else {
357 set args $vorigargs($view)
360 if {[catch {
361 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
362 --boundary $args "--" $files] r]
363 } err]} {
364 error_popup "[mc "Error executing git log:"] $err"
365 return 0
367 set i [reg_instance $fd]
368 set viewinstances($view) [list $i]
369 set viewmainheadid($view) $mainheadid
370 set viewmainheadid_orig($view) $mainheadid
371 if {$files ne {} && $mainheadid ne {}} {
372 get_viewmainhead $view
374 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
375 interestedin $viewmainheadid($view) dodiffindex
377 fconfigure $fd -blocking 0 -translation lf -eofchar {}
378 if {$tclencoding != {}} {
379 fconfigure $fd -encoding $tclencoding
381 filerun $fd [list getcommitlines $fd $i $view 0]
382 nowbusy $view [mc "Reading"]
383 set viewcomplete($view) 0
384 set viewactive($view) 1
385 return 1
388 proc stop_instance {inst} {
389 global commfd leftover
391 set fd $commfd($inst)
392 catch {
393 set pid [pid $fd]
395 if {$::tcl_platform(platform) eq {windows}} {
396 exec kill -f $pid
397 } else {
398 exec kill $pid
401 catch {close $fd}
402 nukefile $fd
403 unset commfd($inst)
404 unset leftover($inst)
407 proc stop_backends {} {
408 global commfd
410 foreach inst [array names commfd] {
411 stop_instance $inst
415 proc stop_rev_list {view} {
416 global viewinstances
418 foreach inst $viewinstances($view) {
419 stop_instance $inst
421 set viewinstances($view) {}
424 proc reset_pending_select {selid} {
425 global pending_select mainheadid selectheadid
427 if {$selid ne {}} {
428 set pending_select $selid
429 } elseif {$selectheadid ne {}} {
430 set pending_select $selectheadid
431 } else {
432 set pending_select $mainheadid
436 proc getcommits {selid} {
437 global canv curview need_redisplay viewactive
439 initlayout
440 if {[start_rev_list $curview]} {
441 reset_pending_select $selid
442 show_status [mc "Reading commits..."]
443 set need_redisplay 1
444 } else {
445 show_status [mc "No commits selected"]
449 proc updatecommits {} {
450 global curview vcanopt vorigargs vfilelimit viewinstances
451 global viewactive viewcomplete tclencoding
452 global startmsecs showneartags showlocalchanges
453 global mainheadid viewmainheadid viewmainheadid_orig pending_select
454 global isworktree
455 global varcid vposids vnegids vflags vrevs
457 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
458 rereadrefs
459 set view $curview
460 if {$mainheadid ne $viewmainheadid_orig($view)} {
461 if {$showlocalchanges} {
462 dohidelocalchanges
464 set viewmainheadid($view) $mainheadid
465 set viewmainheadid_orig($view) $mainheadid
466 if {$vfilelimit($view) ne {}} {
467 get_viewmainhead $view
470 if {$showlocalchanges} {
471 doshowlocalchanges
473 if {$vcanopt($view)} {
474 set oldpos $vposids($view)
475 set oldneg $vnegids($view)
476 set revs [parseviewrevs $view $vrevs($view)]
477 if {$revs eq {}} {
478 return
480 # note: getting the delta when negative refs change is hard,
481 # and could require multiple git log invocations, so in that
482 # case we ask git log for all the commits (not just the delta)
483 if {$oldneg eq $vnegids($view)} {
484 set newrevs {}
485 set npos 0
486 # take out positive refs that we asked for before or
487 # that we have already seen
488 foreach rev $revs {
489 if {[string length $rev] == 40} {
490 if {[lsearch -exact $oldpos $rev] < 0
491 && ![info exists varcid($view,$rev)]} {
492 lappend newrevs $rev
493 incr npos
495 } else {
496 lappend $newrevs $rev
499 if {$npos == 0} return
500 set revs $newrevs
501 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
503 set args [concat $vflags($view) $revs --not $oldpos]
504 } else {
505 set args $vorigargs($view)
507 if {[catch {
508 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
509 --boundary $args "--" $vfilelimit($view)] r]
510 } err]} {
511 error_popup "[mc "Error executing git log:"] $err"
512 return
514 if {$viewactive($view) == 0} {
515 set startmsecs [clock clicks -milliseconds]
517 set i [reg_instance $fd]
518 lappend viewinstances($view) $i
519 fconfigure $fd -blocking 0 -translation lf -eofchar {}
520 if {$tclencoding != {}} {
521 fconfigure $fd -encoding $tclencoding
523 filerun $fd [list getcommitlines $fd $i $view 1]
524 incr viewactive($view)
525 set viewcomplete($view) 0
526 reset_pending_select {}
527 nowbusy $view [mc "Reading"]
528 if {$showneartags} {
529 getallcommits
533 proc reloadcommits {} {
534 global curview viewcomplete selectedline currentid thickerline
535 global showneartags treediffs commitinterest cached_commitrow
536 global targetid
538 set selid {}
539 if {$selectedline ne {}} {
540 set selid $currentid
543 if {!$viewcomplete($curview)} {
544 stop_rev_list $curview
546 resetvarcs $curview
547 set selectedline {}
548 catch {unset currentid}
549 catch {unset thickerline}
550 catch {unset treediffs}
551 readrefs
552 changedrefs
553 if {$showneartags} {
554 getallcommits
556 clear_display
557 catch {unset commitinterest}
558 catch {unset cached_commitrow}
559 catch {unset targetid}
560 setcanvscroll
561 getcommits $selid
562 return 0
565 # This makes a string representation of a positive integer which
566 # sorts as a string in numerical order
567 proc strrep {n} {
568 if {$n < 16} {
569 return [format "%x" $n]
570 } elseif {$n < 256} {
571 return [format "x%.2x" $n]
572 } elseif {$n < 65536} {
573 return [format "y%.4x" $n]
575 return [format "z%.8x" $n]
578 # Procedures used in reordering commits from git log (without
579 # --topo-order) into the order for display.
581 proc varcinit {view} {
582 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
583 global vtokmod varcmod vrowmod varcix vlastins
585 set varcstart($view) {{}}
586 set vupptr($view) {0}
587 set vdownptr($view) {0}
588 set vleftptr($view) {0}
589 set vbackptr($view) {0}
590 set varctok($view) {{}}
591 set varcrow($view) {{}}
592 set vtokmod($view) {}
593 set varcmod($view) 0
594 set vrowmod($view) 0
595 set varcix($view) {{}}
596 set vlastins($view) {0}
599 proc resetvarcs {view} {
600 global varcid varccommits parents children vseedcount ordertok
602 foreach vid [array names varcid $view,*] {
603 unset varcid($vid)
604 unset children($vid)
605 unset parents($vid)
607 # some commits might have children but haven't been seen yet
608 foreach vid [array names children $view,*] {
609 unset children($vid)
611 foreach va [array names varccommits $view,*] {
612 unset varccommits($va)
614 foreach vd [array names vseedcount $view,*] {
615 unset vseedcount($vd)
617 catch {unset ordertok}
620 # returns a list of the commits with no children
621 proc seeds {v} {
622 global vdownptr vleftptr varcstart
624 set ret {}
625 set a [lindex $vdownptr($v) 0]
626 while {$a != 0} {
627 lappend ret [lindex $varcstart($v) $a]
628 set a [lindex $vleftptr($v) $a]
630 return $ret
633 proc newvarc {view id} {
634 global varcid varctok parents children vdatemode
635 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
636 global commitdata commitinfo vseedcount varccommits vlastins
638 set a [llength $varctok($view)]
639 set vid $view,$id
640 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
641 if {![info exists commitinfo($id)]} {
642 parsecommit $id $commitdata($id) 1
644 set cdate [lindex $commitinfo($id) 4]
645 if {![string is integer -strict $cdate]} {
646 set cdate 0
648 if {![info exists vseedcount($view,$cdate)]} {
649 set vseedcount($view,$cdate) -1
651 set c [incr vseedcount($view,$cdate)]
652 set cdate [expr {$cdate ^ 0xffffffff}]
653 set tok "s[strrep $cdate][strrep $c]"
654 } else {
655 set tok {}
657 set ka 0
658 if {[llength $children($vid)] > 0} {
659 set kid [lindex $children($vid) end]
660 set k $varcid($view,$kid)
661 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
662 set ki $kid
663 set ka $k
664 set tok [lindex $varctok($view) $k]
667 if {$ka != 0} {
668 set i [lsearch -exact $parents($view,$ki) $id]
669 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
670 append tok [strrep $j]
672 set c [lindex $vlastins($view) $ka]
673 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
674 set c $ka
675 set b [lindex $vdownptr($view) $ka]
676 } else {
677 set b [lindex $vleftptr($view) $c]
679 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
680 set c $b
681 set b [lindex $vleftptr($view) $c]
683 if {$c == $ka} {
684 lset vdownptr($view) $ka $a
685 lappend vbackptr($view) 0
686 } else {
687 lset vleftptr($view) $c $a
688 lappend vbackptr($view) $c
690 lset vlastins($view) $ka $a
691 lappend vupptr($view) $ka
692 lappend vleftptr($view) $b
693 if {$b != 0} {
694 lset vbackptr($view) $b $a
696 lappend varctok($view) $tok
697 lappend varcstart($view) $id
698 lappend vdownptr($view) 0
699 lappend varcrow($view) {}
700 lappend varcix($view) {}
701 set varccommits($view,$a) {}
702 lappend vlastins($view) 0
703 return $a
706 proc splitvarc {p v} {
707 global varcid varcstart varccommits varctok vtokmod
708 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
710 set oa $varcid($v,$p)
711 set otok [lindex $varctok($v) $oa]
712 set ac $varccommits($v,$oa)
713 set i [lsearch -exact $varccommits($v,$oa) $p]
714 if {$i <= 0} return
715 set na [llength $varctok($v)]
716 # "%" sorts before "0"...
717 set tok "$otok%[strrep $i]"
718 lappend varctok($v) $tok
719 lappend varcrow($v) {}
720 lappend varcix($v) {}
721 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
722 set varccommits($v,$na) [lrange $ac $i end]
723 lappend varcstart($v) $p
724 foreach id $varccommits($v,$na) {
725 set varcid($v,$id) $na
727 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
728 lappend vlastins($v) [lindex $vlastins($v) $oa]
729 lset vdownptr($v) $oa $na
730 lset vlastins($v) $oa 0
731 lappend vupptr($v) $oa
732 lappend vleftptr($v) 0
733 lappend vbackptr($v) 0
734 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
735 lset vupptr($v) $b $na
737 if {[string compare $otok $vtokmod($v)] <= 0} {
738 modify_arc $v $oa
742 proc renumbervarc {a v} {
743 global parents children varctok varcstart varccommits
744 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
746 set t1 [clock clicks -milliseconds]
747 set todo {}
748 set isrelated($a) 1
749 set kidchanged($a) 1
750 set ntot 0
751 while {$a != 0} {
752 if {[info exists isrelated($a)]} {
753 lappend todo $a
754 set id [lindex $varccommits($v,$a) end]
755 foreach p $parents($v,$id) {
756 if {[info exists varcid($v,$p)]} {
757 set isrelated($varcid($v,$p)) 1
761 incr ntot
762 set b [lindex $vdownptr($v) $a]
763 if {$b == 0} {
764 while {$a != 0} {
765 set b [lindex $vleftptr($v) $a]
766 if {$b != 0} break
767 set a [lindex $vupptr($v) $a]
770 set a $b
772 foreach a $todo {
773 if {![info exists kidchanged($a)]} continue
774 set id [lindex $varcstart($v) $a]
775 if {[llength $children($v,$id)] > 1} {
776 set children($v,$id) [lsort -command [list vtokcmp $v] \
777 $children($v,$id)]
779 set oldtok [lindex $varctok($v) $a]
780 if {!$vdatemode($v)} {
781 set tok {}
782 } else {
783 set tok $oldtok
785 set ka 0
786 set kid [last_real_child $v,$id]
787 if {$kid ne {}} {
788 set k $varcid($v,$kid)
789 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
790 set ki $kid
791 set ka $k
792 set tok [lindex $varctok($v) $k]
795 if {$ka != 0} {
796 set i [lsearch -exact $parents($v,$ki) $id]
797 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
798 append tok [strrep $j]
800 if {$tok eq $oldtok} {
801 continue
803 set id [lindex $varccommits($v,$a) end]
804 foreach p $parents($v,$id) {
805 if {[info exists varcid($v,$p)]} {
806 set kidchanged($varcid($v,$p)) 1
807 } else {
808 set sortkids($p) 1
811 lset varctok($v) $a $tok
812 set b [lindex $vupptr($v) $a]
813 if {$b != $ka} {
814 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
815 modify_arc $v $ka
817 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
818 modify_arc $v $b
820 set c [lindex $vbackptr($v) $a]
821 set d [lindex $vleftptr($v) $a]
822 if {$c == 0} {
823 lset vdownptr($v) $b $d
824 } else {
825 lset vleftptr($v) $c $d
827 if {$d != 0} {
828 lset vbackptr($v) $d $c
830 if {[lindex $vlastins($v) $b] == $a} {
831 lset vlastins($v) $b $c
833 lset vupptr($v) $a $ka
834 set c [lindex $vlastins($v) $ka]
835 if {$c == 0 || \
836 [string compare $tok [lindex $varctok($v) $c]] < 0} {
837 set c $ka
838 set b [lindex $vdownptr($v) $ka]
839 } else {
840 set b [lindex $vleftptr($v) $c]
842 while {$b != 0 && \
843 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
844 set c $b
845 set b [lindex $vleftptr($v) $c]
847 if {$c == $ka} {
848 lset vdownptr($v) $ka $a
849 lset vbackptr($v) $a 0
850 } else {
851 lset vleftptr($v) $c $a
852 lset vbackptr($v) $a $c
854 lset vleftptr($v) $a $b
855 if {$b != 0} {
856 lset vbackptr($v) $b $a
858 lset vlastins($v) $ka $a
861 foreach id [array names sortkids] {
862 if {[llength $children($v,$id)] > 1} {
863 set children($v,$id) [lsort -command [list vtokcmp $v] \
864 $children($v,$id)]
867 set t2 [clock clicks -milliseconds]
868 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
871 # Fix up the graph after we have found out that in view $v,
872 # $p (a commit that we have already seen) is actually the parent
873 # of the last commit in arc $a.
874 proc fix_reversal {p a v} {
875 global varcid varcstart varctok vupptr
877 set pa $varcid($v,$p)
878 if {$p ne [lindex $varcstart($v) $pa]} {
879 splitvarc $p $v
880 set pa $varcid($v,$p)
882 # seeds always need to be renumbered
883 if {[lindex $vupptr($v) $pa] == 0 ||
884 [string compare [lindex $varctok($v) $a] \
885 [lindex $varctok($v) $pa]] > 0} {
886 renumbervarc $pa $v
890 proc insertrow {id p v} {
891 global cmitlisted children parents varcid varctok vtokmod
892 global varccommits ordertok commitidx numcommits curview
893 global targetid targetrow
895 readcommit $id
896 set vid $v,$id
897 set cmitlisted($vid) 1
898 set children($vid) {}
899 set parents($vid) [list $p]
900 set a [newvarc $v $id]
901 set varcid($vid) $a
902 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
903 modify_arc $v $a
905 lappend varccommits($v,$a) $id
906 set vp $v,$p
907 if {[llength [lappend children($vp) $id]] > 1} {
908 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
909 catch {unset ordertok}
911 fix_reversal $p $a $v
912 incr commitidx($v)
913 if {$v == $curview} {
914 set numcommits $commitidx($v)
915 setcanvscroll
916 if {[info exists targetid]} {
917 if {![comes_before $targetid $p]} {
918 incr targetrow
924 proc insertfakerow {id p} {
925 global varcid varccommits parents children cmitlisted
926 global commitidx varctok vtokmod targetid targetrow curview numcommits
928 set v $curview
929 set a $varcid($v,$p)
930 set i [lsearch -exact $varccommits($v,$a) $p]
931 if {$i < 0} {
932 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
933 return
935 set children($v,$id) {}
936 set parents($v,$id) [list $p]
937 set varcid($v,$id) $a
938 lappend children($v,$p) $id
939 set cmitlisted($v,$id) 1
940 set numcommits [incr commitidx($v)]
941 # note we deliberately don't update varcstart($v) even if $i == 0
942 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
943 modify_arc $v $a $i
944 if {[info exists targetid]} {
945 if {![comes_before $targetid $p]} {
946 incr targetrow
949 setcanvscroll
950 drawvisible
953 proc removefakerow {id} {
954 global varcid varccommits parents children commitidx
955 global varctok vtokmod cmitlisted currentid selectedline
956 global targetid curview numcommits
958 set v $curview
959 if {[llength $parents($v,$id)] != 1} {
960 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
961 return
963 set p [lindex $parents($v,$id) 0]
964 set a $varcid($v,$id)
965 set i [lsearch -exact $varccommits($v,$a) $id]
966 if {$i < 0} {
967 puts "oops: removefakerow can't find [shortids $id] on arc $a"
968 return
970 unset varcid($v,$id)
971 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
972 unset parents($v,$id)
973 unset children($v,$id)
974 unset cmitlisted($v,$id)
975 set numcommits [incr commitidx($v) -1]
976 set j [lsearch -exact $children($v,$p) $id]
977 if {$j >= 0} {
978 set children($v,$p) [lreplace $children($v,$p) $j $j]
980 modify_arc $v $a $i
981 if {[info exist currentid] && $id eq $currentid} {
982 unset currentid
983 set selectedline {}
985 if {[info exists targetid] && $targetid eq $id} {
986 set targetid $p
988 setcanvscroll
989 drawvisible
992 proc real_children {vp} {
993 global children nullid nullid2
995 set kids {}
996 foreach id $children($vp) {
997 if {$id ne $nullid && $id ne $nullid2} {
998 lappend kids $id
1001 return $kids
1004 proc first_real_child {vp} {
1005 global children nullid nullid2
1007 foreach id $children($vp) {
1008 if {$id ne $nullid && $id ne $nullid2} {
1009 return $id
1012 return {}
1015 proc last_real_child {vp} {
1016 global children nullid nullid2
1018 set kids $children($vp)
1019 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1020 set id [lindex $kids $i]
1021 if {$id ne $nullid && $id ne $nullid2} {
1022 return $id
1025 return {}
1028 proc vtokcmp {v a b} {
1029 global varctok varcid
1031 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1032 [lindex $varctok($v) $varcid($v,$b)]]
1035 # This assumes that if lim is not given, the caller has checked that
1036 # arc a's token is less than $vtokmod($v)
1037 proc modify_arc {v a {lim {}}} {
1038 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1040 if {$lim ne {}} {
1041 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1042 if {$c > 0} return
1043 if {$c == 0} {
1044 set r [lindex $varcrow($v) $a]
1045 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1048 set vtokmod($v) [lindex $varctok($v) $a]
1049 set varcmod($v) $a
1050 if {$v == $curview} {
1051 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1052 set a [lindex $vupptr($v) $a]
1053 set lim {}
1055 set r 0
1056 if {$a != 0} {
1057 if {$lim eq {}} {
1058 set lim [llength $varccommits($v,$a)]
1060 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1062 set vrowmod($v) $r
1063 undolayout $r
1067 proc update_arcrows {v} {
1068 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1069 global varcid vrownum varcorder varcix varccommits
1070 global vupptr vdownptr vleftptr varctok
1071 global displayorder parentlist curview cached_commitrow
1073 if {$vrowmod($v) == $commitidx($v)} return
1074 if {$v == $curview} {
1075 if {[llength $displayorder] > $vrowmod($v)} {
1076 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1077 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1079 catch {unset cached_commitrow}
1081 set narctot [expr {[llength $varctok($v)] - 1}]
1082 set a $varcmod($v)
1083 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1084 # go up the tree until we find something that has a row number,
1085 # or we get to a seed
1086 set a [lindex $vupptr($v) $a]
1088 if {$a == 0} {
1089 set a [lindex $vdownptr($v) 0]
1090 if {$a == 0} return
1091 set vrownum($v) {0}
1092 set varcorder($v) [list $a]
1093 lset varcix($v) $a 0
1094 lset varcrow($v) $a 0
1095 set arcn 0
1096 set row 0
1097 } else {
1098 set arcn [lindex $varcix($v) $a]
1099 if {[llength $vrownum($v)] > $arcn + 1} {
1100 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1101 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1103 set row [lindex $varcrow($v) $a]
1105 while {1} {
1106 set p $a
1107 incr row [llength $varccommits($v,$a)]
1108 # go down if possible
1109 set b [lindex $vdownptr($v) $a]
1110 if {$b == 0} {
1111 # if not, go left, or go up until we can go left
1112 while {$a != 0} {
1113 set b [lindex $vleftptr($v) $a]
1114 if {$b != 0} break
1115 set a [lindex $vupptr($v) $a]
1117 if {$a == 0} break
1119 set a $b
1120 incr arcn
1121 lappend vrownum($v) $row
1122 lappend varcorder($v) $a
1123 lset varcix($v) $a $arcn
1124 lset varcrow($v) $a $row
1126 set vtokmod($v) [lindex $varctok($v) $p]
1127 set varcmod($v) $p
1128 set vrowmod($v) $row
1129 if {[info exists currentid]} {
1130 set selectedline [rowofcommit $currentid]
1134 # Test whether view $v contains commit $id
1135 proc commitinview {id v} {
1136 global varcid
1138 return [info exists varcid($v,$id)]
1141 # Return the row number for commit $id in the current view
1142 proc rowofcommit {id} {
1143 global varcid varccommits varcrow curview cached_commitrow
1144 global varctok vtokmod
1146 set v $curview
1147 if {![info exists varcid($v,$id)]} {
1148 puts "oops rowofcommit no arc for [shortids $id]"
1149 return {}
1151 set a $varcid($v,$id)
1152 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1153 update_arcrows $v
1155 if {[info exists cached_commitrow($id)]} {
1156 return $cached_commitrow($id)
1158 set i [lsearch -exact $varccommits($v,$a) $id]
1159 if {$i < 0} {
1160 puts "oops didn't find commit [shortids $id] in arc $a"
1161 return {}
1163 incr i [lindex $varcrow($v) $a]
1164 set cached_commitrow($id) $i
1165 return $i
1168 # Returns 1 if a is on an earlier row than b, otherwise 0
1169 proc comes_before {a b} {
1170 global varcid varctok curview
1172 set v $curview
1173 if {$a eq $b || ![info exists varcid($v,$a)] || \
1174 ![info exists varcid($v,$b)]} {
1175 return 0
1177 if {$varcid($v,$a) != $varcid($v,$b)} {
1178 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1179 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1181 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1184 proc bsearch {l elt} {
1185 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1186 return 0
1188 set lo 0
1189 set hi [llength $l]
1190 while {$hi - $lo > 1} {
1191 set mid [expr {int(($lo + $hi) / 2)}]
1192 set t [lindex $l $mid]
1193 if {$elt < $t} {
1194 set hi $mid
1195 } elseif {$elt > $t} {
1196 set lo $mid
1197 } else {
1198 return $mid
1201 return $lo
1204 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1205 proc make_disporder {start end} {
1206 global vrownum curview commitidx displayorder parentlist
1207 global varccommits varcorder parents vrowmod varcrow
1208 global d_valid_start d_valid_end
1210 if {$end > $vrowmod($curview)} {
1211 update_arcrows $curview
1213 set ai [bsearch $vrownum($curview) $start]
1214 set start [lindex $vrownum($curview) $ai]
1215 set narc [llength $vrownum($curview)]
1216 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1217 set a [lindex $varcorder($curview) $ai]
1218 set l [llength $displayorder]
1219 set al [llength $varccommits($curview,$a)]
1220 if {$l < $r + $al} {
1221 if {$l < $r} {
1222 set pad [ntimes [expr {$r - $l}] {}]
1223 set displayorder [concat $displayorder $pad]
1224 set parentlist [concat $parentlist $pad]
1225 } elseif {$l > $r} {
1226 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1227 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1229 foreach id $varccommits($curview,$a) {
1230 lappend displayorder $id
1231 lappend parentlist $parents($curview,$id)
1233 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1234 set i $r
1235 foreach id $varccommits($curview,$a) {
1236 lset displayorder $i $id
1237 lset parentlist $i $parents($curview,$id)
1238 incr i
1241 incr r $al
1245 proc commitonrow {row} {
1246 global displayorder
1248 set id [lindex $displayorder $row]
1249 if {$id eq {}} {
1250 make_disporder $row [expr {$row + 1}]
1251 set id [lindex $displayorder $row]
1253 return $id
1256 proc closevarcs {v} {
1257 global varctok varccommits varcid parents children
1258 global cmitlisted commitidx vtokmod
1260 set missing_parents 0
1261 set scripts {}
1262 set narcs [llength $varctok($v)]
1263 for {set a 1} {$a < $narcs} {incr a} {
1264 set id [lindex $varccommits($v,$a) end]
1265 foreach p $parents($v,$id) {
1266 if {[info exists varcid($v,$p)]} continue
1267 # add p as a new commit
1268 incr missing_parents
1269 set cmitlisted($v,$p) 0
1270 set parents($v,$p) {}
1271 if {[llength $children($v,$p)] == 1 &&
1272 [llength $parents($v,$id)] == 1} {
1273 set b $a
1274 } else {
1275 set b [newvarc $v $p]
1277 set varcid($v,$p) $b
1278 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1279 modify_arc $v $b
1281 lappend varccommits($v,$b) $p
1282 incr commitidx($v)
1283 set scripts [check_interest $p $scripts]
1286 if {$missing_parents > 0} {
1287 foreach s $scripts {
1288 eval $s
1293 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1294 # Assumes we already have an arc for $rwid.
1295 proc rewrite_commit {v id rwid} {
1296 global children parents varcid varctok vtokmod varccommits
1298 foreach ch $children($v,$id) {
1299 # make $rwid be $ch's parent in place of $id
1300 set i [lsearch -exact $parents($v,$ch) $id]
1301 if {$i < 0} {
1302 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1304 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1305 # add $ch to $rwid's children and sort the list if necessary
1306 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1307 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1308 $children($v,$rwid)]
1310 # fix the graph after joining $id to $rwid
1311 set a $varcid($v,$ch)
1312 fix_reversal $rwid $a $v
1313 # parentlist is wrong for the last element of arc $a
1314 # even if displayorder is right, hence the 3rd arg here
1315 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1319 # Mechanism for registering a command to be executed when we come
1320 # across a particular commit. To handle the case when only the
1321 # prefix of the commit is known, the commitinterest array is now
1322 # indexed by the first 4 characters of the ID. Each element is a
1323 # list of id, cmd pairs.
1324 proc interestedin {id cmd} {
1325 global commitinterest
1327 lappend commitinterest([string range $id 0 3]) $id $cmd
1330 proc check_interest {id scripts} {
1331 global commitinterest
1333 set prefix [string range $id 0 3]
1334 if {[info exists commitinterest($prefix)]} {
1335 set newlist {}
1336 foreach {i script} $commitinterest($prefix) {
1337 if {[string match "$i*" $id]} {
1338 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1339 } else {
1340 lappend newlist $i $script
1343 if {$newlist ne {}} {
1344 set commitinterest($prefix) $newlist
1345 } else {
1346 unset commitinterest($prefix)
1349 return $scripts
1352 proc getcommitlines {fd inst view updating} {
1353 global cmitlisted leftover
1354 global commitidx commitdata vdatemode
1355 global parents children curview hlview
1356 global idpending ordertok
1357 global varccommits varcid varctok vtokmod vfilelimit
1359 set stuff [read $fd 500000]
1360 # git log doesn't terminate the last commit with a null...
1361 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1362 set stuff "\0"
1364 if {$stuff == {}} {
1365 if {![eof $fd]} {
1366 return 1
1368 global commfd viewcomplete viewactive viewname
1369 global viewinstances
1370 unset commfd($inst)
1371 set i [lsearch -exact $viewinstances($view) $inst]
1372 if {$i >= 0} {
1373 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1375 # set it blocking so we wait for the process to terminate
1376 fconfigure $fd -blocking 1
1377 if {[catch {close $fd} err]} {
1378 set fv {}
1379 if {$view != $curview} {
1380 set fv " for the \"$viewname($view)\" view"
1382 if {[string range $err 0 4] == "usage"} {
1383 set err "Gitk: error reading commits$fv:\
1384 bad arguments to git log."
1385 if {$viewname($view) eq "Command line"} {
1386 append err \
1387 " (Note: arguments to gitk are passed to git log\
1388 to allow selection of commits to be displayed.)"
1390 } else {
1391 set err "Error reading commits$fv: $err"
1393 error_popup $err
1395 if {[incr viewactive($view) -1] <= 0} {
1396 set viewcomplete($view) 1
1397 # Check if we have seen any ids listed as parents that haven't
1398 # appeared in the list
1399 closevarcs $view
1400 notbusy $view
1402 if {$view == $curview} {
1403 run chewcommits
1405 return 0
1407 set start 0
1408 set gotsome 0
1409 set scripts {}
1410 while 1 {
1411 set i [string first "\0" $stuff $start]
1412 if {$i < 0} {
1413 append leftover($inst) [string range $stuff $start end]
1414 break
1416 if {$start == 0} {
1417 set cmit $leftover($inst)
1418 append cmit [string range $stuff 0 [expr {$i - 1}]]
1419 set leftover($inst) {}
1420 } else {
1421 set cmit [string range $stuff $start [expr {$i - 1}]]
1423 set start [expr {$i + 1}]
1424 set j [string first "\n" $cmit]
1425 set ok 0
1426 set listed 1
1427 if {$j >= 0 && [string match "commit *" $cmit]} {
1428 set ids [string range $cmit 7 [expr {$j - 1}]]
1429 if {[string match {[-^<>]*} $ids]} {
1430 switch -- [string index $ids 0] {
1431 "-" {set listed 0}
1432 "^" {set listed 2}
1433 "<" {set listed 3}
1434 ">" {set listed 4}
1436 set ids [string range $ids 1 end]
1438 set ok 1
1439 foreach id $ids {
1440 if {[string length $id] != 40} {
1441 set ok 0
1442 break
1446 if {!$ok} {
1447 set shortcmit $cmit
1448 if {[string length $shortcmit] > 80} {
1449 set shortcmit "[string range $shortcmit 0 80]..."
1451 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1452 exit 1
1454 set id [lindex $ids 0]
1455 set vid $view,$id
1457 if {!$listed && $updating && ![info exists varcid($vid)] &&
1458 $vfilelimit($view) ne {}} {
1459 # git log doesn't rewrite parents for unlisted commits
1460 # when doing path limiting, so work around that here
1461 # by working out the rewritten parent with git rev-list
1462 # and if we already know about it, using the rewritten
1463 # parent as a substitute parent for $id's children.
1464 if {![catch {
1465 set rwid [exec git rev-list --first-parent --max-count=1 \
1466 $id -- $vfilelimit($view)]
1467 }]} {
1468 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1469 # use $rwid in place of $id
1470 rewrite_commit $view $id $rwid
1471 continue
1476 set a 0
1477 if {[info exists varcid($vid)]} {
1478 if {$cmitlisted($vid) || !$listed} continue
1479 set a $varcid($vid)
1481 if {$listed} {
1482 set olds [lrange $ids 1 end]
1483 } else {
1484 set olds {}
1486 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1487 set cmitlisted($vid) $listed
1488 set parents($vid) $olds
1489 if {![info exists children($vid)]} {
1490 set children($vid) {}
1491 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1492 set k [lindex $children($vid) 0]
1493 if {[llength $parents($view,$k)] == 1 &&
1494 (!$vdatemode($view) ||
1495 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1496 set a $varcid($view,$k)
1499 if {$a == 0} {
1500 # new arc
1501 set a [newvarc $view $id]
1503 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1504 modify_arc $view $a
1506 if {![info exists varcid($vid)]} {
1507 set varcid($vid) $a
1508 lappend varccommits($view,$a) $id
1509 incr commitidx($view)
1512 set i 0
1513 foreach p $olds {
1514 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1515 set vp $view,$p
1516 if {[llength [lappend children($vp) $id]] > 1 &&
1517 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1518 set children($vp) [lsort -command [list vtokcmp $view] \
1519 $children($vp)]
1520 catch {unset ordertok}
1522 if {[info exists varcid($view,$p)]} {
1523 fix_reversal $p $a $view
1526 incr i
1529 set scripts [check_interest $id $scripts]
1530 set gotsome 1
1532 if {$gotsome} {
1533 global numcommits hlview
1535 if {$view == $curview} {
1536 set numcommits $commitidx($view)
1537 run chewcommits
1539 if {[info exists hlview] && $view == $hlview} {
1540 # we never actually get here...
1541 run vhighlightmore
1543 foreach s $scripts {
1544 eval $s
1547 return 2
1550 proc chewcommits {} {
1551 global curview hlview viewcomplete
1552 global pending_select
1554 layoutmore
1555 if {$viewcomplete($curview)} {
1556 global commitidx varctok
1557 global numcommits startmsecs
1559 if {[info exists pending_select]} {
1560 update
1561 reset_pending_select {}
1563 if {[commitinview $pending_select $curview]} {
1564 selectline [rowofcommit $pending_select] 1
1565 } else {
1566 set row [first_real_row]
1567 selectline $row 1
1570 if {$commitidx($curview) > 0} {
1571 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1572 #puts "overall $ms ms for $numcommits commits"
1573 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1574 } else {
1575 show_status [mc "No commits selected"]
1577 notbusy layout
1579 return 0
1582 proc do_readcommit {id} {
1583 global tclencoding
1585 # Invoke git-log to handle automatic encoding conversion
1586 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1587 # Read the results using i18n.logoutputencoding
1588 fconfigure $fd -translation lf -eofchar {}
1589 if {$tclencoding != {}} {
1590 fconfigure $fd -encoding $tclencoding
1592 set contents [read $fd]
1593 close $fd
1594 # Remove the heading line
1595 regsub {^commit [0-9a-f]+\n} $contents {} contents
1597 return $contents
1600 proc readcommit {id} {
1601 if {[catch {set contents [do_readcommit $id]}]} return
1602 parsecommit $id $contents 1
1605 proc parsecommit {id contents listed} {
1606 global commitinfo cdate
1608 set inhdr 1
1609 set comment {}
1610 set headline {}
1611 set auname {}
1612 set audate {}
1613 set comname {}
1614 set comdate {}
1615 set hdrend [string first "\n\n" $contents]
1616 if {$hdrend < 0} {
1617 # should never happen...
1618 set hdrend [string length $contents]
1620 set header [string range $contents 0 [expr {$hdrend - 1}]]
1621 set comment [string range $contents [expr {$hdrend + 2}] end]
1622 foreach line [split $header "\n"] {
1623 set line [split $line " "]
1624 set tag [lindex $line 0]
1625 if {$tag == "author"} {
1626 set audate [lindex $line end-1]
1627 set auname [join [lrange $line 1 end-2] " "]
1628 } elseif {$tag == "committer"} {
1629 set comdate [lindex $line end-1]
1630 set comname [join [lrange $line 1 end-2] " "]
1633 set headline {}
1634 # take the first non-blank line of the comment as the headline
1635 set headline [string trimleft $comment]
1636 set i [string first "\n" $headline]
1637 if {$i >= 0} {
1638 set headline [string range $headline 0 $i]
1640 set headline [string trimright $headline]
1641 set i [string first "\r" $headline]
1642 if {$i >= 0} {
1643 set headline [string trimright [string range $headline 0 $i]]
1645 if {!$listed} {
1646 # git log indents the comment by 4 spaces;
1647 # if we got this via git cat-file, add the indentation
1648 set newcomment {}
1649 foreach line [split $comment "\n"] {
1650 append newcomment " "
1651 append newcomment $line
1652 append newcomment "\n"
1654 set comment $newcomment
1656 if {$comdate != {}} {
1657 set cdate($id) $comdate
1659 set commitinfo($id) [list $headline $auname $audate \
1660 $comname $comdate $comment]
1663 proc getcommit {id} {
1664 global commitdata commitinfo
1666 if {[info exists commitdata($id)]} {
1667 parsecommit $id $commitdata($id) 1
1668 } else {
1669 readcommit $id
1670 if {![info exists commitinfo($id)]} {
1671 set commitinfo($id) [list [mc "No commit information available"]]
1674 return 1
1677 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1678 # and are present in the current view.
1679 # This is fairly slow...
1680 proc longid {prefix} {
1681 global varcid curview
1683 set ids {}
1684 foreach match [array names varcid "$curview,$prefix*"] {
1685 lappend ids [lindex [split $match ","] 1]
1687 return $ids
1690 proc readrefs {} {
1691 global tagids idtags headids idheads tagobjid
1692 global otherrefids idotherrefs mainhead mainheadid
1693 global selecthead selectheadid
1694 global hideremotes
1696 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1697 catch {unset $v}
1699 set refd [open [list | git show-ref -d] r]
1700 while {[gets $refd line] >= 0} {
1701 if {[string index $line 40] ne " "} continue
1702 set id [string range $line 0 39]
1703 set ref [string range $line 41 end]
1704 if {![string match "refs/*" $ref]} continue
1705 set name [string range $ref 5 end]
1706 if {[string match "remotes/*" $name]} {
1707 if {![string match "*/HEAD" $name] && !$hideremotes} {
1708 set headids($name) $id
1709 lappend idheads($id) $name
1711 } elseif {[string match "heads/*" $name]} {
1712 set name [string range $name 6 end]
1713 set headids($name) $id
1714 lappend idheads($id) $name
1715 } elseif {[string match "tags/*" $name]} {
1716 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1717 # which is what we want since the former is the commit ID
1718 set name [string range $name 5 end]
1719 if {[string match "*^{}" $name]} {
1720 set name [string range $name 0 end-3]
1721 } else {
1722 set tagobjid($name) $id
1724 set tagids($name) $id
1725 lappend idtags($id) $name
1726 } else {
1727 set otherrefids($name) $id
1728 lappend idotherrefs($id) $name
1731 catch {close $refd}
1732 set mainhead {}
1733 set mainheadid {}
1734 catch {
1735 set mainheadid [exec git rev-parse HEAD]
1736 set thehead [exec git symbolic-ref HEAD]
1737 if {[string match "refs/heads/*" $thehead]} {
1738 set mainhead [string range $thehead 11 end]
1741 set selectheadid {}
1742 if {$selecthead ne {}} {
1743 catch {
1744 set selectheadid [exec git rev-parse --verify $selecthead]
1749 # skip over fake commits
1750 proc first_real_row {} {
1751 global nullid nullid2 numcommits
1753 for {set row 0} {$row < $numcommits} {incr row} {
1754 set id [commitonrow $row]
1755 if {$id ne $nullid && $id ne $nullid2} {
1756 break
1759 return $row
1762 # update things for a head moved to a child of its previous location
1763 proc movehead {id name} {
1764 global headids idheads
1766 removehead $headids($name) $name
1767 set headids($name) $id
1768 lappend idheads($id) $name
1771 # update things when a head has been removed
1772 proc removehead {id name} {
1773 global headids idheads
1775 if {$idheads($id) eq $name} {
1776 unset idheads($id)
1777 } else {
1778 set i [lsearch -exact $idheads($id) $name]
1779 if {$i >= 0} {
1780 set idheads($id) [lreplace $idheads($id) $i $i]
1783 unset headids($name)
1786 proc ttk_toplevel {w args} {
1787 global use_ttk
1788 eval [linsert $args 0 ::toplevel $w]
1789 if {$use_ttk} {
1790 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1792 return $w
1795 proc make_transient {window origin} {
1796 global have_tk85
1798 # In MacOS Tk 8.4 transient appears to work by setting
1799 # overrideredirect, which is utterly useless, since the
1800 # windows get no border, and are not even kept above
1801 # the parent.
1802 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1804 wm transient $window $origin
1806 # Windows fails to place transient windows normally, so
1807 # schedule a callback to center them on the parent.
1808 if {[tk windowingsystem] eq {win32}} {
1809 after idle [list tk::PlaceWindow $window widget $origin]
1813 proc show_error {w top msg {mc mc}} {
1814 global NS
1815 if {![info exists NS]} {set NS ""}
1816 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1817 message $w.m -text $msg -justify center -aspect 400
1818 pack $w.m -side top -fill x -padx 20 -pady 20
1819 ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1820 pack $w.ok -side bottom -fill x
1821 bind $top <Visibility> "grab $top; focus $top"
1822 bind $top <Key-Return> "destroy $top"
1823 bind $top <Key-space> "destroy $top"
1824 bind $top <Key-Escape> "destroy $top"
1825 tkwait window $top
1828 proc error_popup {msg {owner .}} {
1829 if {[tk windowingsystem] eq "win32"} {
1830 tk_messageBox -icon error -type ok -title [wm title .] \
1831 -parent $owner -message $msg
1832 } else {
1833 set w .error
1834 ttk_toplevel $w
1835 make_transient $w $owner
1836 show_error $w $w $msg
1840 proc confirm_popup {msg {owner .}} {
1841 global confirm_ok NS
1842 set confirm_ok 0
1843 set w .confirm
1844 ttk_toplevel $w
1845 make_transient $w $owner
1846 message $w.m -text $msg -justify center -aspect 400
1847 pack $w.m -side top -fill x -padx 20 -pady 20
1848 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1849 pack $w.ok -side left -fill x
1850 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1851 pack $w.cancel -side right -fill x
1852 bind $w <Visibility> "grab $w; focus $w"
1853 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1854 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1855 bind $w <Key-Escape> "destroy $w"
1856 tk::PlaceWindow $w widget $owner
1857 tkwait window $w
1858 return $confirm_ok
1861 proc setoptions {} {
1862 if {[tk windowingsystem] ne "win32"} {
1863 option add *Panedwindow.showHandle 1 startupFile
1864 option add *Panedwindow.sashRelief raised startupFile
1865 if {[tk windowingsystem] ne "aqua"} {
1866 option add *Menu.font uifont startupFile
1868 } else {
1869 option add *Menu.TearOff 0 startupFile
1871 option add *Button.font uifont startupFile
1872 option add *Checkbutton.font uifont startupFile
1873 option add *Radiobutton.font uifont startupFile
1874 option add *Menubutton.font uifont startupFile
1875 option add *Label.font uifont startupFile
1876 option add *Message.font uifont startupFile
1877 option add *Entry.font uifont startupFile
1878 option add *Labelframe.font uifont startupFile
1881 # Make a menu and submenus.
1882 # m is the window name for the menu, items is the list of menu items to add.
1883 # Each item is a list {mc label type description options...}
1884 # mc is ignored; it's so we can put mc there to alert xgettext
1885 # label is the string that appears in the menu
1886 # type is cascade, command or radiobutton (should add checkbutton)
1887 # description depends on type; it's the sublist for cascade, the
1888 # command to invoke for command, or {variable value} for radiobutton
1889 proc makemenu {m items} {
1890 menu $m
1891 if {[tk windowingsystem] eq {aqua}} {
1892 set Meta1 Cmd
1893 } else {
1894 set Meta1 Ctrl
1896 foreach i $items {
1897 set name [mc [lindex $i 1]]
1898 set type [lindex $i 2]
1899 set thing [lindex $i 3]
1900 set params [list $type]
1901 if {$name ne {}} {
1902 set u [string first "&" [string map {&& x} $name]]
1903 lappend params -label [string map {&& & & {}} $name]
1904 if {$u >= 0} {
1905 lappend params -underline $u
1908 switch -- $type {
1909 "cascade" {
1910 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1911 lappend params -menu $m.$submenu
1913 "command" {
1914 lappend params -command $thing
1916 "radiobutton" {
1917 lappend params -variable [lindex $thing 0] \
1918 -value [lindex $thing 1]
1921 set tail [lrange $i 4 end]
1922 regsub -all {\yMeta1\y} $tail $Meta1 tail
1923 eval $m add $params $tail
1924 if {$type eq "cascade"} {
1925 makemenu $m.$submenu $thing
1930 # translate string and remove ampersands
1931 proc mca {str} {
1932 return [string map {&& & & {}} [mc $str]]
1935 proc makedroplist {w varname args} {
1936 global use_ttk
1937 if {$use_ttk} {
1938 set width 0
1939 foreach label $args {
1940 set cx [string length $label]
1941 if {$cx > $width} {set width $cx}
1943 set gm [ttk::combobox $w -width $width -state readonly\
1944 -textvariable $varname -values $args]
1945 } else {
1946 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
1948 return $gm
1951 proc makewindow {} {
1952 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1953 global tabstop
1954 global findtype findtypemenu findloc findstring fstring geometry
1955 global entries sha1entry sha1string sha1but
1956 global diffcontextstring diffcontext
1957 global ignorespace
1958 global maincursor textcursor curtextcursor
1959 global rowctxmenu fakerowmenu mergemax wrapcomment
1960 global highlight_files gdttype
1961 global searchstring sstring
1962 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1963 global headctxmenu progresscanv progressitem progresscoords statusw
1964 global fprogitem fprogcoord lastprogupdate progupdatepending
1965 global rprogitem rprogcoord rownumsel numcommits
1966 global have_tk85 use_ttk NS
1968 # The "mc" arguments here are purely so that xgettext
1969 # sees the following string as needing to be translated
1970 set file {
1971 mc "File" cascade {
1972 {mc "Update" command updatecommits -accelerator F5}
1973 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1974 {mc "Reread references" command rereadrefs}
1975 {mc "List references" command showrefs -accelerator F2}
1976 {xx "" separator}
1977 {mc "Start git gui" command {exec git gui &}}
1978 {xx "" separator}
1979 {mc "Quit" command doquit -accelerator Meta1-Q}
1981 set edit {
1982 mc "Edit" cascade {
1983 {mc "Preferences" command doprefs}
1985 set view {
1986 mc "View" cascade {
1987 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1988 {mc "Edit view..." command editview -state disabled -accelerator F4}
1989 {mc "Delete view" command delview -state disabled}
1990 {xx "" separator}
1991 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1993 if {[tk windowingsystem] ne "aqua"} {
1994 set help {
1995 mc "Help" cascade {
1996 {mc "About gitk" command about}
1997 {mc "Key bindings" command keys}
1999 set bar [list $file $edit $view $help]
2000 } else {
2001 proc ::tk::mac::ShowPreferences {} {doprefs}
2002 proc ::tk::mac::Quit {} {doquit}
2003 lset file end [lreplace [lindex $file end] end-1 end]
2004 set apple {
2005 xx "Apple" cascade {
2006 {mc "About gitk" command about}
2007 {xx "" separator}
2009 set help {
2010 mc "Help" cascade {
2011 {mc "Key bindings" command keys}
2013 set bar [list $apple $file $view $help]
2015 makemenu .bar $bar
2016 . configure -menu .bar
2018 if {$use_ttk} {
2019 # cover the non-themed toplevel with a themed frame.
2020 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2023 # the gui has upper and lower half, parts of a paned window.
2024 ${NS}::panedwindow .ctop -orient vertical
2026 # possibly use assumed geometry
2027 if {![info exists geometry(pwsash0)]} {
2028 set geometry(topheight) [expr {15 * $linespc}]
2029 set geometry(topwidth) [expr {80 * $charspc}]
2030 set geometry(botheight) [expr {15 * $linespc}]
2031 set geometry(botwidth) [expr {50 * $charspc}]
2032 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2033 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2036 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2037 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2038 ${NS}::frame .tf.histframe
2039 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2040 if {!$use_ttk} {
2041 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2044 # create three canvases
2045 set cscroll .tf.histframe.csb
2046 set canv .tf.histframe.pwclist.canv
2047 canvas $canv \
2048 -selectbackground $selectbgcolor \
2049 -background $bgcolor -bd 0 \
2050 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2051 .tf.histframe.pwclist add $canv
2052 set canv2 .tf.histframe.pwclist.canv2
2053 canvas $canv2 \
2054 -selectbackground $selectbgcolor \
2055 -background $bgcolor -bd 0 -yscrollincr $linespc
2056 .tf.histframe.pwclist add $canv2
2057 set canv3 .tf.histframe.pwclist.canv3
2058 canvas $canv3 \
2059 -selectbackground $selectbgcolor \
2060 -background $bgcolor -bd 0 -yscrollincr $linespc
2061 .tf.histframe.pwclist add $canv3
2062 if {$use_ttk} {
2063 bind .tf.histframe.pwclist <Map> {
2064 bind %W <Map> {}
2065 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2066 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2068 } else {
2069 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2070 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2073 # a scroll bar to rule them
2074 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2075 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2076 pack $cscroll -side right -fill y
2077 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2078 lappend bglist $canv $canv2 $canv3
2079 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2081 # we have two button bars at bottom of top frame. Bar 1
2082 ${NS}::frame .tf.bar
2083 ${NS}::frame .tf.lbar -height 15
2085 set sha1entry .tf.bar.sha1
2086 set entries $sha1entry
2087 set sha1but .tf.bar.sha1label
2088 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
2089 -command gotocommit -width 8
2090 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2091 pack .tf.bar.sha1label -side left
2092 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2093 trace add variable sha1string write sha1change
2094 pack $sha1entry -side left -pady 2
2096 image create bitmap bm-left -data {
2097 #define left_width 16
2098 #define left_height 16
2099 static unsigned char left_bits[] = {
2100 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2101 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2102 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2104 image create bitmap bm-right -data {
2105 #define right_width 16
2106 #define right_height 16
2107 static unsigned char right_bits[] = {
2108 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2109 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2110 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2112 ${NS}::button .tf.bar.leftbut -image bm-left -command goback \
2113 -state disabled -width 26
2114 pack .tf.bar.leftbut -side left -fill y
2115 ${NS}::button .tf.bar.rightbut -image bm-right -command goforw \
2116 -state disabled -width 26
2117 pack .tf.bar.rightbut -side left -fill y
2119 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2120 set rownumsel {}
2121 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2122 -relief sunken -anchor e
2123 ${NS}::label .tf.bar.rowlabel2 -text "/"
2124 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2125 -relief sunken -anchor e
2126 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2127 -side left
2128 if {!$use_ttk} {
2129 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2131 global selectedline
2132 trace add variable selectedline write selectedline_change
2134 # Status label and progress bar
2135 set statusw .tf.bar.status
2136 ${NS}::label $statusw -width 15 -relief sunken
2137 pack $statusw -side left -padx 5
2138 if {$use_ttk} {
2139 set progresscanv [ttk::progressbar .tf.bar.progress]
2140 } else {
2141 set h [expr {[font metrics uifont -linespace] + 2}]
2142 set progresscanv .tf.bar.progress
2143 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2144 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2145 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2146 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2148 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2149 set progresscoords {0 0}
2150 set fprogcoord 0
2151 set rprogcoord 0
2152 bind $progresscanv <Configure> adjustprogress
2153 set lastprogupdate [clock clicks -milliseconds]
2154 set progupdatepending 0
2156 # build up the bottom bar of upper window
2157 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2158 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2159 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2160 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2161 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2162 -side left -fill y
2163 set gdttype [mc "containing:"]
2164 set gm [makedroplist .tf.lbar.gdttype gdttype \
2165 [mc "containing:"] \
2166 [mc "touching paths:"] \
2167 [mc "adding/removing string:"]]
2168 trace add variable gdttype write gdttype_change
2169 pack .tf.lbar.gdttype -side left -fill y
2171 set findstring {}
2172 set fstring .tf.lbar.findstring
2173 lappend entries $fstring
2174 ${NS}::entry $fstring -width 30 -font textfont -textvariable findstring
2175 trace add variable findstring write find_change
2176 set findtype [mc "Exact"]
2177 set findtypemenu [makedroplist .tf.lbar.findtype \
2178 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2179 trace add variable findtype write findcom_change
2180 set findloc [mc "All fields"]
2181 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2182 [mc "Comments"] [mc "Author"] [mc "Committer"]
2183 trace add variable findloc write find_change
2184 pack .tf.lbar.findloc -side right
2185 pack .tf.lbar.findtype -side right
2186 pack $fstring -side left -expand 1 -fill x
2188 # Finish putting the upper half of the viewer together
2189 pack .tf.lbar -in .tf -side bottom -fill x
2190 pack .tf.bar -in .tf -side bottom -fill x
2191 pack .tf.histframe -fill both -side top -expand 1
2192 .ctop add .tf
2193 if {!$use_ttk} {
2194 .ctop paneconfigure .tf -height $geometry(topheight)
2195 .ctop paneconfigure .tf -width $geometry(topwidth)
2198 # now build up the bottom
2199 ${NS}::panedwindow .pwbottom -orient horizontal
2201 # lower left, a text box over search bar, scroll bar to the right
2202 # if we know window height, then that will set the lower text height, otherwise
2203 # we set lower text height which will drive window height
2204 if {[info exists geometry(main)]} {
2205 ${NS}::frame .bleft -width $geometry(botwidth)
2206 } else {
2207 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2209 ${NS}::frame .bleft.top
2210 ${NS}::frame .bleft.mid
2211 ${NS}::frame .bleft.bottom
2213 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2214 pack .bleft.top.search -side left -padx 5
2215 set sstring .bleft.top.sstring
2216 set searchstring ""
2217 ${NS}::entry $sstring -width 20 -font textfont -textvariable searchstring
2218 lappend entries $sstring
2219 trace add variable searchstring write incrsearch
2220 pack $sstring -side left -expand 1 -fill x
2221 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2222 -command changediffdisp -variable diffelide -value {0 0}
2223 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2224 -command changediffdisp -variable diffelide -value {0 1}
2225 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2226 -command changediffdisp -variable diffelide -value {1 0}
2227 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2228 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2229 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2230 -from 0 -increment 1 -to 10000000 \
2231 -validate all -validatecommand "diffcontextvalidate %P" \
2232 -textvariable diffcontextstring
2233 .bleft.mid.diffcontext set $diffcontext
2234 trace add variable diffcontextstring write diffcontextchange
2235 lappend entries .bleft.mid.diffcontext
2236 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2237 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2238 -command changeignorespace -variable ignorespace
2239 pack .bleft.mid.ignspace -side left -padx 5
2240 set ctext .bleft.bottom.ctext
2241 text $ctext -background $bgcolor -foreground $fgcolor \
2242 -state disabled -font textfont \
2243 -yscrollcommand scrolltext -wrap none \
2244 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2245 if {$have_tk85} {
2246 $ctext conf -tabstyle wordprocessor
2248 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2249 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2250 pack .bleft.top -side top -fill x
2251 pack .bleft.mid -side top -fill x
2252 grid $ctext .bleft.bottom.sb -sticky nsew
2253 grid .bleft.bottom.sbhorizontal -sticky ew
2254 grid columnconfigure .bleft.bottom 0 -weight 1
2255 grid rowconfigure .bleft.bottom 0 -weight 1
2256 grid rowconfigure .bleft.bottom 1 -weight 0
2257 pack .bleft.bottom -side top -fill both -expand 1
2258 lappend bglist $ctext
2259 lappend fglist $ctext
2261 $ctext tag conf comment -wrap $wrapcomment
2262 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2263 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2264 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2265 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2266 $ctext tag conf m0 -fore red
2267 $ctext tag conf m1 -fore blue
2268 $ctext tag conf m2 -fore green
2269 $ctext tag conf m3 -fore purple
2270 $ctext tag conf m4 -fore brown
2271 $ctext tag conf m5 -fore "#009090"
2272 $ctext tag conf m6 -fore magenta
2273 $ctext tag conf m7 -fore "#808000"
2274 $ctext tag conf m8 -fore "#009000"
2275 $ctext tag conf m9 -fore "#ff0080"
2276 $ctext tag conf m10 -fore cyan
2277 $ctext tag conf m11 -fore "#b07070"
2278 $ctext tag conf m12 -fore "#70b0f0"
2279 $ctext tag conf m13 -fore "#70f0b0"
2280 $ctext tag conf m14 -fore "#f0b070"
2281 $ctext tag conf m15 -fore "#ff70b0"
2282 $ctext tag conf mmax -fore darkgrey
2283 set mergemax 16
2284 $ctext tag conf mresult -font textfontbold
2285 $ctext tag conf msep -font textfontbold
2286 $ctext tag conf found -back yellow
2288 .pwbottom add .bleft
2289 if {!$use_ttk} {
2290 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2293 # lower right
2294 ${NS}::frame .bright
2295 ${NS}::frame .bright.mode
2296 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2297 -command reselectline -variable cmitmode -value "patch"
2298 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2299 -command reselectline -variable cmitmode -value "tree"
2300 grid .bright.mode.patch .bright.mode.tree -sticky ew
2301 pack .bright.mode -side top -fill x
2302 set cflist .bright.cfiles
2303 set indent [font measure mainfont "nn"]
2304 text $cflist \
2305 -selectbackground $selectbgcolor \
2306 -background $bgcolor -foreground $fgcolor \
2307 -font mainfont \
2308 -tabs [list $indent [expr {2 * $indent}]] \
2309 -yscrollcommand ".bright.sb set" \
2310 -cursor [. cget -cursor] \
2311 -spacing1 1 -spacing3 1
2312 lappend bglist $cflist
2313 lappend fglist $cflist
2314 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2315 pack .bright.sb -side right -fill y
2316 pack $cflist -side left -fill both -expand 1
2317 $cflist tag configure highlight \
2318 -background [$cflist cget -selectbackground]
2319 $cflist tag configure bold -font mainfontbold
2321 .pwbottom add .bright
2322 .ctop add .pwbottom
2324 # restore window width & height if known
2325 if {[info exists geometry(main)]} {
2326 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2327 if {$w > [winfo screenwidth .]} {
2328 set w [winfo screenwidth .]
2330 if {$h > [winfo screenheight .]} {
2331 set h [winfo screenheight .]
2333 wm geometry . "${w}x$h"
2337 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2338 wm state . $geometry(state)
2341 if {[tk windowingsystem] eq {aqua}} {
2342 set M1B M1
2343 set ::BM "3"
2344 } else {
2345 set M1B Control
2346 set ::BM "2"
2349 if {$use_ttk} {
2350 bind .ctop <Map> {
2351 bind %W <Map> {}
2352 %W sashpos 0 $::geometry(topheight)
2354 bind .pwbottom <Map> {
2355 bind %W <Map> {}
2356 %W sashpos 0 $::geometry(botwidth)
2360 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2361 pack .ctop -fill both -expand 1
2362 bindall <1> {selcanvline %W %x %y}
2363 #bindall <B1-Motion> {selcanvline %W %x %y}
2364 if {[tk windowingsystem] == "win32"} {
2365 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2366 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2367 } else {
2368 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2369 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2370 if {[tk windowingsystem] eq "aqua"} {
2371 bindall <MouseWheel> {
2372 set delta [expr {- (%D)}]
2373 allcanvs yview scroll $delta units
2375 bindall <Shift-MouseWheel> {
2376 set delta [expr {- (%D)}]
2377 $canv xview scroll $delta units
2381 bindall <$::BM> "canvscan mark %W %x %y"
2382 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2383 bindkey <Home> selfirstline
2384 bindkey <End> sellastline
2385 bind . <Key-Up> "selnextline -1"
2386 bind . <Key-Down> "selnextline 1"
2387 bind . <Shift-Key-Up> "dofind -1 0"
2388 bind . <Shift-Key-Down> "dofind 1 0"
2389 bindkey <Key-Right> "goforw"
2390 bindkey <Key-Left> "goback"
2391 bind . <Key-Prior> "selnextpage -1"
2392 bind . <Key-Next> "selnextpage 1"
2393 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2394 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2395 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2396 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2397 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2398 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2399 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2400 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2401 bindkey <Key-space> "$ctext yview scroll 1 pages"
2402 bindkey p "selnextline -1"
2403 bindkey n "selnextline 1"
2404 bindkey z "goback"
2405 bindkey x "goforw"
2406 bindkey i "selnextline -1"
2407 bindkey k "selnextline 1"
2408 bindkey j "goback"
2409 bindkey l "goforw"
2410 bindkey b prevfile
2411 bindkey d "$ctext yview scroll 18 units"
2412 bindkey u "$ctext yview scroll -18 units"
2413 bindkey / {focus $fstring}
2414 bindkey <Key-KP_Divide> {focus $fstring}
2415 bindkey <Key-Return> {dofind 1 1}
2416 bindkey ? {dofind -1 1}
2417 bindkey f nextfile
2418 bind . <F5> updatecommits
2419 bind . <$M1B-F5> reloadcommits
2420 bind . <F2> showrefs
2421 bind . <Shift-F4> {newview 0}
2422 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2423 bind . <F4> edit_or_newview
2424 bind . <$M1B-q> doquit
2425 bind . <$M1B-f> {dofind 1 1}
2426 bind . <$M1B-g> {dofind 1 0}
2427 bind . <$M1B-r> dosearchback
2428 bind . <$M1B-s> dosearch
2429 bind . <$M1B-equal> {incrfont 1}
2430 bind . <$M1B-plus> {incrfont 1}
2431 bind . <$M1B-KP_Add> {incrfont 1}
2432 bind . <$M1B-minus> {incrfont -1}
2433 bind . <$M1B-KP_Subtract> {incrfont -1}
2434 wm protocol . WM_DELETE_WINDOW doquit
2435 bind . <Destroy> {stop_backends}
2436 bind . <Button-1> "click %W"
2437 bind $fstring <Key-Return> {dofind 1 1}
2438 bind $sha1entry <Key-Return> {gotocommit; break}
2439 bind $sha1entry <<PasteSelection>> clearsha1
2440 bind $cflist <1> {sel_flist %W %x %y; break}
2441 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2442 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2443 global ctxbut
2444 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2445 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2447 set maincursor [. cget -cursor]
2448 set textcursor [$ctext cget -cursor]
2449 set curtextcursor $textcursor
2451 set rowctxmenu .rowctxmenu
2452 makemenu $rowctxmenu {
2453 {mc "Diff this -> selected" command {diffvssel 0}}
2454 {mc "Diff selected -> this" command {diffvssel 1}}
2455 {mc "Make patch" command mkpatch}
2456 {mc "Create tag" command mktag}
2457 {mc "Write commit to file" command writecommit}
2458 {mc "Create new branch" command mkbranch}
2459 {mc "Cherry-pick this commit" command cherrypick}
2460 {mc "Reset HEAD branch to here" command resethead}
2461 {mc "Mark this commit" command markhere}
2462 {mc "Return to mark" command gotomark}
2463 {mc "Find descendant of this and mark" command find_common_desc}
2464 {mc "Compare with marked commit" command compare_commits}
2466 $rowctxmenu configure -tearoff 0
2468 set fakerowmenu .fakerowmenu
2469 makemenu $fakerowmenu {
2470 {mc "Diff this -> selected" command {diffvssel 0}}
2471 {mc "Diff selected -> this" command {diffvssel 1}}
2472 {mc "Make patch" command mkpatch}
2474 $fakerowmenu configure -tearoff 0
2476 set headctxmenu .headctxmenu
2477 makemenu $headctxmenu {
2478 {mc "Check out this branch" command cobranch}
2479 {mc "Remove this branch" command rmbranch}
2481 $headctxmenu configure -tearoff 0
2483 global flist_menu
2484 set flist_menu .flistctxmenu
2485 makemenu $flist_menu {
2486 {mc "Highlight this too" command {flist_hl 0}}
2487 {mc "Highlight this only" command {flist_hl 1}}
2488 {mc "External diff" command {external_diff}}
2489 {mc "Blame parent commit" command {external_blame 1}}
2491 $flist_menu configure -tearoff 0
2493 global diff_menu
2494 set diff_menu .diffctxmenu
2495 makemenu $diff_menu {
2496 {mc "Show origin of this line" command show_line_source}
2497 {mc "Run git gui blame on this line" command {external_blame_diff}}
2499 $diff_menu configure -tearoff 0
2502 # Windows sends all mouse wheel events to the current focused window, not
2503 # the one where the mouse hovers, so bind those events here and redirect
2504 # to the correct window
2505 proc windows_mousewheel_redirector {W X Y D} {
2506 global canv canv2 canv3
2507 set w [winfo containing -displayof $W $X $Y]
2508 if {$w ne ""} {
2509 set u [expr {$D < 0 ? 5 : -5}]
2510 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2511 allcanvs yview scroll $u units
2512 } else {
2513 catch {
2514 $w yview scroll $u units
2520 # Update row number label when selectedline changes
2521 proc selectedline_change {n1 n2 op} {
2522 global selectedline rownumsel
2524 if {$selectedline eq {}} {
2525 set rownumsel {}
2526 } else {
2527 set rownumsel [expr {$selectedline + 1}]
2531 # mouse-2 makes all windows scan vertically, but only the one
2532 # the cursor is in scans horizontally
2533 proc canvscan {op w x y} {
2534 global canv canv2 canv3
2535 foreach c [list $canv $canv2 $canv3] {
2536 if {$c == $w} {
2537 $c scan $op $x $y
2538 } else {
2539 $c scan $op 0 $y
2544 proc scrollcanv {cscroll f0 f1} {
2545 $cscroll set $f0 $f1
2546 drawvisible
2547 flushhighlights
2550 # when we make a key binding for the toplevel, make sure
2551 # it doesn't get triggered when that key is pressed in the
2552 # find string entry widget.
2553 proc bindkey {ev script} {
2554 global entries
2555 bind . $ev $script
2556 set escript [bind Entry $ev]
2557 if {$escript == {}} {
2558 set escript [bind Entry <Key>]
2560 foreach e $entries {
2561 bind $e $ev "$escript; break"
2565 # set the focus back to the toplevel for any click outside
2566 # the entry widgets
2567 proc click {w} {
2568 global ctext entries
2569 foreach e [concat $entries $ctext] {
2570 if {$w == $e} return
2572 focus .
2575 # Adjust the progress bar for a change in requested extent or canvas size
2576 proc adjustprogress {} {
2577 global progresscanv progressitem progresscoords
2578 global fprogitem fprogcoord lastprogupdate progupdatepending
2579 global rprogitem rprogcoord use_ttk
2581 if {$use_ttk} {
2582 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2583 return
2586 set w [expr {[winfo width $progresscanv] - 4}]
2587 set x0 [expr {$w * [lindex $progresscoords 0]}]
2588 set x1 [expr {$w * [lindex $progresscoords 1]}]
2589 set h [winfo height $progresscanv]
2590 $progresscanv coords $progressitem $x0 0 $x1 $h
2591 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2592 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2593 set now [clock clicks -milliseconds]
2594 if {$now >= $lastprogupdate + 100} {
2595 set progupdatepending 0
2596 update
2597 } elseif {!$progupdatepending} {
2598 set progupdatepending 1
2599 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2603 proc doprogupdate {} {
2604 global lastprogupdate progupdatepending
2606 if {$progupdatepending} {
2607 set progupdatepending 0
2608 set lastprogupdate [clock clicks -milliseconds]
2609 update
2613 proc savestuff {w} {
2614 global canv canv2 canv3 mainfont textfont uifont tabstop
2615 global stuffsaved findmergefiles maxgraphpct
2616 global maxwidth showneartags showlocalchanges
2617 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2618 global cmitmode wrapcomment datetimeformat limitdiffs
2619 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2620 global autoselect extdifftool perfile_attrs markbgcolor use_ttk
2621 global hideremotes want_ttk
2623 if {$stuffsaved} return
2624 if {![winfo viewable .]} return
2625 catch {
2626 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2627 set f [open "~/.gitk-new" w]
2628 if {$::tcl_platform(platform) eq {windows}} {
2629 file attributes "~/.gitk-new" -hidden true
2631 puts $f [list set mainfont $mainfont]
2632 puts $f [list set textfont $textfont]
2633 puts $f [list set uifont $uifont]
2634 puts $f [list set tabstop $tabstop]
2635 puts $f [list set findmergefiles $findmergefiles]
2636 puts $f [list set maxgraphpct $maxgraphpct]
2637 puts $f [list set maxwidth $maxwidth]
2638 puts $f [list set cmitmode $cmitmode]
2639 puts $f [list set wrapcomment $wrapcomment]
2640 puts $f [list set autoselect $autoselect]
2641 puts $f [list set showneartags $showneartags]
2642 puts $f [list set hideremotes $hideremotes]
2643 puts $f [list set showlocalchanges $showlocalchanges]
2644 puts $f [list set datetimeformat $datetimeformat]
2645 puts $f [list set limitdiffs $limitdiffs]
2646 puts $f [list set uicolor $uicolor]
2647 puts $f [list set want_ttk $want_ttk]
2648 puts $f [list set bgcolor $bgcolor]
2649 puts $f [list set fgcolor $fgcolor]
2650 puts $f [list set colors $colors]
2651 puts $f [list set diffcolors $diffcolors]
2652 puts $f [list set markbgcolor $markbgcolor]
2653 puts $f [list set diffcontext $diffcontext]
2654 puts $f [list set selectbgcolor $selectbgcolor]
2655 puts $f [list set extdifftool $extdifftool]
2656 puts $f [list set perfile_attrs $perfile_attrs]
2658 puts $f "set geometry(main) [wm geometry .]"
2659 puts $f "set geometry(state) [wm state .]"
2660 puts $f "set geometry(topwidth) [winfo width .tf]"
2661 puts $f "set geometry(topheight) [winfo height .tf]"
2662 if {$use_ttk} {
2663 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2664 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2665 } else {
2666 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2667 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2669 puts $f "set geometry(botwidth) [winfo width .bleft]"
2670 puts $f "set geometry(botheight) [winfo height .bleft]"
2672 puts -nonewline $f "set permviews {"
2673 for {set v 0} {$v < $nextviewnum} {incr v} {
2674 if {$viewperm($v)} {
2675 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2678 puts $f "}"
2679 close $f
2680 file rename -force "~/.gitk-new" "~/.gitk"
2682 set stuffsaved 1
2685 proc resizeclistpanes {win w} {
2686 global oldwidth use_ttk
2687 if {[info exists oldwidth($win)]} {
2688 if {$use_ttk} {
2689 set s0 [$win sashpos 0]
2690 set s1 [$win sashpos 1]
2691 } else {
2692 set s0 [$win sash coord 0]
2693 set s1 [$win sash coord 1]
2695 if {$w < 60} {
2696 set sash0 [expr {int($w/2 - 2)}]
2697 set sash1 [expr {int($w*5/6 - 2)}]
2698 } else {
2699 set factor [expr {1.0 * $w / $oldwidth($win)}]
2700 set sash0 [expr {int($factor * [lindex $s0 0])}]
2701 set sash1 [expr {int($factor * [lindex $s1 0])}]
2702 if {$sash0 < 30} {
2703 set sash0 30
2705 if {$sash1 < $sash0 + 20} {
2706 set sash1 [expr {$sash0 + 20}]
2708 if {$sash1 > $w - 10} {
2709 set sash1 [expr {$w - 10}]
2710 if {$sash0 > $sash1 - 20} {
2711 set sash0 [expr {$sash1 - 20}]
2715 if {$use_ttk} {
2716 $win sashpos 0 $sash0
2717 $win sashpos 1 $sash1
2718 } else {
2719 $win sash place 0 $sash0 [lindex $s0 1]
2720 $win sash place 1 $sash1 [lindex $s1 1]
2723 set oldwidth($win) $w
2726 proc resizecdetpanes {win w} {
2727 global oldwidth use_ttk
2728 if {[info exists oldwidth($win)]} {
2729 if {$use_ttk} {
2730 set s0 [$win sashpos 0]
2731 } else {
2732 set s0 [$win sash coord 0]
2734 if {$w < 60} {
2735 set sash0 [expr {int($w*3/4 - 2)}]
2736 } else {
2737 set factor [expr {1.0 * $w / $oldwidth($win)}]
2738 set sash0 [expr {int($factor * [lindex $s0 0])}]
2739 if {$sash0 < 45} {
2740 set sash0 45
2742 if {$sash0 > $w - 15} {
2743 set sash0 [expr {$w - 15}]
2746 if {$use_ttk} {
2747 $win sashpos 0 $sash0
2748 } else {
2749 $win sash place 0 $sash0 [lindex $s0 1]
2752 set oldwidth($win) $w
2755 proc allcanvs args {
2756 global canv canv2 canv3
2757 eval $canv $args
2758 eval $canv2 $args
2759 eval $canv3 $args
2762 proc bindall {event action} {
2763 global canv canv2 canv3
2764 bind $canv $event $action
2765 bind $canv2 $event $action
2766 bind $canv3 $event $action
2769 proc about {} {
2770 global uifont NS
2771 set w .about
2772 if {[winfo exists $w]} {
2773 raise $w
2774 return
2776 ttk_toplevel $w
2777 wm title $w [mc "About gitk"]
2778 make_transient $w .
2779 message $w.m -text [mc "
2780 Gitk - a commit viewer for git
2782 Copyright \u00a9 2005-2009 Paul Mackerras
2784 Use and redistribute under the terms of the GNU General Public License"] \
2785 -justify center -aspect 400 -border 2 -bg white -relief groove
2786 pack $w.m -side top -fill x -padx 2 -pady 2
2787 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2788 pack $w.ok -side bottom
2789 bind $w <Visibility> "focus $w.ok"
2790 bind $w <Key-Escape> "destroy $w"
2791 bind $w <Key-Return> "destroy $w"
2792 tk::PlaceWindow $w widget .
2795 proc keys {} {
2796 global NS
2797 set w .keys
2798 if {[winfo exists $w]} {
2799 raise $w
2800 return
2802 if {[tk windowingsystem] eq {aqua}} {
2803 set M1T Cmd
2804 } else {
2805 set M1T Ctrl
2807 ttk_toplevel $w
2808 wm title $w [mc "Gitk key bindings"]
2809 make_transient $w .
2810 message $w.m -text "
2811 [mc "Gitk key bindings:"]
2813 [mc "<%s-Q> Quit" $M1T]
2814 [mc "<Home> Move to first commit"]
2815 [mc "<End> Move to last commit"]
2816 [mc "<Up>, p, i Move up one commit"]
2817 [mc "<Down>, n, k Move down one commit"]
2818 [mc "<Left>, z, j Go back in history list"]
2819 [mc "<Right>, x, l Go forward in history list"]
2820 [mc "<PageUp> Move up one page in commit list"]
2821 [mc "<PageDown> Move down one page in commit list"]
2822 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2823 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2824 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2825 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2826 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2827 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2828 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2829 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2830 [mc "<Delete>, b Scroll diff view up one page"]
2831 [mc "<Backspace> Scroll diff view up one page"]
2832 [mc "<Space> Scroll diff view down one page"]
2833 [mc "u Scroll diff view up 18 lines"]
2834 [mc "d Scroll diff view down 18 lines"]
2835 [mc "<%s-F> Find" $M1T]
2836 [mc "<%s-G> Move to next find hit" $M1T]
2837 [mc "<Return> Move to next find hit"]
2838 [mc "/ Focus the search box"]
2839 [mc "? Move to previous find hit"]
2840 [mc "f Scroll diff view to next file"]
2841 [mc "<%s-S> Search for next hit in diff view" $M1T]
2842 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2843 [mc "<%s-KP+> Increase font size" $M1T]
2844 [mc "<%s-plus> Increase font size" $M1T]
2845 [mc "<%s-KP-> Decrease font size" $M1T]
2846 [mc "<%s-minus> Decrease font size" $M1T]
2847 [mc "<F5> Update"]
2849 -justify left -bg white -border 2 -relief groove
2850 pack $w.m -side top -fill both -padx 2 -pady 2
2851 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2852 bind $w <Key-Escape> [list destroy $w]
2853 pack $w.ok -side bottom
2854 bind $w <Visibility> "focus $w.ok"
2855 bind $w <Key-Escape> "destroy $w"
2856 bind $w <Key-Return> "destroy $w"
2859 # Procedures for manipulating the file list window at the
2860 # bottom right of the overall window.
2862 proc treeview {w l openlevs} {
2863 global treecontents treediropen treeheight treeparent treeindex
2865 set ix 0
2866 set treeindex() 0
2867 set lev 0
2868 set prefix {}
2869 set prefixend -1
2870 set prefendstack {}
2871 set htstack {}
2872 set ht 0
2873 set treecontents() {}
2874 $w conf -state normal
2875 foreach f $l {
2876 while {[string range $f 0 $prefixend] ne $prefix} {
2877 if {$lev <= $openlevs} {
2878 $w mark set e:$treeindex($prefix) "end -1c"
2879 $w mark gravity e:$treeindex($prefix) left
2881 set treeheight($prefix) $ht
2882 incr ht [lindex $htstack end]
2883 set htstack [lreplace $htstack end end]
2884 set prefixend [lindex $prefendstack end]
2885 set prefendstack [lreplace $prefendstack end end]
2886 set prefix [string range $prefix 0 $prefixend]
2887 incr lev -1
2889 set tail [string range $f [expr {$prefixend+1}] end]
2890 while {[set slash [string first "/" $tail]] >= 0} {
2891 lappend htstack $ht
2892 set ht 0
2893 lappend prefendstack $prefixend
2894 incr prefixend [expr {$slash + 1}]
2895 set d [string range $tail 0 $slash]
2896 lappend treecontents($prefix) $d
2897 set oldprefix $prefix
2898 append prefix $d
2899 set treecontents($prefix) {}
2900 set treeindex($prefix) [incr ix]
2901 set treeparent($prefix) $oldprefix
2902 set tail [string range $tail [expr {$slash+1}] end]
2903 if {$lev <= $openlevs} {
2904 set ht 1
2905 set treediropen($prefix) [expr {$lev < $openlevs}]
2906 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2907 $w mark set d:$ix "end -1c"
2908 $w mark gravity d:$ix left
2909 set str "\n"
2910 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2911 $w insert end $str
2912 $w image create end -align center -image $bm -padx 1 \
2913 -name a:$ix
2914 $w insert end $d [highlight_tag $prefix]
2915 $w mark set s:$ix "end -1c"
2916 $w mark gravity s:$ix left
2918 incr lev
2920 if {$tail ne {}} {
2921 if {$lev <= $openlevs} {
2922 incr ht
2923 set str "\n"
2924 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2925 $w insert end $str
2926 $w insert end $tail [highlight_tag $f]
2928 lappend treecontents($prefix) $tail
2931 while {$htstack ne {}} {
2932 set treeheight($prefix) $ht
2933 incr ht [lindex $htstack end]
2934 set htstack [lreplace $htstack end end]
2935 set prefixend [lindex $prefendstack end]
2936 set prefendstack [lreplace $prefendstack end end]
2937 set prefix [string range $prefix 0 $prefixend]
2939 $w conf -state disabled
2942 proc linetoelt {l} {
2943 global treeheight treecontents
2945 set y 2
2946 set prefix {}
2947 while {1} {
2948 foreach e $treecontents($prefix) {
2949 if {$y == $l} {
2950 return "$prefix$e"
2952 set n 1
2953 if {[string index $e end] eq "/"} {
2954 set n $treeheight($prefix$e)
2955 if {$y + $n > $l} {
2956 append prefix $e
2957 incr y
2958 break
2961 incr y $n
2966 proc highlight_tree {y prefix} {
2967 global treeheight treecontents cflist
2969 foreach e $treecontents($prefix) {
2970 set path $prefix$e
2971 if {[highlight_tag $path] ne {}} {
2972 $cflist tag add bold $y.0 "$y.0 lineend"
2974 incr y
2975 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2976 set y [highlight_tree $y $path]
2979 return $y
2982 proc treeclosedir {w dir} {
2983 global treediropen treeheight treeparent treeindex
2985 set ix $treeindex($dir)
2986 $w conf -state normal
2987 $w delete s:$ix e:$ix
2988 set treediropen($dir) 0
2989 $w image configure a:$ix -image tri-rt
2990 $w conf -state disabled
2991 set n [expr {1 - $treeheight($dir)}]
2992 while {$dir ne {}} {
2993 incr treeheight($dir) $n
2994 set dir $treeparent($dir)
2998 proc treeopendir {w dir} {
2999 global treediropen treeheight treeparent treecontents treeindex
3001 set ix $treeindex($dir)
3002 $w conf -state normal
3003 $w image configure a:$ix -image tri-dn
3004 $w mark set e:$ix s:$ix
3005 $w mark gravity e:$ix right
3006 set lev 0
3007 set str "\n"
3008 set n [llength $treecontents($dir)]
3009 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3010 incr lev
3011 append str "\t"
3012 incr treeheight($x) $n
3014 foreach e $treecontents($dir) {
3015 set de $dir$e
3016 if {[string index $e end] eq "/"} {
3017 set iy $treeindex($de)
3018 $w mark set d:$iy e:$ix
3019 $w mark gravity d:$iy left
3020 $w insert e:$ix $str
3021 set treediropen($de) 0
3022 $w image create e:$ix -align center -image tri-rt -padx 1 \
3023 -name a:$iy
3024 $w insert e:$ix $e [highlight_tag $de]
3025 $w mark set s:$iy e:$ix
3026 $w mark gravity s:$iy left
3027 set treeheight($de) 1
3028 } else {
3029 $w insert e:$ix $str
3030 $w insert e:$ix $e [highlight_tag $de]
3033 $w mark gravity e:$ix right
3034 $w conf -state disabled
3035 set treediropen($dir) 1
3036 set top [lindex [split [$w index @0,0] .] 0]
3037 set ht [$w cget -height]
3038 set l [lindex [split [$w index s:$ix] .] 0]
3039 if {$l < $top} {
3040 $w yview $l.0
3041 } elseif {$l + $n + 1 > $top + $ht} {
3042 set top [expr {$l + $n + 2 - $ht}]
3043 if {$l < $top} {
3044 set top $l
3046 $w yview $top.0
3050 proc treeclick {w x y} {
3051 global treediropen cmitmode ctext cflist cflist_top
3053 if {$cmitmode ne "tree"} return
3054 if {![info exists cflist_top]} return
3055 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3056 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3057 $cflist tag add highlight $l.0 "$l.0 lineend"
3058 set cflist_top $l
3059 if {$l == 1} {
3060 $ctext yview 1.0
3061 return
3063 set e [linetoelt $l]
3064 if {[string index $e end] ne "/"} {
3065 showfile $e
3066 } elseif {$treediropen($e)} {
3067 treeclosedir $w $e
3068 } else {
3069 treeopendir $w $e
3073 proc setfilelist {id} {
3074 global treefilelist cflist jump_to_here
3076 treeview $cflist $treefilelist($id) 0
3077 if {$jump_to_here ne {}} {
3078 set f [lindex $jump_to_here 0]
3079 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3080 showfile $f
3085 image create bitmap tri-rt -background black -foreground blue -data {
3086 #define tri-rt_width 13
3087 #define tri-rt_height 13
3088 static unsigned char tri-rt_bits[] = {
3089 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3090 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3091 0x00, 0x00};
3092 } -maskdata {
3093 #define tri-rt-mask_width 13
3094 #define tri-rt-mask_height 13
3095 static unsigned char tri-rt-mask_bits[] = {
3096 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3097 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3098 0x08, 0x00};
3100 image create bitmap tri-dn -background black -foreground blue -data {
3101 #define tri-dn_width 13
3102 #define tri-dn_height 13
3103 static unsigned char tri-dn_bits[] = {
3104 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3105 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3106 0x00, 0x00};
3107 } -maskdata {
3108 #define tri-dn-mask_width 13
3109 #define tri-dn-mask_height 13
3110 static unsigned char tri-dn-mask_bits[] = {
3111 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3112 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3113 0x00, 0x00};
3116 image create bitmap reficon-T -background black -foreground yellow -data {
3117 #define tagicon_width 13
3118 #define tagicon_height 9
3119 static unsigned char tagicon_bits[] = {
3120 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3121 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3122 } -maskdata {
3123 #define tagicon-mask_width 13
3124 #define tagicon-mask_height 9
3125 static unsigned char tagicon-mask_bits[] = {
3126 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3127 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3129 set rectdata {
3130 #define headicon_width 13
3131 #define headicon_height 9
3132 static unsigned char headicon_bits[] = {
3133 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3134 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3136 set rectmask {
3137 #define headicon-mask_width 13
3138 #define headicon-mask_height 9
3139 static unsigned char headicon-mask_bits[] = {
3140 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3141 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3143 image create bitmap reficon-H -background black -foreground green \
3144 -data $rectdata -maskdata $rectmask
3145 image create bitmap reficon-o -background black -foreground "#ddddff" \
3146 -data $rectdata -maskdata $rectmask
3148 proc init_flist {first} {
3149 global cflist cflist_top difffilestart
3151 $cflist conf -state normal
3152 $cflist delete 0.0 end
3153 if {$first ne {}} {
3154 $cflist insert end $first
3155 set cflist_top 1
3156 $cflist tag add highlight 1.0 "1.0 lineend"
3157 } else {
3158 catch {unset cflist_top}
3160 $cflist conf -state disabled
3161 set difffilestart {}
3164 proc highlight_tag {f} {
3165 global highlight_paths
3167 foreach p $highlight_paths {
3168 if {[string match $p $f]} {
3169 return "bold"
3172 return {}
3175 proc highlight_filelist {} {
3176 global cmitmode cflist
3178 $cflist conf -state normal
3179 if {$cmitmode ne "tree"} {
3180 set end [lindex [split [$cflist index end] .] 0]
3181 for {set l 2} {$l < $end} {incr l} {
3182 set line [$cflist get $l.0 "$l.0 lineend"]
3183 if {[highlight_tag $line] ne {}} {
3184 $cflist tag add bold $l.0 "$l.0 lineend"
3187 } else {
3188 highlight_tree 2 {}
3190 $cflist conf -state disabled
3193 proc unhighlight_filelist {} {
3194 global cflist
3196 $cflist conf -state normal
3197 $cflist tag remove bold 1.0 end
3198 $cflist conf -state disabled
3201 proc add_flist {fl} {
3202 global cflist
3204 $cflist conf -state normal
3205 foreach f $fl {
3206 $cflist insert end "\n"
3207 $cflist insert end $f [highlight_tag $f]
3209 $cflist conf -state disabled
3212 proc sel_flist {w x y} {
3213 global ctext difffilestart cflist cflist_top cmitmode
3215 if {$cmitmode eq "tree"} return
3216 if {![info exists cflist_top]} return
3217 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3218 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3219 $cflist tag add highlight $l.0 "$l.0 lineend"
3220 set cflist_top $l
3221 if {$l == 1} {
3222 $ctext yview 1.0
3223 } else {
3224 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3228 proc pop_flist_menu {w X Y x y} {
3229 global ctext cflist cmitmode flist_menu flist_menu_file
3230 global treediffs diffids
3232 stopfinding
3233 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3234 if {$l <= 1} return
3235 if {$cmitmode eq "tree"} {
3236 set e [linetoelt $l]
3237 if {[string index $e end] eq "/"} return
3238 } else {
3239 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3241 set flist_menu_file $e
3242 set xdiffstate "normal"
3243 if {$cmitmode eq "tree"} {
3244 set xdiffstate "disabled"
3246 # Disable "External diff" item in tree mode
3247 $flist_menu entryconf 2 -state $xdiffstate
3248 tk_popup $flist_menu $X $Y
3251 proc find_ctext_fileinfo {line} {
3252 global ctext_file_names ctext_file_lines
3254 set ok [bsearch $ctext_file_lines $line]
3255 set tline [lindex $ctext_file_lines $ok]
3257 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3258 return {}
3259 } else {
3260 return [list [lindex $ctext_file_names $ok] $tline]
3264 proc pop_diff_menu {w X Y x y} {
3265 global ctext diff_menu flist_menu_file
3266 global diff_menu_txtpos diff_menu_line
3267 global diff_menu_filebase
3269 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3270 set diff_menu_line [lindex $diff_menu_txtpos 0]
3271 # don't pop up the menu on hunk-separator or file-separator lines
3272 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3273 return
3275 stopfinding
3276 set f [find_ctext_fileinfo $diff_menu_line]
3277 if {$f eq {}} return
3278 set flist_menu_file [lindex $f 0]
3279 set diff_menu_filebase [lindex $f 1]
3280 tk_popup $diff_menu $X $Y
3283 proc flist_hl {only} {
3284 global flist_menu_file findstring gdttype
3286 set x [shellquote $flist_menu_file]
3287 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3288 set findstring $x
3289 } else {
3290 append findstring " " $x
3292 set gdttype [mc "touching paths:"]
3295 proc gitknewtmpdir {} {
3296 global diffnum gitktmpdir gitdir
3298 if {![info exists gitktmpdir]} {
3299 set gitktmpdir [file join [file dirname $gitdir] \
3300 [format ".gitk-tmp.%s" [pid]]]
3301 if {[catch {file mkdir $gitktmpdir} err]} {
3302 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3303 unset gitktmpdir
3304 return {}
3306 set diffnum 0
3308 incr diffnum
3309 set diffdir [file join $gitktmpdir $diffnum]
3310 if {[catch {file mkdir $diffdir} err]} {
3311 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3312 return {}
3314 return $diffdir
3317 proc save_file_from_commit {filename output what} {
3318 global nullfile
3320 if {[catch {exec git show $filename -- > $output} err]} {
3321 if {[string match "fatal: bad revision *" $err]} {
3322 return $nullfile
3324 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3325 return {}
3327 return $output
3330 proc external_diff_get_one_file {diffid filename diffdir} {
3331 global nullid nullid2 nullfile
3332 global gitdir
3334 if {$diffid == $nullid} {
3335 set difffile [file join [file dirname $gitdir] $filename]
3336 if {[file exists $difffile]} {
3337 return $difffile
3339 return $nullfile
3341 if {$diffid == $nullid2} {
3342 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3343 return [save_file_from_commit :$filename $difffile index]
3345 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3346 return [save_file_from_commit $diffid:$filename $difffile \
3347 "revision $diffid"]
3350 proc external_diff {} {
3351 global nullid nullid2
3352 global flist_menu_file
3353 global diffids
3354 global extdifftool
3356 if {[llength $diffids] == 1} {
3357 # no reference commit given
3358 set diffidto [lindex $diffids 0]
3359 if {$diffidto eq $nullid} {
3360 # diffing working copy with index
3361 set diffidfrom $nullid2
3362 } elseif {$diffidto eq $nullid2} {
3363 # diffing index with HEAD
3364 set diffidfrom "HEAD"
3365 } else {
3366 # use first parent commit
3367 global parentlist selectedline
3368 set diffidfrom [lindex $parentlist $selectedline 0]
3370 } else {
3371 set diffidfrom [lindex $diffids 0]
3372 set diffidto [lindex $diffids 1]
3375 # make sure that several diffs wont collide
3376 set diffdir [gitknewtmpdir]
3377 if {$diffdir eq {}} return
3379 # gather files to diff
3380 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3381 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3383 if {$difffromfile ne {} && $difftofile ne {}} {
3384 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3385 if {[catch {set fl [open |$cmd r]} err]} {
3386 file delete -force $diffdir
3387 error_popup "$extdifftool: [mc "command failed:"] $err"
3388 } else {
3389 fconfigure $fl -blocking 0
3390 filerun $fl [list delete_at_eof $fl $diffdir]
3395 proc find_hunk_blamespec {base line} {
3396 global ctext
3398 # Find and parse the hunk header
3399 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3400 if {$s_lix eq {}} return
3402 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3403 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3404 s_line old_specs osz osz1 new_line nsz]} {
3405 return
3408 # base lines for the parents
3409 set base_lines [list $new_line]
3410 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3411 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3412 old_spec old_line osz]} {
3413 return
3415 lappend base_lines $old_line
3418 # Now scan the lines to determine offset within the hunk
3419 set max_parent [expr {[llength $base_lines]-2}]
3420 set dline 0
3421 set s_lno [lindex [split $s_lix "."] 0]
3423 # Determine if the line is removed
3424 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3425 if {[string match {[-+ ]*} $chunk]} {
3426 set removed_idx [string first "-" $chunk]
3427 # Choose a parent index
3428 if {$removed_idx >= 0} {
3429 set parent $removed_idx
3430 } else {
3431 set unchanged_idx [string first " " $chunk]
3432 if {$unchanged_idx >= 0} {
3433 set parent $unchanged_idx
3434 } else {
3435 # blame the current commit
3436 set parent -1
3439 # then count other lines that belong to it
3440 for {set i $line} {[incr i -1] > $s_lno} {} {
3441 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3442 # Determine if the line is removed
3443 set removed_idx [string first "-" $chunk]
3444 if {$parent >= 0} {
3445 set code [string index $chunk $parent]
3446 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3447 incr dline
3449 } else {
3450 if {$removed_idx < 0} {
3451 incr dline
3455 incr parent
3456 } else {
3457 set parent 0
3460 incr dline [lindex $base_lines $parent]
3461 return [list $parent $dline]
3464 proc external_blame_diff {} {
3465 global currentid cmitmode
3466 global diff_menu_txtpos diff_menu_line
3467 global diff_menu_filebase flist_menu_file
3469 if {$cmitmode eq "tree"} {
3470 set parent_idx 0
3471 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3472 } else {
3473 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3474 if {$hinfo ne {}} {
3475 set parent_idx [lindex $hinfo 0]
3476 set line [lindex $hinfo 1]
3477 } else {
3478 set parent_idx 0
3479 set line 0
3483 external_blame $parent_idx $line
3486 # Find the SHA1 ID of the blob for file $fname in the index
3487 # at stage 0 or 2
3488 proc index_sha1 {fname} {
3489 set f [open [list | git ls-files -s $fname] r]
3490 while {[gets $f line] >= 0} {
3491 set info [lindex [split $line "\t"] 0]
3492 set stage [lindex $info 2]
3493 if {$stage eq "0" || $stage eq "2"} {
3494 close $f
3495 return [lindex $info 1]
3498 close $f
3499 return {}
3502 # Turn an absolute path into one relative to the current directory
3503 proc make_relative {f} {
3504 if {[file pathtype $f] eq "relative"} {
3505 return $f
3507 set elts [file split $f]
3508 set here [file split [pwd]]
3509 set ei 0
3510 set hi 0
3511 set res {}
3512 foreach d $here {
3513 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3514 lappend res ".."
3515 } else {
3516 incr ei
3518 incr hi
3520 set elts [concat $res [lrange $elts $ei end]]
3521 return [eval file join $elts]
3524 proc external_blame {parent_idx {line {}}} {
3525 global flist_menu_file gitdir
3526 global nullid nullid2
3527 global parentlist selectedline currentid
3529 if {$parent_idx > 0} {
3530 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3531 } else {
3532 set base_commit $currentid
3535 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3536 error_popup [mc "No such commit"]
3537 return
3540 set cmdline [list git gui blame]
3541 if {$line ne {} && $line > 1} {
3542 lappend cmdline "--line=$line"
3544 set f [file join [file dirname $gitdir] $flist_menu_file]
3545 # Unfortunately it seems git gui blame doesn't like
3546 # being given an absolute path...
3547 set f [make_relative $f]
3548 lappend cmdline $base_commit $f
3549 if {[catch {eval exec $cmdline &} err]} {
3550 error_popup "[mc "git gui blame: command failed:"] $err"
3554 proc show_line_source {} {
3555 global cmitmode currentid parents curview blamestuff blameinst
3556 global diff_menu_line diff_menu_filebase flist_menu_file
3557 global nullid nullid2 gitdir
3559 set from_index {}
3560 if {$cmitmode eq "tree"} {
3561 set id $currentid
3562 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3563 } else {
3564 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3565 if {$h eq {}} return
3566 set pi [lindex $h 0]
3567 if {$pi == 0} {
3568 mark_ctext_line $diff_menu_line
3569 return
3571 incr pi -1
3572 if {$currentid eq $nullid} {
3573 if {$pi > 0} {
3574 # must be a merge in progress...
3575 if {[catch {
3576 # get the last line from .git/MERGE_HEAD
3577 set f [open [file join $gitdir MERGE_HEAD] r]
3578 set id [lindex [split [read $f] "\n"] end-1]
3579 close $f
3580 } err]} {
3581 error_popup [mc "Couldn't read merge head: %s" $err]
3582 return
3584 } elseif {$parents($curview,$currentid) eq $nullid2} {
3585 # need to do the blame from the index
3586 if {[catch {
3587 set from_index [index_sha1 $flist_menu_file]
3588 } err]} {
3589 error_popup [mc "Error reading index: %s" $err]
3590 return
3592 } else {
3593 set id $parents($curview,$currentid)
3595 } else {
3596 set id [lindex $parents($curview,$currentid) $pi]
3598 set line [lindex $h 1]
3600 set blameargs {}
3601 if {$from_index ne {}} {
3602 lappend blameargs | git cat-file blob $from_index
3604 lappend blameargs | git blame -p -L$line,+1
3605 if {$from_index ne {}} {
3606 lappend blameargs --contents -
3607 } else {
3608 lappend blameargs $id
3610 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3611 if {[catch {
3612 set f [open $blameargs r]
3613 } err]} {
3614 error_popup [mc "Couldn't start git blame: %s" $err]
3615 return
3617 nowbusy blaming [mc "Searching"]
3618 fconfigure $f -blocking 0
3619 set i [reg_instance $f]
3620 set blamestuff($i) {}
3621 set blameinst $i
3622 filerun $f [list read_line_source $f $i]
3625 proc stopblaming {} {
3626 global blameinst
3628 if {[info exists blameinst]} {
3629 stop_instance $blameinst
3630 unset blameinst
3631 notbusy blaming
3635 proc read_line_source {fd inst} {
3636 global blamestuff curview commfd blameinst nullid nullid2
3638 while {[gets $fd line] >= 0} {
3639 lappend blamestuff($inst) $line
3641 if {![eof $fd]} {
3642 return 1
3644 unset commfd($inst)
3645 unset blameinst
3646 notbusy blaming
3647 fconfigure $fd -blocking 1
3648 if {[catch {close $fd} err]} {
3649 error_popup [mc "Error running git blame: %s" $err]
3650 return 0
3653 set fname {}
3654 set line [split [lindex $blamestuff($inst) 0] " "]
3655 set id [lindex $line 0]
3656 set lnum [lindex $line 1]
3657 if {[string length $id] == 40 && [string is xdigit $id] &&
3658 [string is digit -strict $lnum]} {
3659 # look for "filename" line
3660 foreach l $blamestuff($inst) {
3661 if {[string match "filename *" $l]} {
3662 set fname [string range $l 9 end]
3663 break
3667 if {$fname ne {}} {
3668 # all looks good, select it
3669 if {$id eq $nullid} {
3670 # blame uses all-zeroes to mean not committed,
3671 # which would mean a change in the index
3672 set id $nullid2
3674 if {[commitinview $id $curview]} {
3675 selectline [rowofcommit $id] 1 [list $fname $lnum]
3676 } else {
3677 error_popup [mc "That line comes from commit %s, \
3678 which is not in this view" [shortids $id]]
3680 } else {
3681 puts "oops couldn't parse git blame output"
3683 return 0
3686 # delete $dir when we see eof on $f (presumably because the child has exited)
3687 proc delete_at_eof {f dir} {
3688 while {[gets $f line] >= 0} {}
3689 if {[eof $f]} {
3690 if {[catch {close $f} err]} {
3691 error_popup "[mc "External diff viewer failed:"] $err"
3693 file delete -force $dir
3694 return 0
3696 return 1
3699 # Functions for adding and removing shell-type quoting
3701 proc shellquote {str} {
3702 if {![string match "*\['\"\\ \t]*" $str]} {
3703 return $str
3705 if {![string match "*\['\"\\]*" $str]} {
3706 return "\"$str\""
3708 if {![string match "*'*" $str]} {
3709 return "'$str'"
3711 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3714 proc shellarglist {l} {
3715 set str {}
3716 foreach a $l {
3717 if {$str ne {}} {
3718 append str " "
3720 append str [shellquote $a]
3722 return $str
3725 proc shelldequote {str} {
3726 set ret {}
3727 set used -1
3728 while {1} {
3729 incr used
3730 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3731 append ret [string range $str $used end]
3732 set used [string length $str]
3733 break
3735 set first [lindex $first 0]
3736 set ch [string index $str $first]
3737 if {$first > $used} {
3738 append ret [string range $str $used [expr {$first - 1}]]
3739 set used $first
3741 if {$ch eq " " || $ch eq "\t"} break
3742 incr used
3743 if {$ch eq "'"} {
3744 set first [string first "'" $str $used]
3745 if {$first < 0} {
3746 error "unmatched single-quote"
3748 append ret [string range $str $used [expr {$first - 1}]]
3749 set used $first
3750 continue
3752 if {$ch eq "\\"} {
3753 if {$used >= [string length $str]} {
3754 error "trailing backslash"
3756 append ret [string index $str $used]
3757 continue
3759 # here ch == "\""
3760 while {1} {
3761 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3762 error "unmatched double-quote"
3764 set first [lindex $first 0]
3765 set ch [string index $str $first]
3766 if {$first > $used} {
3767 append ret [string range $str $used [expr {$first - 1}]]
3768 set used $first
3770 if {$ch eq "\""} break
3771 incr used
3772 append ret [string index $str $used]
3773 incr used
3776 return [list $used $ret]
3779 proc shellsplit {str} {
3780 set l {}
3781 while {1} {
3782 set str [string trimleft $str]
3783 if {$str eq {}} break
3784 set dq [shelldequote $str]
3785 set n [lindex $dq 0]
3786 set word [lindex $dq 1]
3787 set str [string range $str $n end]
3788 lappend l $word
3790 return $l
3793 # Code to implement multiple views
3795 proc newview {ishighlight} {
3796 global nextviewnum newviewname newishighlight
3797 global revtreeargs viewargscmd newviewopts curview
3799 set newishighlight $ishighlight
3800 set top .gitkview
3801 if {[winfo exists $top]} {
3802 raise $top
3803 return
3805 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3806 set newviewopts($nextviewnum,perm) 0
3807 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3808 decode_view_opts $nextviewnum $revtreeargs
3809 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3812 set known_view_options {
3813 {perm b . {} {mc "Remember this view"}}
3814 {reflabel l + {} {mc "References (space separated list):"}}
3815 {refs t15 .. {} {mc "Branches & tags:"}}
3816 {allrefs b *. "--all" {mc "All refs"}}
3817 {branches b . "--branches" {mc "All (local) branches"}}
3818 {tags b . "--tags" {mc "All tags"}}
3819 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3820 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3821 {author t15 .. "--author=*" {mc "Author:"}}
3822 {committer t15 . "--committer=*" {mc "Committer:"}}
3823 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3824 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3825 {changes_l l + {} {mc "Changes to Files:"}}
3826 {pickaxe_s r0 . {} {mc "Fixed String"}}
3827 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3828 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3829 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3830 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3831 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3832 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3833 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3834 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3835 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3836 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3837 {lright b . "--left-right" {mc "Mark branch sides"}}
3838 {first b . "--first-parent" {mc "Limit to first parent"}}
3839 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3840 {args t50 *. {} {mc "Additional arguments to git log:"}}
3841 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3842 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3845 proc encode_view_opts {n} {
3846 global known_view_options newviewopts
3848 set rargs [list]
3849 foreach opt $known_view_options {
3850 set patterns [lindex $opt 3]
3851 if {$patterns eq {}} continue
3852 set pattern [lindex $patterns 0]
3854 if {[lindex $opt 1] eq "b"} {
3855 set val $newviewopts($n,[lindex $opt 0])
3856 if {$val} {
3857 lappend rargs $pattern
3859 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3860 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3861 set val $newviewopts($n,$button_id)
3862 if {$val eq $value} {
3863 lappend rargs $pattern
3865 } else {
3866 set val $newviewopts($n,[lindex $opt 0])
3867 set val [string trim $val]
3868 if {$val ne {}} {
3869 set pfix [string range $pattern 0 end-1]
3870 lappend rargs $pfix$val
3874 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3875 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3878 proc decode_view_opts {n view_args} {
3879 global known_view_options newviewopts
3881 foreach opt $known_view_options {
3882 set id [lindex $opt 0]
3883 if {[lindex $opt 1] eq "b"} {
3884 # Checkboxes
3885 set val 0
3886 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3887 # Radiobuttons
3888 regexp {^(.*_)} $id uselessvar id
3889 set val 0
3890 } else {
3891 # Text fields
3892 set val {}
3894 set newviewopts($n,$id) $val
3896 set oargs [list]
3897 set refargs [list]
3898 foreach arg $view_args {
3899 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3900 && ![info exists found(limit)]} {
3901 set newviewopts($n,limit) $cnt
3902 set found(limit) 1
3903 continue
3905 catch { unset val }
3906 foreach opt $known_view_options {
3907 set id [lindex $opt 0]
3908 if {[info exists found($id)]} continue
3909 foreach pattern [lindex $opt 3] {
3910 if {![string match $pattern $arg]} continue
3911 if {[lindex $opt 1] eq "b"} {
3912 # Check buttons
3913 set val 1
3914 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3915 # Radio buttons
3916 regexp {^(.*_)} $id uselessvar id
3917 set val $num
3918 } else {
3919 # Text input fields
3920 set size [string length $pattern]
3921 set val [string range $arg [expr {$size-1}] end]
3923 set newviewopts($n,$id) $val
3924 set found($id) 1
3925 break
3927 if {[info exists val]} break
3929 if {[info exists val]} continue
3930 if {[regexp {^-} $arg]} {
3931 lappend oargs $arg
3932 } else {
3933 lappend refargs $arg
3936 set newviewopts($n,refs) [shellarglist $refargs]
3937 set newviewopts($n,args) [shellarglist $oargs]
3940 proc edit_or_newview {} {
3941 global curview
3943 if {$curview > 0} {
3944 editview
3945 } else {
3946 newview 0
3950 proc editview {} {
3951 global curview
3952 global viewname viewperm newviewname newviewopts
3953 global viewargs viewargscmd
3955 set top .gitkvedit-$curview
3956 if {[winfo exists $top]} {
3957 raise $top
3958 return
3960 set newviewname($curview) $viewname($curview)
3961 set newviewopts($curview,perm) $viewperm($curview)
3962 set newviewopts($curview,cmd) $viewargscmd($curview)
3963 decode_view_opts $curview $viewargs($curview)
3964 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3967 proc vieweditor {top n title} {
3968 global newviewname newviewopts viewfiles bgcolor
3969 global known_view_options NS
3971 ttk_toplevel $top
3972 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3973 make_transient $top .
3975 # View name
3976 ${NS}::frame $top.nfr
3977 ${NS}::label $top.nl -text [mc "View Name"]
3978 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
3979 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3980 pack $top.nl -in $top.nfr -side left -padx {0 5}
3981 pack $top.name -in $top.nfr -side left -padx {0 25}
3983 # View options
3984 set cframe $top.nfr
3985 set cexpand 0
3986 set cnt 0
3987 foreach opt $known_view_options {
3988 set id [lindex $opt 0]
3989 set type [lindex $opt 1]
3990 set flags [lindex $opt 2]
3991 set title [eval [lindex $opt 4]]
3992 set lxpad 0
3994 if {$flags eq "+" || $flags eq "*"} {
3995 set cframe $top.fr$cnt
3996 incr cnt
3997 ${NS}::frame $cframe
3998 pack $cframe -in $top -fill x -pady 3 -padx 3
3999 set cexpand [expr {$flags eq "*"}]
4000 } elseif {$flags eq ".." || $flags eq "*."} {
4001 set cframe $top.fr$cnt
4002 incr cnt
4003 ${NS}::frame $cframe
4004 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4005 set cexpand [expr {$flags eq "*."}]
4006 } else {
4007 set lxpad 5
4010 if {$type eq "l"} {
4011 ${NS}::label $cframe.l_$id -text $title
4012 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4013 } elseif {$type eq "b"} {
4014 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4015 pack $cframe.c_$id -in $cframe -side left \
4016 -padx [list $lxpad 0] -expand $cexpand -anchor w
4017 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4018 regexp {^(.*_)} $id uselessvar button_id
4019 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4020 pack $cframe.c_$id -in $cframe -side left \
4021 -padx [list $lxpad 0] -expand $cexpand -anchor w
4022 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4023 ${NS}::label $cframe.l_$id -text $title
4024 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4025 -textvariable newviewopts($n,$id)
4026 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4027 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4028 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4029 ${NS}::label $cframe.l_$id -text $title
4030 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4031 -textvariable newviewopts($n,$id)
4032 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4033 pack $cframe.e_$id -in $cframe -side top -fill x
4034 } elseif {$type eq "path"} {
4035 ${NS}::label $top.l -text $title
4036 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4037 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
4038 if {[info exists viewfiles($n)]} {
4039 foreach f $viewfiles($n) {
4040 $top.t insert end $f
4041 $top.t insert end "\n"
4043 $top.t delete {end - 1c} end
4044 $top.t mark set insert 0.0
4046 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4050 ${NS}::frame $top.buts
4051 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4052 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4053 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4054 bind $top <Control-Return> [list newviewok $top $n]
4055 bind $top <F5> [list newviewok $top $n 1]
4056 bind $top <Escape> [list destroy $top]
4057 grid $top.buts.ok $top.buts.apply $top.buts.can
4058 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4059 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4060 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4061 pack $top.buts -in $top -side top -fill x
4062 focus $top.t
4065 proc doviewmenu {m first cmd op argv} {
4066 set nmenu [$m index end]
4067 for {set i $first} {$i <= $nmenu} {incr i} {
4068 if {[$m entrycget $i -command] eq $cmd} {
4069 eval $m $op $i $argv
4070 break
4075 proc allviewmenus {n op args} {
4076 # global viewhlmenu
4078 doviewmenu .bar.view 5 [list showview $n] $op $args
4079 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4082 proc newviewok {top n {apply 0}} {
4083 global nextviewnum newviewperm newviewname newishighlight
4084 global viewname viewfiles viewperm selectedview curview
4085 global viewargs viewargscmd newviewopts viewhlmenu
4087 if {[catch {
4088 set newargs [encode_view_opts $n]
4089 } err]} {
4090 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4091 return
4093 set files {}
4094 foreach f [split [$top.t get 0.0 end] "\n"] {
4095 set ft [string trim $f]
4096 if {$ft ne {}} {
4097 lappend files $ft
4100 if {![info exists viewfiles($n)]} {
4101 # creating a new view
4102 incr nextviewnum
4103 set viewname($n) $newviewname($n)
4104 set viewperm($n) $newviewopts($n,perm)
4105 set viewfiles($n) $files
4106 set viewargs($n) $newargs
4107 set viewargscmd($n) $newviewopts($n,cmd)
4108 addviewmenu $n
4109 if {!$newishighlight} {
4110 run showview $n
4111 } else {
4112 run addvhighlight $n
4114 } else {
4115 # editing an existing view
4116 set viewperm($n) $newviewopts($n,perm)
4117 if {$newviewname($n) ne $viewname($n)} {
4118 set viewname($n) $newviewname($n)
4119 doviewmenu .bar.view 5 [list showview $n] \
4120 entryconf [list -label $viewname($n)]
4121 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4122 # entryconf [list -label $viewname($n) -value $viewname($n)]
4124 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4125 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4126 set viewfiles($n) $files
4127 set viewargs($n) $newargs
4128 set viewargscmd($n) $newviewopts($n,cmd)
4129 if {$curview == $n} {
4130 run reloadcommits
4134 if {$apply} return
4135 catch {destroy $top}
4138 proc delview {} {
4139 global curview viewperm hlview selectedhlview
4141 if {$curview == 0} return
4142 if {[info exists hlview] && $hlview == $curview} {
4143 set selectedhlview [mc "None"]
4144 unset hlview
4146 allviewmenus $curview delete
4147 set viewperm($curview) 0
4148 showview 0
4151 proc addviewmenu {n} {
4152 global viewname viewhlmenu
4154 .bar.view add radiobutton -label $viewname($n) \
4155 -command [list showview $n] -variable selectedview -value $n
4156 #$viewhlmenu add radiobutton -label $viewname($n) \
4157 # -command [list addvhighlight $n] -variable selectedhlview
4160 proc showview {n} {
4161 global curview cached_commitrow ordertok
4162 global displayorder parentlist rowidlist rowisopt rowfinal
4163 global colormap rowtextx nextcolor canvxmax
4164 global numcommits viewcomplete
4165 global selectedline currentid canv canvy0
4166 global treediffs
4167 global pending_select mainheadid
4168 global commitidx
4169 global selectedview
4170 global hlview selectedhlview commitinterest
4172 if {$n == $curview} return
4173 set selid {}
4174 set ymax [lindex [$canv cget -scrollregion] 3]
4175 set span [$canv yview]
4176 set ytop [expr {[lindex $span 0] * $ymax}]
4177 set ybot [expr {[lindex $span 1] * $ymax}]
4178 set yscreen [expr {($ybot - $ytop) / 2}]
4179 if {$selectedline ne {}} {
4180 set selid $currentid
4181 set y [yc $selectedline]
4182 if {$ytop < $y && $y < $ybot} {
4183 set yscreen [expr {$y - $ytop}]
4185 } elseif {[info exists pending_select]} {
4186 set selid $pending_select
4187 unset pending_select
4189 unselectline
4190 normalline
4191 catch {unset treediffs}
4192 clear_display
4193 if {[info exists hlview] && $hlview == $n} {
4194 unset hlview
4195 set selectedhlview [mc "None"]
4197 catch {unset commitinterest}
4198 catch {unset cached_commitrow}
4199 catch {unset ordertok}
4201 set curview $n
4202 set selectedview $n
4203 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4204 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4206 run refill_reflist
4207 if {![info exists viewcomplete($n)]} {
4208 getcommits $selid
4209 return
4212 set displayorder {}
4213 set parentlist {}
4214 set rowidlist {}
4215 set rowisopt {}
4216 set rowfinal {}
4217 set numcommits $commitidx($n)
4219 catch {unset colormap}
4220 catch {unset rowtextx}
4221 set nextcolor 0
4222 set canvxmax [$canv cget -width]
4223 set curview $n
4224 set row 0
4225 setcanvscroll
4226 set yf 0
4227 set row {}
4228 if {$selid ne {} && [commitinview $selid $n]} {
4229 set row [rowofcommit $selid]
4230 # try to get the selected row in the same position on the screen
4231 set ymax [lindex [$canv cget -scrollregion] 3]
4232 set ytop [expr {[yc $row] - $yscreen}]
4233 if {$ytop < 0} {
4234 set ytop 0
4236 set yf [expr {$ytop * 1.0 / $ymax}]
4238 allcanvs yview moveto $yf
4239 drawvisible
4240 if {$row ne {}} {
4241 selectline $row 0
4242 } elseif {!$viewcomplete($n)} {
4243 reset_pending_select $selid
4244 } else {
4245 reset_pending_select {}
4247 if {[commitinview $pending_select $curview]} {
4248 selectline [rowofcommit $pending_select] 1
4249 } else {
4250 set row [first_real_row]
4251 if {$row < $numcommits} {
4252 selectline $row 0
4256 if {!$viewcomplete($n)} {
4257 if {$numcommits == 0} {
4258 show_status [mc "Reading commits..."]
4260 } elseif {$numcommits == 0} {
4261 show_status [mc "No commits selected"]
4265 # Stuff relating to the highlighting facility
4267 proc ishighlighted {id} {
4268 global vhighlights fhighlights nhighlights rhighlights
4270 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4271 return $nhighlights($id)
4273 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4274 return $vhighlights($id)
4276 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4277 return $fhighlights($id)
4279 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4280 return $rhighlights($id)
4282 return 0
4285 proc bolden {id font} {
4286 global canv linehtag currentid boldids need_redisplay markedid
4288 # need_redisplay = 1 means the display is stale and about to be redrawn
4289 if {$need_redisplay} return
4290 lappend boldids $id
4291 $canv itemconf $linehtag($id) -font $font
4292 if {[info exists currentid] && $id eq $currentid} {
4293 $canv delete secsel
4294 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4295 -outline {{}} -tags secsel \
4296 -fill [$canv cget -selectbackground]]
4297 $canv lower $t
4299 if {[info exists markedid] && $id eq $markedid} {
4300 make_idmark $id
4304 proc bolden_name {id font} {
4305 global canv2 linentag currentid boldnameids need_redisplay
4307 if {$need_redisplay} return
4308 lappend boldnameids $id
4309 $canv2 itemconf $linentag($id) -font $font
4310 if {[info exists currentid] && $id eq $currentid} {
4311 $canv2 delete secsel
4312 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4313 -outline {{}} -tags secsel \
4314 -fill [$canv2 cget -selectbackground]]
4315 $canv2 lower $t
4319 proc unbolden {} {
4320 global boldids
4322 set stillbold {}
4323 foreach id $boldids {
4324 if {![ishighlighted $id]} {
4325 bolden $id mainfont
4326 } else {
4327 lappend stillbold $id
4330 set boldids $stillbold
4333 proc addvhighlight {n} {
4334 global hlview viewcomplete curview vhl_done commitidx
4336 if {[info exists hlview]} {
4337 delvhighlight
4339 set hlview $n
4340 if {$n != $curview && ![info exists viewcomplete($n)]} {
4341 start_rev_list $n
4343 set vhl_done $commitidx($hlview)
4344 if {$vhl_done > 0} {
4345 drawvisible
4349 proc delvhighlight {} {
4350 global hlview vhighlights
4352 if {![info exists hlview]} return
4353 unset hlview
4354 catch {unset vhighlights}
4355 unbolden
4358 proc vhighlightmore {} {
4359 global hlview vhl_done commitidx vhighlights curview
4361 set max $commitidx($hlview)
4362 set vr [visiblerows]
4363 set r0 [lindex $vr 0]
4364 set r1 [lindex $vr 1]
4365 for {set i $vhl_done} {$i < $max} {incr i} {
4366 set id [commitonrow $i $hlview]
4367 if {[commitinview $id $curview]} {
4368 set row [rowofcommit $id]
4369 if {$r0 <= $row && $row <= $r1} {
4370 if {![highlighted $row]} {
4371 bolden $id mainfontbold
4373 set vhighlights($id) 1
4377 set vhl_done $max
4378 return 0
4381 proc askvhighlight {row id} {
4382 global hlview vhighlights iddrawn
4384 if {[commitinview $id $hlview]} {
4385 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4386 bolden $id mainfontbold
4388 set vhighlights($id) 1
4389 } else {
4390 set vhighlights($id) 0
4394 proc hfiles_change {} {
4395 global highlight_files filehighlight fhighlights fh_serial
4396 global highlight_paths
4398 if {[info exists filehighlight]} {
4399 # delete previous highlights
4400 catch {close $filehighlight}
4401 unset filehighlight
4402 catch {unset fhighlights}
4403 unbolden
4404 unhighlight_filelist
4406 set highlight_paths {}
4407 after cancel do_file_hl $fh_serial
4408 incr fh_serial
4409 if {$highlight_files ne {}} {
4410 after 300 do_file_hl $fh_serial
4414 proc gdttype_change {name ix op} {
4415 global gdttype highlight_files findstring findpattern
4417 stopfinding
4418 if {$findstring ne {}} {
4419 if {$gdttype eq [mc "containing:"]} {
4420 if {$highlight_files ne {}} {
4421 set highlight_files {}
4422 hfiles_change
4424 findcom_change
4425 } else {
4426 if {$findpattern ne {}} {
4427 set findpattern {}
4428 findcom_change
4430 set highlight_files $findstring
4431 hfiles_change
4433 drawvisible
4435 # enable/disable findtype/findloc menus too
4438 proc find_change {name ix op} {
4439 global gdttype findstring highlight_files
4441 stopfinding
4442 if {$gdttype eq [mc "containing:"]} {
4443 findcom_change
4444 } else {
4445 if {$highlight_files ne $findstring} {
4446 set highlight_files $findstring
4447 hfiles_change
4450 drawvisible
4453 proc findcom_change args {
4454 global nhighlights boldnameids
4455 global findpattern findtype findstring gdttype
4457 stopfinding
4458 # delete previous highlights, if any
4459 foreach id $boldnameids {
4460 bolden_name $id mainfont
4462 set boldnameids {}
4463 catch {unset nhighlights}
4464 unbolden
4465 unmarkmatches
4466 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4467 set findpattern {}
4468 } elseif {$findtype eq [mc "Regexp"]} {
4469 set findpattern $findstring
4470 } else {
4471 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4472 $findstring]
4473 set findpattern "*$e*"
4477 proc makepatterns {l} {
4478 set ret {}
4479 foreach e $l {
4480 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4481 if {[string index $ee end] eq "/"} {
4482 lappend ret "$ee*"
4483 } else {
4484 lappend ret $ee
4485 lappend ret "$ee/*"
4488 return $ret
4491 proc do_file_hl {serial} {
4492 global highlight_files filehighlight highlight_paths gdttype fhl_list
4494 if {$gdttype eq [mc "touching paths:"]} {
4495 if {[catch {set paths [shellsplit $highlight_files]}]} return
4496 set highlight_paths [makepatterns $paths]
4497 highlight_filelist
4498 set gdtargs [concat -- $paths]
4499 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4500 set gdtargs [list "-S$highlight_files"]
4501 } else {
4502 # must be "containing:", i.e. we're searching commit info
4503 return
4505 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4506 set filehighlight [open $cmd r+]
4507 fconfigure $filehighlight -blocking 0
4508 filerun $filehighlight readfhighlight
4509 set fhl_list {}
4510 drawvisible
4511 flushhighlights
4514 proc flushhighlights {} {
4515 global filehighlight fhl_list
4517 if {[info exists filehighlight]} {
4518 lappend fhl_list {}
4519 puts $filehighlight ""
4520 flush $filehighlight
4524 proc askfilehighlight {row id} {
4525 global filehighlight fhighlights fhl_list
4527 lappend fhl_list $id
4528 set fhighlights($id) -1
4529 puts $filehighlight $id
4532 proc readfhighlight {} {
4533 global filehighlight fhighlights curview iddrawn
4534 global fhl_list find_dirn
4536 if {![info exists filehighlight]} {
4537 return 0
4539 set nr 0
4540 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4541 set line [string trim $line]
4542 set i [lsearch -exact $fhl_list $line]
4543 if {$i < 0} continue
4544 for {set j 0} {$j < $i} {incr j} {
4545 set id [lindex $fhl_list $j]
4546 set fhighlights($id) 0
4548 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4549 if {$line eq {}} continue
4550 if {![commitinview $line $curview]} continue
4551 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4552 bolden $line mainfontbold
4554 set fhighlights($line) 1
4556 if {[eof $filehighlight]} {
4557 # strange...
4558 puts "oops, git diff-tree died"
4559 catch {close $filehighlight}
4560 unset filehighlight
4561 return 0
4563 if {[info exists find_dirn]} {
4564 run findmore
4566 return 1
4569 proc doesmatch {f} {
4570 global findtype findpattern
4572 if {$findtype eq [mc "Regexp"]} {
4573 return [regexp $findpattern $f]
4574 } elseif {$findtype eq [mc "IgnCase"]} {
4575 return [string match -nocase $findpattern $f]
4576 } else {
4577 return [string match $findpattern $f]
4581 proc askfindhighlight {row id} {
4582 global nhighlights commitinfo iddrawn
4583 global findloc
4584 global markingmatches
4586 if {![info exists commitinfo($id)]} {
4587 getcommit $id
4589 set info $commitinfo($id)
4590 set isbold 0
4591 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4592 foreach f $info ty $fldtypes {
4593 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4594 [doesmatch $f]} {
4595 if {$ty eq [mc "Author"]} {
4596 set isbold 2
4597 break
4599 set isbold 1
4602 if {$isbold && [info exists iddrawn($id)]} {
4603 if {![ishighlighted $id]} {
4604 bolden $id mainfontbold
4605 if {$isbold > 1} {
4606 bolden_name $id mainfontbold
4609 if {$markingmatches} {
4610 markrowmatches $row $id
4613 set nhighlights($id) $isbold
4616 proc markrowmatches {row id} {
4617 global canv canv2 linehtag linentag commitinfo findloc
4619 set headline [lindex $commitinfo($id) 0]
4620 set author [lindex $commitinfo($id) 1]
4621 $canv delete match$row
4622 $canv2 delete match$row
4623 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4624 set m [findmatches $headline]
4625 if {$m ne {}} {
4626 markmatches $canv $row $headline $linehtag($id) $m \
4627 [$canv itemcget $linehtag($id) -font] $row
4630 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4631 set m [findmatches $author]
4632 if {$m ne {}} {
4633 markmatches $canv2 $row $author $linentag($id) $m \
4634 [$canv2 itemcget $linentag($id) -font] $row
4639 proc vrel_change {name ix op} {
4640 global highlight_related
4642 rhighlight_none
4643 if {$highlight_related ne [mc "None"]} {
4644 run drawvisible
4648 # prepare for testing whether commits are descendents or ancestors of a
4649 proc rhighlight_sel {a} {
4650 global descendent desc_todo ancestor anc_todo
4651 global highlight_related
4653 catch {unset descendent}
4654 set desc_todo [list $a]
4655 catch {unset ancestor}
4656 set anc_todo [list $a]
4657 if {$highlight_related ne [mc "None"]} {
4658 rhighlight_none
4659 run drawvisible
4663 proc rhighlight_none {} {
4664 global rhighlights
4666 catch {unset rhighlights}
4667 unbolden
4670 proc is_descendent {a} {
4671 global curview children descendent desc_todo
4673 set v $curview
4674 set la [rowofcommit $a]
4675 set todo $desc_todo
4676 set leftover {}
4677 set done 0
4678 for {set i 0} {$i < [llength $todo]} {incr i} {
4679 set do [lindex $todo $i]
4680 if {[rowofcommit $do] < $la} {
4681 lappend leftover $do
4682 continue
4684 foreach nk $children($v,$do) {
4685 if {![info exists descendent($nk)]} {
4686 set descendent($nk) 1
4687 lappend todo $nk
4688 if {$nk eq $a} {
4689 set done 1
4693 if {$done} {
4694 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4695 return
4698 set descendent($a) 0
4699 set desc_todo $leftover
4702 proc is_ancestor {a} {
4703 global curview parents ancestor anc_todo
4705 set v $curview
4706 set la [rowofcommit $a]
4707 set todo $anc_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 {![commitinview $do $v] || [rowofcommit $do] > $la} {
4713 lappend leftover $do
4714 continue
4716 foreach np $parents($v,$do) {
4717 if {![info exists ancestor($np)]} {
4718 set ancestor($np) 1
4719 lappend todo $np
4720 if {$np eq $a} {
4721 set done 1
4725 if {$done} {
4726 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4727 return
4730 set ancestor($a) 0
4731 set anc_todo $leftover
4734 proc askrelhighlight {row id} {
4735 global descendent highlight_related iddrawn rhighlights
4736 global selectedline ancestor
4738 if {$selectedline eq {}} return
4739 set isbold 0
4740 if {$highlight_related eq [mc "Descendant"] ||
4741 $highlight_related eq [mc "Not descendant"]} {
4742 if {![info exists descendent($id)]} {
4743 is_descendent $id
4745 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4746 set isbold 1
4748 } elseif {$highlight_related eq [mc "Ancestor"] ||
4749 $highlight_related eq [mc "Not ancestor"]} {
4750 if {![info exists ancestor($id)]} {
4751 is_ancestor $id
4753 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4754 set isbold 1
4757 if {[info exists iddrawn($id)]} {
4758 if {$isbold && ![ishighlighted $id]} {
4759 bolden $id mainfontbold
4762 set rhighlights($id) $isbold
4765 # Graph layout functions
4767 proc shortids {ids} {
4768 set res {}
4769 foreach id $ids {
4770 if {[llength $id] > 1} {
4771 lappend res [shortids $id]
4772 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4773 lappend res [string range $id 0 7]
4774 } else {
4775 lappend res $id
4778 return $res
4781 proc ntimes {n o} {
4782 set ret {}
4783 set o [list $o]
4784 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4785 if {($n & $mask) != 0} {
4786 set ret [concat $ret $o]
4788 set o [concat $o $o]
4790 return $ret
4793 proc ordertoken {id} {
4794 global ordertok curview varcid varcstart varctok curview parents children
4795 global nullid nullid2
4797 if {[info exists ordertok($id)]} {
4798 return $ordertok($id)
4800 set origid $id
4801 set todo {}
4802 while {1} {
4803 if {[info exists varcid($curview,$id)]} {
4804 set a $varcid($curview,$id)
4805 set p [lindex $varcstart($curview) $a]
4806 } else {
4807 set p [lindex $children($curview,$id) 0]
4809 if {[info exists ordertok($p)]} {
4810 set tok $ordertok($p)
4811 break
4813 set id [first_real_child $curview,$p]
4814 if {$id eq {}} {
4815 # it's a root
4816 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4817 break
4819 if {[llength $parents($curview,$id)] == 1} {
4820 lappend todo [list $p {}]
4821 } else {
4822 set j [lsearch -exact $parents($curview,$id) $p]
4823 if {$j < 0} {
4824 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4826 lappend todo [list $p [strrep $j]]
4829 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4830 set p [lindex $todo $i 0]
4831 append tok [lindex $todo $i 1]
4832 set ordertok($p) $tok
4834 set ordertok($origid) $tok
4835 return $tok
4838 # Work out where id should go in idlist so that order-token
4839 # values increase from left to right
4840 proc idcol {idlist id {i 0}} {
4841 set t [ordertoken $id]
4842 if {$i < 0} {
4843 set i 0
4845 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4846 if {$i > [llength $idlist]} {
4847 set i [llength $idlist]
4849 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4850 incr i
4851 } else {
4852 if {$t > [ordertoken [lindex $idlist $i]]} {
4853 while {[incr i] < [llength $idlist] &&
4854 $t >= [ordertoken [lindex $idlist $i]]} {}
4857 return $i
4860 proc initlayout {} {
4861 global rowidlist rowisopt rowfinal displayorder parentlist
4862 global numcommits canvxmax canv
4863 global nextcolor
4864 global colormap rowtextx
4866 set numcommits 0
4867 set displayorder {}
4868 set parentlist {}
4869 set nextcolor 0
4870 set rowidlist {}
4871 set rowisopt {}
4872 set rowfinal {}
4873 set canvxmax [$canv cget -width]
4874 catch {unset colormap}
4875 catch {unset rowtextx}
4876 setcanvscroll
4879 proc setcanvscroll {} {
4880 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4881 global lastscrollset lastscrollrows
4883 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4884 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4885 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4886 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4887 set lastscrollset [clock clicks -milliseconds]
4888 set lastscrollrows $numcommits
4891 proc visiblerows {} {
4892 global canv numcommits linespc
4894 set ymax [lindex [$canv cget -scrollregion] 3]
4895 if {$ymax eq {} || $ymax == 0} return
4896 set f [$canv yview]
4897 set y0 [expr {int([lindex $f 0] * $ymax)}]
4898 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4899 if {$r0 < 0} {
4900 set r0 0
4902 set y1 [expr {int([lindex $f 1] * $ymax)}]
4903 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4904 if {$r1 >= $numcommits} {
4905 set r1 [expr {$numcommits - 1}]
4907 return [list $r0 $r1]
4910 proc layoutmore {} {
4911 global commitidx viewcomplete curview
4912 global numcommits pending_select curview
4913 global lastscrollset lastscrollrows
4915 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4916 [clock clicks -milliseconds] - $lastscrollset > 500} {
4917 setcanvscroll
4919 if {[info exists pending_select] &&
4920 [commitinview $pending_select $curview]} {
4921 update
4922 selectline [rowofcommit $pending_select] 1
4924 drawvisible
4927 # With path limiting, we mightn't get the actual HEAD commit,
4928 # so ask git rev-list what is the first ancestor of HEAD that
4929 # touches a file in the path limit.
4930 proc get_viewmainhead {view} {
4931 global viewmainheadid vfilelimit viewinstances mainheadid
4933 catch {
4934 set rfd [open [concat | git rev-list -1 $mainheadid \
4935 -- $vfilelimit($view)] r]
4936 set j [reg_instance $rfd]
4937 lappend viewinstances($view) $j
4938 fconfigure $rfd -blocking 0
4939 filerun $rfd [list getviewhead $rfd $j $view]
4940 set viewmainheadid($curview) {}
4944 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4945 proc getviewhead {fd inst view} {
4946 global viewmainheadid commfd curview viewinstances showlocalchanges
4948 set id {}
4949 if {[gets $fd line] < 0} {
4950 if {![eof $fd]} {
4951 return 1
4953 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4954 set id $line
4956 set viewmainheadid($view) $id
4957 close $fd
4958 unset commfd($inst)
4959 set i [lsearch -exact $viewinstances($view) $inst]
4960 if {$i >= 0} {
4961 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4963 if {$showlocalchanges && $id ne {} && $view == $curview} {
4964 doshowlocalchanges
4966 return 0
4969 proc doshowlocalchanges {} {
4970 global curview viewmainheadid
4972 if {$viewmainheadid($curview) eq {}} return
4973 if {[commitinview $viewmainheadid($curview) $curview]} {
4974 dodiffindex
4975 } else {
4976 interestedin $viewmainheadid($curview) dodiffindex
4980 proc dohidelocalchanges {} {
4981 global nullid nullid2 lserial curview
4983 if {[commitinview $nullid $curview]} {
4984 removefakerow $nullid
4986 if {[commitinview $nullid2 $curview]} {
4987 removefakerow $nullid2
4989 incr lserial
4992 # spawn off a process to do git diff-index --cached HEAD
4993 proc dodiffindex {} {
4994 global lserial showlocalchanges vfilelimit curview
4995 global isworktree
4997 if {!$showlocalchanges || !$isworktree} return
4998 incr lserial
4999 set cmd "|git diff-index --cached HEAD"
5000 if {$vfilelimit($curview) ne {}} {
5001 set cmd [concat $cmd -- $vfilelimit($curview)]
5003 set fd [open $cmd r]
5004 fconfigure $fd -blocking 0
5005 set i [reg_instance $fd]
5006 filerun $fd [list readdiffindex $fd $lserial $i]
5009 proc readdiffindex {fd serial inst} {
5010 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5011 global vfilelimit
5013 set isdiff 1
5014 if {[gets $fd line] < 0} {
5015 if {![eof $fd]} {
5016 return 1
5018 set isdiff 0
5020 # we only need to see one line and we don't really care what it says...
5021 stop_instance $inst
5023 if {$serial != $lserial} {
5024 return 0
5027 # now see if there are any local changes not checked in to the index
5028 set cmd "|git diff-files"
5029 if {$vfilelimit($curview) ne {}} {
5030 set cmd [concat $cmd -- $vfilelimit($curview)]
5032 set fd [open $cmd r]
5033 fconfigure $fd -blocking 0
5034 set i [reg_instance $fd]
5035 filerun $fd [list readdifffiles $fd $serial $i]
5037 if {$isdiff && ![commitinview $nullid2 $curview]} {
5038 # add the line for the changes in the index to the graph
5039 set hl [mc "Local changes checked in to index but not committed"]
5040 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5041 set commitdata($nullid2) "\n $hl\n"
5042 if {[commitinview $nullid $curview]} {
5043 removefakerow $nullid
5045 insertfakerow $nullid2 $viewmainheadid($curview)
5046 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5047 if {[commitinview $nullid $curview]} {
5048 removefakerow $nullid
5050 removefakerow $nullid2
5052 return 0
5055 proc readdifffiles {fd serial inst} {
5056 global viewmainheadid nullid nullid2 curview
5057 global commitinfo commitdata lserial
5059 set isdiff 1
5060 if {[gets $fd line] < 0} {
5061 if {![eof $fd]} {
5062 return 1
5064 set isdiff 0
5066 # we only need to see one line and we don't really care what it says...
5067 stop_instance $inst
5069 if {$serial != $lserial} {
5070 return 0
5073 if {$isdiff && ![commitinview $nullid $curview]} {
5074 # add the line for the local diff to the graph
5075 set hl [mc "Local uncommitted changes, not checked in to index"]
5076 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5077 set commitdata($nullid) "\n $hl\n"
5078 if {[commitinview $nullid2 $curview]} {
5079 set p $nullid2
5080 } else {
5081 set p $viewmainheadid($curview)
5083 insertfakerow $nullid $p
5084 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5085 removefakerow $nullid
5087 return 0
5090 proc nextuse {id row} {
5091 global curview children
5093 if {[info exists children($curview,$id)]} {
5094 foreach kid $children($curview,$id) {
5095 if {![commitinview $kid $curview]} {
5096 return -1
5098 if {[rowofcommit $kid] > $row} {
5099 return [rowofcommit $kid]
5103 if {[commitinview $id $curview]} {
5104 return [rowofcommit $id]
5106 return -1
5109 proc prevuse {id row} {
5110 global curview children
5112 set ret -1
5113 if {[info exists children($curview,$id)]} {
5114 foreach kid $children($curview,$id) {
5115 if {![commitinview $kid $curview]} break
5116 if {[rowofcommit $kid] < $row} {
5117 set ret [rowofcommit $kid]
5121 return $ret
5124 proc make_idlist {row} {
5125 global displayorder parentlist uparrowlen downarrowlen mingaplen
5126 global commitidx curview children
5128 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5129 if {$r < 0} {
5130 set r 0
5132 set ra [expr {$row - $downarrowlen}]
5133 if {$ra < 0} {
5134 set ra 0
5136 set rb [expr {$row + $uparrowlen}]
5137 if {$rb > $commitidx($curview)} {
5138 set rb $commitidx($curview)
5140 make_disporder $r [expr {$rb + 1}]
5141 set ids {}
5142 for {} {$r < $ra} {incr r} {
5143 set nextid [lindex $displayorder [expr {$r + 1}]]
5144 foreach p [lindex $parentlist $r] {
5145 if {$p eq $nextid} continue
5146 set rn [nextuse $p $r]
5147 if {$rn >= $row &&
5148 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5149 lappend ids [list [ordertoken $p] $p]
5153 for {} {$r < $row} {incr r} {
5154 set nextid [lindex $displayorder [expr {$r + 1}]]
5155 foreach p [lindex $parentlist $r] {
5156 if {$p eq $nextid} continue
5157 set rn [nextuse $p $r]
5158 if {$rn < 0 || $rn >= $row} {
5159 lappend ids [list [ordertoken $p] $p]
5163 set id [lindex $displayorder $row]
5164 lappend ids [list [ordertoken $id] $id]
5165 while {$r < $rb} {
5166 foreach p [lindex $parentlist $r] {
5167 set firstkid [lindex $children($curview,$p) 0]
5168 if {[rowofcommit $firstkid] < $row} {
5169 lappend ids [list [ordertoken $p] $p]
5172 incr r
5173 set id [lindex $displayorder $r]
5174 if {$id ne {}} {
5175 set firstkid [lindex $children($curview,$id) 0]
5176 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5177 lappend ids [list [ordertoken $id] $id]
5181 set idlist {}
5182 foreach idx [lsort -unique $ids] {
5183 lappend idlist [lindex $idx 1]
5185 return $idlist
5188 proc rowsequal {a b} {
5189 while {[set i [lsearch -exact $a {}]] >= 0} {
5190 set a [lreplace $a $i $i]
5192 while {[set i [lsearch -exact $b {}]] >= 0} {
5193 set b [lreplace $b $i $i]
5195 return [expr {$a eq $b}]
5198 proc makeupline {id row rend col} {
5199 global rowidlist uparrowlen downarrowlen mingaplen
5201 for {set r $rend} {1} {set r $rstart} {
5202 set rstart [prevuse $id $r]
5203 if {$rstart < 0} return
5204 if {$rstart < $row} break
5206 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5207 set rstart [expr {$rend - $uparrowlen - 1}]
5209 for {set r $rstart} {[incr r] <= $row} {} {
5210 set idlist [lindex $rowidlist $r]
5211 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5212 set col [idcol $idlist $id $col]
5213 lset rowidlist $r [linsert $idlist $col $id]
5214 changedrow $r
5219 proc layoutrows {row endrow} {
5220 global rowidlist rowisopt rowfinal displayorder
5221 global uparrowlen downarrowlen maxwidth mingaplen
5222 global children parentlist
5223 global commitidx viewcomplete curview
5225 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5226 set idlist {}
5227 if {$row > 0} {
5228 set rm1 [expr {$row - 1}]
5229 foreach id [lindex $rowidlist $rm1] {
5230 if {$id ne {}} {
5231 lappend idlist $id
5234 set final [lindex $rowfinal $rm1]
5236 for {} {$row < $endrow} {incr row} {
5237 set rm1 [expr {$row - 1}]
5238 if {$rm1 < 0 || $idlist eq {}} {
5239 set idlist [make_idlist $row]
5240 set final 1
5241 } else {
5242 set id [lindex $displayorder $rm1]
5243 set col [lsearch -exact $idlist $id]
5244 set idlist [lreplace $idlist $col $col]
5245 foreach p [lindex $parentlist $rm1] {
5246 if {[lsearch -exact $idlist $p] < 0} {
5247 set col [idcol $idlist $p $col]
5248 set idlist [linsert $idlist $col $p]
5249 # if not the first child, we have to insert a line going up
5250 if {$id ne [lindex $children($curview,$p) 0]} {
5251 makeupline $p $rm1 $row $col
5255 set id [lindex $displayorder $row]
5256 if {$row > $downarrowlen} {
5257 set termrow [expr {$row - $downarrowlen - 1}]
5258 foreach p [lindex $parentlist $termrow] {
5259 set i [lsearch -exact $idlist $p]
5260 if {$i < 0} continue
5261 set nr [nextuse $p $termrow]
5262 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5263 set idlist [lreplace $idlist $i $i]
5267 set col [lsearch -exact $idlist $id]
5268 if {$col < 0} {
5269 set col [idcol $idlist $id]
5270 set idlist [linsert $idlist $col $id]
5271 if {$children($curview,$id) ne {}} {
5272 makeupline $id $rm1 $row $col
5275 set r [expr {$row + $uparrowlen - 1}]
5276 if {$r < $commitidx($curview)} {
5277 set x $col
5278 foreach p [lindex $parentlist $r] {
5279 if {[lsearch -exact $idlist $p] >= 0} continue
5280 set fk [lindex $children($curview,$p) 0]
5281 if {[rowofcommit $fk] < $row} {
5282 set x [idcol $idlist $p $x]
5283 set idlist [linsert $idlist $x $p]
5286 if {[incr r] < $commitidx($curview)} {
5287 set p [lindex $displayorder $r]
5288 if {[lsearch -exact $idlist $p] < 0} {
5289 set fk [lindex $children($curview,$p) 0]
5290 if {$fk ne {} && [rowofcommit $fk] < $row} {
5291 set x [idcol $idlist $p $x]
5292 set idlist [linsert $idlist $x $p]
5298 if {$final && !$viewcomplete($curview) &&
5299 $row + $uparrowlen + $mingaplen + $downarrowlen
5300 >= $commitidx($curview)} {
5301 set final 0
5303 set l [llength $rowidlist]
5304 if {$row == $l} {
5305 lappend rowidlist $idlist
5306 lappend rowisopt 0
5307 lappend rowfinal $final
5308 } elseif {$row < $l} {
5309 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5310 lset rowidlist $row $idlist
5311 changedrow $row
5313 lset rowfinal $row $final
5314 } else {
5315 set pad [ntimes [expr {$row - $l}] {}]
5316 set rowidlist [concat $rowidlist $pad]
5317 lappend rowidlist $idlist
5318 set rowfinal [concat $rowfinal $pad]
5319 lappend rowfinal $final
5320 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5323 return $row
5326 proc changedrow {row} {
5327 global displayorder iddrawn rowisopt need_redisplay
5329 set l [llength $rowisopt]
5330 if {$row < $l} {
5331 lset rowisopt $row 0
5332 if {$row + 1 < $l} {
5333 lset rowisopt [expr {$row + 1}] 0
5334 if {$row + 2 < $l} {
5335 lset rowisopt [expr {$row + 2}] 0
5339 set id [lindex $displayorder $row]
5340 if {[info exists iddrawn($id)]} {
5341 set need_redisplay 1
5345 proc insert_pad {row col npad} {
5346 global rowidlist
5348 set pad [ntimes $npad {}]
5349 set idlist [lindex $rowidlist $row]
5350 set bef [lrange $idlist 0 [expr {$col - 1}]]
5351 set aft [lrange $idlist $col end]
5352 set i [lsearch -exact $aft {}]
5353 if {$i > 0} {
5354 set aft [lreplace $aft $i $i]
5356 lset rowidlist $row [concat $bef $pad $aft]
5357 changedrow $row
5360 proc optimize_rows {row col endrow} {
5361 global rowidlist rowisopt displayorder curview children
5363 if {$row < 1} {
5364 set row 1
5366 for {} {$row < $endrow} {incr row; set col 0} {
5367 if {[lindex $rowisopt $row]} continue
5368 set haspad 0
5369 set y0 [expr {$row - 1}]
5370 set ym [expr {$row - 2}]
5371 set idlist [lindex $rowidlist $row]
5372 set previdlist [lindex $rowidlist $y0]
5373 if {$idlist eq {} || $previdlist eq {}} continue
5374 if {$ym >= 0} {
5375 set pprevidlist [lindex $rowidlist $ym]
5376 if {$pprevidlist eq {}} continue
5377 } else {
5378 set pprevidlist {}
5380 set x0 -1
5381 set xm -1
5382 for {} {$col < [llength $idlist]} {incr col} {
5383 set id [lindex $idlist $col]
5384 if {[lindex $previdlist $col] eq $id} continue
5385 if {$id eq {}} {
5386 set haspad 1
5387 continue
5389 set x0 [lsearch -exact $previdlist $id]
5390 if {$x0 < 0} continue
5391 set z [expr {$x0 - $col}]
5392 set isarrow 0
5393 set z0 {}
5394 if {$ym >= 0} {
5395 set xm [lsearch -exact $pprevidlist $id]
5396 if {$xm >= 0} {
5397 set z0 [expr {$xm - $x0}]
5400 if {$z0 eq {}} {
5401 # if row y0 is the first child of $id then it's not an arrow
5402 if {[lindex $children($curview,$id) 0] ne
5403 [lindex $displayorder $y0]} {
5404 set isarrow 1
5407 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5408 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5409 set isarrow 1
5411 # Looking at lines from this row to the previous row,
5412 # make them go straight up if they end in an arrow on
5413 # the previous row; otherwise make them go straight up
5414 # or at 45 degrees.
5415 if {$z < -1 || ($z < 0 && $isarrow)} {
5416 # Line currently goes left too much;
5417 # insert pads in the previous row, then optimize it
5418 set npad [expr {-1 - $z + $isarrow}]
5419 insert_pad $y0 $x0 $npad
5420 if {$y0 > 0} {
5421 optimize_rows $y0 $x0 $row
5423 set previdlist [lindex $rowidlist $y0]
5424 set x0 [lsearch -exact $previdlist $id]
5425 set z [expr {$x0 - $col}]
5426 if {$z0 ne {}} {
5427 set pprevidlist [lindex $rowidlist $ym]
5428 set xm [lsearch -exact $pprevidlist $id]
5429 set z0 [expr {$xm - $x0}]
5431 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5432 # Line currently goes right too much;
5433 # insert pads in this line
5434 set npad [expr {$z - 1 + $isarrow}]
5435 insert_pad $row $col $npad
5436 set idlist [lindex $rowidlist $row]
5437 incr col $npad
5438 set z [expr {$x0 - $col}]
5439 set haspad 1
5441 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5442 # this line links to its first child on row $row-2
5443 set id [lindex $displayorder $ym]
5444 set xc [lsearch -exact $pprevidlist $id]
5445 if {$xc >= 0} {
5446 set z0 [expr {$xc - $x0}]
5449 # avoid lines jigging left then immediately right
5450 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5451 insert_pad $y0 $x0 1
5452 incr x0
5453 optimize_rows $y0 $x0 $row
5454 set previdlist [lindex $rowidlist $y0]
5457 if {!$haspad} {
5458 # Find the first column that doesn't have a line going right
5459 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5460 set id [lindex $idlist $col]
5461 if {$id eq {}} break
5462 set x0 [lsearch -exact $previdlist $id]
5463 if {$x0 < 0} {
5464 # check if this is the link to the first child
5465 set kid [lindex $displayorder $y0]
5466 if {[lindex $children($curview,$id) 0] eq $kid} {
5467 # it is, work out offset to child
5468 set x0 [lsearch -exact $previdlist $kid]
5471 if {$x0 <= $col} break
5473 # Insert a pad at that column as long as it has a line and
5474 # isn't the last column
5475 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5476 set idlist [linsert $idlist $col {}]
5477 lset rowidlist $row $idlist
5478 changedrow $row
5484 proc xc {row col} {
5485 global canvx0 linespc
5486 return [expr {$canvx0 + $col * $linespc}]
5489 proc yc {row} {
5490 global canvy0 linespc
5491 return [expr {$canvy0 + $row * $linespc}]
5494 proc linewidth {id} {
5495 global thickerline lthickness
5497 set wid $lthickness
5498 if {[info exists thickerline] && $id eq $thickerline} {
5499 set wid [expr {2 * $lthickness}]
5501 return $wid
5504 proc rowranges {id} {
5505 global curview children uparrowlen downarrowlen
5506 global rowidlist
5508 set kids $children($curview,$id)
5509 if {$kids eq {}} {
5510 return {}
5512 set ret {}
5513 lappend kids $id
5514 foreach child $kids {
5515 if {![commitinview $child $curview]} break
5516 set row [rowofcommit $child]
5517 if {![info exists prev]} {
5518 lappend ret [expr {$row + 1}]
5519 } else {
5520 if {$row <= $prevrow} {
5521 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5523 # see if the line extends the whole way from prevrow to row
5524 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5525 [lsearch -exact [lindex $rowidlist \
5526 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5527 # it doesn't, see where it ends
5528 set r [expr {$prevrow + $downarrowlen}]
5529 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5530 while {[incr r -1] > $prevrow &&
5531 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5532 } else {
5533 while {[incr r] <= $row &&
5534 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5535 incr r -1
5537 lappend ret $r
5538 # see where it starts up again
5539 set r [expr {$row - $uparrowlen}]
5540 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5541 while {[incr r] < $row &&
5542 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5543 } else {
5544 while {[incr r -1] >= $prevrow &&
5545 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5546 incr r
5548 lappend ret $r
5551 if {$child eq $id} {
5552 lappend ret $row
5554 set prev $child
5555 set prevrow $row
5557 return $ret
5560 proc drawlineseg {id row endrow arrowlow} {
5561 global rowidlist displayorder iddrawn linesegs
5562 global canv colormap linespc curview maxlinelen parentlist
5564 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5565 set le [expr {$row + 1}]
5566 set arrowhigh 1
5567 while {1} {
5568 set c [lsearch -exact [lindex $rowidlist $le] $id]
5569 if {$c < 0} {
5570 incr le -1
5571 break
5573 lappend cols $c
5574 set x [lindex $displayorder $le]
5575 if {$x eq $id} {
5576 set arrowhigh 0
5577 break
5579 if {[info exists iddrawn($x)] || $le == $endrow} {
5580 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5581 if {$c >= 0} {
5582 lappend cols $c
5583 set arrowhigh 0
5585 break
5587 incr le
5589 if {$le <= $row} {
5590 return $row
5593 set lines {}
5594 set i 0
5595 set joinhigh 0
5596 if {[info exists linesegs($id)]} {
5597 set lines $linesegs($id)
5598 foreach li $lines {
5599 set r0 [lindex $li 0]
5600 if {$r0 > $row} {
5601 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5602 set joinhigh 1
5604 break
5606 incr i
5609 set joinlow 0
5610 if {$i > 0} {
5611 set li [lindex $lines [expr {$i-1}]]
5612 set r1 [lindex $li 1]
5613 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5614 set joinlow 1
5618 set x [lindex $cols [expr {$le - $row}]]
5619 set xp [lindex $cols [expr {$le - 1 - $row}]]
5620 set dir [expr {$xp - $x}]
5621 if {$joinhigh} {
5622 set ith [lindex $lines $i 2]
5623 set coords [$canv coords $ith]
5624 set ah [$canv itemcget $ith -arrow]
5625 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5626 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5627 if {$x2 ne {} && $x - $x2 == $dir} {
5628 set coords [lrange $coords 0 end-2]
5630 } else {
5631 set coords [list [xc $le $x] [yc $le]]
5633 if {$joinlow} {
5634 set itl [lindex $lines [expr {$i-1}] 2]
5635 set al [$canv itemcget $itl -arrow]
5636 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5637 } elseif {$arrowlow} {
5638 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5639 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5640 set arrowlow 0
5643 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5644 for {set y $le} {[incr y -1] > $row} {} {
5645 set x $xp
5646 set xp [lindex $cols [expr {$y - 1 - $row}]]
5647 set ndir [expr {$xp - $x}]
5648 if {$dir != $ndir || $xp < 0} {
5649 lappend coords [xc $y $x] [yc $y]
5651 set dir $ndir
5653 if {!$joinlow} {
5654 if {$xp < 0} {
5655 # join parent line to first child
5656 set ch [lindex $displayorder $row]
5657 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5658 if {$xc < 0} {
5659 puts "oops: drawlineseg: child $ch not on row $row"
5660 } elseif {$xc != $x} {
5661 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5662 set d [expr {int(0.5 * $linespc)}]
5663 set x1 [xc $row $x]
5664 if {$xc < $x} {
5665 set x2 [expr {$x1 - $d}]
5666 } else {
5667 set x2 [expr {$x1 + $d}]
5669 set y2 [yc $row]
5670 set y1 [expr {$y2 + $d}]
5671 lappend coords $x1 $y1 $x2 $y2
5672 } elseif {$xc < $x - 1} {
5673 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5674 } elseif {$xc > $x + 1} {
5675 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5677 set x $xc
5679 lappend coords [xc $row $x] [yc $row]
5680 } else {
5681 set xn [xc $row $xp]
5682 set yn [yc $row]
5683 lappend coords $xn $yn
5685 if {!$joinhigh} {
5686 assigncolor $id
5687 set t [$canv create line $coords -width [linewidth $id] \
5688 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5689 $canv lower $t
5690 bindline $t $id
5691 set lines [linsert $lines $i [list $row $le $t]]
5692 } else {
5693 $canv coords $ith $coords
5694 if {$arrow ne $ah} {
5695 $canv itemconf $ith -arrow $arrow
5697 lset lines $i 0 $row
5699 } else {
5700 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5701 set ndir [expr {$xo - $xp}]
5702 set clow [$canv coords $itl]
5703 if {$dir == $ndir} {
5704 set clow [lrange $clow 2 end]
5706 set coords [concat $coords $clow]
5707 if {!$joinhigh} {
5708 lset lines [expr {$i-1}] 1 $le
5709 } else {
5710 # coalesce two pieces
5711 $canv delete $ith
5712 set b [lindex $lines [expr {$i-1}] 0]
5713 set e [lindex $lines $i 1]
5714 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5716 $canv coords $itl $coords
5717 if {$arrow ne $al} {
5718 $canv itemconf $itl -arrow $arrow
5722 set linesegs($id) $lines
5723 return $le
5726 proc drawparentlinks {id row} {
5727 global rowidlist canv colormap curview parentlist
5728 global idpos linespc
5730 set rowids [lindex $rowidlist $row]
5731 set col [lsearch -exact $rowids $id]
5732 if {$col < 0} return
5733 set olds [lindex $parentlist $row]
5734 set row2 [expr {$row + 1}]
5735 set x [xc $row $col]
5736 set y [yc $row]
5737 set y2 [yc $row2]
5738 set d [expr {int(0.5 * $linespc)}]
5739 set ymid [expr {$y + $d}]
5740 set ids [lindex $rowidlist $row2]
5741 # rmx = right-most X coord used
5742 set rmx 0
5743 foreach p $olds {
5744 set i [lsearch -exact $ids $p]
5745 if {$i < 0} {
5746 puts "oops, parent $p of $id not in list"
5747 continue
5749 set x2 [xc $row2 $i]
5750 if {$x2 > $rmx} {
5751 set rmx $x2
5753 set j [lsearch -exact $rowids $p]
5754 if {$j < 0} {
5755 # drawlineseg will do this one for us
5756 continue
5758 assigncolor $p
5759 # should handle duplicated parents here...
5760 set coords [list $x $y]
5761 if {$i != $col} {
5762 # if attaching to a vertical segment, draw a smaller
5763 # slant for visual distinctness
5764 if {$i == $j} {
5765 if {$i < $col} {
5766 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5767 } else {
5768 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5770 } elseif {$i < $col && $i < $j} {
5771 # segment slants towards us already
5772 lappend coords [xc $row $j] $y
5773 } else {
5774 if {$i < $col - 1} {
5775 lappend coords [expr {$x2 + $linespc}] $y
5776 } elseif {$i > $col + 1} {
5777 lappend coords [expr {$x2 - $linespc}] $y
5779 lappend coords $x2 $y2
5781 } else {
5782 lappend coords $x2 $y2
5784 set t [$canv create line $coords -width [linewidth $p] \
5785 -fill $colormap($p) -tags lines.$p]
5786 $canv lower $t
5787 bindline $t $p
5789 if {$rmx > [lindex $idpos($id) 1]} {
5790 lset idpos($id) 1 $rmx
5791 redrawtags $id
5795 proc drawlines {id} {
5796 global canv
5798 $canv itemconf lines.$id -width [linewidth $id]
5801 proc drawcmittext {id row col} {
5802 global linespc canv canv2 canv3 fgcolor curview
5803 global cmitlisted commitinfo rowidlist parentlist
5804 global rowtextx idpos idtags idheads idotherrefs
5805 global linehtag linentag linedtag selectedline
5806 global canvxmax boldids boldnameids fgcolor markedid
5807 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5809 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5810 set listed $cmitlisted($curview,$id)
5811 if {$id eq $nullid} {
5812 set ofill red
5813 } elseif {$id eq $nullid2} {
5814 set ofill green
5815 } elseif {$id eq $mainheadid} {
5816 set ofill yellow
5817 } else {
5818 set ofill [lindex $circlecolors $listed]
5820 set x [xc $row $col]
5821 set y [yc $row]
5822 set orad [expr {$linespc / 3}]
5823 if {$listed <= 2} {
5824 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5825 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5826 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5827 } elseif {$listed == 3} {
5828 # triangle pointing left for left-side commits
5829 set t [$canv create polygon \
5830 [expr {$x - $orad}] $y \
5831 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5832 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5833 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5834 } else {
5835 # triangle pointing right for right-side commits
5836 set t [$canv create polygon \
5837 [expr {$x + $orad - 1}] $y \
5838 [expr {$x - $orad}] [expr {$y - $orad}] \
5839 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5840 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5842 set circleitem($row) $t
5843 $canv raise $t
5844 $canv bind $t <1> {selcanvline {} %x %y}
5845 set rmx [llength [lindex $rowidlist $row]]
5846 set olds [lindex $parentlist $row]
5847 if {$olds ne {}} {
5848 set nextids [lindex $rowidlist [expr {$row + 1}]]
5849 foreach p $olds {
5850 set i [lsearch -exact $nextids $p]
5851 if {$i > $rmx} {
5852 set rmx $i
5856 set xt [xc $row $rmx]
5857 set rowtextx($row) $xt
5858 set idpos($id) [list $x $xt $y]
5859 if {[info exists idtags($id)] || [info exists idheads($id)]
5860 || [info exists idotherrefs($id)]} {
5861 set xt [drawtags $id $x $xt $y]
5863 set headline [lindex $commitinfo($id) 0]
5864 set name [lindex $commitinfo($id) 1]
5865 set date [lindex $commitinfo($id) 2]
5866 set date [formatdate $date]
5867 set font mainfont
5868 set nfont mainfont
5869 set isbold [ishighlighted $id]
5870 if {$isbold > 0} {
5871 lappend boldids $id
5872 set font mainfontbold
5873 if {$isbold > 1} {
5874 lappend boldnameids $id
5875 set nfont mainfontbold
5878 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5879 -text $headline -font $font -tags text]
5880 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5881 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5882 -text $name -font $nfont -tags text]
5883 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5884 -text $date -font mainfont -tags text]
5885 if {$selectedline == $row} {
5886 make_secsel $id
5888 if {[info exists markedid] && $markedid eq $id} {
5889 make_idmark $id
5891 set xr [expr {$xt + [font measure $font $headline]}]
5892 if {$xr > $canvxmax} {
5893 set canvxmax $xr
5894 setcanvscroll
5898 proc drawcmitrow {row} {
5899 global displayorder rowidlist nrows_drawn
5900 global iddrawn markingmatches
5901 global commitinfo numcommits
5902 global filehighlight fhighlights findpattern nhighlights
5903 global hlview vhighlights
5904 global highlight_related rhighlights
5906 if {$row >= $numcommits} return
5908 set id [lindex $displayorder $row]
5909 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5910 askvhighlight $row $id
5912 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5913 askfilehighlight $row $id
5915 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5916 askfindhighlight $row $id
5918 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5919 askrelhighlight $row $id
5921 if {![info exists iddrawn($id)]} {
5922 set col [lsearch -exact [lindex $rowidlist $row] $id]
5923 if {$col < 0} {
5924 puts "oops, row $row id $id not in list"
5925 return
5927 if {![info exists commitinfo($id)]} {
5928 getcommit $id
5930 assigncolor $id
5931 drawcmittext $id $row $col
5932 set iddrawn($id) 1
5933 incr nrows_drawn
5935 if {$markingmatches} {
5936 markrowmatches $row $id
5940 proc drawcommits {row {endrow {}}} {
5941 global numcommits iddrawn displayorder curview need_redisplay
5942 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5944 if {$row < 0} {
5945 set row 0
5947 if {$endrow eq {}} {
5948 set endrow $row
5950 if {$endrow >= $numcommits} {
5951 set endrow [expr {$numcommits - 1}]
5954 set rl1 [expr {$row - $downarrowlen - 3}]
5955 if {$rl1 < 0} {
5956 set rl1 0
5958 set ro1 [expr {$row - 3}]
5959 if {$ro1 < 0} {
5960 set ro1 0
5962 set r2 [expr {$endrow + $uparrowlen + 3}]
5963 if {$r2 > $numcommits} {
5964 set r2 $numcommits
5966 for {set r $rl1} {$r < $r2} {incr r} {
5967 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5968 if {$rl1 < $r} {
5969 layoutrows $rl1 $r
5971 set rl1 [expr {$r + 1}]
5974 if {$rl1 < $r} {
5975 layoutrows $rl1 $r
5977 optimize_rows $ro1 0 $r2
5978 if {$need_redisplay || $nrows_drawn > 2000} {
5979 clear_display
5982 # make the lines join to already-drawn rows either side
5983 set r [expr {$row - 1}]
5984 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5985 set r $row
5987 set er [expr {$endrow + 1}]
5988 if {$er >= $numcommits ||
5989 ![info exists iddrawn([lindex $displayorder $er])]} {
5990 set er $endrow
5992 for {} {$r <= $er} {incr r} {
5993 set id [lindex $displayorder $r]
5994 set wasdrawn [info exists iddrawn($id)]
5995 drawcmitrow $r
5996 if {$r == $er} break
5997 set nextid [lindex $displayorder [expr {$r + 1}]]
5998 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5999 drawparentlinks $id $r
6001 set rowids [lindex $rowidlist $r]
6002 foreach lid $rowids {
6003 if {$lid eq {}} continue
6004 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6005 if {$lid eq $id} {
6006 # see if this is the first child of any of its parents
6007 foreach p [lindex $parentlist $r] {
6008 if {[lsearch -exact $rowids $p] < 0} {
6009 # make this line extend up to the child
6010 set lineend($p) [drawlineseg $p $r $er 0]
6013 } else {
6014 set lineend($lid) [drawlineseg $lid $r $er 1]
6020 proc undolayout {row} {
6021 global uparrowlen mingaplen downarrowlen
6022 global rowidlist rowisopt rowfinal need_redisplay
6024 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6025 if {$r < 0} {
6026 set r 0
6028 if {[llength $rowidlist] > $r} {
6029 incr r -1
6030 set rowidlist [lrange $rowidlist 0 $r]
6031 set rowfinal [lrange $rowfinal 0 $r]
6032 set rowisopt [lrange $rowisopt 0 $r]
6033 set need_redisplay 1
6034 run drawvisible
6038 proc drawvisible {} {
6039 global canv linespc curview vrowmod selectedline targetrow targetid
6040 global need_redisplay cscroll numcommits
6042 set fs [$canv yview]
6043 set ymax [lindex [$canv cget -scrollregion] 3]
6044 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6045 set f0 [lindex $fs 0]
6046 set f1 [lindex $fs 1]
6047 set y0 [expr {int($f0 * $ymax)}]
6048 set y1 [expr {int($f1 * $ymax)}]
6050 if {[info exists targetid]} {
6051 if {[commitinview $targetid $curview]} {
6052 set r [rowofcommit $targetid]
6053 if {$r != $targetrow} {
6054 # Fix up the scrollregion and change the scrolling position
6055 # now that our target row has moved.
6056 set diff [expr {($r - $targetrow) * $linespc}]
6057 set targetrow $r
6058 setcanvscroll
6059 set ymax [lindex [$canv cget -scrollregion] 3]
6060 incr y0 $diff
6061 incr y1 $diff
6062 set f0 [expr {$y0 / $ymax}]
6063 set f1 [expr {$y1 / $ymax}]
6064 allcanvs yview moveto $f0
6065 $cscroll set $f0 $f1
6066 set need_redisplay 1
6068 } else {
6069 unset targetid
6073 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6074 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6075 if {$endrow >= $vrowmod($curview)} {
6076 update_arcrows $curview
6078 if {$selectedline ne {} &&
6079 $row <= $selectedline && $selectedline <= $endrow} {
6080 set targetrow $selectedline
6081 } elseif {[info exists targetid]} {
6082 set targetrow [expr {int(($row + $endrow) / 2)}]
6084 if {[info exists targetrow]} {
6085 if {$targetrow >= $numcommits} {
6086 set targetrow [expr {$numcommits - 1}]
6088 set targetid [commitonrow $targetrow]
6090 drawcommits $row $endrow
6093 proc clear_display {} {
6094 global iddrawn linesegs need_redisplay nrows_drawn
6095 global vhighlights fhighlights nhighlights rhighlights
6096 global linehtag linentag linedtag boldids boldnameids
6098 allcanvs delete all
6099 catch {unset iddrawn}
6100 catch {unset linesegs}
6101 catch {unset linehtag}
6102 catch {unset linentag}
6103 catch {unset linedtag}
6104 set boldids {}
6105 set boldnameids {}
6106 catch {unset vhighlights}
6107 catch {unset fhighlights}
6108 catch {unset nhighlights}
6109 catch {unset rhighlights}
6110 set need_redisplay 0
6111 set nrows_drawn 0
6114 proc findcrossings {id} {
6115 global rowidlist parentlist numcommits displayorder
6117 set cross {}
6118 set ccross {}
6119 foreach {s e} [rowranges $id] {
6120 if {$e >= $numcommits} {
6121 set e [expr {$numcommits - 1}]
6123 if {$e <= $s} continue
6124 for {set row $e} {[incr row -1] >= $s} {} {
6125 set x [lsearch -exact [lindex $rowidlist $row] $id]
6126 if {$x < 0} break
6127 set olds [lindex $parentlist $row]
6128 set kid [lindex $displayorder $row]
6129 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6130 if {$kidx < 0} continue
6131 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6132 foreach p $olds {
6133 set px [lsearch -exact $nextrow $p]
6134 if {$px < 0} continue
6135 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6136 if {[lsearch -exact $ccross $p] >= 0} continue
6137 if {$x == $px + ($kidx < $px? -1: 1)} {
6138 lappend ccross $p
6139 } elseif {[lsearch -exact $cross $p] < 0} {
6140 lappend cross $p
6146 return [concat $ccross {{}} $cross]
6149 proc assigncolor {id} {
6150 global colormap colors nextcolor
6151 global parents children children curview
6153 if {[info exists colormap($id)]} return
6154 set ncolors [llength $colors]
6155 if {[info exists children($curview,$id)]} {
6156 set kids $children($curview,$id)
6157 } else {
6158 set kids {}
6160 if {[llength $kids] == 1} {
6161 set child [lindex $kids 0]
6162 if {[info exists colormap($child)]
6163 && [llength $parents($curview,$child)] == 1} {
6164 set colormap($id) $colormap($child)
6165 return
6168 set badcolors {}
6169 set origbad {}
6170 foreach x [findcrossings $id] {
6171 if {$x eq {}} {
6172 # delimiter between corner crossings and other crossings
6173 if {[llength $badcolors] >= $ncolors - 1} break
6174 set origbad $badcolors
6176 if {[info exists colormap($x)]
6177 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6178 lappend badcolors $colormap($x)
6181 if {[llength $badcolors] >= $ncolors} {
6182 set badcolors $origbad
6184 set origbad $badcolors
6185 if {[llength $badcolors] < $ncolors - 1} {
6186 foreach child $kids {
6187 if {[info exists colormap($child)]
6188 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6189 lappend badcolors $colormap($child)
6191 foreach p $parents($curview,$child) {
6192 if {[info exists colormap($p)]
6193 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6194 lappend badcolors $colormap($p)
6198 if {[llength $badcolors] >= $ncolors} {
6199 set badcolors $origbad
6202 for {set i 0} {$i <= $ncolors} {incr i} {
6203 set c [lindex $colors $nextcolor]
6204 if {[incr nextcolor] >= $ncolors} {
6205 set nextcolor 0
6207 if {[lsearch -exact $badcolors $c]} break
6209 set colormap($id) $c
6212 proc bindline {t id} {
6213 global canv
6215 $canv bind $t <Enter> "lineenter %x %y $id"
6216 $canv bind $t <Motion> "linemotion %x %y $id"
6217 $canv bind $t <Leave> "lineleave $id"
6218 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6221 proc drawtags {id x xt y1} {
6222 global idtags idheads idotherrefs mainhead
6223 global linespc lthickness
6224 global canv rowtextx curview fgcolor bgcolor ctxbut
6226 set marks {}
6227 set ntags 0
6228 set nheads 0
6229 if {[info exists idtags($id)]} {
6230 set marks $idtags($id)
6231 set ntags [llength $marks]
6233 if {[info exists idheads($id)]} {
6234 set marks [concat $marks $idheads($id)]
6235 set nheads [llength $idheads($id)]
6237 if {[info exists idotherrefs($id)]} {
6238 set marks [concat $marks $idotherrefs($id)]
6240 if {$marks eq {}} {
6241 return $xt
6244 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6245 set yt [expr {$y1 - 0.5 * $linespc}]
6246 set yb [expr {$yt + $linespc - 1}]
6247 set xvals {}
6248 set wvals {}
6249 set i -1
6250 foreach tag $marks {
6251 incr i
6252 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6253 set wid [font measure mainfontbold $tag]
6254 } else {
6255 set wid [font measure mainfont $tag]
6257 lappend xvals $xt
6258 lappend wvals $wid
6259 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6261 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6262 -width $lthickness -fill black -tags tag.$id]
6263 $canv lower $t
6264 foreach tag $marks x $xvals wid $wvals {
6265 set xl [expr {$x + $delta}]
6266 set xr [expr {$x + $delta + $wid + $lthickness}]
6267 set font mainfont
6268 if {[incr ntags -1] >= 0} {
6269 # draw a tag
6270 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6271 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6272 -width 1 -outline black -fill yellow -tags tag.$id]
6273 $canv bind $t <1> [list showtag $tag 1]
6274 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6275 } else {
6276 # draw a head or other ref
6277 if {[incr nheads -1] >= 0} {
6278 set col green
6279 if {$tag eq $mainhead} {
6280 set font mainfontbold
6282 } else {
6283 set col "#ddddff"
6285 set xl [expr {$xl - $delta/2}]
6286 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6287 -width 1 -outline black -fill $col -tags tag.$id
6288 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6289 set rwid [font measure mainfont $remoteprefix]
6290 set xi [expr {$x + 1}]
6291 set yti [expr {$yt + 1}]
6292 set xri [expr {$x + $rwid}]
6293 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6294 -width 0 -fill "#ffddaa" -tags tag.$id
6297 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6298 -font $font -tags [list tag.$id text]]
6299 if {$ntags >= 0} {
6300 $canv bind $t <1> [list showtag $tag 1]
6301 } elseif {$nheads >= 0} {
6302 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6305 return $xt
6308 proc xcoord {i level ln} {
6309 global canvx0 xspc1 xspc2
6311 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6312 if {$i > 0 && $i == $level} {
6313 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6314 } elseif {$i > $level} {
6315 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6317 return $x
6320 proc show_status {msg} {
6321 global canv fgcolor
6323 clear_display
6324 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6325 -tags text -fill $fgcolor
6328 # Don't change the text pane cursor if it is currently the hand cursor,
6329 # showing that we are over a sha1 ID link.
6330 proc settextcursor {c} {
6331 global ctext curtextcursor
6333 if {[$ctext cget -cursor] == $curtextcursor} {
6334 $ctext config -cursor $c
6336 set curtextcursor $c
6339 proc nowbusy {what {name {}}} {
6340 global isbusy busyname statusw
6342 if {[array names isbusy] eq {}} {
6343 . config -cursor watch
6344 settextcursor watch
6346 set isbusy($what) 1
6347 set busyname($what) $name
6348 if {$name ne {}} {
6349 $statusw conf -text $name
6353 proc notbusy {what} {
6354 global isbusy maincursor textcursor busyname statusw
6356 catch {
6357 unset isbusy($what)
6358 if {$busyname($what) ne {} &&
6359 [$statusw cget -text] eq $busyname($what)} {
6360 $statusw conf -text {}
6363 if {[array names isbusy] eq {}} {
6364 . config -cursor $maincursor
6365 settextcursor $textcursor
6369 proc findmatches {f} {
6370 global findtype findstring
6371 if {$findtype == [mc "Regexp"]} {
6372 set matches [regexp -indices -all -inline $findstring $f]
6373 } else {
6374 set fs $findstring
6375 if {$findtype == [mc "IgnCase"]} {
6376 set f [string tolower $f]
6377 set fs [string tolower $fs]
6379 set matches {}
6380 set i 0
6381 set l [string length $fs]
6382 while {[set j [string first $fs $f $i]] >= 0} {
6383 lappend matches [list $j [expr {$j+$l-1}]]
6384 set i [expr {$j + $l}]
6387 return $matches
6390 proc dofind {{dirn 1} {wrap 1}} {
6391 global findstring findstartline findcurline selectedline numcommits
6392 global gdttype filehighlight fh_serial find_dirn findallowwrap
6394 if {[info exists find_dirn]} {
6395 if {$find_dirn == $dirn} return
6396 stopfinding
6398 focus .
6399 if {$findstring eq {} || $numcommits == 0} return
6400 if {$selectedline eq {}} {
6401 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6402 } else {
6403 set findstartline $selectedline
6405 set findcurline $findstartline
6406 nowbusy finding [mc "Searching"]
6407 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6408 after cancel do_file_hl $fh_serial
6409 do_file_hl $fh_serial
6411 set find_dirn $dirn
6412 set findallowwrap $wrap
6413 run findmore
6416 proc stopfinding {} {
6417 global find_dirn findcurline fprogcoord
6419 if {[info exists find_dirn]} {
6420 unset find_dirn
6421 unset findcurline
6422 notbusy finding
6423 set fprogcoord 0
6424 adjustprogress
6426 stopblaming
6429 proc findmore {} {
6430 global commitdata commitinfo numcommits findpattern findloc
6431 global findstartline findcurline findallowwrap
6432 global find_dirn gdttype fhighlights fprogcoord
6433 global curview varcorder vrownum varccommits vrowmod
6435 if {![info exists find_dirn]} {
6436 return 0
6438 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6439 set l $findcurline
6440 set moretodo 0
6441 if {$find_dirn > 0} {
6442 incr l
6443 if {$l >= $numcommits} {
6444 set l 0
6446 if {$l <= $findstartline} {
6447 set lim [expr {$findstartline + 1}]
6448 } else {
6449 set lim $numcommits
6450 set moretodo $findallowwrap
6452 } else {
6453 if {$l == 0} {
6454 set l $numcommits
6456 incr l -1
6457 if {$l >= $findstartline} {
6458 set lim [expr {$findstartline - 1}]
6459 } else {
6460 set lim -1
6461 set moretodo $findallowwrap
6464 set n [expr {($lim - $l) * $find_dirn}]
6465 if {$n > 500} {
6466 set n 500
6467 set moretodo 1
6469 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6470 update_arcrows $curview
6472 set found 0
6473 set domore 1
6474 set ai [bsearch $vrownum($curview) $l]
6475 set a [lindex $varcorder($curview) $ai]
6476 set arow [lindex $vrownum($curview) $ai]
6477 set ids [lindex $varccommits($curview,$a)]
6478 set arowend [expr {$arow + [llength $ids]}]
6479 if {$gdttype eq [mc "containing:"]} {
6480 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6481 if {$l < $arow || $l >= $arowend} {
6482 incr ai $find_dirn
6483 set a [lindex $varcorder($curview) $ai]
6484 set arow [lindex $vrownum($curview) $ai]
6485 set ids [lindex $varccommits($curview,$a)]
6486 set arowend [expr {$arow + [llength $ids]}]
6488 set id [lindex $ids [expr {$l - $arow}]]
6489 # shouldn't happen unless git log doesn't give all the commits...
6490 if {![info exists commitdata($id)] ||
6491 ![doesmatch $commitdata($id)]} {
6492 continue
6494 if {![info exists commitinfo($id)]} {
6495 getcommit $id
6497 set info $commitinfo($id)
6498 foreach f $info ty $fldtypes {
6499 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6500 [doesmatch $f]} {
6501 set found 1
6502 break
6505 if {$found} break
6507 } else {
6508 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6509 if {$l < $arow || $l >= $arowend} {
6510 incr ai $find_dirn
6511 set a [lindex $varcorder($curview) $ai]
6512 set arow [lindex $vrownum($curview) $ai]
6513 set ids [lindex $varccommits($curview,$a)]
6514 set arowend [expr {$arow + [llength $ids]}]
6516 set id [lindex $ids [expr {$l - $arow}]]
6517 if {![info exists fhighlights($id)]} {
6518 # this sets fhighlights($id) to -1
6519 askfilehighlight $l $id
6521 if {$fhighlights($id) > 0} {
6522 set found $domore
6523 break
6525 if {$fhighlights($id) < 0} {
6526 if {$domore} {
6527 set domore 0
6528 set findcurline [expr {$l - $find_dirn}]
6533 if {$found || ($domore && !$moretodo)} {
6534 unset findcurline
6535 unset find_dirn
6536 notbusy finding
6537 set fprogcoord 0
6538 adjustprogress
6539 if {$found} {
6540 findselectline $l
6541 } else {
6542 bell
6544 return 0
6546 if {!$domore} {
6547 flushhighlights
6548 } else {
6549 set findcurline [expr {$l - $find_dirn}]
6551 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6552 if {$n < 0} {
6553 incr n $numcommits
6555 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6556 adjustprogress
6557 return $domore
6560 proc findselectline {l} {
6561 global findloc commentend ctext findcurline markingmatches gdttype
6563 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6564 set findcurline $l
6565 selectline $l 1
6566 if {$markingmatches &&
6567 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6568 # highlight the matches in the comments
6569 set f [$ctext get 1.0 $commentend]
6570 set matches [findmatches $f]
6571 foreach match $matches {
6572 set start [lindex $match 0]
6573 set end [expr {[lindex $match 1] + 1}]
6574 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6577 drawvisible
6580 # mark the bits of a headline or author that match a find string
6581 proc markmatches {canv l str tag matches font row} {
6582 global selectedline
6584 set bbox [$canv bbox $tag]
6585 set x0 [lindex $bbox 0]
6586 set y0 [lindex $bbox 1]
6587 set y1 [lindex $bbox 3]
6588 foreach match $matches {
6589 set start [lindex $match 0]
6590 set end [lindex $match 1]
6591 if {$start > $end} continue
6592 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6593 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6594 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6595 [expr {$x0+$xlen+2}] $y1 \
6596 -outline {} -tags [list match$l matches] -fill yellow]
6597 $canv lower $t
6598 if {$row == $selectedline} {
6599 $canv raise $t secsel
6604 proc unmarkmatches {} {
6605 global markingmatches
6607 allcanvs delete matches
6608 set markingmatches 0
6609 stopfinding
6612 proc selcanvline {w x y} {
6613 global canv canvy0 ctext linespc
6614 global rowtextx
6615 set ymax [lindex [$canv cget -scrollregion] 3]
6616 if {$ymax == {}} return
6617 set yfrac [lindex [$canv yview] 0]
6618 set y [expr {$y + $yfrac * $ymax}]
6619 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6620 if {$l < 0} {
6621 set l 0
6623 if {$w eq $canv} {
6624 set xmax [lindex [$canv cget -scrollregion] 2]
6625 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6626 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6628 unmarkmatches
6629 selectline $l 1
6632 proc commit_descriptor {p} {
6633 global commitinfo
6634 if {![info exists commitinfo($p)]} {
6635 getcommit $p
6637 set l "..."
6638 if {[llength $commitinfo($p)] > 1} {
6639 set l [lindex $commitinfo($p) 0]
6641 return "$p ($l)\n"
6644 # append some text to the ctext widget, and make any SHA1 ID
6645 # that we know about be a clickable link.
6646 proc appendwithlinks {text tags} {
6647 global ctext linknum curview
6649 set start [$ctext index "end - 1c"]
6650 $ctext insert end $text $tags
6651 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6652 foreach l $links {
6653 set s [lindex $l 0]
6654 set e [lindex $l 1]
6655 set linkid [string range $text $s $e]
6656 incr e
6657 $ctext tag delete link$linknum
6658 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6659 setlink $linkid link$linknum
6660 incr linknum
6664 proc setlink {id lk} {
6665 global curview ctext pendinglinks
6667 set known 0
6668 if {[string length $id] < 40} {
6669 set matches [longid $id]
6670 if {[llength $matches] > 0} {
6671 if {[llength $matches] > 1} return
6672 set known 1
6673 set id [lindex $matches 0]
6675 } else {
6676 set known [commitinview $id $curview]
6678 if {$known} {
6679 $ctext tag conf $lk -foreground blue -underline 1
6680 $ctext tag bind $lk <1> [list selbyid $id]
6681 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6682 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6683 } else {
6684 lappend pendinglinks($id) $lk
6685 interestedin $id {makelink %P}
6689 proc appendshortlink {id {pre {}} {post {}}} {
6690 global ctext linknum
6692 $ctext insert end $pre
6693 $ctext tag delete link$linknum
6694 $ctext insert end [string range $id 0 7] link$linknum
6695 $ctext insert end $post
6696 setlink $id link$linknum
6697 incr linknum
6700 proc makelink {id} {
6701 global pendinglinks
6703 if {![info exists pendinglinks($id)]} return
6704 foreach lk $pendinglinks($id) {
6705 setlink $id $lk
6707 unset pendinglinks($id)
6710 proc linkcursor {w inc} {
6711 global linkentercount curtextcursor
6713 if {[incr linkentercount $inc] > 0} {
6714 $w configure -cursor hand2
6715 } else {
6716 $w configure -cursor $curtextcursor
6717 if {$linkentercount < 0} {
6718 set linkentercount 0
6723 proc viewnextline {dir} {
6724 global canv linespc
6726 $canv delete hover
6727 set ymax [lindex [$canv cget -scrollregion] 3]
6728 set wnow [$canv yview]
6729 set wtop [expr {[lindex $wnow 0] * $ymax}]
6730 set newtop [expr {$wtop + $dir * $linespc}]
6731 if {$newtop < 0} {
6732 set newtop 0
6733 } elseif {$newtop > $ymax} {
6734 set newtop $ymax
6736 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6739 # add a list of tag or branch names at position pos
6740 # returns the number of names inserted
6741 proc appendrefs {pos ids var} {
6742 global ctext linknum curview $var maxrefs
6744 if {[catch {$ctext index $pos}]} {
6745 return 0
6747 $ctext conf -state normal
6748 $ctext delete $pos "$pos lineend"
6749 set tags {}
6750 foreach id $ids {
6751 foreach tag [set $var\($id\)] {
6752 lappend tags [list $tag $id]
6755 if {[llength $tags] > $maxrefs} {
6756 $ctext insert $pos "[mc "many"] ([llength $tags])"
6757 } else {
6758 set tags [lsort -index 0 -decreasing $tags]
6759 set sep {}
6760 foreach ti $tags {
6761 set id [lindex $ti 1]
6762 set lk link$linknum
6763 incr linknum
6764 $ctext tag delete $lk
6765 $ctext insert $pos $sep
6766 $ctext insert $pos [lindex $ti 0] $lk
6767 setlink $id $lk
6768 set sep ", "
6771 $ctext conf -state disabled
6772 return [llength $tags]
6775 # called when we have finished computing the nearby tags
6776 proc dispneartags {delay} {
6777 global selectedline currentid showneartags tagphase
6779 if {$selectedline eq {} || !$showneartags} return
6780 after cancel dispnexttag
6781 if {$delay} {
6782 after 200 dispnexttag
6783 set tagphase -1
6784 } else {
6785 after idle dispnexttag
6786 set tagphase 0
6790 proc dispnexttag {} {
6791 global selectedline currentid showneartags tagphase ctext
6793 if {$selectedline eq {} || !$showneartags} return
6794 switch -- $tagphase {
6796 set dtags [desctags $currentid]
6797 if {$dtags ne {}} {
6798 appendrefs precedes $dtags idtags
6802 set atags [anctags $currentid]
6803 if {$atags ne {}} {
6804 appendrefs follows $atags idtags
6808 set dheads [descheads $currentid]
6809 if {$dheads ne {}} {
6810 if {[appendrefs branch $dheads idheads] > 1
6811 && [$ctext get "branch -3c"] eq "h"} {
6812 # turn "Branch" into "Branches"
6813 $ctext conf -state normal
6814 $ctext insert "branch -2c" "es"
6815 $ctext conf -state disabled
6820 if {[incr tagphase] <= 2} {
6821 after idle dispnexttag
6825 proc make_secsel {id} {
6826 global linehtag linentag linedtag canv canv2 canv3
6828 if {![info exists linehtag($id)]} return
6829 $canv delete secsel
6830 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6831 -tags secsel -fill [$canv cget -selectbackground]]
6832 $canv lower $t
6833 $canv2 delete secsel
6834 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6835 -tags secsel -fill [$canv2 cget -selectbackground]]
6836 $canv2 lower $t
6837 $canv3 delete secsel
6838 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6839 -tags secsel -fill [$canv3 cget -selectbackground]]
6840 $canv3 lower $t
6843 proc make_idmark {id} {
6844 global linehtag canv fgcolor
6846 if {![info exists linehtag($id)]} return
6847 $canv delete markid
6848 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6849 -tags markid -outline $fgcolor]
6850 $canv raise $t
6853 proc selectline {l isnew {desired_loc {}}} {
6854 global canv ctext commitinfo selectedline
6855 global canvy0 linespc parents children curview
6856 global currentid sha1entry
6857 global commentend idtags linknum
6858 global mergemax numcommits pending_select
6859 global cmitmode showneartags allcommits
6860 global targetrow targetid lastscrollrows
6861 global autoselect jump_to_here
6863 catch {unset pending_select}
6864 $canv delete hover
6865 normalline
6866 unsel_reflist
6867 stopfinding
6868 if {$l < 0 || $l >= $numcommits} return
6869 set id [commitonrow $l]
6870 set targetid $id
6871 set targetrow $l
6872 set selectedline $l
6873 set currentid $id
6874 if {$lastscrollrows < $numcommits} {
6875 setcanvscroll
6878 set y [expr {$canvy0 + $l * $linespc}]
6879 set ymax [lindex [$canv cget -scrollregion] 3]
6880 set ytop [expr {$y - $linespc - 1}]
6881 set ybot [expr {$y + $linespc + 1}]
6882 set wnow [$canv yview]
6883 set wtop [expr {[lindex $wnow 0] * $ymax}]
6884 set wbot [expr {[lindex $wnow 1] * $ymax}]
6885 set wh [expr {$wbot - $wtop}]
6886 set newtop $wtop
6887 if {$ytop < $wtop} {
6888 if {$ybot < $wtop} {
6889 set newtop [expr {$y - $wh / 2.0}]
6890 } else {
6891 set newtop $ytop
6892 if {$newtop > $wtop - $linespc} {
6893 set newtop [expr {$wtop - $linespc}]
6896 } elseif {$ybot > $wbot} {
6897 if {$ytop > $wbot} {
6898 set newtop [expr {$y - $wh / 2.0}]
6899 } else {
6900 set newtop [expr {$ybot - $wh}]
6901 if {$newtop < $wtop + $linespc} {
6902 set newtop [expr {$wtop + $linespc}]
6906 if {$newtop != $wtop} {
6907 if {$newtop < 0} {
6908 set newtop 0
6910 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6911 drawvisible
6914 make_secsel $id
6916 if {$isnew} {
6917 addtohistory [list selbyid $id 0] savecmitpos
6920 $sha1entry delete 0 end
6921 $sha1entry insert 0 $id
6922 if {$autoselect} {
6923 $sha1entry selection range 0 end
6925 rhighlight_sel $id
6927 $ctext conf -state normal
6928 clear_ctext
6929 set linknum 0
6930 if {![info exists commitinfo($id)]} {
6931 getcommit $id
6933 set info $commitinfo($id)
6934 set date [formatdate [lindex $info 2]]
6935 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6936 set date [formatdate [lindex $info 4]]
6937 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6938 if {[info exists idtags($id)]} {
6939 $ctext insert end [mc "Tags:"]
6940 foreach tag $idtags($id) {
6941 $ctext insert end " $tag"
6943 $ctext insert end "\n"
6946 set headers {}
6947 set olds $parents($curview,$id)
6948 if {[llength $olds] > 1} {
6949 set np 0
6950 foreach p $olds {
6951 if {$np >= $mergemax} {
6952 set tag mmax
6953 } else {
6954 set tag m$np
6956 $ctext insert end "[mc "Parent"]: " $tag
6957 appendwithlinks [commit_descriptor $p] {}
6958 incr np
6960 } else {
6961 foreach p $olds {
6962 append headers "[mc "Parent"]: [commit_descriptor $p]"
6966 foreach c $children($curview,$id) {
6967 append headers "[mc "Child"]: [commit_descriptor $c]"
6970 # make anything that looks like a SHA1 ID be a clickable link
6971 appendwithlinks $headers {}
6972 if {$showneartags} {
6973 if {![info exists allcommits]} {
6974 getallcommits
6976 $ctext insert end "[mc "Branch"]: "
6977 $ctext mark set branch "end -1c"
6978 $ctext mark gravity branch left
6979 $ctext insert end "\n[mc "Follows"]: "
6980 $ctext mark set follows "end -1c"
6981 $ctext mark gravity follows left
6982 $ctext insert end "\n[mc "Precedes"]: "
6983 $ctext mark set precedes "end -1c"
6984 $ctext mark gravity precedes left
6985 $ctext insert end "\n"
6986 dispneartags 1
6988 $ctext insert end "\n"
6989 set comment [lindex $info 5]
6990 if {[string first "\r" $comment] >= 0} {
6991 set comment [string map {"\r" "\n "} $comment]
6993 appendwithlinks $comment {comment}
6995 $ctext tag remove found 1.0 end
6996 $ctext conf -state disabled
6997 set commentend [$ctext index "end - 1c"]
6999 set jump_to_here $desired_loc
7000 init_flist [mc "Comments"]
7001 if {$cmitmode eq "tree"} {
7002 gettree $id
7003 } elseif {[llength $olds] <= 1} {
7004 startdiff $id
7005 } else {
7006 mergediff $id
7010 proc selfirstline {} {
7011 unmarkmatches
7012 selectline 0 1
7015 proc sellastline {} {
7016 global numcommits
7017 unmarkmatches
7018 set l [expr {$numcommits - 1}]
7019 selectline $l 1
7022 proc selnextline {dir} {
7023 global selectedline
7024 focus .
7025 if {$selectedline eq {}} return
7026 set l [expr {$selectedline + $dir}]
7027 unmarkmatches
7028 selectline $l 1
7031 proc selnextpage {dir} {
7032 global canv linespc selectedline numcommits
7034 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7035 if {$lpp < 1} {
7036 set lpp 1
7038 allcanvs yview scroll [expr {$dir * $lpp}] units
7039 drawvisible
7040 if {$selectedline eq {}} return
7041 set l [expr {$selectedline + $dir * $lpp}]
7042 if {$l < 0} {
7043 set l 0
7044 } elseif {$l >= $numcommits} {
7045 set l [expr $numcommits - 1]
7047 unmarkmatches
7048 selectline $l 1
7051 proc unselectline {} {
7052 global selectedline currentid
7054 set selectedline {}
7055 catch {unset currentid}
7056 allcanvs delete secsel
7057 rhighlight_none
7060 proc reselectline {} {
7061 global selectedline
7063 if {$selectedline ne {}} {
7064 selectline $selectedline 0
7068 proc addtohistory {cmd {saveproc {}}} {
7069 global history historyindex curview
7071 unset_posvars
7072 save_position
7073 set elt [list $curview $cmd $saveproc {}]
7074 if {$historyindex > 0
7075 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7076 return
7079 if {$historyindex < [llength $history]} {
7080 set history [lreplace $history $historyindex end $elt]
7081 } else {
7082 lappend history $elt
7084 incr historyindex
7085 if {$historyindex > 1} {
7086 .tf.bar.leftbut conf -state normal
7087 } else {
7088 .tf.bar.leftbut conf -state disabled
7090 .tf.bar.rightbut conf -state disabled
7093 # save the scrolling position of the diff display pane
7094 proc save_position {} {
7095 global historyindex history
7097 if {$historyindex < 1} return
7098 set hi [expr {$historyindex - 1}]
7099 set fn [lindex $history $hi 2]
7100 if {$fn ne {}} {
7101 lset history $hi 3 [eval $fn]
7105 proc unset_posvars {} {
7106 global last_posvars
7108 if {[info exists last_posvars]} {
7109 foreach {var val} $last_posvars {
7110 global $var
7111 catch {unset $var}
7113 unset last_posvars
7117 proc godo {elt} {
7118 global curview last_posvars
7120 set view [lindex $elt 0]
7121 set cmd [lindex $elt 1]
7122 set pv [lindex $elt 3]
7123 if {$curview != $view} {
7124 showview $view
7126 unset_posvars
7127 foreach {var val} $pv {
7128 global $var
7129 set $var $val
7131 set last_posvars $pv
7132 eval $cmd
7135 proc goback {} {
7136 global history historyindex
7137 focus .
7139 if {$historyindex > 1} {
7140 save_position
7141 incr historyindex -1
7142 godo [lindex $history [expr {$historyindex - 1}]]
7143 .tf.bar.rightbut conf -state normal
7145 if {$historyindex <= 1} {
7146 .tf.bar.leftbut conf -state disabled
7150 proc goforw {} {
7151 global history historyindex
7152 focus .
7154 if {$historyindex < [llength $history]} {
7155 save_position
7156 set cmd [lindex $history $historyindex]
7157 incr historyindex
7158 godo $cmd
7159 .tf.bar.leftbut conf -state normal
7161 if {$historyindex >= [llength $history]} {
7162 .tf.bar.rightbut conf -state disabled
7166 proc gettree {id} {
7167 global treefilelist treeidlist diffids diffmergeid treepending
7168 global nullid nullid2
7170 set diffids $id
7171 catch {unset diffmergeid}
7172 if {![info exists treefilelist($id)]} {
7173 if {![info exists treepending]} {
7174 if {$id eq $nullid} {
7175 set cmd [list | git ls-files]
7176 } elseif {$id eq $nullid2} {
7177 set cmd [list | git ls-files --stage -t]
7178 } else {
7179 set cmd [list | git ls-tree -r $id]
7181 if {[catch {set gtf [open $cmd r]}]} {
7182 return
7184 set treepending $id
7185 set treefilelist($id) {}
7186 set treeidlist($id) {}
7187 fconfigure $gtf -blocking 0 -encoding binary
7188 filerun $gtf [list gettreeline $gtf $id]
7190 } else {
7191 setfilelist $id
7195 proc gettreeline {gtf id} {
7196 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7198 set nl 0
7199 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7200 if {$diffids eq $nullid} {
7201 set fname $line
7202 } else {
7203 set i [string first "\t" $line]
7204 if {$i < 0} continue
7205 set fname [string range $line [expr {$i+1}] end]
7206 set line [string range $line 0 [expr {$i-1}]]
7207 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7208 set sha1 [lindex $line 2]
7209 lappend treeidlist($id) $sha1
7211 if {[string index $fname 0] eq "\""} {
7212 set fname [lindex $fname 0]
7214 set fname [encoding convertfrom $fname]
7215 lappend treefilelist($id) $fname
7217 if {![eof $gtf]} {
7218 return [expr {$nl >= 1000? 2: 1}]
7220 close $gtf
7221 unset treepending
7222 if {$cmitmode ne "tree"} {
7223 if {![info exists diffmergeid]} {
7224 gettreediffs $diffids
7226 } elseif {$id ne $diffids} {
7227 gettree $diffids
7228 } else {
7229 setfilelist $id
7231 return 0
7234 proc showfile {f} {
7235 global treefilelist treeidlist diffids nullid nullid2
7236 global ctext_file_names ctext_file_lines
7237 global ctext commentend
7239 set i [lsearch -exact $treefilelist($diffids) $f]
7240 if {$i < 0} {
7241 puts "oops, $f not in list for id $diffids"
7242 return
7244 if {$diffids eq $nullid} {
7245 if {[catch {set bf [open $f r]} err]} {
7246 puts "oops, can't read $f: $err"
7247 return
7249 } else {
7250 set blob [lindex $treeidlist($diffids) $i]
7251 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7252 puts "oops, error reading blob $blob: $err"
7253 return
7256 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7257 filerun $bf [list getblobline $bf $diffids]
7258 $ctext config -state normal
7259 clear_ctext $commentend
7260 lappend ctext_file_names $f
7261 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7262 $ctext insert end "\n"
7263 $ctext insert end "$f\n" filesep
7264 $ctext config -state disabled
7265 $ctext yview $commentend
7266 settabs 0
7269 proc getblobline {bf id} {
7270 global diffids cmitmode ctext
7272 if {$id ne $diffids || $cmitmode ne "tree"} {
7273 catch {close $bf}
7274 return 0
7276 $ctext config -state normal
7277 set nl 0
7278 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7279 $ctext insert end "$line\n"
7281 if {[eof $bf]} {
7282 global jump_to_here ctext_file_names commentend
7284 # delete last newline
7285 $ctext delete "end - 2c" "end - 1c"
7286 close $bf
7287 if {$jump_to_here ne {} &&
7288 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7289 set lnum [expr {[lindex $jump_to_here 1] +
7290 [lindex [split $commentend .] 0]}]
7291 mark_ctext_line $lnum
7293 return 0
7295 $ctext config -state disabled
7296 return [expr {$nl >= 1000? 2: 1}]
7299 proc mark_ctext_line {lnum} {
7300 global ctext markbgcolor
7302 $ctext tag delete omark
7303 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7304 $ctext tag conf omark -background $markbgcolor
7305 $ctext see $lnum.0
7308 proc mergediff {id} {
7309 global diffmergeid
7310 global diffids treediffs
7311 global parents curview
7313 set diffmergeid $id
7314 set diffids $id
7315 set treediffs($id) {}
7316 set np [llength $parents($curview,$id)]
7317 settabs $np
7318 getblobdiffs $id
7321 proc startdiff {ids} {
7322 global treediffs diffids treepending diffmergeid nullid nullid2
7324 settabs 1
7325 set diffids $ids
7326 catch {unset diffmergeid}
7327 if {![info exists treediffs($ids)] ||
7328 [lsearch -exact $ids $nullid] >= 0 ||
7329 [lsearch -exact $ids $nullid2] >= 0} {
7330 if {![info exists treepending]} {
7331 gettreediffs $ids
7333 } else {
7334 addtocflist $ids
7338 proc path_filter {filter name} {
7339 foreach p $filter {
7340 set l [string length $p]
7341 if {[string index $p end] eq "/"} {
7342 if {[string compare -length $l $p $name] == 0} {
7343 return 1
7345 } else {
7346 if {[string compare -length $l $p $name] == 0 &&
7347 ([string length $name] == $l ||
7348 [string index $name $l] eq "/")} {
7349 return 1
7353 return 0
7356 proc addtocflist {ids} {
7357 global treediffs
7359 add_flist $treediffs($ids)
7360 getblobdiffs $ids
7363 proc diffcmd {ids flags} {
7364 global nullid nullid2
7366 set i [lsearch -exact $ids $nullid]
7367 set j [lsearch -exact $ids $nullid2]
7368 if {$i >= 0} {
7369 if {[llength $ids] > 1 && $j < 0} {
7370 # comparing working directory with some specific revision
7371 set cmd [concat | git diff-index $flags]
7372 if {$i == 0} {
7373 lappend cmd -R [lindex $ids 1]
7374 } else {
7375 lappend cmd [lindex $ids 0]
7377 } else {
7378 # comparing working directory with index
7379 set cmd [concat | git diff-files $flags]
7380 if {$j == 1} {
7381 lappend cmd -R
7384 } elseif {$j >= 0} {
7385 set cmd [concat | git diff-index --cached $flags]
7386 if {[llength $ids] > 1} {
7387 # comparing index with specific revision
7388 if {$j == 0} {
7389 lappend cmd -R [lindex $ids 1]
7390 } else {
7391 lappend cmd [lindex $ids 0]
7393 } else {
7394 # comparing index with HEAD
7395 lappend cmd HEAD
7397 } else {
7398 set cmd [concat | git diff-tree -r $flags $ids]
7400 return $cmd
7403 proc gettreediffs {ids} {
7404 global treediff treepending
7406 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7408 set treepending $ids
7409 set treediff {}
7410 fconfigure $gdtf -blocking 0 -encoding binary
7411 filerun $gdtf [list gettreediffline $gdtf $ids]
7414 proc gettreediffline {gdtf ids} {
7415 global treediff treediffs treepending diffids diffmergeid
7416 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7418 set nr 0
7419 set sublist {}
7420 set max 1000
7421 if {$perfile_attrs} {
7422 # cache_gitattr is slow, and even slower on win32 where we
7423 # have to invoke it for only about 30 paths at a time
7424 set max 500
7425 if {[tk windowingsystem] == "win32"} {
7426 set max 120
7429 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7430 set i [string first "\t" $line]
7431 if {$i >= 0} {
7432 set file [string range $line [expr {$i+1}] end]
7433 if {[string index $file 0] eq "\""} {
7434 set file [lindex $file 0]
7436 set file [encoding convertfrom $file]
7437 if {$file ne [lindex $treediff end]} {
7438 lappend treediff $file
7439 lappend sublist $file
7443 if {$perfile_attrs} {
7444 cache_gitattr encoding $sublist
7446 if {![eof $gdtf]} {
7447 return [expr {$nr >= $max? 2: 1}]
7449 close $gdtf
7450 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7451 set flist {}
7452 foreach f $treediff {
7453 if {[path_filter $vfilelimit($curview) $f]} {
7454 lappend flist $f
7457 set treediffs($ids) $flist
7458 } else {
7459 set treediffs($ids) $treediff
7461 unset treepending
7462 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7463 gettree $diffids
7464 } elseif {$ids != $diffids} {
7465 if {![info exists diffmergeid]} {
7466 gettreediffs $diffids
7468 } else {
7469 addtocflist $ids
7471 return 0
7474 # empty string or positive integer
7475 proc diffcontextvalidate {v} {
7476 return [regexp {^(|[1-9][0-9]*)$} $v]
7479 proc diffcontextchange {n1 n2 op} {
7480 global diffcontextstring diffcontext
7482 if {[string is integer -strict $diffcontextstring]} {
7483 if {$diffcontextstring >= 0} {
7484 set diffcontext $diffcontextstring
7485 reselectline
7490 proc changeignorespace {} {
7491 reselectline
7494 proc getblobdiffs {ids} {
7495 global blobdifffd diffids env
7496 global diffinhdr treediffs
7497 global diffcontext
7498 global ignorespace
7499 global limitdiffs vfilelimit curview
7500 global diffencoding targetline diffnparents
7501 global git_version
7503 set textconv {}
7504 if {[package vcompare $git_version "1.6.1"] >= 0} {
7505 set textconv "--textconv"
7507 set submodule {}
7508 if {[package vcompare $git_version "1.6.6"] >= 0} {
7509 set submodule "--submodule"
7511 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7512 if {$ignorespace} {
7513 append cmd " -w"
7515 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7516 set cmd [concat $cmd -- $vfilelimit($curview)]
7518 if {[catch {set bdf [open $cmd r]} err]} {
7519 error_popup [mc "Error getting diffs: %s" $err]
7520 return
7522 set targetline {}
7523 set diffnparents 0
7524 set diffinhdr 0
7525 set diffencoding [get_path_encoding {}]
7526 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7527 set blobdifffd($ids) $bdf
7528 filerun $bdf [list getblobdiffline $bdf $diffids]
7531 proc savecmitpos {} {
7532 global ctext cmitmode
7534 if {$cmitmode eq "tree"} {
7535 return {}
7537 return [list target_scrollpos [$ctext index @0,0]]
7540 proc savectextpos {} {
7541 global ctext
7543 return [list target_scrollpos [$ctext index @0,0]]
7546 proc maybe_scroll_ctext {ateof} {
7547 global ctext target_scrollpos
7549 if {![info exists target_scrollpos]} return
7550 if {!$ateof} {
7551 set nlines [expr {[winfo height $ctext]
7552 / [font metrics textfont -linespace]}]
7553 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7555 $ctext yview $target_scrollpos
7556 unset target_scrollpos
7559 proc setinlist {var i val} {
7560 global $var
7562 while {[llength [set $var]] < $i} {
7563 lappend $var {}
7565 if {[llength [set $var]] == $i} {
7566 lappend $var $val
7567 } else {
7568 lset $var $i $val
7572 proc makediffhdr {fname ids} {
7573 global ctext curdiffstart treediffs diffencoding
7574 global ctext_file_names jump_to_here targetline diffline
7576 set fname [encoding convertfrom $fname]
7577 set diffencoding [get_path_encoding $fname]
7578 set i [lsearch -exact $treediffs($ids) $fname]
7579 if {$i >= 0} {
7580 setinlist difffilestart $i $curdiffstart
7582 lset ctext_file_names end $fname
7583 set l [expr {(78 - [string length $fname]) / 2}]
7584 set pad [string range "----------------------------------------" 1 $l]
7585 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7586 set targetline {}
7587 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7588 set targetline [lindex $jump_to_here 1]
7590 set diffline 0
7593 proc getblobdiffline {bdf ids} {
7594 global diffids blobdifffd ctext curdiffstart
7595 global diffnexthead diffnextnote difffilestart
7596 global ctext_file_names ctext_file_lines
7597 global diffinhdr treediffs mergemax diffnparents
7598 global diffencoding jump_to_here targetline diffline
7600 set nr 0
7601 $ctext conf -state normal
7602 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7603 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7604 catch {close $bdf}
7605 return 0
7607 if {![string compare -length 5 "diff " $line]} {
7608 if {![regexp {^diff (--cc|--git) } $line m type]} {
7609 set line [encoding convertfrom $line]
7610 $ctext insert end "$line\n" hunksep
7611 continue
7613 # start of a new file
7614 set diffinhdr 1
7615 $ctext insert end "\n"
7616 set curdiffstart [$ctext index "end - 1c"]
7617 lappend ctext_file_names ""
7618 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7619 $ctext insert end "\n" filesep
7621 if {$type eq "--cc"} {
7622 # start of a new file in a merge diff
7623 set fname [string range $line 10 end]
7624 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7625 lappend treediffs($ids) $fname
7626 add_flist [list $fname]
7629 } else {
7630 set line [string range $line 11 end]
7631 # If the name hasn't changed the length will be odd,
7632 # the middle char will be a space, and the two bits either
7633 # side will be a/name and b/name, or "a/name" and "b/name".
7634 # If the name has changed we'll get "rename from" and
7635 # "rename to" or "copy from" and "copy to" lines following
7636 # this, and we'll use them to get the filenames.
7637 # This complexity is necessary because spaces in the
7638 # filename(s) don't get escaped.
7639 set l [string length $line]
7640 set i [expr {$l / 2}]
7641 if {!(($l & 1) && [string index $line $i] eq " " &&
7642 [string range $line 2 [expr {$i - 1}]] eq \
7643 [string range $line [expr {$i + 3}] end])} {
7644 continue
7646 # unescape if quoted and chop off the a/ from the front
7647 if {[string index $line 0] eq "\""} {
7648 set fname [string range [lindex $line 0] 2 end]
7649 } else {
7650 set fname [string range $line 2 [expr {$i - 1}]]
7653 makediffhdr $fname $ids
7655 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7656 set fname [encoding convertfrom [string range $line 16 end]]
7657 $ctext insert end "\n"
7658 set curdiffstart [$ctext index "end - 1c"]
7659 lappend ctext_file_names $fname
7660 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7661 $ctext insert end "$line\n" filesep
7662 set i [lsearch -exact $treediffs($ids) $fname]
7663 if {$i >= 0} {
7664 setinlist difffilestart $i $curdiffstart
7667 } elseif {![string compare -length 2 "@@" $line]} {
7668 regexp {^@@+} $line ats
7669 set line [encoding convertfrom $diffencoding $line]
7670 $ctext insert end "$line\n" hunksep
7671 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7672 set diffline $nl
7674 set diffnparents [expr {[string length $ats] - 1}]
7675 set diffinhdr 0
7677 } elseif {![string compare -length 10 "Submodule " $line]} {
7678 # start of a new submodule
7679 if {[string compare [$ctext get "end - 4c" end] "\n \n\n"]} {
7680 $ctext insert end "\n"; # Add newline after commit message
7682 set curdiffstart [$ctext index "end - 1c"]
7683 lappend ctext_file_names ""
7684 set fname [string range $line 10 [expr [string last " " $line] - 1]]
7685 lappend ctext_file_lines $fname
7686 makediffhdr $fname $ids
7687 $ctext insert end "\n$line\n" filesep
7688 } elseif {![string compare -length 3 " >" $line]} {
7689 $ctext insert end "$line\n" dresult
7690 } elseif {![string compare -length 3 " <" $line]} {
7691 $ctext insert end "$line\n" d0
7692 } elseif {$diffinhdr} {
7693 if {![string compare -length 12 "rename from " $line]} {
7694 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7695 if {[string index $fname 0] eq "\""} {
7696 set fname [lindex $fname 0]
7698 set fname [encoding convertfrom $fname]
7699 set i [lsearch -exact $treediffs($ids) $fname]
7700 if {$i >= 0} {
7701 setinlist difffilestart $i $curdiffstart
7703 } elseif {![string compare -length 10 $line "rename to "] ||
7704 ![string compare -length 8 $line "copy to "]} {
7705 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7706 if {[string index $fname 0] eq "\""} {
7707 set fname [lindex $fname 0]
7709 makediffhdr $fname $ids
7710 } elseif {[string compare -length 3 $line "---"] == 0} {
7711 # do nothing
7712 continue
7713 } elseif {[string compare -length 3 $line "+++"] == 0} {
7714 set diffinhdr 0
7715 continue
7717 $ctext insert end "$line\n" filesep
7719 } else {
7720 set line [string map {\x1A ^Z} \
7721 [encoding convertfrom $diffencoding $line]]
7722 # parse the prefix - one ' ', '-' or '+' for each parent
7723 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7724 set tag [expr {$diffnparents > 1? "m": "d"}]
7725 if {[string trim $prefix " -+"] eq {}} {
7726 # prefix only has " ", "-" and "+" in it: normal diff line
7727 set num [string first "-" $prefix]
7728 if {$num >= 0} {
7729 # removed line, first parent with line is $num
7730 if {$num >= $mergemax} {
7731 set num "max"
7733 $ctext insert end "$line\n" $tag$num
7734 } else {
7735 set tags {}
7736 if {[string first "+" $prefix] >= 0} {
7737 # added line
7738 lappend tags ${tag}result
7739 if {$diffnparents > 1} {
7740 set num [string first " " $prefix]
7741 if {$num >= 0} {
7742 if {$num >= $mergemax} {
7743 set num "max"
7745 lappend tags m$num
7749 if {$targetline ne {}} {
7750 if {$diffline == $targetline} {
7751 set seehere [$ctext index "end - 1 chars"]
7752 set targetline {}
7753 } else {
7754 incr diffline
7757 $ctext insert end "$line\n" $tags
7759 } else {
7760 # "\ No newline at end of file",
7761 # or something else we don't recognize
7762 $ctext insert end "$line\n" hunksep
7766 if {[info exists seehere]} {
7767 mark_ctext_line [lindex [split $seehere .] 0]
7769 maybe_scroll_ctext [eof $bdf]
7770 $ctext conf -state disabled
7771 if {[eof $bdf]} {
7772 catch {close $bdf}
7773 return 0
7775 return [expr {$nr >= 1000? 2: 1}]
7778 proc changediffdisp {} {
7779 global ctext diffelide
7781 $ctext tag conf d0 -elide [lindex $diffelide 0]
7782 $ctext tag conf dresult -elide [lindex $diffelide 1]
7785 proc highlightfile {loc cline} {
7786 global ctext cflist cflist_top
7788 $ctext yview $loc
7789 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7790 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7791 $cflist see $cline.0
7792 set cflist_top $cline
7795 proc prevfile {} {
7796 global difffilestart ctext cmitmode
7798 if {$cmitmode eq "tree"} return
7799 set prev 0.0
7800 set prevline 1
7801 set here [$ctext index @0,0]
7802 foreach loc $difffilestart {
7803 if {[$ctext compare $loc >= $here]} {
7804 highlightfile $prev $prevline
7805 return
7807 set prev $loc
7808 incr prevline
7810 highlightfile $prev $prevline
7813 proc nextfile {} {
7814 global difffilestart ctext cmitmode
7816 if {$cmitmode eq "tree"} return
7817 set here [$ctext index @0,0]
7818 set line 1
7819 foreach loc $difffilestart {
7820 incr line
7821 if {[$ctext compare $loc > $here]} {
7822 highlightfile $loc $line
7823 return
7828 proc clear_ctext {{first 1.0}} {
7829 global ctext smarktop smarkbot
7830 global ctext_file_names ctext_file_lines
7831 global pendinglinks
7833 set l [lindex [split $first .] 0]
7834 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7835 set smarktop $l
7837 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7838 set smarkbot $l
7840 $ctext delete $first end
7841 if {$first eq "1.0"} {
7842 catch {unset pendinglinks}
7844 set ctext_file_names {}
7845 set ctext_file_lines {}
7848 proc settabs {{firstab {}}} {
7849 global firsttabstop tabstop ctext have_tk85
7851 if {$firstab ne {} && $have_tk85} {
7852 set firsttabstop $firstab
7854 set w [font measure textfont "0"]
7855 if {$firsttabstop != 0} {
7856 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7857 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7858 } elseif {$have_tk85 || $tabstop != 8} {
7859 $ctext conf -tabs [expr {$tabstop * $w}]
7860 } else {
7861 $ctext conf -tabs {}
7865 proc incrsearch {name ix op} {
7866 global ctext searchstring searchdirn
7868 $ctext tag remove found 1.0 end
7869 if {[catch {$ctext index anchor}]} {
7870 # no anchor set, use start of selection, or of visible area
7871 set sel [$ctext tag ranges sel]
7872 if {$sel ne {}} {
7873 $ctext mark set anchor [lindex $sel 0]
7874 } elseif {$searchdirn eq "-forwards"} {
7875 $ctext mark set anchor @0,0
7876 } else {
7877 $ctext mark set anchor @0,[winfo height $ctext]
7880 if {$searchstring ne {}} {
7881 set here [$ctext search $searchdirn -- $searchstring anchor]
7882 if {$here ne {}} {
7883 $ctext see $here
7885 searchmarkvisible 1
7889 proc dosearch {} {
7890 global sstring ctext searchstring searchdirn
7892 focus $sstring
7893 $sstring icursor end
7894 set searchdirn -forwards
7895 if {$searchstring ne {}} {
7896 set sel [$ctext tag ranges sel]
7897 if {$sel ne {}} {
7898 set start "[lindex $sel 0] + 1c"
7899 } elseif {[catch {set start [$ctext index anchor]}]} {
7900 set start "@0,0"
7902 set match [$ctext search -count mlen -- $searchstring $start]
7903 $ctext tag remove sel 1.0 end
7904 if {$match eq {}} {
7905 bell
7906 return
7908 $ctext see $match
7909 set mend "$match + $mlen c"
7910 $ctext tag add sel $match $mend
7911 $ctext mark unset anchor
7915 proc dosearchback {} {
7916 global sstring ctext searchstring searchdirn
7918 focus $sstring
7919 $sstring icursor end
7920 set searchdirn -backwards
7921 if {$searchstring ne {}} {
7922 set sel [$ctext tag ranges sel]
7923 if {$sel ne {}} {
7924 set start [lindex $sel 0]
7925 } elseif {[catch {set start [$ctext index anchor]}]} {
7926 set start @0,[winfo height $ctext]
7928 set match [$ctext search -backwards -count ml -- $searchstring $start]
7929 $ctext tag remove sel 1.0 end
7930 if {$match eq {}} {
7931 bell
7932 return
7934 $ctext see $match
7935 set mend "$match + $ml c"
7936 $ctext tag add sel $match $mend
7937 $ctext mark unset anchor
7941 proc searchmark {first last} {
7942 global ctext searchstring
7944 set mend $first.0
7945 while {1} {
7946 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7947 if {$match eq {}} break
7948 set mend "$match + $mlen c"
7949 $ctext tag add found $match $mend
7953 proc searchmarkvisible {doall} {
7954 global ctext smarktop smarkbot
7956 set topline [lindex [split [$ctext index @0,0] .] 0]
7957 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7958 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7959 # no overlap with previous
7960 searchmark $topline $botline
7961 set smarktop $topline
7962 set smarkbot $botline
7963 } else {
7964 if {$topline < $smarktop} {
7965 searchmark $topline [expr {$smarktop-1}]
7966 set smarktop $topline
7968 if {$botline > $smarkbot} {
7969 searchmark [expr {$smarkbot+1}] $botline
7970 set smarkbot $botline
7975 proc scrolltext {f0 f1} {
7976 global searchstring
7978 .bleft.bottom.sb set $f0 $f1
7979 if {$searchstring ne {}} {
7980 searchmarkvisible 0
7984 proc setcoords {} {
7985 global linespc charspc canvx0 canvy0
7986 global xspc1 xspc2 lthickness
7988 set linespc [font metrics mainfont -linespace]
7989 set charspc [font measure mainfont "m"]
7990 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7991 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7992 set lthickness [expr {int($linespc / 9) + 1}]
7993 set xspc1(0) $linespc
7994 set xspc2 $linespc
7997 proc redisplay {} {
7998 global canv
7999 global selectedline
8001 set ymax [lindex [$canv cget -scrollregion] 3]
8002 if {$ymax eq {} || $ymax == 0} return
8003 set span [$canv yview]
8004 clear_display
8005 setcanvscroll
8006 allcanvs yview moveto [lindex $span 0]
8007 drawvisible
8008 if {$selectedline ne {}} {
8009 selectline $selectedline 0
8010 allcanvs yview moveto [lindex $span 0]
8014 proc parsefont {f n} {
8015 global fontattr
8017 set fontattr($f,family) [lindex $n 0]
8018 set s [lindex $n 1]
8019 if {$s eq {} || $s == 0} {
8020 set s 10
8021 } elseif {$s < 0} {
8022 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8024 set fontattr($f,size) $s
8025 set fontattr($f,weight) normal
8026 set fontattr($f,slant) roman
8027 foreach style [lrange $n 2 end] {
8028 switch -- $style {
8029 "normal" -
8030 "bold" {set fontattr($f,weight) $style}
8031 "roman" -
8032 "italic" {set fontattr($f,slant) $style}
8037 proc fontflags {f {isbold 0}} {
8038 global fontattr
8040 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8041 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8042 -slant $fontattr($f,slant)]
8045 proc fontname {f} {
8046 global fontattr
8048 set n [list $fontattr($f,family) $fontattr($f,size)]
8049 if {$fontattr($f,weight) eq "bold"} {
8050 lappend n "bold"
8052 if {$fontattr($f,slant) eq "italic"} {
8053 lappend n "italic"
8055 return $n
8058 proc incrfont {inc} {
8059 global mainfont textfont ctext canv cflist showrefstop
8060 global stopped entries fontattr
8062 unmarkmatches
8063 set s $fontattr(mainfont,size)
8064 incr s $inc
8065 if {$s < 1} {
8066 set s 1
8068 set fontattr(mainfont,size) $s
8069 font config mainfont -size $s
8070 font config mainfontbold -size $s
8071 set mainfont [fontname mainfont]
8072 set s $fontattr(textfont,size)
8073 incr s $inc
8074 if {$s < 1} {
8075 set s 1
8077 set fontattr(textfont,size) $s
8078 font config textfont -size $s
8079 font config textfontbold -size $s
8080 set textfont [fontname textfont]
8081 setcoords
8082 settabs
8083 redisplay
8086 proc clearsha1 {} {
8087 global sha1entry sha1string
8088 if {[string length $sha1string] == 40} {
8089 $sha1entry delete 0 end
8093 proc sha1change {n1 n2 op} {
8094 global sha1string currentid sha1but
8095 if {$sha1string == {}
8096 || ([info exists currentid] && $sha1string == $currentid)} {
8097 set state disabled
8098 } else {
8099 set state normal
8101 if {[$sha1but cget -state] == $state} return
8102 if {$state == "normal"} {
8103 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8104 } else {
8105 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8109 proc gotocommit {} {
8110 global sha1string tagids headids curview varcid
8112 if {$sha1string == {}
8113 || ([info exists currentid] && $sha1string == $currentid)} return
8114 if {[info exists tagids($sha1string)]} {
8115 set id $tagids($sha1string)
8116 } elseif {[info exists headids($sha1string)]} {
8117 set id $headids($sha1string)
8118 } else {
8119 set id [string tolower $sha1string]
8120 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8121 set matches [longid $id]
8122 if {$matches ne {}} {
8123 if {[llength $matches] > 1} {
8124 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8125 return
8127 set id [lindex $matches 0]
8129 } else {
8130 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8131 error_popup [mc "Revision %s is not known" $sha1string]
8132 return
8136 if {[commitinview $id $curview]} {
8137 selectline [rowofcommit $id] 1
8138 return
8140 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8141 set msg [mc "SHA1 id %s is not known" $sha1string]
8142 } else {
8143 set msg [mc "Revision %s is not in the current view" $sha1string]
8145 error_popup $msg
8148 proc lineenter {x y id} {
8149 global hoverx hovery hoverid hovertimer
8150 global commitinfo canv
8152 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8153 set hoverx $x
8154 set hovery $y
8155 set hoverid $id
8156 if {[info exists hovertimer]} {
8157 after cancel $hovertimer
8159 set hovertimer [after 500 linehover]
8160 $canv delete hover
8163 proc linemotion {x y id} {
8164 global hoverx hovery hoverid hovertimer
8166 if {[info exists hoverid] && $id == $hoverid} {
8167 set hoverx $x
8168 set hovery $y
8169 if {[info exists hovertimer]} {
8170 after cancel $hovertimer
8172 set hovertimer [after 500 linehover]
8176 proc lineleave {id} {
8177 global hoverid hovertimer canv
8179 if {[info exists hoverid] && $id == $hoverid} {
8180 $canv delete hover
8181 if {[info exists hovertimer]} {
8182 after cancel $hovertimer
8183 unset hovertimer
8185 unset hoverid
8189 proc linehover {} {
8190 global hoverx hovery hoverid hovertimer
8191 global canv linespc lthickness
8192 global commitinfo
8194 set text [lindex $commitinfo($hoverid) 0]
8195 set ymax [lindex [$canv cget -scrollregion] 3]
8196 if {$ymax == {}} return
8197 set yfrac [lindex [$canv yview] 0]
8198 set x [expr {$hoverx + 2 * $linespc}]
8199 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8200 set x0 [expr {$x - 2 * $lthickness}]
8201 set y0 [expr {$y - 2 * $lthickness}]
8202 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8203 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8204 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8205 -fill \#ffff80 -outline black -width 1 -tags hover]
8206 $canv raise $t
8207 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8208 -font mainfont]
8209 $canv raise $t
8212 proc clickisonarrow {id y} {
8213 global lthickness
8215 set ranges [rowranges $id]
8216 set thresh [expr {2 * $lthickness + 6}]
8217 set n [expr {[llength $ranges] - 1}]
8218 for {set i 1} {$i < $n} {incr i} {
8219 set row [lindex $ranges $i]
8220 if {abs([yc $row] - $y) < $thresh} {
8221 return $i
8224 return {}
8227 proc arrowjump {id n y} {
8228 global canv
8230 # 1 <-> 2, 3 <-> 4, etc...
8231 set n [expr {(($n - 1) ^ 1) + 1}]
8232 set row [lindex [rowranges $id] $n]
8233 set yt [yc $row]
8234 set ymax [lindex [$canv cget -scrollregion] 3]
8235 if {$ymax eq {} || $ymax <= 0} return
8236 set view [$canv yview]
8237 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8238 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8239 if {$yfrac < 0} {
8240 set yfrac 0
8242 allcanvs yview moveto $yfrac
8245 proc lineclick {x y id isnew} {
8246 global ctext commitinfo children canv thickerline curview
8248 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8249 unmarkmatches
8250 unselectline
8251 normalline
8252 $canv delete hover
8253 # draw this line thicker than normal
8254 set thickerline $id
8255 drawlines $id
8256 if {$isnew} {
8257 set ymax [lindex [$canv cget -scrollregion] 3]
8258 if {$ymax eq {}} return
8259 set yfrac [lindex [$canv yview] 0]
8260 set y [expr {$y + $yfrac * $ymax}]
8262 set dirn [clickisonarrow $id $y]
8263 if {$dirn ne {}} {
8264 arrowjump $id $dirn $y
8265 return
8268 if {$isnew} {
8269 addtohistory [list lineclick $x $y $id 0] savectextpos
8271 # fill the details pane with info about this line
8272 $ctext conf -state normal
8273 clear_ctext
8274 settabs 0
8275 $ctext insert end "[mc "Parent"]:\t"
8276 $ctext insert end $id link0
8277 setlink $id link0
8278 set info $commitinfo($id)
8279 $ctext insert end "\n\t[lindex $info 0]\n"
8280 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8281 set date [formatdate [lindex $info 2]]
8282 $ctext insert end "\t[mc "Date"]:\t$date\n"
8283 set kids $children($curview,$id)
8284 if {$kids ne {}} {
8285 $ctext insert end "\n[mc "Children"]:"
8286 set i 0
8287 foreach child $kids {
8288 incr i
8289 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8290 set info $commitinfo($child)
8291 $ctext insert end "\n\t"
8292 $ctext insert end $child link$i
8293 setlink $child link$i
8294 $ctext insert end "\n\t[lindex $info 0]"
8295 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8296 set date [formatdate [lindex $info 2]]
8297 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8300 maybe_scroll_ctext 1
8301 $ctext conf -state disabled
8302 init_flist {}
8305 proc normalline {} {
8306 global thickerline
8307 if {[info exists thickerline]} {
8308 set id $thickerline
8309 unset thickerline
8310 drawlines $id
8314 proc selbyid {id {isnew 1}} {
8315 global curview
8316 if {[commitinview $id $curview]} {
8317 selectline [rowofcommit $id] $isnew
8321 proc mstime {} {
8322 global startmstime
8323 if {![info exists startmstime]} {
8324 set startmstime [clock clicks -milliseconds]
8326 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8329 proc rowmenu {x y id} {
8330 global rowctxmenu selectedline rowmenuid curview
8331 global nullid nullid2 fakerowmenu mainhead markedid
8333 stopfinding
8334 set rowmenuid $id
8335 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8336 set state disabled
8337 } else {
8338 set state normal
8340 if {$id ne $nullid && $id ne $nullid2} {
8341 set menu $rowctxmenu
8342 if {$mainhead ne {}} {
8343 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8344 } else {
8345 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8347 if {[info exists markedid] && $markedid ne $id} {
8348 $menu entryconfigure 9 -state normal
8349 $menu entryconfigure 10 -state normal
8350 $menu entryconfigure 11 -state normal
8351 } else {
8352 $menu entryconfigure 9 -state disabled
8353 $menu entryconfigure 10 -state disabled
8354 $menu entryconfigure 11 -state disabled
8356 } else {
8357 set menu $fakerowmenu
8359 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8360 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8361 $menu entryconfigure [mca "Make patch"] -state $state
8362 tk_popup $menu $x $y
8365 proc markhere {} {
8366 global rowmenuid markedid canv
8368 set markedid $rowmenuid
8369 make_idmark $markedid
8372 proc gotomark {} {
8373 global markedid
8375 if {[info exists markedid]} {
8376 selbyid $markedid
8380 proc replace_by_kids {l r} {
8381 global curview children
8383 set id [commitonrow $r]
8384 set l [lreplace $l 0 0]
8385 foreach kid $children($curview,$id) {
8386 lappend l [rowofcommit $kid]
8388 return [lsort -integer -decreasing -unique $l]
8391 proc find_common_desc {} {
8392 global markedid rowmenuid curview children
8394 if {![info exists markedid]} return
8395 if {![commitinview $markedid $curview] ||
8396 ![commitinview $rowmenuid $curview]} return
8397 #set t1 [clock clicks -milliseconds]
8398 set l1 [list [rowofcommit $markedid]]
8399 set l2 [list [rowofcommit $rowmenuid]]
8400 while 1 {
8401 set r1 [lindex $l1 0]
8402 set r2 [lindex $l2 0]
8403 if {$r1 eq {} || $r2 eq {}} break
8404 if {$r1 == $r2} {
8405 selectline $r1 1
8406 break
8408 if {$r1 > $r2} {
8409 set l1 [replace_by_kids $l1 $r1]
8410 } else {
8411 set l2 [replace_by_kids $l2 $r2]
8414 #set t2 [clock clicks -milliseconds]
8415 #puts "took [expr {$t2-$t1}]ms"
8418 proc compare_commits {} {
8419 global markedid rowmenuid curview children
8421 if {![info exists markedid]} return
8422 if {![commitinview $markedid $curview]} return
8423 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8424 do_cmp_commits $markedid $rowmenuid
8427 proc getpatchid {id} {
8428 global patchids
8430 if {![info exists patchids($id)]} {
8431 set cmd [diffcmd [list $id] {-p --root}]
8432 # trim off the initial "|"
8433 set cmd [lrange $cmd 1 end]
8434 if {[catch {
8435 set x [eval exec $cmd | git patch-id]
8436 set patchids($id) [lindex $x 0]
8437 }]} {
8438 set patchids($id) "error"
8441 return $patchids($id)
8444 proc do_cmp_commits {a b} {
8445 global ctext curview parents children patchids commitinfo
8447 $ctext conf -state normal
8448 clear_ctext
8449 init_flist {}
8450 for {set i 0} {$i < 100} {incr i} {
8451 set skipa 0
8452 set skipb 0
8453 if {[llength $parents($curview,$a)] > 1} {
8454 appendshortlink $a [mc "Skipping merge commit "] "\n"
8455 set skipa 1
8456 } else {
8457 set patcha [getpatchid $a]
8459 if {[llength $parents($curview,$b)] > 1} {
8460 appendshortlink $b [mc "Skipping merge commit "] "\n"
8461 set skipb 1
8462 } else {
8463 set patchb [getpatchid $b]
8465 if {!$skipa && !$skipb} {
8466 set heada [lindex $commitinfo($a) 0]
8467 set headb [lindex $commitinfo($b) 0]
8468 if {$patcha eq "error"} {
8469 appendshortlink $a [mc "Error getting patch ID for "] \
8470 [mc " - stopping\n"]
8471 break
8473 if {$patchb eq "error"} {
8474 appendshortlink $b [mc "Error getting patch ID for "] \
8475 [mc " - stopping\n"]
8476 break
8478 if {$patcha eq $patchb} {
8479 if {$heada eq $headb} {
8480 appendshortlink $a [mc "Commit "]
8481 appendshortlink $b " == " " $heada\n"
8482 } else {
8483 appendshortlink $a [mc "Commit "] " $heada\n"
8484 appendshortlink $b [mc " is the same patch as\n "] \
8485 " $headb\n"
8487 set skipa 1
8488 set skipb 1
8489 } else {
8490 $ctext insert end "\n"
8491 appendshortlink $a [mc "Commit "] " $heada\n"
8492 appendshortlink $b [mc " differs from\n "] \
8493 " $headb\n"
8494 $ctext insert end [mc "Diff of commits:\n\n"]
8495 $ctext conf -state disabled
8496 update
8497 diffcommits $a $b
8498 return
8501 if {$skipa} {
8502 set kids [real_children $curview,$a]
8503 if {[llength $kids] != 1} {
8504 $ctext insert end "\n"
8505 appendshortlink $a [mc "Commit "] \
8506 [mc " has %s children - stopping\n" [llength $kids]]
8507 break
8509 set a [lindex $kids 0]
8511 if {$skipb} {
8512 set kids [real_children $curview,$b]
8513 if {[llength $kids] != 1} {
8514 appendshortlink $b [mc "Commit "] \
8515 [mc " has %s children - stopping\n" [llength $kids]]
8516 break
8518 set b [lindex $kids 0]
8521 $ctext conf -state disabled
8524 proc diffcommits {a b} {
8525 global diffcontext diffids blobdifffd diffinhdr
8527 set tmpdir [gitknewtmpdir]
8528 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8529 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8530 if {[catch {
8531 exec git diff-tree -p --pretty $a >$fna
8532 exec git diff-tree -p --pretty $b >$fnb
8533 } err]} {
8534 error_popup [mc "Error writing commit to file: %s" $err]
8535 return
8537 if {[catch {
8538 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8539 } err]} {
8540 error_popup [mc "Error diffing commits: %s" $err]
8541 return
8543 set diffids [list commits $a $b]
8544 set blobdifffd($diffids) $fd
8545 set diffinhdr 0
8546 filerun $fd [list getblobdiffline $fd $diffids]
8549 proc diffvssel {dirn} {
8550 global rowmenuid selectedline
8552 if {$selectedline eq {}} return
8553 if {$dirn} {
8554 set oldid [commitonrow $selectedline]
8555 set newid $rowmenuid
8556 } else {
8557 set oldid $rowmenuid
8558 set newid [commitonrow $selectedline]
8560 addtohistory [list doseldiff $oldid $newid] savectextpos
8561 doseldiff $oldid $newid
8564 proc doseldiff {oldid newid} {
8565 global ctext
8566 global commitinfo
8568 $ctext conf -state normal
8569 clear_ctext
8570 init_flist [mc "Top"]
8571 $ctext insert end "[mc "From"] "
8572 $ctext insert end $oldid link0
8573 setlink $oldid link0
8574 $ctext insert end "\n "
8575 $ctext insert end [lindex $commitinfo($oldid) 0]
8576 $ctext insert end "\n\n[mc "To"] "
8577 $ctext insert end $newid link1
8578 setlink $newid link1
8579 $ctext insert end "\n "
8580 $ctext insert end [lindex $commitinfo($newid) 0]
8581 $ctext insert end "\n"
8582 $ctext conf -state disabled
8583 $ctext tag remove found 1.0 end
8584 startdiff [list $oldid $newid]
8587 proc mkpatch {} {
8588 global rowmenuid currentid commitinfo patchtop patchnum NS
8590 if {![info exists currentid]} return
8591 set oldid $currentid
8592 set oldhead [lindex $commitinfo($oldid) 0]
8593 set newid $rowmenuid
8594 set newhead [lindex $commitinfo($newid) 0]
8595 set top .patch
8596 set patchtop $top
8597 catch {destroy $top}
8598 ttk_toplevel $top
8599 make_transient $top .
8600 ${NS}::label $top.title -text [mc "Generate patch"]
8601 grid $top.title - -pady 10
8602 ${NS}::label $top.from -text [mc "From:"]
8603 ${NS}::entry $top.fromsha1 -width 40
8604 $top.fromsha1 insert 0 $oldid
8605 $top.fromsha1 conf -state readonly
8606 grid $top.from $top.fromsha1 -sticky w
8607 ${NS}::entry $top.fromhead -width 60
8608 $top.fromhead insert 0 $oldhead
8609 $top.fromhead conf -state readonly
8610 grid x $top.fromhead -sticky w
8611 ${NS}::label $top.to -text [mc "To:"]
8612 ${NS}::entry $top.tosha1 -width 40
8613 $top.tosha1 insert 0 $newid
8614 $top.tosha1 conf -state readonly
8615 grid $top.to $top.tosha1 -sticky w
8616 ${NS}::entry $top.tohead -width 60
8617 $top.tohead insert 0 $newhead
8618 $top.tohead conf -state readonly
8619 grid x $top.tohead -sticky w
8620 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8621 grid $top.rev x -pady 10 -padx 5
8622 ${NS}::label $top.flab -text [mc "Output file:"]
8623 ${NS}::entry $top.fname -width 60
8624 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8625 incr patchnum
8626 grid $top.flab $top.fname -sticky w
8627 ${NS}::frame $top.buts
8628 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8629 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8630 bind $top <Key-Return> mkpatchgo
8631 bind $top <Key-Escape> mkpatchcan
8632 grid $top.buts.gen $top.buts.can
8633 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8634 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8635 grid $top.buts - -pady 10 -sticky ew
8636 focus $top.fname
8639 proc mkpatchrev {} {
8640 global patchtop
8642 set oldid [$patchtop.fromsha1 get]
8643 set oldhead [$patchtop.fromhead get]
8644 set newid [$patchtop.tosha1 get]
8645 set newhead [$patchtop.tohead get]
8646 foreach e [list fromsha1 fromhead tosha1 tohead] \
8647 v [list $newid $newhead $oldid $oldhead] {
8648 $patchtop.$e conf -state normal
8649 $patchtop.$e delete 0 end
8650 $patchtop.$e insert 0 $v
8651 $patchtop.$e conf -state readonly
8655 proc mkpatchgo {} {
8656 global patchtop nullid nullid2
8658 set oldid [$patchtop.fromsha1 get]
8659 set newid [$patchtop.tosha1 get]
8660 set fname [$patchtop.fname get]
8661 set cmd [diffcmd [list $oldid $newid] -p]
8662 # trim off the initial "|"
8663 set cmd [lrange $cmd 1 end]
8664 lappend cmd >$fname &
8665 if {[catch {eval exec $cmd} err]} {
8666 error_popup "[mc "Error creating patch:"] $err" $patchtop
8668 catch {destroy $patchtop}
8669 unset patchtop
8672 proc mkpatchcan {} {
8673 global patchtop
8675 catch {destroy $patchtop}
8676 unset patchtop
8679 proc mktag {} {
8680 global rowmenuid mktagtop commitinfo NS
8682 set top .maketag
8683 set mktagtop $top
8684 catch {destroy $top}
8685 ttk_toplevel $top
8686 make_transient $top .
8687 ${NS}::label $top.title -text [mc "Create tag"]
8688 grid $top.title - -pady 10
8689 ${NS}::label $top.id -text [mc "ID:"]
8690 ${NS}::entry $top.sha1 -width 40
8691 $top.sha1 insert 0 $rowmenuid
8692 $top.sha1 conf -state readonly
8693 grid $top.id $top.sha1 -sticky w
8694 ${NS}::entry $top.head -width 60
8695 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8696 $top.head conf -state readonly
8697 grid x $top.head -sticky w
8698 ${NS}::label $top.tlab -text [mc "Tag name:"]
8699 ${NS}::entry $top.tag -width 60
8700 grid $top.tlab $top.tag -sticky w
8701 ${NS}::frame $top.buts
8702 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8703 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8704 bind $top <Key-Return> mktaggo
8705 bind $top <Key-Escape> mktagcan
8706 grid $top.buts.gen $top.buts.can
8707 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8708 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8709 grid $top.buts - -pady 10 -sticky ew
8710 focus $top.tag
8713 proc domktag {} {
8714 global mktagtop env tagids idtags
8716 set id [$mktagtop.sha1 get]
8717 set tag [$mktagtop.tag get]
8718 if {$tag == {}} {
8719 error_popup [mc "No tag name specified"] $mktagtop
8720 return 0
8722 if {[info exists tagids($tag)]} {
8723 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8724 return 0
8726 if {[catch {
8727 exec git tag $tag $id
8728 } err]} {
8729 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8730 return 0
8733 set tagids($tag) $id
8734 lappend idtags($id) $tag
8735 redrawtags $id
8736 addedtag $id
8737 dispneartags 0
8738 run refill_reflist
8739 return 1
8742 proc redrawtags {id} {
8743 global canv linehtag idpos currentid curview cmitlisted markedid
8744 global canvxmax iddrawn circleitem mainheadid circlecolors
8746 if {![commitinview $id $curview]} return
8747 if {![info exists iddrawn($id)]} return
8748 set row [rowofcommit $id]
8749 if {$id eq $mainheadid} {
8750 set ofill yellow
8751 } else {
8752 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8754 $canv itemconf $circleitem($row) -fill $ofill
8755 $canv delete tag.$id
8756 set xt [eval drawtags $id $idpos($id)]
8757 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8758 set text [$canv itemcget $linehtag($id) -text]
8759 set font [$canv itemcget $linehtag($id) -font]
8760 set xr [expr {$xt + [font measure $font $text]}]
8761 if {$xr > $canvxmax} {
8762 set canvxmax $xr
8763 setcanvscroll
8765 if {[info exists currentid] && $currentid == $id} {
8766 make_secsel $id
8768 if {[info exists markedid] && $markedid eq $id} {
8769 make_idmark $id
8773 proc mktagcan {} {
8774 global mktagtop
8776 catch {destroy $mktagtop}
8777 unset mktagtop
8780 proc mktaggo {} {
8781 if {![domktag]} return
8782 mktagcan
8785 proc writecommit {} {
8786 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8788 set top .writecommit
8789 set wrcomtop $top
8790 catch {destroy $top}
8791 ttk_toplevel $top
8792 make_transient $top .
8793 ${NS}::label $top.title -text [mc "Write commit to file"]
8794 grid $top.title - -pady 10
8795 ${NS}::label $top.id -text [mc "ID:"]
8796 ${NS}::entry $top.sha1 -width 40
8797 $top.sha1 insert 0 $rowmenuid
8798 $top.sha1 conf -state readonly
8799 grid $top.id $top.sha1 -sticky w
8800 ${NS}::entry $top.head -width 60
8801 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8802 $top.head conf -state readonly
8803 grid x $top.head -sticky w
8804 ${NS}::label $top.clab -text [mc "Command:"]
8805 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8806 grid $top.clab $top.cmd -sticky w -pady 10
8807 ${NS}::label $top.flab -text [mc "Output file:"]
8808 ${NS}::entry $top.fname -width 60
8809 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8810 grid $top.flab $top.fname -sticky w
8811 ${NS}::frame $top.buts
8812 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8813 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8814 bind $top <Key-Return> wrcomgo
8815 bind $top <Key-Escape> wrcomcan
8816 grid $top.buts.gen $top.buts.can
8817 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8818 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8819 grid $top.buts - -pady 10 -sticky ew
8820 focus $top.fname
8823 proc wrcomgo {} {
8824 global wrcomtop
8826 set id [$wrcomtop.sha1 get]
8827 set cmd "echo $id | [$wrcomtop.cmd get]"
8828 set fname [$wrcomtop.fname get]
8829 if {[catch {exec sh -c $cmd >$fname &} err]} {
8830 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8832 catch {destroy $wrcomtop}
8833 unset wrcomtop
8836 proc wrcomcan {} {
8837 global wrcomtop
8839 catch {destroy $wrcomtop}
8840 unset wrcomtop
8843 proc mkbranch {} {
8844 global rowmenuid mkbrtop NS
8846 set top .makebranch
8847 catch {destroy $top}
8848 ttk_toplevel $top
8849 make_transient $top .
8850 ${NS}::label $top.title -text [mc "Create new branch"]
8851 grid $top.title - -pady 10
8852 ${NS}::label $top.id -text [mc "ID:"]
8853 ${NS}::entry $top.sha1 -width 40
8854 $top.sha1 insert 0 $rowmenuid
8855 $top.sha1 conf -state readonly
8856 grid $top.id $top.sha1 -sticky w
8857 ${NS}::label $top.nlab -text [mc "Name:"]
8858 ${NS}::entry $top.name -width 40
8859 grid $top.nlab $top.name -sticky w
8860 ${NS}::frame $top.buts
8861 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8862 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8863 bind $top <Key-Return> [list mkbrgo $top]
8864 bind $top <Key-Escape> "catch {destroy $top}"
8865 grid $top.buts.go $top.buts.can
8866 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8867 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8868 grid $top.buts - -pady 10 -sticky ew
8869 focus $top.name
8872 proc mkbrgo {top} {
8873 global headids idheads
8875 set name [$top.name get]
8876 set id [$top.sha1 get]
8877 set cmdargs {}
8878 set old_id {}
8879 if {$name eq {}} {
8880 error_popup [mc "Please specify a name for the new branch"] $top
8881 return
8883 if {[info exists headids($name)]} {
8884 if {![confirm_popup [mc \
8885 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8886 return
8888 set old_id $headids($name)
8889 lappend cmdargs -f
8891 catch {destroy $top}
8892 lappend cmdargs $name $id
8893 nowbusy newbranch
8894 update
8895 if {[catch {
8896 eval exec git branch $cmdargs
8897 } err]} {
8898 notbusy newbranch
8899 error_popup $err
8900 } else {
8901 notbusy newbranch
8902 if {$old_id ne {}} {
8903 movehead $id $name
8904 movedhead $id $name
8905 redrawtags $old_id
8906 redrawtags $id
8907 } else {
8908 set headids($name) $id
8909 lappend idheads($id) $name
8910 addedhead $id $name
8911 redrawtags $id
8913 dispneartags 0
8914 run refill_reflist
8918 proc exec_citool {tool_args {baseid {}}} {
8919 global commitinfo env
8921 set save_env [array get env GIT_AUTHOR_*]
8923 if {$baseid ne {}} {
8924 if {![info exists commitinfo($baseid)]} {
8925 getcommit $baseid
8927 set author [lindex $commitinfo($baseid) 1]
8928 set date [lindex $commitinfo($baseid) 2]
8929 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8930 $author author name email]
8931 && $date ne {}} {
8932 set env(GIT_AUTHOR_NAME) $name
8933 set env(GIT_AUTHOR_EMAIL) $email
8934 set env(GIT_AUTHOR_DATE) $date
8938 eval exec git citool $tool_args &
8940 array unset env GIT_AUTHOR_*
8941 array set env $save_env
8944 proc cherrypick {} {
8945 global rowmenuid curview
8946 global mainhead mainheadid
8948 set oldhead [exec git rev-parse HEAD]
8949 set dheads [descheads $rowmenuid]
8950 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8951 set ok [confirm_popup [mc "Commit %s is already\
8952 included in branch %s -- really re-apply it?" \
8953 [string range $rowmenuid 0 7] $mainhead]]
8954 if {!$ok} return
8956 nowbusy cherrypick [mc "Cherry-picking"]
8957 update
8958 # Unfortunately git-cherry-pick writes stuff to stderr even when
8959 # no error occurs, and exec takes that as an indication of error...
8960 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8961 notbusy cherrypick
8962 if {[regexp -line \
8963 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8964 $err msg fname]} {
8965 error_popup [mc "Cherry-pick failed because of local changes\
8966 to file '%s'.\nPlease commit, reset or stash\
8967 your changes and try again." $fname]
8968 } elseif {[regexp -line \
8969 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8970 $err]} {
8971 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8972 conflict.\nDo you wish to run git citool to\
8973 resolve it?"]]} {
8974 # Force citool to read MERGE_MSG
8975 file delete [file join [gitdir] "GITGUI_MSG"]
8976 exec_citool {} $rowmenuid
8978 } else {
8979 error_popup $err
8981 run updatecommits
8982 return
8984 set newhead [exec git rev-parse HEAD]
8985 if {$newhead eq $oldhead} {
8986 notbusy cherrypick
8987 error_popup [mc "No changes committed"]
8988 return
8990 addnewchild $newhead $oldhead
8991 if {[commitinview $oldhead $curview]} {
8992 # XXX this isn't right if we have a path limit...
8993 insertrow $newhead $oldhead $curview
8994 if {$mainhead ne {}} {
8995 movehead $newhead $mainhead
8996 movedhead $newhead $mainhead
8998 set mainheadid $newhead
8999 redrawtags $oldhead
9000 redrawtags $newhead
9001 selbyid $newhead
9003 notbusy cherrypick
9006 proc resethead {} {
9007 global mainhead rowmenuid confirm_ok resettype NS
9009 set confirm_ok 0
9010 set w ".confirmreset"
9011 ttk_toplevel $w
9012 make_transient $w .
9013 wm title $w [mc "Confirm reset"]
9014 ${NS}::label $w.m -text \
9015 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9016 pack $w.m -side top -fill x -padx 20 -pady 20
9017 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9018 set resettype mixed
9019 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9020 -text [mc "Soft: Leave working tree and index untouched"]
9021 grid $w.f.soft -sticky w
9022 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9023 -text [mc "Mixed: Leave working tree untouched, reset index"]
9024 grid $w.f.mixed -sticky w
9025 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9026 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9027 grid $w.f.hard -sticky w
9028 pack $w.f -side top -fill x -padx 4
9029 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9030 pack $w.ok -side left -fill x -padx 20 -pady 20
9031 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9032 bind $w <Key-Escape> [list destroy $w]
9033 pack $w.cancel -side right -fill x -padx 20 -pady 20
9034 bind $w <Visibility> "grab $w; focus $w"
9035 tkwait window $w
9036 if {!$confirm_ok} return
9037 if {[catch {set fd [open \
9038 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9039 error_popup $err
9040 } else {
9041 dohidelocalchanges
9042 filerun $fd [list readresetstat $fd]
9043 nowbusy reset [mc "Resetting"]
9044 selbyid $rowmenuid
9048 proc readresetstat {fd} {
9049 global mainhead mainheadid showlocalchanges rprogcoord
9051 if {[gets $fd line] >= 0} {
9052 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9053 set rprogcoord [expr {1.0 * $m / $n}]
9054 adjustprogress
9056 return 1
9058 set rprogcoord 0
9059 adjustprogress
9060 notbusy reset
9061 if {[catch {close $fd} err]} {
9062 error_popup $err
9064 set oldhead $mainheadid
9065 set newhead [exec git rev-parse HEAD]
9066 if {$newhead ne $oldhead} {
9067 movehead $newhead $mainhead
9068 movedhead $newhead $mainhead
9069 set mainheadid $newhead
9070 redrawtags $oldhead
9071 redrawtags $newhead
9073 if {$showlocalchanges} {
9074 doshowlocalchanges
9076 return 0
9079 # context menu for a head
9080 proc headmenu {x y id head} {
9081 global headmenuid headmenuhead headctxmenu mainhead
9083 stopfinding
9084 set headmenuid $id
9085 set headmenuhead $head
9086 set state normal
9087 if {[string match "remotes/*" $head]} {
9088 set state disabled
9090 if {$head eq $mainhead} {
9091 set state disabled
9093 $headctxmenu entryconfigure 0 -state $state
9094 $headctxmenu entryconfigure 1 -state $state
9095 tk_popup $headctxmenu $x $y
9098 proc cobranch {} {
9099 global headmenuid headmenuhead headids
9100 global showlocalchanges
9102 # check the tree is clean first??
9103 nowbusy checkout [mc "Checking out"]
9104 update
9105 dohidelocalchanges
9106 if {[catch {
9107 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9108 } err]} {
9109 notbusy checkout
9110 error_popup $err
9111 if {$showlocalchanges} {
9112 dodiffindex
9114 } else {
9115 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9119 proc readcheckoutstat {fd newhead newheadid} {
9120 global mainhead mainheadid headids showlocalchanges progresscoords
9121 global viewmainheadid curview
9123 if {[gets $fd line] >= 0} {
9124 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9125 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9126 adjustprogress
9128 return 1
9130 set progresscoords {0 0}
9131 adjustprogress
9132 notbusy checkout
9133 if {[catch {close $fd} err]} {
9134 error_popup $err
9136 set oldmainid $mainheadid
9137 set mainhead $newhead
9138 set mainheadid $newheadid
9139 set viewmainheadid($curview) $newheadid
9140 redrawtags $oldmainid
9141 redrawtags $newheadid
9142 selbyid $newheadid
9143 if {$showlocalchanges} {
9144 dodiffindex
9148 proc rmbranch {} {
9149 global headmenuid headmenuhead mainhead
9150 global idheads
9152 set head $headmenuhead
9153 set id $headmenuid
9154 # this check shouldn't be needed any more...
9155 if {$head eq $mainhead} {
9156 error_popup [mc "Cannot delete the currently checked-out branch"]
9157 return
9159 set dheads [descheads $id]
9160 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9161 # the stuff on this branch isn't on any other branch
9162 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9163 branch.\nReally delete branch %s?" $head $head]]} return
9165 nowbusy rmbranch
9166 update
9167 if {[catch {exec git branch -D $head} err]} {
9168 notbusy rmbranch
9169 error_popup $err
9170 return
9172 removehead $id $head
9173 removedhead $id $head
9174 redrawtags $id
9175 notbusy rmbranch
9176 dispneartags 0
9177 run refill_reflist
9180 # Display a list of tags and heads
9181 proc showrefs {} {
9182 global showrefstop bgcolor fgcolor selectbgcolor NS
9183 global bglist fglist reflistfilter reflist maincursor
9185 set top .showrefs
9186 set showrefstop $top
9187 if {[winfo exists $top]} {
9188 raise $top
9189 refill_reflist
9190 return
9192 ttk_toplevel $top
9193 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9194 make_transient $top .
9195 text $top.list -background $bgcolor -foreground $fgcolor \
9196 -selectbackground $selectbgcolor -font mainfont \
9197 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9198 -width 30 -height 20 -cursor $maincursor \
9199 -spacing1 1 -spacing3 1 -state disabled
9200 $top.list tag configure highlight -background $selectbgcolor
9201 lappend bglist $top.list
9202 lappend fglist $top.list
9203 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9204 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9205 grid $top.list $top.ysb -sticky nsew
9206 grid $top.xsb x -sticky ew
9207 ${NS}::frame $top.f
9208 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9209 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9210 set reflistfilter "*"
9211 trace add variable reflistfilter write reflistfilter_change
9212 pack $top.f.e -side right -fill x -expand 1
9213 pack $top.f.l -side left
9214 grid $top.f - -sticky ew -pady 2
9215 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9216 bind $top <Key-Escape> [list destroy $top]
9217 grid $top.close -
9218 grid columnconfigure $top 0 -weight 1
9219 grid rowconfigure $top 0 -weight 1
9220 bind $top.list <1> {break}
9221 bind $top.list <B1-Motion> {break}
9222 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9223 set reflist {}
9224 refill_reflist
9227 proc sel_reflist {w x y} {
9228 global showrefstop reflist headids tagids otherrefids
9230 if {![winfo exists $showrefstop]} return
9231 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9232 set ref [lindex $reflist [expr {$l-1}]]
9233 set n [lindex $ref 0]
9234 switch -- [lindex $ref 1] {
9235 "H" {selbyid $headids($n)}
9236 "T" {selbyid $tagids($n)}
9237 "o" {selbyid $otherrefids($n)}
9239 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9242 proc unsel_reflist {} {
9243 global showrefstop
9245 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9246 $showrefstop.list tag remove highlight 0.0 end
9249 proc reflistfilter_change {n1 n2 op} {
9250 global reflistfilter
9252 after cancel refill_reflist
9253 after 200 refill_reflist
9256 proc refill_reflist {} {
9257 global reflist reflistfilter showrefstop headids tagids otherrefids
9258 global curview
9260 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9261 set refs {}
9262 foreach n [array names headids] {
9263 if {[string match $reflistfilter $n]} {
9264 if {[commitinview $headids($n) $curview]} {
9265 lappend refs [list $n H]
9266 } else {
9267 interestedin $headids($n) {run refill_reflist}
9271 foreach n [array names tagids] {
9272 if {[string match $reflistfilter $n]} {
9273 if {[commitinview $tagids($n) $curview]} {
9274 lappend refs [list $n T]
9275 } else {
9276 interestedin $tagids($n) {run refill_reflist}
9280 foreach n [array names otherrefids] {
9281 if {[string match $reflistfilter $n]} {
9282 if {[commitinview $otherrefids($n) $curview]} {
9283 lappend refs [list $n o]
9284 } else {
9285 interestedin $otherrefids($n) {run refill_reflist}
9289 set refs [lsort -index 0 $refs]
9290 if {$refs eq $reflist} return
9292 # Update the contents of $showrefstop.list according to the
9293 # differences between $reflist (old) and $refs (new)
9294 $showrefstop.list conf -state normal
9295 $showrefstop.list insert end "\n"
9296 set i 0
9297 set j 0
9298 while {$i < [llength $reflist] || $j < [llength $refs]} {
9299 if {$i < [llength $reflist]} {
9300 if {$j < [llength $refs]} {
9301 set cmp [string compare [lindex $reflist $i 0] \
9302 [lindex $refs $j 0]]
9303 if {$cmp == 0} {
9304 set cmp [string compare [lindex $reflist $i 1] \
9305 [lindex $refs $j 1]]
9307 } else {
9308 set cmp -1
9310 } else {
9311 set cmp 1
9313 switch -- $cmp {
9314 -1 {
9315 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9316 incr i
9319 incr i
9320 incr j
9323 set l [expr {$j + 1}]
9324 $showrefstop.list image create $l.0 -align baseline \
9325 -image reficon-[lindex $refs $j 1] -padx 2
9326 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9327 incr j
9331 set reflist $refs
9332 # delete last newline
9333 $showrefstop.list delete end-2c end-1c
9334 $showrefstop.list conf -state disabled
9337 # Stuff for finding nearby tags
9338 proc getallcommits {} {
9339 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9340 global idheads idtags idotherrefs allparents tagobjid
9342 if {![info exists allcommits]} {
9343 set nextarc 0
9344 set allcommits 0
9345 set seeds {}
9346 set allcwait 0
9347 set cachedarcs 0
9348 set allccache [file join [gitdir] "gitk.cache"]
9349 if {![catch {
9350 set f [open $allccache r]
9351 set allcwait 1
9352 getcache $f
9353 }]} return
9356 if {$allcwait} {
9357 return
9359 set cmd [list | git rev-list --parents]
9360 set allcupdate [expr {$seeds ne {}}]
9361 if {!$allcupdate} {
9362 set ids "--all"
9363 } else {
9364 set refs [concat [array names idheads] [array names idtags] \
9365 [array names idotherrefs]]
9366 set ids {}
9367 set tagobjs {}
9368 foreach name [array names tagobjid] {
9369 lappend tagobjs $tagobjid($name)
9371 foreach id [lsort -unique $refs] {
9372 if {![info exists allparents($id)] &&
9373 [lsearch -exact $tagobjs $id] < 0} {
9374 lappend ids $id
9377 if {$ids ne {}} {
9378 foreach id $seeds {
9379 lappend ids "^$id"
9383 if {$ids ne {}} {
9384 set fd [open [concat $cmd $ids] r]
9385 fconfigure $fd -blocking 0
9386 incr allcommits
9387 nowbusy allcommits
9388 filerun $fd [list getallclines $fd]
9389 } else {
9390 dispneartags 0
9394 # Since most commits have 1 parent and 1 child, we group strings of
9395 # such commits into "arcs" joining branch/merge points (BMPs), which
9396 # are commits that either don't have 1 parent or don't have 1 child.
9398 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9399 # arcout(id) - outgoing arcs for BMP
9400 # arcids(a) - list of IDs on arc including end but not start
9401 # arcstart(a) - BMP ID at start of arc
9402 # arcend(a) - BMP ID at end of arc
9403 # growing(a) - arc a is still growing
9404 # arctags(a) - IDs out of arcids (excluding end) that have tags
9405 # archeads(a) - IDs out of arcids (excluding end) that have heads
9406 # The start of an arc is at the descendent end, so "incoming" means
9407 # coming from descendents, and "outgoing" means going towards ancestors.
9409 proc getallclines {fd} {
9410 global allparents allchildren idtags idheads nextarc
9411 global arcnos arcids arctags arcout arcend arcstart archeads growing
9412 global seeds allcommits cachedarcs allcupdate
9414 set nid 0
9415 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9416 set id [lindex $line 0]
9417 if {[info exists allparents($id)]} {
9418 # seen it already
9419 continue
9421 set cachedarcs 0
9422 set olds [lrange $line 1 end]
9423 set allparents($id) $olds
9424 if {![info exists allchildren($id)]} {
9425 set allchildren($id) {}
9426 set arcnos($id) {}
9427 lappend seeds $id
9428 } else {
9429 set a $arcnos($id)
9430 if {[llength $olds] == 1 && [llength $a] == 1} {
9431 lappend arcids($a) $id
9432 if {[info exists idtags($id)]} {
9433 lappend arctags($a) $id
9435 if {[info exists idheads($id)]} {
9436 lappend archeads($a) $id
9438 if {[info exists allparents($olds)]} {
9439 # seen parent already
9440 if {![info exists arcout($olds)]} {
9441 splitarc $olds
9443 lappend arcids($a) $olds
9444 set arcend($a) $olds
9445 unset growing($a)
9447 lappend allchildren($olds) $id
9448 lappend arcnos($olds) $a
9449 continue
9452 foreach a $arcnos($id) {
9453 lappend arcids($a) $id
9454 set arcend($a) $id
9455 unset growing($a)
9458 set ao {}
9459 foreach p $olds {
9460 lappend allchildren($p) $id
9461 set a [incr nextarc]
9462 set arcstart($a) $id
9463 set archeads($a) {}
9464 set arctags($a) {}
9465 set archeads($a) {}
9466 set arcids($a) {}
9467 lappend ao $a
9468 set growing($a) 1
9469 if {[info exists allparents($p)]} {
9470 # seen it already, may need to make a new branch
9471 if {![info exists arcout($p)]} {
9472 splitarc $p
9474 lappend arcids($a) $p
9475 set arcend($a) $p
9476 unset growing($a)
9478 lappend arcnos($p) $a
9480 set arcout($id) $ao
9482 if {$nid > 0} {
9483 global cached_dheads cached_dtags cached_atags
9484 catch {unset cached_dheads}
9485 catch {unset cached_dtags}
9486 catch {unset cached_atags}
9488 if {![eof $fd]} {
9489 return [expr {$nid >= 1000? 2: 1}]
9491 set cacheok 1
9492 if {[catch {
9493 fconfigure $fd -blocking 1
9494 close $fd
9495 } err]} {
9496 # got an error reading the list of commits
9497 # if we were updating, try rereading the whole thing again
9498 if {$allcupdate} {
9499 incr allcommits -1
9500 dropcache $err
9501 return
9503 error_popup "[mc "Error reading commit topology information;\
9504 branch and preceding/following tag information\
9505 will be incomplete."]\n($err)"
9506 set cacheok 0
9508 if {[incr allcommits -1] == 0} {
9509 notbusy allcommits
9510 if {$cacheok} {
9511 run savecache
9514 dispneartags 0
9515 return 0
9518 proc recalcarc {a} {
9519 global arctags archeads arcids idtags idheads
9521 set at {}
9522 set ah {}
9523 foreach id [lrange $arcids($a) 0 end-1] {
9524 if {[info exists idtags($id)]} {
9525 lappend at $id
9527 if {[info exists idheads($id)]} {
9528 lappend ah $id
9531 set arctags($a) $at
9532 set archeads($a) $ah
9535 proc splitarc {p} {
9536 global arcnos arcids nextarc arctags archeads idtags idheads
9537 global arcstart arcend arcout allparents growing
9539 set a $arcnos($p)
9540 if {[llength $a] != 1} {
9541 puts "oops splitarc called but [llength $a] arcs already"
9542 return
9544 set a [lindex $a 0]
9545 set i [lsearch -exact $arcids($a) $p]
9546 if {$i < 0} {
9547 puts "oops splitarc $p not in arc $a"
9548 return
9550 set na [incr nextarc]
9551 if {[info exists arcend($a)]} {
9552 set arcend($na) $arcend($a)
9553 } else {
9554 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9555 set j [lsearch -exact $arcnos($l) $a]
9556 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9558 set tail [lrange $arcids($a) [expr {$i+1}] end]
9559 set arcids($a) [lrange $arcids($a) 0 $i]
9560 set arcend($a) $p
9561 set arcstart($na) $p
9562 set arcout($p) $na
9563 set arcids($na) $tail
9564 if {[info exists growing($a)]} {
9565 set growing($na) 1
9566 unset growing($a)
9569 foreach id $tail {
9570 if {[llength $arcnos($id)] == 1} {
9571 set arcnos($id) $na
9572 } else {
9573 set j [lsearch -exact $arcnos($id) $a]
9574 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9578 # reconstruct tags and heads lists
9579 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9580 recalcarc $a
9581 recalcarc $na
9582 } else {
9583 set arctags($na) {}
9584 set archeads($na) {}
9588 # Update things for a new commit added that is a child of one
9589 # existing commit. Used when cherry-picking.
9590 proc addnewchild {id p} {
9591 global allparents allchildren idtags nextarc
9592 global arcnos arcids arctags arcout arcend arcstart archeads growing
9593 global seeds allcommits
9595 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9596 set allparents($id) [list $p]
9597 set allchildren($id) {}
9598 set arcnos($id) {}
9599 lappend seeds $id
9600 lappend allchildren($p) $id
9601 set a [incr nextarc]
9602 set arcstart($a) $id
9603 set archeads($a) {}
9604 set arctags($a) {}
9605 set arcids($a) [list $p]
9606 set arcend($a) $p
9607 if {![info exists arcout($p)]} {
9608 splitarc $p
9610 lappend arcnos($p) $a
9611 set arcout($id) [list $a]
9614 # This implements a cache for the topology information.
9615 # The cache saves, for each arc, the start and end of the arc,
9616 # the ids on the arc, and the outgoing arcs from the end.
9617 proc readcache {f} {
9618 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9619 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9620 global allcwait
9622 set a $nextarc
9623 set lim $cachedarcs
9624 if {$lim - $a > 500} {
9625 set lim [expr {$a + 500}]
9627 if {[catch {
9628 if {$a == $lim} {
9629 # finish reading the cache and setting up arctags, etc.
9630 set line [gets $f]
9631 if {$line ne "1"} {error "bad final version"}
9632 close $f
9633 foreach id [array names idtags] {
9634 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9635 [llength $allparents($id)] == 1} {
9636 set a [lindex $arcnos($id) 0]
9637 if {$arctags($a) eq {}} {
9638 recalcarc $a
9642 foreach id [array names idheads] {
9643 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9644 [llength $allparents($id)] == 1} {
9645 set a [lindex $arcnos($id) 0]
9646 if {$archeads($a) eq {}} {
9647 recalcarc $a
9651 foreach id [lsort -unique $possible_seeds] {
9652 if {$arcnos($id) eq {}} {
9653 lappend seeds $id
9656 set allcwait 0
9657 } else {
9658 while {[incr a] <= $lim} {
9659 set line [gets $f]
9660 if {[llength $line] != 3} {error "bad line"}
9661 set s [lindex $line 0]
9662 set arcstart($a) $s
9663 lappend arcout($s) $a
9664 if {![info exists arcnos($s)]} {
9665 lappend possible_seeds $s
9666 set arcnos($s) {}
9668 set e [lindex $line 1]
9669 if {$e eq {}} {
9670 set growing($a) 1
9671 } else {
9672 set arcend($a) $e
9673 if {![info exists arcout($e)]} {
9674 set arcout($e) {}
9677 set arcids($a) [lindex $line 2]
9678 foreach id $arcids($a) {
9679 lappend allparents($s) $id
9680 set s $id
9681 lappend arcnos($id) $a
9683 if {![info exists allparents($s)]} {
9684 set allparents($s) {}
9686 set arctags($a) {}
9687 set archeads($a) {}
9689 set nextarc [expr {$a - 1}]
9691 } err]} {
9692 dropcache $err
9693 return 0
9695 if {!$allcwait} {
9696 getallcommits
9698 return $allcwait
9701 proc getcache {f} {
9702 global nextarc cachedarcs possible_seeds
9704 if {[catch {
9705 set line [gets $f]
9706 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9707 # make sure it's an integer
9708 set cachedarcs [expr {int([lindex $line 1])}]
9709 if {$cachedarcs < 0} {error "bad number of arcs"}
9710 set nextarc 0
9711 set possible_seeds {}
9712 run readcache $f
9713 } err]} {
9714 dropcache $err
9716 return 0
9719 proc dropcache {err} {
9720 global allcwait nextarc cachedarcs seeds
9722 #puts "dropping cache ($err)"
9723 foreach v {arcnos arcout arcids arcstart arcend growing \
9724 arctags archeads allparents allchildren} {
9725 global $v
9726 catch {unset $v}
9728 set allcwait 0
9729 set nextarc 0
9730 set cachedarcs 0
9731 set seeds {}
9732 getallcommits
9735 proc writecache {f} {
9736 global cachearc cachedarcs allccache
9737 global arcstart arcend arcnos arcids arcout
9739 set a $cachearc
9740 set lim $cachedarcs
9741 if {$lim - $a > 1000} {
9742 set lim [expr {$a + 1000}]
9744 if {[catch {
9745 while {[incr a] <= $lim} {
9746 if {[info exists arcend($a)]} {
9747 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9748 } else {
9749 puts $f [list $arcstart($a) {} $arcids($a)]
9752 } err]} {
9753 catch {close $f}
9754 catch {file delete $allccache}
9755 #puts "writing cache failed ($err)"
9756 return 0
9758 set cachearc [expr {$a - 1}]
9759 if {$a > $cachedarcs} {
9760 puts $f "1"
9761 close $f
9762 return 0
9764 return 1
9767 proc savecache {} {
9768 global nextarc cachedarcs cachearc allccache
9770 if {$nextarc == $cachedarcs} return
9771 set cachearc 0
9772 set cachedarcs $nextarc
9773 catch {
9774 set f [open $allccache w]
9775 puts $f [list 1 $cachedarcs]
9776 run writecache $f
9780 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9781 # or 0 if neither is true.
9782 proc anc_or_desc {a b} {
9783 global arcout arcstart arcend arcnos cached_isanc
9785 if {$arcnos($a) eq $arcnos($b)} {
9786 # Both are on the same arc(s); either both are the same BMP,
9787 # or if one is not a BMP, the other is also not a BMP or is
9788 # the BMP at end of the arc (and it only has 1 incoming arc).
9789 # Or both can be BMPs with no incoming arcs.
9790 if {$a eq $b || $arcnos($a) eq {}} {
9791 return 0
9793 # assert {[llength $arcnos($a)] == 1}
9794 set arc [lindex $arcnos($a) 0]
9795 set i [lsearch -exact $arcids($arc) $a]
9796 set j [lsearch -exact $arcids($arc) $b]
9797 if {$i < 0 || $i > $j} {
9798 return 1
9799 } else {
9800 return -1
9804 if {![info exists arcout($a)]} {
9805 set arc [lindex $arcnos($a) 0]
9806 if {[info exists arcend($arc)]} {
9807 set aend $arcend($arc)
9808 } else {
9809 set aend {}
9811 set a $arcstart($arc)
9812 } else {
9813 set aend $a
9815 if {![info exists arcout($b)]} {
9816 set arc [lindex $arcnos($b) 0]
9817 if {[info exists arcend($arc)]} {
9818 set bend $arcend($arc)
9819 } else {
9820 set bend {}
9822 set b $arcstart($arc)
9823 } else {
9824 set bend $b
9826 if {$a eq $bend} {
9827 return 1
9829 if {$b eq $aend} {
9830 return -1
9832 if {[info exists cached_isanc($a,$bend)]} {
9833 if {$cached_isanc($a,$bend)} {
9834 return 1
9837 if {[info exists cached_isanc($b,$aend)]} {
9838 if {$cached_isanc($b,$aend)} {
9839 return -1
9841 if {[info exists cached_isanc($a,$bend)]} {
9842 return 0
9846 set todo [list $a $b]
9847 set anc($a) a
9848 set anc($b) b
9849 for {set i 0} {$i < [llength $todo]} {incr i} {
9850 set x [lindex $todo $i]
9851 if {$anc($x) eq {}} {
9852 continue
9854 foreach arc $arcnos($x) {
9855 set xd $arcstart($arc)
9856 if {$xd eq $bend} {
9857 set cached_isanc($a,$bend) 1
9858 set cached_isanc($b,$aend) 0
9859 return 1
9860 } elseif {$xd eq $aend} {
9861 set cached_isanc($b,$aend) 1
9862 set cached_isanc($a,$bend) 0
9863 return -1
9865 if {![info exists anc($xd)]} {
9866 set anc($xd) $anc($x)
9867 lappend todo $xd
9868 } elseif {$anc($xd) ne $anc($x)} {
9869 set anc($xd) {}
9873 set cached_isanc($a,$bend) 0
9874 set cached_isanc($b,$aend) 0
9875 return 0
9878 # This identifies whether $desc has an ancestor that is
9879 # a growing tip of the graph and which is not an ancestor of $anc
9880 # and returns 0 if so and 1 if not.
9881 # If we subsequently discover a tag on such a growing tip, and that
9882 # turns out to be a descendent of $anc (which it could, since we
9883 # don't necessarily see children before parents), then $desc
9884 # isn't a good choice to display as a descendent tag of
9885 # $anc (since it is the descendent of another tag which is
9886 # a descendent of $anc). Similarly, $anc isn't a good choice to
9887 # display as a ancestor tag of $desc.
9889 proc is_certain {desc anc} {
9890 global arcnos arcout arcstart arcend growing problems
9892 set certain {}
9893 if {[llength $arcnos($anc)] == 1} {
9894 # tags on the same arc are certain
9895 if {$arcnos($desc) eq $arcnos($anc)} {
9896 return 1
9898 if {![info exists arcout($anc)]} {
9899 # if $anc is partway along an arc, use the start of the arc instead
9900 set a [lindex $arcnos($anc) 0]
9901 set anc $arcstart($a)
9904 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9905 set x $desc
9906 } else {
9907 set a [lindex $arcnos($desc) 0]
9908 set x $arcend($a)
9910 if {$x == $anc} {
9911 return 1
9913 set anclist [list $x]
9914 set dl($x) 1
9915 set nnh 1
9916 set ngrowanc 0
9917 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9918 set x [lindex $anclist $i]
9919 if {$dl($x)} {
9920 incr nnh -1
9922 set done($x) 1
9923 foreach a $arcout($x) {
9924 if {[info exists growing($a)]} {
9925 if {![info exists growanc($x)] && $dl($x)} {
9926 set growanc($x) 1
9927 incr ngrowanc
9929 } else {
9930 set y $arcend($a)
9931 if {[info exists dl($y)]} {
9932 if {$dl($y)} {
9933 if {!$dl($x)} {
9934 set dl($y) 0
9935 if {![info exists done($y)]} {
9936 incr nnh -1
9938 if {[info exists growanc($x)]} {
9939 incr ngrowanc -1
9941 set xl [list $y]
9942 for {set k 0} {$k < [llength $xl]} {incr k} {
9943 set z [lindex $xl $k]
9944 foreach c $arcout($z) {
9945 if {[info exists arcend($c)]} {
9946 set v $arcend($c)
9947 if {[info exists dl($v)] && $dl($v)} {
9948 set dl($v) 0
9949 if {![info exists done($v)]} {
9950 incr nnh -1
9952 if {[info exists growanc($v)]} {
9953 incr ngrowanc -1
9955 lappend xl $v
9962 } elseif {$y eq $anc || !$dl($x)} {
9963 set dl($y) 0
9964 lappend anclist $y
9965 } else {
9966 set dl($y) 1
9967 lappend anclist $y
9968 incr nnh
9973 foreach x [array names growanc] {
9974 if {$dl($x)} {
9975 return 0
9977 return 0
9979 return 1
9982 proc validate_arctags {a} {
9983 global arctags idtags
9985 set i -1
9986 set na $arctags($a)
9987 foreach id $arctags($a) {
9988 incr i
9989 if {![info exists idtags($id)]} {
9990 set na [lreplace $na $i $i]
9991 incr i -1
9994 set arctags($a) $na
9997 proc validate_archeads {a} {
9998 global archeads idheads
10000 set i -1
10001 set na $archeads($a)
10002 foreach id $archeads($a) {
10003 incr i
10004 if {![info exists idheads($id)]} {
10005 set na [lreplace $na $i $i]
10006 incr i -1
10009 set archeads($a) $na
10012 # Return the list of IDs that have tags that are descendents of id,
10013 # ignoring IDs that are descendents of IDs already reported.
10014 proc desctags {id} {
10015 global arcnos arcstart arcids arctags idtags allparents
10016 global growing cached_dtags
10018 if {![info exists allparents($id)]} {
10019 return {}
10021 set t1 [clock clicks -milliseconds]
10022 set argid $id
10023 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10024 # part-way along an arc; check that arc first
10025 set a [lindex $arcnos($id) 0]
10026 if {$arctags($a) ne {}} {
10027 validate_arctags $a
10028 set i [lsearch -exact $arcids($a) $id]
10029 set tid {}
10030 foreach t $arctags($a) {
10031 set j [lsearch -exact $arcids($a) $t]
10032 if {$j >= $i} break
10033 set tid $t
10035 if {$tid ne {}} {
10036 return $tid
10039 set id $arcstart($a)
10040 if {[info exists idtags($id)]} {
10041 return $id
10044 if {[info exists cached_dtags($id)]} {
10045 return $cached_dtags($id)
10048 set origid $id
10049 set todo [list $id]
10050 set queued($id) 1
10051 set nc 1
10052 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10053 set id [lindex $todo $i]
10054 set done($id) 1
10055 set ta [info exists hastaggedancestor($id)]
10056 if {!$ta} {
10057 incr nc -1
10059 # ignore tags on starting node
10060 if {!$ta && $i > 0} {
10061 if {[info exists idtags($id)]} {
10062 set tagloc($id) $id
10063 set ta 1
10064 } elseif {[info exists cached_dtags($id)]} {
10065 set tagloc($id) $cached_dtags($id)
10066 set ta 1
10069 foreach a $arcnos($id) {
10070 set d $arcstart($a)
10071 if {!$ta && $arctags($a) ne {}} {
10072 validate_arctags $a
10073 if {$arctags($a) ne {}} {
10074 lappend tagloc($id) [lindex $arctags($a) end]
10077 if {$ta || $arctags($a) ne {}} {
10078 set tomark [list $d]
10079 for {set j 0} {$j < [llength $tomark]} {incr j} {
10080 set dd [lindex $tomark $j]
10081 if {![info exists hastaggedancestor($dd)]} {
10082 if {[info exists done($dd)]} {
10083 foreach b $arcnos($dd) {
10084 lappend tomark $arcstart($b)
10086 if {[info exists tagloc($dd)]} {
10087 unset tagloc($dd)
10089 } elseif {[info exists queued($dd)]} {
10090 incr nc -1
10092 set hastaggedancestor($dd) 1
10096 if {![info exists queued($d)]} {
10097 lappend todo $d
10098 set queued($d) 1
10099 if {![info exists hastaggedancestor($d)]} {
10100 incr nc
10105 set tags {}
10106 foreach id [array names tagloc] {
10107 if {![info exists hastaggedancestor($id)]} {
10108 foreach t $tagloc($id) {
10109 if {[lsearch -exact $tags $t] < 0} {
10110 lappend tags $t
10115 set t2 [clock clicks -milliseconds]
10116 set loopix $i
10118 # remove tags that are descendents of other tags
10119 for {set i 0} {$i < [llength $tags]} {incr i} {
10120 set a [lindex $tags $i]
10121 for {set j 0} {$j < $i} {incr j} {
10122 set b [lindex $tags $j]
10123 set r [anc_or_desc $a $b]
10124 if {$r == 1} {
10125 set tags [lreplace $tags $j $j]
10126 incr j -1
10127 incr i -1
10128 } elseif {$r == -1} {
10129 set tags [lreplace $tags $i $i]
10130 incr i -1
10131 break
10136 if {[array names growing] ne {}} {
10137 # graph isn't finished, need to check if any tag could get
10138 # eclipsed by another tag coming later. Simply ignore any
10139 # tags that could later get eclipsed.
10140 set ctags {}
10141 foreach t $tags {
10142 if {[is_certain $t $origid]} {
10143 lappend ctags $t
10146 if {$tags eq $ctags} {
10147 set cached_dtags($origid) $tags
10148 } else {
10149 set tags $ctags
10151 } else {
10152 set cached_dtags($origid) $tags
10154 set t3 [clock clicks -milliseconds]
10155 if {0 && $t3 - $t1 >= 100} {
10156 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10157 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10159 return $tags
10162 proc anctags {id} {
10163 global arcnos arcids arcout arcend arctags idtags allparents
10164 global growing cached_atags
10166 if {![info exists allparents($id)]} {
10167 return {}
10169 set t1 [clock clicks -milliseconds]
10170 set argid $id
10171 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10172 # part-way along an arc; check that arc first
10173 set a [lindex $arcnos($id) 0]
10174 if {$arctags($a) ne {}} {
10175 validate_arctags $a
10176 set i [lsearch -exact $arcids($a) $id]
10177 foreach t $arctags($a) {
10178 set j [lsearch -exact $arcids($a) $t]
10179 if {$j > $i} {
10180 return $t
10184 if {![info exists arcend($a)]} {
10185 return {}
10187 set id $arcend($a)
10188 if {[info exists idtags($id)]} {
10189 return $id
10192 if {[info exists cached_atags($id)]} {
10193 return $cached_atags($id)
10196 set origid $id
10197 set todo [list $id]
10198 set queued($id) 1
10199 set taglist {}
10200 set nc 1
10201 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10202 set id [lindex $todo $i]
10203 set done($id) 1
10204 set td [info exists hastaggeddescendent($id)]
10205 if {!$td} {
10206 incr nc -1
10208 # ignore tags on starting node
10209 if {!$td && $i > 0} {
10210 if {[info exists idtags($id)]} {
10211 set tagloc($id) $id
10212 set td 1
10213 } elseif {[info exists cached_atags($id)]} {
10214 set tagloc($id) $cached_atags($id)
10215 set td 1
10218 foreach a $arcout($id) {
10219 if {!$td && $arctags($a) ne {}} {
10220 validate_arctags $a
10221 if {$arctags($a) ne {}} {
10222 lappend tagloc($id) [lindex $arctags($a) 0]
10225 if {![info exists arcend($a)]} continue
10226 set d $arcend($a)
10227 if {$td || $arctags($a) ne {}} {
10228 set tomark [list $d]
10229 for {set j 0} {$j < [llength $tomark]} {incr j} {
10230 set dd [lindex $tomark $j]
10231 if {![info exists hastaggeddescendent($dd)]} {
10232 if {[info exists done($dd)]} {
10233 foreach b $arcout($dd) {
10234 if {[info exists arcend($b)]} {
10235 lappend tomark $arcend($b)
10238 if {[info exists tagloc($dd)]} {
10239 unset tagloc($dd)
10241 } elseif {[info exists queued($dd)]} {
10242 incr nc -1
10244 set hastaggeddescendent($dd) 1
10248 if {![info exists queued($d)]} {
10249 lappend todo $d
10250 set queued($d) 1
10251 if {![info exists hastaggeddescendent($d)]} {
10252 incr nc
10257 set t2 [clock clicks -milliseconds]
10258 set loopix $i
10259 set tags {}
10260 foreach id [array names tagloc] {
10261 if {![info exists hastaggeddescendent($id)]} {
10262 foreach t $tagloc($id) {
10263 if {[lsearch -exact $tags $t] < 0} {
10264 lappend tags $t
10270 # remove tags that are ancestors of other tags
10271 for {set i 0} {$i < [llength $tags]} {incr i} {
10272 set a [lindex $tags $i]
10273 for {set j 0} {$j < $i} {incr j} {
10274 set b [lindex $tags $j]
10275 set r [anc_or_desc $a $b]
10276 if {$r == -1} {
10277 set tags [lreplace $tags $j $j]
10278 incr j -1
10279 incr i -1
10280 } elseif {$r == 1} {
10281 set tags [lreplace $tags $i $i]
10282 incr i -1
10283 break
10288 if {[array names growing] ne {}} {
10289 # graph isn't finished, need to check if any tag could get
10290 # eclipsed by another tag coming later. Simply ignore any
10291 # tags that could later get eclipsed.
10292 set ctags {}
10293 foreach t $tags {
10294 if {[is_certain $origid $t]} {
10295 lappend ctags $t
10298 if {$tags eq $ctags} {
10299 set cached_atags($origid) $tags
10300 } else {
10301 set tags $ctags
10303 } else {
10304 set cached_atags($origid) $tags
10306 set t3 [clock clicks -milliseconds]
10307 if {0 && $t3 - $t1 >= 100} {
10308 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10309 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10311 return $tags
10314 # Return the list of IDs that have heads that are descendents of id,
10315 # including id itself if it has a head.
10316 proc descheads {id} {
10317 global arcnos arcstart arcids archeads idheads cached_dheads
10318 global allparents
10320 if {![info exists allparents($id)]} {
10321 return {}
10323 set aret {}
10324 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10325 # part-way along an arc; check it first
10326 set a [lindex $arcnos($id) 0]
10327 if {$archeads($a) ne {}} {
10328 validate_archeads $a
10329 set i [lsearch -exact $arcids($a) $id]
10330 foreach t $archeads($a) {
10331 set j [lsearch -exact $arcids($a) $t]
10332 if {$j > $i} break
10333 lappend aret $t
10336 set id $arcstart($a)
10338 set origid $id
10339 set todo [list $id]
10340 set seen($id) 1
10341 set ret {}
10342 for {set i 0} {$i < [llength $todo]} {incr i} {
10343 set id [lindex $todo $i]
10344 if {[info exists cached_dheads($id)]} {
10345 set ret [concat $ret $cached_dheads($id)]
10346 } else {
10347 if {[info exists idheads($id)]} {
10348 lappend ret $id
10350 foreach a $arcnos($id) {
10351 if {$archeads($a) ne {}} {
10352 validate_archeads $a
10353 if {$archeads($a) ne {}} {
10354 set ret [concat $ret $archeads($a)]
10357 set d $arcstart($a)
10358 if {![info exists seen($d)]} {
10359 lappend todo $d
10360 set seen($d) 1
10365 set ret [lsort -unique $ret]
10366 set cached_dheads($origid) $ret
10367 return [concat $ret $aret]
10370 proc addedtag {id} {
10371 global arcnos arcout cached_dtags cached_atags
10373 if {![info exists arcnos($id)]} return
10374 if {![info exists arcout($id)]} {
10375 recalcarc [lindex $arcnos($id) 0]
10377 catch {unset cached_dtags}
10378 catch {unset cached_atags}
10381 proc addedhead {hid head} {
10382 global arcnos arcout cached_dheads
10384 if {![info exists arcnos($hid)]} return
10385 if {![info exists arcout($hid)]} {
10386 recalcarc [lindex $arcnos($hid) 0]
10388 catch {unset cached_dheads}
10391 proc removedhead {hid head} {
10392 global cached_dheads
10394 catch {unset cached_dheads}
10397 proc movedhead {hid head} {
10398 global arcnos arcout cached_dheads
10400 if {![info exists arcnos($hid)]} return
10401 if {![info exists arcout($hid)]} {
10402 recalcarc [lindex $arcnos($hid) 0]
10404 catch {unset cached_dheads}
10407 proc changedrefs {} {
10408 global cached_dheads cached_dtags cached_atags
10409 global arctags archeads arcnos arcout idheads idtags
10411 foreach id [concat [array names idheads] [array names idtags]] {
10412 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10413 set a [lindex $arcnos($id) 0]
10414 if {![info exists donearc($a)]} {
10415 recalcarc $a
10416 set donearc($a) 1
10420 catch {unset cached_dtags}
10421 catch {unset cached_atags}
10422 catch {unset cached_dheads}
10425 proc rereadrefs {} {
10426 global idtags idheads idotherrefs mainheadid
10428 set refids [concat [array names idtags] \
10429 [array names idheads] [array names idotherrefs]]
10430 foreach id $refids {
10431 if {![info exists ref($id)]} {
10432 set ref($id) [listrefs $id]
10435 set oldmainhead $mainheadid
10436 readrefs
10437 changedrefs
10438 set refids [lsort -unique [concat $refids [array names idtags] \
10439 [array names idheads] [array names idotherrefs]]]
10440 foreach id $refids {
10441 set v [listrefs $id]
10442 if {![info exists ref($id)] || $ref($id) != $v} {
10443 redrawtags $id
10446 if {$oldmainhead ne $mainheadid} {
10447 redrawtags $oldmainhead
10448 redrawtags $mainheadid
10450 run refill_reflist
10453 proc listrefs {id} {
10454 global idtags idheads idotherrefs
10456 set x {}
10457 if {[info exists idtags($id)]} {
10458 set x $idtags($id)
10460 set y {}
10461 if {[info exists idheads($id)]} {
10462 set y $idheads($id)
10464 set z {}
10465 if {[info exists idotherrefs($id)]} {
10466 set z $idotherrefs($id)
10468 return [list $x $y $z]
10471 proc showtag {tag isnew} {
10472 global ctext tagcontents tagids linknum tagobjid
10474 if {$isnew} {
10475 addtohistory [list showtag $tag 0] savectextpos
10477 $ctext conf -state normal
10478 clear_ctext
10479 settabs 0
10480 set linknum 0
10481 if {![info exists tagcontents($tag)]} {
10482 catch {
10483 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
10486 if {[info exists tagcontents($tag)]} {
10487 set text $tagcontents($tag)
10488 } else {
10489 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10491 appendwithlinks $text {}
10492 maybe_scroll_ctext 1
10493 $ctext conf -state disabled
10494 init_flist {}
10497 proc doquit {} {
10498 global stopped
10499 global gitktmpdir
10501 set stopped 100
10502 savestuff .
10503 destroy .
10505 if {[info exists gitktmpdir]} {
10506 catch {file delete -force $gitktmpdir}
10510 proc mkfontdisp {font top which} {
10511 global fontattr fontpref $font NS use_ttk
10513 set fontpref($font) [set $font]
10514 ${NS}::button $top.${font}but -text $which \
10515 -command [list choosefont $font $which]
10516 if {!$use_ttk} {$top.${font}but configure -font optionfont}
10517 ${NS}::label $top.$font -relief flat -font $font \
10518 -text $fontattr($font,family) -justify left
10519 grid x $top.${font}but $top.$font -sticky w
10522 proc choosefont {font which} {
10523 global fontparam fontlist fonttop fontattr
10524 global prefstop NS
10526 set fontparam(which) $which
10527 set fontparam(font) $font
10528 set fontparam(family) [font actual $font -family]
10529 set fontparam(size) $fontattr($font,size)
10530 set fontparam(weight) $fontattr($font,weight)
10531 set fontparam(slant) $fontattr($font,slant)
10532 set top .gitkfont
10533 set fonttop $top
10534 if {![winfo exists $top]} {
10535 font create sample
10536 eval font config sample [font actual $font]
10537 ttk_toplevel $top
10538 make_transient $top $prefstop
10539 wm title $top [mc "Gitk font chooser"]
10540 ${NS}::label $top.l -textvariable fontparam(which)
10541 pack $top.l -side top
10542 set fontlist [lsort [font families]]
10543 ${NS}::frame $top.f
10544 listbox $top.f.fam -listvariable fontlist \
10545 -yscrollcommand [list $top.f.sb set]
10546 bind $top.f.fam <<ListboxSelect>> selfontfam
10547 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10548 pack $top.f.sb -side right -fill y
10549 pack $top.f.fam -side left -fill both -expand 1
10550 pack $top.f -side top -fill both -expand 1
10551 ${NS}::frame $top.g
10552 spinbox $top.g.size -from 4 -to 40 -width 4 \
10553 -textvariable fontparam(size) \
10554 -validatecommand {string is integer -strict %s}
10555 checkbutton $top.g.bold -padx 5 \
10556 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10557 -variable fontparam(weight) -onvalue bold -offvalue normal
10558 checkbutton $top.g.ital -padx 5 \
10559 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10560 -variable fontparam(slant) -onvalue italic -offvalue roman
10561 pack $top.g.size $top.g.bold $top.g.ital -side left
10562 pack $top.g -side top
10563 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10564 -background white
10565 $top.c create text 100 25 -anchor center -text $which -font sample \
10566 -fill black -tags text
10567 bind $top.c <Configure> [list centertext $top.c]
10568 pack $top.c -side top -fill x
10569 ${NS}::frame $top.buts
10570 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10571 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10572 bind $top <Key-Return> fontok
10573 bind $top <Key-Escape> fontcan
10574 grid $top.buts.ok $top.buts.can
10575 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10576 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10577 pack $top.buts -side bottom -fill x
10578 trace add variable fontparam write chg_fontparam
10579 } else {
10580 raise $top
10581 $top.c itemconf text -text $which
10583 set i [lsearch -exact $fontlist $fontparam(family)]
10584 if {$i >= 0} {
10585 $top.f.fam selection set $i
10586 $top.f.fam see $i
10590 proc centertext {w} {
10591 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10594 proc fontok {} {
10595 global fontparam fontpref prefstop
10597 set f $fontparam(font)
10598 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10599 if {$fontparam(weight) eq "bold"} {
10600 lappend fontpref($f) "bold"
10602 if {$fontparam(slant) eq "italic"} {
10603 lappend fontpref($f) "italic"
10605 set w $prefstop.$f
10606 $w conf -text $fontparam(family) -font $fontpref($f)
10608 fontcan
10611 proc fontcan {} {
10612 global fonttop fontparam
10614 if {[info exists fonttop]} {
10615 catch {destroy $fonttop}
10616 catch {font delete sample}
10617 unset fonttop
10618 unset fontparam
10622 if {[package vsatisfies [package provide Tk] 8.6]} {
10623 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10624 # function to make use of it.
10625 proc choosefont {font which} {
10626 tk fontchooser configure -title $which -font $font \
10627 -command [list on_choosefont $font $which]
10628 tk fontchooser show
10630 proc on_choosefont {font which newfont} {
10631 global fontparam
10632 puts stderr "$font $newfont"
10633 array set f [font actual $newfont]
10634 set fontparam(which) $which
10635 set fontparam(font) $font
10636 set fontparam(family) $f(-family)
10637 set fontparam(size) $f(-size)
10638 set fontparam(weight) $f(-weight)
10639 set fontparam(slant) $f(-slant)
10640 fontok
10644 proc selfontfam {} {
10645 global fonttop fontparam
10647 set i [$fonttop.f.fam curselection]
10648 if {$i ne {}} {
10649 set fontparam(family) [$fonttop.f.fam get $i]
10653 proc chg_fontparam {v sub op} {
10654 global fontparam
10656 font config sample -$sub $fontparam($sub)
10659 proc doprefs {} {
10660 global maxwidth maxgraphpct use_ttk NS
10661 global oldprefs prefstop showneartags showlocalchanges
10662 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10663 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10664 global hideremotes want_ttk have_ttk
10666 set top .gitkprefs
10667 set prefstop $top
10668 if {[winfo exists $top]} {
10669 raise $top
10670 return
10672 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10673 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10674 set oldprefs($v) [set $v]
10676 ttk_toplevel $top
10677 wm title $top [mc "Gitk preferences"]
10678 make_transient $top .
10679 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10680 grid $top.ldisp - -sticky w -pady 10
10681 ${NS}::label $top.spacer -text " "
10682 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10683 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10684 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10685 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10686 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10687 grid x $top.maxpctl $top.maxpct -sticky w
10688 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10689 -variable showlocalchanges
10690 grid x $top.showlocal -sticky w
10691 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10692 -variable autoselect
10693 grid x $top.autoselect -sticky w
10694 ${NS}::checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10695 -variable hideremotes
10696 grid x $top.hideremotes -sticky w
10698 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10699 grid $top.ddisp - -sticky w -pady 10
10700 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10701 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10702 grid x $top.tabstopl $top.tabstop -sticky w
10703 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10704 -variable showneartags
10705 grid x $top.ntag -sticky w
10706 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10707 -variable limitdiffs
10708 grid x $top.ldiff -sticky w
10709 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10710 -variable perfile_attrs
10711 grid x $top.lattr -sticky w
10713 ${NS}::entry $top.extdifft -textvariable extdifftool
10714 ${NS}::frame $top.extdifff
10715 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10716 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10717 pack $top.extdifff.l $top.extdifff.b -side left
10718 pack configure $top.extdifff.l -padx 10
10719 grid x $top.extdifff $top.extdifft -sticky ew
10721 ${NS}::label $top.lgen -text [mc "General options"]
10722 grid $top.lgen - -sticky w -pady 10
10723 ${NS}::checkbutton $top.want_ttk -variable want_ttk \
10724 -text [mc "Use themed widgets"]
10725 if {$have_ttk} {
10726 ${NS}::label $top.ttk_note -text [mc "(change requires restart)"]
10727 } else {
10728 ${NS}::label $top.ttk_note -text [mc "(currently unavailable)"]
10730 grid x $top.want_ttk $top.ttk_note -sticky w
10732 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10733 grid $top.cdisp - -sticky w -pady 10
10734 label $top.ui -padx 40 -relief sunk -background $uicolor
10735 ${NS}::button $top.uibut -text [mc "Interface"] \
10736 -command [list choosecolor uicolor {} $top.ui [mc "interface"] setui]
10737 grid x $top.uibut $top.ui -sticky w
10738 label $top.bg -padx 40 -relief sunk -background $bgcolor
10739 ${NS}::button $top.bgbut -text [mc "Background"] \
10740 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10741 grid x $top.bgbut $top.bg -sticky w
10742 label $top.fg -padx 40 -relief sunk -background $fgcolor
10743 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10744 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10745 grid x $top.fgbut $top.fg -sticky w
10746 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10747 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10748 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10749 [list $ctext tag conf d0 -foreground]]
10750 grid x $top.diffoldbut $top.diffold -sticky w
10751 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10752 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10753 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10754 [list $ctext tag conf dresult -foreground]]
10755 grid x $top.diffnewbut $top.diffnew -sticky w
10756 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10757 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10758 -command [list choosecolor diffcolors 2 $top.hunksep \
10759 [mc "diff hunk header"] \
10760 [list $ctext tag conf hunksep -foreground]]
10761 grid x $top.hunksepbut $top.hunksep -sticky w
10762 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10763 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10764 -command [list choosecolor markbgcolor {} $top.markbgsep \
10765 [mc "marked line background"] \
10766 [list $ctext tag conf omark -background]]
10767 grid x $top.markbgbut $top.markbgsep -sticky w
10768 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10769 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10770 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10771 grid x $top.selbgbut $top.selbgsep -sticky w
10773 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10774 grid $top.cfont - -sticky w -pady 10
10775 mkfontdisp mainfont $top [mc "Main font"]
10776 mkfontdisp textfont $top [mc "Diff display font"]
10777 mkfontdisp uifont $top [mc "User interface font"]
10779 if {!$use_ttk} {
10780 foreach w {maxpctl maxwidthl showlocal autoselect tabstopl ntag
10781 ldiff lattr extdifff.l extdifff.b bgbut fgbut
10782 diffoldbut diffnewbut hunksepbut markbgbut selbgbut
10783 want_ttk ttk_note} {
10784 $top.$w configure -font optionfont
10788 ${NS}::frame $top.buts
10789 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10790 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10791 bind $top <Key-Return> prefsok
10792 bind $top <Key-Escape> prefscan
10793 grid $top.buts.ok $top.buts.can
10794 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10795 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10796 grid $top.buts - - -pady 10 -sticky ew
10797 grid columnconfigure $top 2 -weight 1
10798 bind $top <Visibility> "focus $top.buts.ok"
10801 proc choose_extdiff {} {
10802 global extdifftool
10804 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10805 if {$prog ne {}} {
10806 set extdifftool $prog
10810 proc choosecolor {v vi w x cmd} {
10811 global $v
10813 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10814 -title [mc "Gitk: choose color for %s" $x]]
10815 if {$c eq {}} return
10816 $w conf -background $c
10817 lset $v $vi $c
10818 eval $cmd $c
10821 proc setselbg {c} {
10822 global bglist cflist
10823 foreach w $bglist {
10824 $w configure -selectbackground $c
10826 $cflist tag configure highlight \
10827 -background [$cflist cget -selectbackground]
10828 allcanvs itemconf secsel -fill $c
10831 # This sets the background color and the color scheme for the whole UI.
10832 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
10833 # if we don't specify one ourselves, which makes the checkbuttons and
10834 # radiobuttons look bad. This chooses white for selectColor if the
10835 # background color is light, or black if it is dark.
10836 proc setui {c} {
10837 set bg [winfo rgb . $c]
10838 set selc black
10839 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
10840 set selc white
10842 tk_setPalette background $c selectColor $selc
10845 proc setbg {c} {
10846 global bglist
10848 foreach w $bglist {
10849 $w conf -background $c
10853 proc setfg {c} {
10854 global fglist canv
10856 foreach w $fglist {
10857 $w conf -foreground $c
10859 allcanvs itemconf text -fill $c
10860 $canv itemconf circle -outline $c
10861 $canv itemconf markid -outline $c
10864 proc prefscan {} {
10865 global oldprefs prefstop
10867 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10868 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10869 global $v
10870 set $v $oldprefs($v)
10872 catch {destroy $prefstop}
10873 unset prefstop
10874 fontcan
10877 proc prefsok {} {
10878 global maxwidth maxgraphpct
10879 global oldprefs prefstop showneartags showlocalchanges
10880 global fontpref mainfont textfont uifont
10881 global limitdiffs treediffs perfile_attrs
10882 global hideremotes
10884 catch {destroy $prefstop}
10885 unset prefstop
10886 fontcan
10887 set fontchanged 0
10888 if {$mainfont ne $fontpref(mainfont)} {
10889 set mainfont $fontpref(mainfont)
10890 parsefont mainfont $mainfont
10891 eval font configure mainfont [fontflags mainfont]
10892 eval font configure mainfontbold [fontflags mainfont 1]
10893 setcoords
10894 set fontchanged 1
10896 if {$textfont ne $fontpref(textfont)} {
10897 set textfont $fontpref(textfont)
10898 parsefont textfont $textfont
10899 eval font configure textfont [fontflags textfont]
10900 eval font configure textfontbold [fontflags textfont 1]
10902 if {$uifont ne $fontpref(uifont)} {
10903 set uifont $fontpref(uifont)
10904 parsefont uifont $uifont
10905 eval font configure uifont [fontflags uifont]
10907 settabs
10908 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10909 if {$showlocalchanges} {
10910 doshowlocalchanges
10911 } else {
10912 dohidelocalchanges
10915 if {$limitdiffs != $oldprefs(limitdiffs) ||
10916 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10917 # treediffs elements are limited by path;
10918 # won't have encodings cached if perfile_attrs was just turned on
10919 catch {unset treediffs}
10921 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10922 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10923 redisplay
10924 } elseif {$showneartags != $oldprefs(showneartags) ||
10925 $limitdiffs != $oldprefs(limitdiffs)} {
10926 reselectline
10928 if {$hideremotes != $oldprefs(hideremotes)} {
10929 rereadrefs
10933 proc formatdate {d} {
10934 global datetimeformat
10935 if {$d ne {}} {
10936 set d [clock format $d -format $datetimeformat]
10938 return $d
10941 # This list of encoding names and aliases is distilled from
10942 # http://www.iana.org/assignments/character-sets.
10943 # Not all of them are supported by Tcl.
10944 set encoding_aliases {
10945 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10946 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10947 { ISO-10646-UTF-1 csISO10646UTF1 }
10948 { ISO_646.basic:1983 ref csISO646basic1983 }
10949 { INVARIANT csINVARIANT }
10950 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10951 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10952 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10953 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10954 { NATS-DANO iso-ir-9-1 csNATSDANO }
10955 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10956 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10957 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10958 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10959 { ISO-2022-KR csISO2022KR }
10960 { EUC-KR csEUCKR }
10961 { ISO-2022-JP csISO2022JP }
10962 { ISO-2022-JP-2 csISO2022JP2 }
10963 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10964 csISO13JISC6220jp }
10965 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10966 { IT iso-ir-15 ISO646-IT csISO15Italian }
10967 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10968 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10969 { greek7-old iso-ir-18 csISO18Greek7Old }
10970 { latin-greek iso-ir-19 csISO19LatinGreek }
10971 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10972 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10973 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10974 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10975 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10976 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10977 { INIS iso-ir-49 csISO49INIS }
10978 { INIS-8 iso-ir-50 csISO50INIS8 }
10979 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10980 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10981 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10982 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10983 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10984 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10985 csISO60Norwegian1 }
10986 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10987 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10988 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10989 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10990 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10991 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10992 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10993 { greek7 iso-ir-88 csISO88Greek7 }
10994 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10995 { iso-ir-90 csISO90 }
10996 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10997 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10998 csISO92JISC62991984b }
10999 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11000 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11001 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11002 csISO95JIS62291984handadd }
11003 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11004 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11005 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11006 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11007 CP819 csISOLatin1 }
11008 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11009 { T.61-7bit iso-ir-102 csISO102T617bit }
11010 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11011 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11012 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11013 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11014 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11015 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11016 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11017 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11018 arabic csISOLatinArabic }
11019 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11020 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11021 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11022 greek greek8 csISOLatinGreek }
11023 { T.101-G2 iso-ir-128 csISO128T101G2 }
11024 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11025 csISOLatinHebrew }
11026 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11027 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11028 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11029 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11030 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11031 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11032 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11033 csISOLatinCyrillic }
11034 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11035 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11036 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11037 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11038 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11039 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11040 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11041 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11042 { ISO_10367-box iso-ir-155 csISO10367Box }
11043 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11044 { latin-lap lap iso-ir-158 csISO158Lap }
11045 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11046 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11047 { us-dk csUSDK }
11048 { dk-us csDKUS }
11049 { JIS_X0201 X0201 csHalfWidthKatakana }
11050 { KSC5636 ISO646-KR csKSC5636 }
11051 { ISO-10646-UCS-2 csUnicode }
11052 { ISO-10646-UCS-4 csUCS4 }
11053 { DEC-MCS dec csDECMCS }
11054 { hp-roman8 roman8 r8 csHPRoman8 }
11055 { macintosh mac csMacintosh }
11056 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11057 csIBM037 }
11058 { IBM038 EBCDIC-INT cp038 csIBM038 }
11059 { IBM273 CP273 csIBM273 }
11060 { IBM274 EBCDIC-BE CP274 csIBM274 }
11061 { IBM275 EBCDIC-BR cp275 csIBM275 }
11062 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11063 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11064 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11065 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11066 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11067 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11068 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11069 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11070 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11071 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11072 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11073 { IBM437 cp437 437 csPC8CodePage437 }
11074 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11075 { IBM775 cp775 csPC775Baltic }
11076 { IBM850 cp850 850 csPC850Multilingual }
11077 { IBM851 cp851 851 csIBM851 }
11078 { IBM852 cp852 852 csPCp852 }
11079 { IBM855 cp855 855 csIBM855 }
11080 { IBM857 cp857 857 csIBM857 }
11081 { IBM860 cp860 860 csIBM860 }
11082 { IBM861 cp861 861 cp-is csIBM861 }
11083 { IBM862 cp862 862 csPC862LatinHebrew }
11084 { IBM863 cp863 863 csIBM863 }
11085 { IBM864 cp864 csIBM864 }
11086 { IBM865 cp865 865 csIBM865 }
11087 { IBM866 cp866 866 csIBM866 }
11088 { IBM868 CP868 cp-ar csIBM868 }
11089 { IBM869 cp869 869 cp-gr csIBM869 }
11090 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11091 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11092 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11093 { IBM891 cp891 csIBM891 }
11094 { IBM903 cp903 csIBM903 }
11095 { IBM904 cp904 904 csIBBM904 }
11096 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11097 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11098 { IBM1026 CP1026 csIBM1026 }
11099 { EBCDIC-AT-DE csIBMEBCDICATDE }
11100 { EBCDIC-AT-DE-A csEBCDICATDEA }
11101 { EBCDIC-CA-FR csEBCDICCAFR }
11102 { EBCDIC-DK-NO csEBCDICDKNO }
11103 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11104 { EBCDIC-FI-SE csEBCDICFISE }
11105 { EBCDIC-FI-SE-A csEBCDICFISEA }
11106 { EBCDIC-FR csEBCDICFR }
11107 { EBCDIC-IT csEBCDICIT }
11108 { EBCDIC-PT csEBCDICPT }
11109 { EBCDIC-ES csEBCDICES }
11110 { EBCDIC-ES-A csEBCDICESA }
11111 { EBCDIC-ES-S csEBCDICESS }
11112 { EBCDIC-UK csEBCDICUK }
11113 { EBCDIC-US csEBCDICUS }
11114 { UNKNOWN-8BIT csUnknown8BiT }
11115 { MNEMONIC csMnemonic }
11116 { MNEM csMnem }
11117 { VISCII csVISCII }
11118 { VIQR csVIQR }
11119 { KOI8-R csKOI8R }
11120 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11121 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11122 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11123 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11124 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11125 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11126 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11127 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11128 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11129 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11130 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11131 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11132 { IBM1047 IBM-1047 }
11133 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11134 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11135 { UNICODE-1-1 csUnicode11 }
11136 { CESU-8 csCESU-8 }
11137 { BOCU-1 csBOCU-1 }
11138 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11139 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11140 l8 }
11141 { ISO-8859-15 ISO_8859-15 Latin-9 }
11142 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11143 { GBK CP936 MS936 windows-936 }
11144 { JIS_Encoding csJISEncoding }
11145 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11146 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11147 EUC-JP }
11148 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11149 { ISO-10646-UCS-Basic csUnicodeASCII }
11150 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11151 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11152 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11153 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11154 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11155 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11156 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11157 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11158 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11159 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11160 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11161 { Ventura-US csVenturaUS }
11162 { Ventura-International csVenturaInternational }
11163 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11164 { PC8-Turkish csPC8Turkish }
11165 { IBM-Symbols csIBMSymbols }
11166 { IBM-Thai csIBMThai }
11167 { HP-Legal csHPLegal }
11168 { HP-Pi-font csHPPiFont }
11169 { HP-Math8 csHPMath8 }
11170 { Adobe-Symbol-Encoding csHPPSMath }
11171 { HP-DeskTop csHPDesktop }
11172 { Ventura-Math csVenturaMath }
11173 { Microsoft-Publishing csMicrosoftPublishing }
11174 { Windows-31J csWindows31J }
11175 { GB2312 csGB2312 }
11176 { Big5 csBig5 }
11179 proc tcl_encoding {enc} {
11180 global encoding_aliases tcl_encoding_cache
11181 if {[info exists tcl_encoding_cache($enc)]} {
11182 return $tcl_encoding_cache($enc)
11184 set names [encoding names]
11185 set lcnames [string tolower $names]
11186 set enc [string tolower $enc]
11187 set i [lsearch -exact $lcnames $enc]
11188 if {$i < 0} {
11189 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11190 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11191 set i [lsearch -exact $lcnames $encx]
11194 if {$i < 0} {
11195 foreach l $encoding_aliases {
11196 set ll [string tolower $l]
11197 if {[lsearch -exact $ll $enc] < 0} continue
11198 # look through the aliases for one that tcl knows about
11199 foreach e $ll {
11200 set i [lsearch -exact $lcnames $e]
11201 if {$i < 0} {
11202 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11203 set i [lsearch -exact $lcnames $ex]
11206 if {$i >= 0} break
11208 break
11211 set tclenc {}
11212 if {$i >= 0} {
11213 set tclenc [lindex $names $i]
11215 set tcl_encoding_cache($enc) $tclenc
11216 return $tclenc
11219 proc gitattr {path attr default} {
11220 global path_attr_cache
11221 if {[info exists path_attr_cache($attr,$path)]} {
11222 set r $path_attr_cache($attr,$path)
11223 } else {
11224 set r "unspecified"
11225 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11226 regexp "(.*): $attr: (.*)" $line m f r
11228 set path_attr_cache($attr,$path) $r
11230 if {$r eq "unspecified"} {
11231 return $default
11233 return $r
11236 proc cache_gitattr {attr pathlist} {
11237 global path_attr_cache
11238 set newlist {}
11239 foreach path $pathlist {
11240 if {![info exists path_attr_cache($attr,$path)]} {
11241 lappend newlist $path
11244 set lim 1000
11245 if {[tk windowingsystem] == "win32"} {
11246 # windows has a 32k limit on the arguments to a command...
11247 set lim 30
11249 while {$newlist ne {}} {
11250 set head [lrange $newlist 0 [expr {$lim - 1}]]
11251 set newlist [lrange $newlist $lim end]
11252 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11253 foreach row [split $rlist "\n"] {
11254 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11255 if {[string index $path 0] eq "\""} {
11256 set path [encoding convertfrom [lindex $path 0]]
11258 set path_attr_cache($attr,$path) $value
11265 proc get_path_encoding {path} {
11266 global gui_encoding perfile_attrs
11267 set tcl_enc $gui_encoding
11268 if {$path ne {} && $perfile_attrs} {
11269 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11270 if {$enc2 ne {}} {
11271 set tcl_enc $enc2
11274 return $tcl_enc
11277 # First check that Tcl/Tk is recent enough
11278 if {[catch {package require Tk 8.4} err]} {
11279 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11280 Gitk requires at least Tcl/Tk 8.4." list
11281 exit 1
11284 # defaults...
11285 set wrcomcmd "git diff-tree --stdin -p --pretty"
11287 set gitencoding {}
11288 catch {
11289 set gitencoding [exec git config --get i18n.commitencoding]
11291 catch {
11292 set gitencoding [exec git config --get i18n.logoutputencoding]
11294 if {$gitencoding == ""} {
11295 set gitencoding "utf-8"
11297 set tclencoding [tcl_encoding $gitencoding]
11298 if {$tclencoding == {}} {
11299 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11302 set gui_encoding [encoding system]
11303 catch {
11304 set enc [exec git config --get gui.encoding]
11305 if {$enc ne {}} {
11306 set tclenc [tcl_encoding $enc]
11307 if {$tclenc ne {}} {
11308 set gui_encoding $tclenc
11309 } else {
11310 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11315 if {[tk windowingsystem] eq "aqua"} {
11316 set mainfont {{Lucida Grande} 9}
11317 set textfont {Monaco 9}
11318 set uifont {{Lucida Grande} 9 bold}
11319 } else {
11320 set mainfont {Helvetica 9}
11321 set textfont {Courier 9}
11322 set uifont {Helvetica 9 bold}
11324 set tabstop 8
11325 set findmergefiles 0
11326 set maxgraphpct 50
11327 set maxwidth 16
11328 set revlistorder 0
11329 set fastdate 0
11330 set uparrowlen 5
11331 set downarrowlen 5
11332 set mingaplen 100
11333 set cmitmode "patch"
11334 set wrapcomment "none"
11335 set showneartags 1
11336 set hideremotes 0
11337 set maxrefs 20
11338 set maxlinelen 200
11339 set showlocalchanges 1
11340 set limitdiffs 1
11341 set datetimeformat "%Y-%m-%d %H:%M:%S"
11342 set autoselect 1
11343 set perfile_attrs 0
11344 set want_ttk 1
11346 if {[tk windowingsystem] eq "aqua"} {
11347 set extdifftool "opendiff"
11348 } else {
11349 set extdifftool "meld"
11352 set colors {green red blue magenta darkgrey brown orange}
11353 if {[tk windowingsystem] eq "win32"} {
11354 set uicolor SystemButtonFace
11355 set bgcolor SystemWindow
11356 set fgcolor SystemButtonText
11357 set selectbgcolor SystemHighlight
11358 } else {
11359 set uicolor grey85
11360 set bgcolor white
11361 set fgcolor black
11362 set selectbgcolor gray85
11364 set diffcolors {red "#00a000" blue}
11365 set diffcontext 3
11366 set ignorespace 0
11367 set markbgcolor "#e0e0ff"
11369 set circlecolors {white blue gray blue blue}
11371 # button for popping up context menus
11372 if {[tk windowingsystem] eq "aqua"} {
11373 set ctxbut <Button-2>
11374 } else {
11375 set ctxbut <Button-3>
11378 ## For msgcat loading, first locate the installation location.
11379 if { [info exists ::env(GITK_MSGSDIR)] } {
11380 ## Msgsdir was manually set in the environment.
11381 set gitk_msgsdir $::env(GITK_MSGSDIR)
11382 } else {
11383 ## Let's guess the prefix from argv0.
11384 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11385 set gitk_libdir [file join $gitk_prefix share gitk lib]
11386 set gitk_msgsdir [file join $gitk_libdir msgs]
11387 unset gitk_prefix
11390 ## Internationalization (i18n) through msgcat and gettext. See
11391 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11392 package require msgcat
11393 namespace import ::msgcat::mc
11394 ## And eventually load the actual message catalog
11395 ::msgcat::mcload $gitk_msgsdir
11397 catch {source ~/.gitk}
11399 font create optionfont -family sans-serif -size -12
11401 parsefont mainfont $mainfont
11402 eval font create mainfont [fontflags mainfont]
11403 eval font create mainfontbold [fontflags mainfont 1]
11405 parsefont textfont $textfont
11406 eval font create textfont [fontflags textfont]
11407 eval font create textfontbold [fontflags textfont 1]
11409 parsefont uifont $uifont
11410 eval font create uifont [fontflags uifont]
11412 setui $uicolor
11414 setoptions
11416 # check that we can find a .git directory somewhere...
11417 if {[catch {set gitdir [gitdir]}]} {
11418 show_error {} . [mc "Cannot find a git repository here."]
11419 exit 1
11421 if {![file isdirectory $gitdir]} {
11422 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11423 exit 1
11426 set selecthead {}
11427 set selectheadid {}
11429 set revtreeargs {}
11430 set cmdline_files {}
11431 set i 0
11432 set revtreeargscmd {}
11433 foreach arg $argv {
11434 switch -glob -- $arg {
11435 "" { }
11436 "--" {
11437 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11438 break
11440 "--select-commit=*" {
11441 set selecthead [string range $arg 16 end]
11443 "--argscmd=*" {
11444 set revtreeargscmd [string range $arg 10 end]
11446 default {
11447 lappend revtreeargs $arg
11450 incr i
11453 if {$selecthead eq "HEAD"} {
11454 set selecthead {}
11457 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11458 # no -- on command line, but some arguments (other than --argscmd)
11459 if {[catch {
11460 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11461 set cmdline_files [split $f "\n"]
11462 set n [llength $cmdline_files]
11463 set revtreeargs [lrange $revtreeargs 0 end-$n]
11464 # Unfortunately git rev-parse doesn't produce an error when
11465 # something is both a revision and a filename. To be consistent
11466 # with git log and git rev-list, check revtreeargs for filenames.
11467 foreach arg $revtreeargs {
11468 if {[file exists $arg]} {
11469 show_error {} . [mc "Ambiguous argument '%s': both revision\
11470 and filename" $arg]
11471 exit 1
11474 } err]} {
11475 # unfortunately we get both stdout and stderr in $err,
11476 # so look for "fatal:".
11477 set i [string first "fatal:" $err]
11478 if {$i > 0} {
11479 set err [string range $err [expr {$i + 6}] end]
11481 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11482 exit 1
11486 set nullid "0000000000000000000000000000000000000000"
11487 set nullid2 "0000000000000000000000000000000000000001"
11488 set nullfile "/dev/null"
11490 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11491 if {![info exists have_ttk]} {
11492 set have_ttk [llength [info commands ::ttk::style]]
11494 set use_ttk [expr {$have_ttk && $want_ttk}]
11495 set NS [expr {$use_ttk ? "ttk" : ""}]
11497 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11499 set runq {}
11500 set history {}
11501 set historyindex 0
11502 set fh_serial 0
11503 set nhl_names {}
11504 set highlight_paths {}
11505 set findpattern {}
11506 set searchdirn -forwards
11507 set boldids {}
11508 set boldnameids {}
11509 set diffelide {0 0}
11510 set markingmatches 0
11511 set linkentercount 0
11512 set need_redisplay 0
11513 set nrows_drawn 0
11514 set firsttabstop 0
11516 set nextviewnum 1
11517 set curview 0
11518 set selectedview 0
11519 set selectedhlview [mc "None"]
11520 set highlight_related [mc "None"]
11521 set highlight_files {}
11522 set viewfiles(0) {}
11523 set viewperm(0) 0
11524 set viewargs(0) {}
11525 set viewargscmd(0) {}
11527 set selectedline {}
11528 set numcommits 0
11529 set loginstance 0
11530 set cmdlineok 0
11531 set stopped 0
11532 set stuffsaved 0
11533 set patchnum 0
11534 set lserial 0
11535 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11536 setcoords
11537 makewindow
11538 catch {
11539 image create photo gitlogo -width 16 -height 16
11541 image create photo gitlogominus -width 4 -height 2
11542 gitlogominus put #C00000 -to 0 0 4 2
11543 gitlogo copy gitlogominus -to 1 5
11544 gitlogo copy gitlogominus -to 6 5
11545 gitlogo copy gitlogominus -to 11 5
11546 image delete gitlogominus
11548 image create photo gitlogoplus -width 4 -height 4
11549 gitlogoplus put #008000 -to 1 0 3 4
11550 gitlogoplus put #008000 -to 0 1 4 3
11551 gitlogo copy gitlogoplus -to 1 9
11552 gitlogo copy gitlogoplus -to 6 9
11553 gitlogo copy gitlogoplus -to 11 9
11554 image delete gitlogoplus
11556 image create photo gitlogo32 -width 32 -height 32
11557 gitlogo32 copy gitlogo -zoom 2 2
11559 wm iconphoto . -default gitlogo gitlogo32
11561 # wait for the window to become visible
11562 tkwait visibility .
11563 wm title . "[file tail $argv0]: [file tail [pwd]]"
11564 update
11565 readrefs
11567 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11568 # create a view for the files/dirs specified on the command line
11569 set curview 1
11570 set selectedview 1
11571 set nextviewnum 2
11572 set viewname(1) [mc "Command line"]
11573 set viewfiles(1) $cmdline_files
11574 set viewargs(1) $revtreeargs
11575 set viewargscmd(1) $revtreeargscmd
11576 set viewperm(1) 0
11577 set vdatemode(1) 0
11578 addviewmenu 1
11579 .bar.view entryconf [mca "Edit view..."] -state normal
11580 .bar.view entryconf [mca "Delete view"] -state normal
11583 if {[info exists permviews]} {
11584 foreach v $permviews {
11585 set n $nextviewnum
11586 incr nextviewnum
11587 set viewname($n) [lindex $v 0]
11588 set viewfiles($n) [lindex $v 1]
11589 set viewargs($n) [lindex $v 2]
11590 set viewargscmd($n) [lindex $v 3]
11591 set viewperm($n) 1
11592 addviewmenu $n
11596 if {[tk windowingsystem] eq "win32"} {
11597 focus -force .
11600 getcommits {}