builtin-mailinfo.c: check error status from rewind and ftruncate
[git/spearce.git] / gitk-git / gitk
bloba0214b7004f141b7c918a5360d85f8f9e2db285c
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2008 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 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq currunq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {} && ![info exists currunq]} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq currunq
43 fileevent $fd readable {}
44 if {$runq eq {} && ![info exists currunq]} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq currunq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set currunq [lindex $runq 0]
71 set runq [lrange $runq 1 end]
72 set repeat [eval $script]
73 unset currunq
74 set t1 [clock clicks -milliseconds]
75 set t [expr {$t1 - $t0}]
76 if {$repeat ne {} && $repeat} {
77 if {$fd eq {} || $repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq [list $fd $script]
81 } else {
82 fileevent $fd readable [list filereadable $fd $script]
84 } elseif {$fd eq {}} {
85 unset isonrunq($script)
87 set t0 $t1
88 if {$t1 - $tstart >= 80} break
90 if {$runq ne {}} {
91 after idle dorunq
95 proc reg_instance {fd} {
96 global commfd leftover loginstance
98 set i [incr loginstance]
99 set commfd($i) $fd
100 set leftover($i) {}
101 return $i
104 proc unmerged_files {files} {
105 global nr_unmerged
107 # find the list of unmerged files
108 set mlist {}
109 set nr_unmerged 0
110 if {[catch {
111 set fd [open "| git ls-files -u" r]
112 } err]} {
113 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
114 exit 1
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
118 if {$i < 0} continue
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
121 incr nr_unmerged
122 if {$files eq {} || [path_filter $files $fname]} {
123 lappend mlist $fname
126 catch {close $fd}
127 return $mlist
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
133 set vdatemode($n) 0
134 set vmergeonly($n) 0
135 set glflags {}
136 set diffargs {}
137 set nextisval 0
138 set revargs {}
139 set origargs $arglist
140 set allknown 1
141 set filtered 0
142 set i -1
143 foreach arg $arglist {
144 incr i
145 if {$nextisval} {
146 lappend glflags $arg
147 set nextisval 0
148 continue
150 switch -glob -- $arg {
151 "-d" -
152 "--date-order" {
153 set vdatemode($n) 1
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
156 incr i -1
158 "-[puabwcrRBMC]" -
159 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163 "--ignore-space-change" - "-U*" - "--unified=*" {
164 # These request or affect diff output, which we don't want.
165 # Some could be used to set our defaults for diff display.
166 lappend diffargs $arg
168 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169 "--name-only" - "--name-status" - "--color" - "--color-words" -
170 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174 "--objects" - "--objects-edge" - "--reverse" {
175 # These cause our parsing of git log's output to fail, or else
176 # they're options we want to set ourselves, so ignore them.
178 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
179 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
180 "--full-history" - "--dense" - "--sparse" -
181 "--follow" - "--left-right" - "--encoding=*" {
182 # These are harmless, and some are even useful
183 lappend glflags $arg
185 "--diff-filter=*" - "--no-merges" - "--unpacked" -
186 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
187 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
188 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
189 "--remove-empty" - "--first-parent" - "--cherry-pick" -
190 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
191 "--simplify-by-decoration" {
192 # These mean that we get a subset of the commits
193 set filtered 1
194 lappend glflags $arg
196 "-n" {
197 # This appears to be the only one that has a value as a
198 # separate word following it
199 set filtered 1
200 set nextisval 1
201 lappend glflags $arg
203 "--not" - "--all" {
204 lappend revargs $arg
206 "--merge" {
207 set vmergeonly($n) 1
208 # git rev-parse doesn't understand --merge
209 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
211 "-*" {
212 # Other flag arguments including -<n>
213 if {[string is digit -strict [string range $arg 1 end]]} {
214 set filtered 1
215 } else {
216 # a flag argument that we don't recognize;
217 # that means we can't optimize
218 set allknown 0
220 lappend glflags $arg
222 default {
223 # Non-flag arguments specify commits or ranges of commits
224 if {[string match "*...*" $arg]} {
225 lappend revargs --gitk-symmetric-diff-marker
227 lappend revargs $arg
231 set vdflags($n) $diffargs
232 set vflags($n) $glflags
233 set vrevs($n) $revargs
234 set vfiltered($n) $filtered
235 set vorigargs($n) $origargs
236 return $allknown
239 proc parseviewrevs {view revs} {
240 global vposids vnegids
242 if {$revs eq {}} {
243 set revs HEAD
245 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
246 # we get stdout followed by stderr in $err
247 # for an unknown rev, git rev-parse echoes it and then errors out
248 set errlines [split $err "\n"]
249 set badrev {}
250 for {set l 0} {$l < [llength $errlines]} {incr l} {
251 set line [lindex $errlines $l]
252 if {!([string length $line] == 40 && [string is xdigit $line])} {
253 if {[string match "fatal:*" $line]} {
254 if {[string match "fatal: ambiguous argument*" $line]
255 && $badrev ne {}} {
256 if {[llength $badrev] == 1} {
257 set err "unknown revision $badrev"
258 } else {
259 set err "unknown revisions: [join $badrev ", "]"
261 } else {
262 set err [join [lrange $errlines $l end] "\n"]
264 break
266 lappend badrev $line
269 error_popup "[mc "Error parsing revisions:"] $err"
270 return {}
272 set ret {}
273 set pos {}
274 set neg {}
275 set sdm 0
276 foreach id [split $ids "\n"] {
277 if {$id eq "--gitk-symmetric-diff-marker"} {
278 set sdm 4
279 } elseif {[string match "^*" $id]} {
280 if {$sdm != 1} {
281 lappend ret $id
282 if {$sdm == 3} {
283 set sdm 0
286 lappend neg [string range $id 1 end]
287 } else {
288 if {$sdm != 2} {
289 lappend ret $id
290 } else {
291 lset ret end $id...[lindex $ret end]
293 lappend pos $id
295 incr sdm -1
297 set vposids($view) $pos
298 set vnegids($view) $neg
299 return $ret
302 # Start off a git log process and arrange to read its output
303 proc start_rev_list {view} {
304 global startmsecs commitidx viewcomplete curview
305 global tclencoding
306 global viewargs viewargscmd viewfiles vfilelimit
307 global showlocalchanges
308 global viewactive viewinstances vmergeonly
309 global mainheadid viewmainheadid viewmainheadid_orig
310 global vcanopt vflags vrevs vorigargs
312 set startmsecs [clock clicks -milliseconds]
313 set commitidx($view) 0
314 # these are set this way for the error exits
315 set viewcomplete($view) 1
316 set viewactive($view) 0
317 varcinit $view
319 set args $viewargs($view)
320 if {$viewargscmd($view) ne {}} {
321 if {[catch {
322 set str [exec sh -c $viewargscmd($view)]
323 } err]} {
324 error_popup "[mc "Error executing --argscmd command:"] $err"
325 return 0
327 set args [concat $args [split $str "\n"]]
329 set vcanopt($view) [parseviewargs $view $args]
331 set files $viewfiles($view)
332 if {$vmergeonly($view)} {
333 set files [unmerged_files $files]
334 if {$files eq {}} {
335 global nr_unmerged
336 if {$nr_unmerged == 0} {
337 error_popup [mc "No files selected: --merge specified but\
338 no files are unmerged."]
339 } else {
340 error_popup [mc "No files selected: --merge specified but\
341 no unmerged files are within file limit."]
343 return 0
346 set vfilelimit($view) $files
348 if {$vcanopt($view)} {
349 set revs [parseviewrevs $view $vrevs($view)]
350 if {$revs eq {}} {
351 return 0
353 set args [concat $vflags($view) $revs]
354 } else {
355 set args $vorigargs($view)
358 if {[catch {
359 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
360 --boundary $args "--" $files] r]
361 } err]} {
362 error_popup "[mc "Error executing git log:"] $err"
363 return 0
365 set i [reg_instance $fd]
366 set viewinstances($view) [list $i]
367 set viewmainheadid($view) $mainheadid
368 set viewmainheadid_orig($view) $mainheadid
369 if {$files ne {} && $mainheadid ne {}} {
370 get_viewmainhead $view
372 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
373 interestedin $viewmainheadid($view) dodiffindex
375 fconfigure $fd -blocking 0 -translation lf -eofchar {}
376 if {$tclencoding != {}} {
377 fconfigure $fd -encoding $tclencoding
379 filerun $fd [list getcommitlines $fd $i $view 0]
380 nowbusy $view [mc "Reading"]
381 set viewcomplete($view) 0
382 set viewactive($view) 1
383 return 1
386 proc stop_instance {inst} {
387 global commfd leftover
389 set fd $commfd($inst)
390 catch {
391 set pid [pid $fd]
393 if {$::tcl_platform(platform) eq {windows}} {
394 exec kill -f $pid
395 } else {
396 exec kill $pid
399 catch {close $fd}
400 nukefile $fd
401 unset commfd($inst)
402 unset leftover($inst)
405 proc stop_backends {} {
406 global commfd
408 foreach inst [array names commfd] {
409 stop_instance $inst
413 proc stop_rev_list {view} {
414 global viewinstances
416 foreach inst $viewinstances($view) {
417 stop_instance $inst
419 set viewinstances($view) {}
422 proc reset_pending_select {selid} {
423 global pending_select mainheadid selectheadid
425 if {$selid ne {}} {
426 set pending_select $selid
427 } elseif {$selectheadid ne {}} {
428 set pending_select $selectheadid
429 } else {
430 set pending_select $mainheadid
434 proc getcommits {selid} {
435 global canv curview need_redisplay viewactive
437 initlayout
438 if {[start_rev_list $curview]} {
439 reset_pending_select $selid
440 show_status [mc "Reading commits..."]
441 set need_redisplay 1
442 } else {
443 show_status [mc "No commits selected"]
447 proc updatecommits {} {
448 global curview vcanopt vorigargs vfilelimit viewinstances
449 global viewactive viewcomplete tclencoding
450 global startmsecs showneartags showlocalchanges
451 global mainheadid viewmainheadid viewmainheadid_orig pending_select
452 global isworktree
453 global varcid vposids vnegids vflags vrevs
455 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
456 rereadrefs
457 set view $curview
458 if {$mainheadid ne $viewmainheadid_orig($view)} {
459 if {$showlocalchanges} {
460 dohidelocalchanges
462 set viewmainheadid($view) $mainheadid
463 set viewmainheadid_orig($view) $mainheadid
464 if {$vfilelimit($view) ne {}} {
465 get_viewmainhead $view
468 if {$showlocalchanges} {
469 doshowlocalchanges
471 if {$vcanopt($view)} {
472 set oldpos $vposids($view)
473 set oldneg $vnegids($view)
474 set revs [parseviewrevs $view $vrevs($view)]
475 if {$revs eq {}} {
476 return
478 # note: getting the delta when negative refs change is hard,
479 # and could require multiple git log invocations, so in that
480 # case we ask git log for all the commits (not just the delta)
481 if {$oldneg eq $vnegids($view)} {
482 set newrevs {}
483 set npos 0
484 # take out positive refs that we asked for before or
485 # that we have already seen
486 foreach rev $revs {
487 if {[string length $rev] == 40} {
488 if {[lsearch -exact $oldpos $rev] < 0
489 && ![info exists varcid($view,$rev)]} {
490 lappend newrevs $rev
491 incr npos
493 } else {
494 lappend $newrevs $rev
497 if {$npos == 0} return
498 set revs $newrevs
499 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
501 set args [concat $vflags($view) $revs --not $oldpos]
502 } else {
503 set args $vorigargs($view)
505 if {[catch {
506 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
507 --boundary $args "--" $vfilelimit($view)] r]
508 } err]} {
509 error_popup "[mc "Error executing git log:"] $err"
510 return
512 if {$viewactive($view) == 0} {
513 set startmsecs [clock clicks -milliseconds]
515 set i [reg_instance $fd]
516 lappend viewinstances($view) $i
517 fconfigure $fd -blocking 0 -translation lf -eofchar {}
518 if {$tclencoding != {}} {
519 fconfigure $fd -encoding $tclencoding
521 filerun $fd [list getcommitlines $fd $i $view 1]
522 incr viewactive($view)
523 set viewcomplete($view) 0
524 reset_pending_select {}
525 nowbusy $view [mc "Reading"]
526 if {$showneartags} {
527 getallcommits
531 proc reloadcommits {} {
532 global curview viewcomplete selectedline currentid thickerline
533 global showneartags treediffs commitinterest cached_commitrow
534 global targetid
536 set selid {}
537 if {$selectedline ne {}} {
538 set selid $currentid
541 if {!$viewcomplete($curview)} {
542 stop_rev_list $curview
544 resetvarcs $curview
545 set selectedline {}
546 catch {unset currentid}
547 catch {unset thickerline}
548 catch {unset treediffs}
549 readrefs
550 changedrefs
551 if {$showneartags} {
552 getallcommits
554 clear_display
555 catch {unset commitinterest}
556 catch {unset cached_commitrow}
557 catch {unset targetid}
558 setcanvscroll
559 getcommits $selid
560 return 0
563 # This makes a string representation of a positive integer which
564 # sorts as a string in numerical order
565 proc strrep {n} {
566 if {$n < 16} {
567 return [format "%x" $n]
568 } elseif {$n < 256} {
569 return [format "x%.2x" $n]
570 } elseif {$n < 65536} {
571 return [format "y%.4x" $n]
573 return [format "z%.8x" $n]
576 # Procedures used in reordering commits from git log (without
577 # --topo-order) into the order for display.
579 proc varcinit {view} {
580 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
581 global vtokmod varcmod vrowmod varcix vlastins
583 set varcstart($view) {{}}
584 set vupptr($view) {0}
585 set vdownptr($view) {0}
586 set vleftptr($view) {0}
587 set vbackptr($view) {0}
588 set varctok($view) {{}}
589 set varcrow($view) {{}}
590 set vtokmod($view) {}
591 set varcmod($view) 0
592 set vrowmod($view) 0
593 set varcix($view) {{}}
594 set vlastins($view) {0}
597 proc resetvarcs {view} {
598 global varcid varccommits parents children vseedcount ordertok
600 foreach vid [array names varcid $view,*] {
601 unset varcid($vid)
602 unset children($vid)
603 unset parents($vid)
605 # some commits might have children but haven't been seen yet
606 foreach vid [array names children $view,*] {
607 unset children($vid)
609 foreach va [array names varccommits $view,*] {
610 unset varccommits($va)
612 foreach vd [array names vseedcount $view,*] {
613 unset vseedcount($vd)
615 catch {unset ordertok}
618 # returns a list of the commits with no children
619 proc seeds {v} {
620 global vdownptr vleftptr varcstart
622 set ret {}
623 set a [lindex $vdownptr($v) 0]
624 while {$a != 0} {
625 lappend ret [lindex $varcstart($v) $a]
626 set a [lindex $vleftptr($v) $a]
628 return $ret
631 proc newvarc {view id} {
632 global varcid varctok parents children vdatemode
633 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
634 global commitdata commitinfo vseedcount varccommits vlastins
636 set a [llength $varctok($view)]
637 set vid $view,$id
638 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
639 if {![info exists commitinfo($id)]} {
640 parsecommit $id $commitdata($id) 1
642 set cdate [lindex $commitinfo($id) 4]
643 if {![string is integer -strict $cdate]} {
644 set cdate 0
646 if {![info exists vseedcount($view,$cdate)]} {
647 set vseedcount($view,$cdate) -1
649 set c [incr vseedcount($view,$cdate)]
650 set cdate [expr {$cdate ^ 0xffffffff}]
651 set tok "s[strrep $cdate][strrep $c]"
652 } else {
653 set tok {}
655 set ka 0
656 if {[llength $children($vid)] > 0} {
657 set kid [lindex $children($vid) end]
658 set k $varcid($view,$kid)
659 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
660 set ki $kid
661 set ka $k
662 set tok [lindex $varctok($view) $k]
665 if {$ka != 0} {
666 set i [lsearch -exact $parents($view,$ki) $id]
667 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
668 append tok [strrep $j]
670 set c [lindex $vlastins($view) $ka]
671 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
672 set c $ka
673 set b [lindex $vdownptr($view) $ka]
674 } else {
675 set b [lindex $vleftptr($view) $c]
677 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
678 set c $b
679 set b [lindex $vleftptr($view) $c]
681 if {$c == $ka} {
682 lset vdownptr($view) $ka $a
683 lappend vbackptr($view) 0
684 } else {
685 lset vleftptr($view) $c $a
686 lappend vbackptr($view) $c
688 lset vlastins($view) $ka $a
689 lappend vupptr($view) $ka
690 lappend vleftptr($view) $b
691 if {$b != 0} {
692 lset vbackptr($view) $b $a
694 lappend varctok($view) $tok
695 lappend varcstart($view) $id
696 lappend vdownptr($view) 0
697 lappend varcrow($view) {}
698 lappend varcix($view) {}
699 set varccommits($view,$a) {}
700 lappend vlastins($view) 0
701 return $a
704 proc splitvarc {p v} {
705 global varcid varcstart varccommits varctok vtokmod
706 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
708 set oa $varcid($v,$p)
709 set otok [lindex $varctok($v) $oa]
710 set ac $varccommits($v,$oa)
711 set i [lsearch -exact $varccommits($v,$oa) $p]
712 if {$i <= 0} return
713 set na [llength $varctok($v)]
714 # "%" sorts before "0"...
715 set tok "$otok%[strrep $i]"
716 lappend varctok($v) $tok
717 lappend varcrow($v) {}
718 lappend varcix($v) {}
719 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
720 set varccommits($v,$na) [lrange $ac $i end]
721 lappend varcstart($v) $p
722 foreach id $varccommits($v,$na) {
723 set varcid($v,$id) $na
725 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
726 lappend vlastins($v) [lindex $vlastins($v) $oa]
727 lset vdownptr($v) $oa $na
728 lset vlastins($v) $oa 0
729 lappend vupptr($v) $oa
730 lappend vleftptr($v) 0
731 lappend vbackptr($v) 0
732 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
733 lset vupptr($v) $b $na
735 if {[string compare $otok $vtokmod($v)] <= 0} {
736 modify_arc $v $oa
740 proc renumbervarc {a v} {
741 global parents children varctok varcstart varccommits
742 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
744 set t1 [clock clicks -milliseconds]
745 set todo {}
746 set isrelated($a) 1
747 set kidchanged($a) 1
748 set ntot 0
749 while {$a != 0} {
750 if {[info exists isrelated($a)]} {
751 lappend todo $a
752 set id [lindex $varccommits($v,$a) end]
753 foreach p $parents($v,$id) {
754 if {[info exists varcid($v,$p)]} {
755 set isrelated($varcid($v,$p)) 1
759 incr ntot
760 set b [lindex $vdownptr($v) $a]
761 if {$b == 0} {
762 while {$a != 0} {
763 set b [lindex $vleftptr($v) $a]
764 if {$b != 0} break
765 set a [lindex $vupptr($v) $a]
768 set a $b
770 foreach a $todo {
771 if {![info exists kidchanged($a)]} continue
772 set id [lindex $varcstart($v) $a]
773 if {[llength $children($v,$id)] > 1} {
774 set children($v,$id) [lsort -command [list vtokcmp $v] \
775 $children($v,$id)]
777 set oldtok [lindex $varctok($v) $a]
778 if {!$vdatemode($v)} {
779 set tok {}
780 } else {
781 set tok $oldtok
783 set ka 0
784 set kid [last_real_child $v,$id]
785 if {$kid ne {}} {
786 set k $varcid($v,$kid)
787 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
788 set ki $kid
789 set ka $k
790 set tok [lindex $varctok($v) $k]
793 if {$ka != 0} {
794 set i [lsearch -exact $parents($v,$ki) $id]
795 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
796 append tok [strrep $j]
798 if {$tok eq $oldtok} {
799 continue
801 set id [lindex $varccommits($v,$a) end]
802 foreach p $parents($v,$id) {
803 if {[info exists varcid($v,$p)]} {
804 set kidchanged($varcid($v,$p)) 1
805 } else {
806 set sortkids($p) 1
809 lset varctok($v) $a $tok
810 set b [lindex $vupptr($v) $a]
811 if {$b != $ka} {
812 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
813 modify_arc $v $ka
815 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
816 modify_arc $v $b
818 set c [lindex $vbackptr($v) $a]
819 set d [lindex $vleftptr($v) $a]
820 if {$c == 0} {
821 lset vdownptr($v) $b $d
822 } else {
823 lset vleftptr($v) $c $d
825 if {$d != 0} {
826 lset vbackptr($v) $d $c
828 if {[lindex $vlastins($v) $b] == $a} {
829 lset vlastins($v) $b $c
831 lset vupptr($v) $a $ka
832 set c [lindex $vlastins($v) $ka]
833 if {$c == 0 || \
834 [string compare $tok [lindex $varctok($v) $c]] < 0} {
835 set c $ka
836 set b [lindex $vdownptr($v) $ka]
837 } else {
838 set b [lindex $vleftptr($v) $c]
840 while {$b != 0 && \
841 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
842 set c $b
843 set b [lindex $vleftptr($v) $c]
845 if {$c == $ka} {
846 lset vdownptr($v) $ka $a
847 lset vbackptr($v) $a 0
848 } else {
849 lset vleftptr($v) $c $a
850 lset vbackptr($v) $a $c
852 lset vleftptr($v) $a $b
853 if {$b != 0} {
854 lset vbackptr($v) $b $a
856 lset vlastins($v) $ka $a
859 foreach id [array names sortkids] {
860 if {[llength $children($v,$id)] > 1} {
861 set children($v,$id) [lsort -command [list vtokcmp $v] \
862 $children($v,$id)]
865 set t2 [clock clicks -milliseconds]
866 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
869 # Fix up the graph after we have found out that in view $v,
870 # $p (a commit that we have already seen) is actually the parent
871 # of the last commit in arc $a.
872 proc fix_reversal {p a v} {
873 global varcid varcstart varctok vupptr
875 set pa $varcid($v,$p)
876 if {$p ne [lindex $varcstart($v) $pa]} {
877 splitvarc $p $v
878 set pa $varcid($v,$p)
880 # seeds always need to be renumbered
881 if {[lindex $vupptr($v) $pa] == 0 ||
882 [string compare [lindex $varctok($v) $a] \
883 [lindex $varctok($v) $pa]] > 0} {
884 renumbervarc $pa $v
888 proc insertrow {id p v} {
889 global cmitlisted children parents varcid varctok vtokmod
890 global varccommits ordertok commitidx numcommits curview
891 global targetid targetrow
893 readcommit $id
894 set vid $v,$id
895 set cmitlisted($vid) 1
896 set children($vid) {}
897 set parents($vid) [list $p]
898 set a [newvarc $v $id]
899 set varcid($vid) $a
900 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
901 modify_arc $v $a
903 lappend varccommits($v,$a) $id
904 set vp $v,$p
905 if {[llength [lappend children($vp) $id]] > 1} {
906 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
907 catch {unset ordertok}
909 fix_reversal $p $a $v
910 incr commitidx($v)
911 if {$v == $curview} {
912 set numcommits $commitidx($v)
913 setcanvscroll
914 if {[info exists targetid]} {
915 if {![comes_before $targetid $p]} {
916 incr targetrow
922 proc insertfakerow {id p} {
923 global varcid varccommits parents children cmitlisted
924 global commitidx varctok vtokmod targetid targetrow curview numcommits
926 set v $curview
927 set a $varcid($v,$p)
928 set i [lsearch -exact $varccommits($v,$a) $p]
929 if {$i < 0} {
930 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
931 return
933 set children($v,$id) {}
934 set parents($v,$id) [list $p]
935 set varcid($v,$id) $a
936 lappend children($v,$p) $id
937 set cmitlisted($v,$id) 1
938 set numcommits [incr commitidx($v)]
939 # note we deliberately don't update varcstart($v) even if $i == 0
940 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
941 modify_arc $v $a $i
942 if {[info exists targetid]} {
943 if {![comes_before $targetid $p]} {
944 incr targetrow
947 setcanvscroll
948 drawvisible
951 proc removefakerow {id} {
952 global varcid varccommits parents children commitidx
953 global varctok vtokmod cmitlisted currentid selectedline
954 global targetid curview numcommits
956 set v $curview
957 if {[llength $parents($v,$id)] != 1} {
958 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
959 return
961 set p [lindex $parents($v,$id) 0]
962 set a $varcid($v,$id)
963 set i [lsearch -exact $varccommits($v,$a) $id]
964 if {$i < 0} {
965 puts "oops: removefakerow can't find [shortids $id] on arc $a"
966 return
968 unset varcid($v,$id)
969 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
970 unset parents($v,$id)
971 unset children($v,$id)
972 unset cmitlisted($v,$id)
973 set numcommits [incr commitidx($v) -1]
974 set j [lsearch -exact $children($v,$p) $id]
975 if {$j >= 0} {
976 set children($v,$p) [lreplace $children($v,$p) $j $j]
978 modify_arc $v $a $i
979 if {[info exist currentid] && $id eq $currentid} {
980 unset currentid
981 set selectedline {}
983 if {[info exists targetid] && $targetid eq $id} {
984 set targetid $p
986 setcanvscroll
987 drawvisible
990 proc first_real_child {vp} {
991 global children nullid nullid2
993 foreach id $children($vp) {
994 if {$id ne $nullid && $id ne $nullid2} {
995 return $id
998 return {}
1001 proc last_real_child {vp} {
1002 global children nullid nullid2
1004 set kids $children($vp)
1005 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1006 set id [lindex $kids $i]
1007 if {$id ne $nullid && $id ne $nullid2} {
1008 return $id
1011 return {}
1014 proc vtokcmp {v a b} {
1015 global varctok varcid
1017 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1018 [lindex $varctok($v) $varcid($v,$b)]]
1021 # This assumes that if lim is not given, the caller has checked that
1022 # arc a's token is less than $vtokmod($v)
1023 proc modify_arc {v a {lim {}}} {
1024 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1026 if {$lim ne {}} {
1027 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1028 if {$c > 0} return
1029 if {$c == 0} {
1030 set r [lindex $varcrow($v) $a]
1031 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1034 set vtokmod($v) [lindex $varctok($v) $a]
1035 set varcmod($v) $a
1036 if {$v == $curview} {
1037 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1038 set a [lindex $vupptr($v) $a]
1039 set lim {}
1041 set r 0
1042 if {$a != 0} {
1043 if {$lim eq {}} {
1044 set lim [llength $varccommits($v,$a)]
1046 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1048 set vrowmod($v) $r
1049 undolayout $r
1053 proc update_arcrows {v} {
1054 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1055 global varcid vrownum varcorder varcix varccommits
1056 global vupptr vdownptr vleftptr varctok
1057 global displayorder parentlist curview cached_commitrow
1059 if {$vrowmod($v) == $commitidx($v)} return
1060 if {$v == $curview} {
1061 if {[llength $displayorder] > $vrowmod($v)} {
1062 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1063 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1065 catch {unset cached_commitrow}
1067 set narctot [expr {[llength $varctok($v)] - 1}]
1068 set a $varcmod($v)
1069 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1070 # go up the tree until we find something that has a row number,
1071 # or we get to a seed
1072 set a [lindex $vupptr($v) $a]
1074 if {$a == 0} {
1075 set a [lindex $vdownptr($v) 0]
1076 if {$a == 0} return
1077 set vrownum($v) {0}
1078 set varcorder($v) [list $a]
1079 lset varcix($v) $a 0
1080 lset varcrow($v) $a 0
1081 set arcn 0
1082 set row 0
1083 } else {
1084 set arcn [lindex $varcix($v) $a]
1085 if {[llength $vrownum($v)] > $arcn + 1} {
1086 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1087 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1089 set row [lindex $varcrow($v) $a]
1091 while {1} {
1092 set p $a
1093 incr row [llength $varccommits($v,$a)]
1094 # go down if possible
1095 set b [lindex $vdownptr($v) $a]
1096 if {$b == 0} {
1097 # if not, go left, or go up until we can go left
1098 while {$a != 0} {
1099 set b [lindex $vleftptr($v) $a]
1100 if {$b != 0} break
1101 set a [lindex $vupptr($v) $a]
1103 if {$a == 0} break
1105 set a $b
1106 incr arcn
1107 lappend vrownum($v) $row
1108 lappend varcorder($v) $a
1109 lset varcix($v) $a $arcn
1110 lset varcrow($v) $a $row
1112 set vtokmod($v) [lindex $varctok($v) $p]
1113 set varcmod($v) $p
1114 set vrowmod($v) $row
1115 if {[info exists currentid]} {
1116 set selectedline [rowofcommit $currentid]
1120 # Test whether view $v contains commit $id
1121 proc commitinview {id v} {
1122 global varcid
1124 return [info exists varcid($v,$id)]
1127 # Return the row number for commit $id in the current view
1128 proc rowofcommit {id} {
1129 global varcid varccommits varcrow curview cached_commitrow
1130 global varctok vtokmod
1132 set v $curview
1133 if {![info exists varcid($v,$id)]} {
1134 puts "oops rowofcommit no arc for [shortids $id]"
1135 return {}
1137 set a $varcid($v,$id)
1138 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1139 update_arcrows $v
1141 if {[info exists cached_commitrow($id)]} {
1142 return $cached_commitrow($id)
1144 set i [lsearch -exact $varccommits($v,$a) $id]
1145 if {$i < 0} {
1146 puts "oops didn't find commit [shortids $id] in arc $a"
1147 return {}
1149 incr i [lindex $varcrow($v) $a]
1150 set cached_commitrow($id) $i
1151 return $i
1154 # Returns 1 if a is on an earlier row than b, otherwise 0
1155 proc comes_before {a b} {
1156 global varcid varctok curview
1158 set v $curview
1159 if {$a eq $b || ![info exists varcid($v,$a)] || \
1160 ![info exists varcid($v,$b)]} {
1161 return 0
1163 if {$varcid($v,$a) != $varcid($v,$b)} {
1164 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1165 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1167 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1170 proc bsearch {l elt} {
1171 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1172 return 0
1174 set lo 0
1175 set hi [llength $l]
1176 while {$hi - $lo > 1} {
1177 set mid [expr {int(($lo + $hi) / 2)}]
1178 set t [lindex $l $mid]
1179 if {$elt < $t} {
1180 set hi $mid
1181 } elseif {$elt > $t} {
1182 set lo $mid
1183 } else {
1184 return $mid
1187 return $lo
1190 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1191 proc make_disporder {start end} {
1192 global vrownum curview commitidx displayorder parentlist
1193 global varccommits varcorder parents vrowmod varcrow
1194 global d_valid_start d_valid_end
1196 if {$end > $vrowmod($curview)} {
1197 update_arcrows $curview
1199 set ai [bsearch $vrownum($curview) $start]
1200 set start [lindex $vrownum($curview) $ai]
1201 set narc [llength $vrownum($curview)]
1202 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1203 set a [lindex $varcorder($curview) $ai]
1204 set l [llength $displayorder]
1205 set al [llength $varccommits($curview,$a)]
1206 if {$l < $r + $al} {
1207 if {$l < $r} {
1208 set pad [ntimes [expr {$r - $l}] {}]
1209 set displayorder [concat $displayorder $pad]
1210 set parentlist [concat $parentlist $pad]
1211 } elseif {$l > $r} {
1212 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1213 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1215 foreach id $varccommits($curview,$a) {
1216 lappend displayorder $id
1217 lappend parentlist $parents($curview,$id)
1219 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1220 set i $r
1221 foreach id $varccommits($curview,$a) {
1222 lset displayorder $i $id
1223 lset parentlist $i $parents($curview,$id)
1224 incr i
1227 incr r $al
1231 proc commitonrow {row} {
1232 global displayorder
1234 set id [lindex $displayorder $row]
1235 if {$id eq {}} {
1236 make_disporder $row [expr {$row + 1}]
1237 set id [lindex $displayorder $row]
1239 return $id
1242 proc closevarcs {v} {
1243 global varctok varccommits varcid parents children
1244 global cmitlisted commitidx vtokmod
1246 set missing_parents 0
1247 set scripts {}
1248 set narcs [llength $varctok($v)]
1249 for {set a 1} {$a < $narcs} {incr a} {
1250 set id [lindex $varccommits($v,$a) end]
1251 foreach p $parents($v,$id) {
1252 if {[info exists varcid($v,$p)]} continue
1253 # add p as a new commit
1254 incr missing_parents
1255 set cmitlisted($v,$p) 0
1256 set parents($v,$p) {}
1257 if {[llength $children($v,$p)] == 1 &&
1258 [llength $parents($v,$id)] == 1} {
1259 set b $a
1260 } else {
1261 set b [newvarc $v $p]
1263 set varcid($v,$p) $b
1264 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1265 modify_arc $v $b
1267 lappend varccommits($v,$b) $p
1268 incr commitidx($v)
1269 set scripts [check_interest $p $scripts]
1272 if {$missing_parents > 0} {
1273 foreach s $scripts {
1274 eval $s
1279 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1280 # Assumes we already have an arc for $rwid.
1281 proc rewrite_commit {v id rwid} {
1282 global children parents varcid varctok vtokmod varccommits
1284 foreach ch $children($v,$id) {
1285 # make $rwid be $ch's parent in place of $id
1286 set i [lsearch -exact $parents($v,$ch) $id]
1287 if {$i < 0} {
1288 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1290 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1291 # add $ch to $rwid's children and sort the list if necessary
1292 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1293 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1294 $children($v,$rwid)]
1296 # fix the graph after joining $id to $rwid
1297 set a $varcid($v,$ch)
1298 fix_reversal $rwid $a $v
1299 # parentlist is wrong for the last element of arc $a
1300 # even if displayorder is right, hence the 3rd arg here
1301 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1305 # Mechanism for registering a command to be executed when we come
1306 # across a particular commit. To handle the case when only the
1307 # prefix of the commit is known, the commitinterest array is now
1308 # indexed by the first 4 characters of the ID. Each element is a
1309 # list of id, cmd pairs.
1310 proc interestedin {id cmd} {
1311 global commitinterest
1313 lappend commitinterest([string range $id 0 3]) $id $cmd
1316 proc check_interest {id scripts} {
1317 global commitinterest
1319 set prefix [string range $id 0 3]
1320 if {[info exists commitinterest($prefix)]} {
1321 set newlist {}
1322 foreach {i script} $commitinterest($prefix) {
1323 if {[string match "$i*" $id]} {
1324 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1325 } else {
1326 lappend newlist $i $script
1329 if {$newlist ne {}} {
1330 set commitinterest($prefix) $newlist
1331 } else {
1332 unset commitinterest($prefix)
1335 return $scripts
1338 proc getcommitlines {fd inst view updating} {
1339 global cmitlisted leftover
1340 global commitidx commitdata vdatemode
1341 global parents children curview hlview
1342 global idpending ordertok
1343 global varccommits varcid varctok vtokmod vfilelimit
1345 set stuff [read $fd 500000]
1346 # git log doesn't terminate the last commit with a null...
1347 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1348 set stuff "\0"
1350 if {$stuff == {}} {
1351 if {![eof $fd]} {
1352 return 1
1354 global commfd viewcomplete viewactive viewname
1355 global viewinstances
1356 unset commfd($inst)
1357 set i [lsearch -exact $viewinstances($view) $inst]
1358 if {$i >= 0} {
1359 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1361 # set it blocking so we wait for the process to terminate
1362 fconfigure $fd -blocking 1
1363 if {[catch {close $fd} err]} {
1364 set fv {}
1365 if {$view != $curview} {
1366 set fv " for the \"$viewname($view)\" view"
1368 if {[string range $err 0 4] == "usage"} {
1369 set err "Gitk: error reading commits$fv:\
1370 bad arguments to git log."
1371 if {$viewname($view) eq "Command line"} {
1372 append err \
1373 " (Note: arguments to gitk are passed to git log\
1374 to allow selection of commits to be displayed.)"
1376 } else {
1377 set err "Error reading commits$fv: $err"
1379 error_popup $err
1381 if {[incr viewactive($view) -1] <= 0} {
1382 set viewcomplete($view) 1
1383 # Check if we have seen any ids listed as parents that haven't
1384 # appeared in the list
1385 closevarcs $view
1386 notbusy $view
1388 if {$view == $curview} {
1389 run chewcommits
1391 return 0
1393 set start 0
1394 set gotsome 0
1395 set scripts {}
1396 while 1 {
1397 set i [string first "\0" $stuff $start]
1398 if {$i < 0} {
1399 append leftover($inst) [string range $stuff $start end]
1400 break
1402 if {$start == 0} {
1403 set cmit $leftover($inst)
1404 append cmit [string range $stuff 0 [expr {$i - 1}]]
1405 set leftover($inst) {}
1406 } else {
1407 set cmit [string range $stuff $start [expr {$i - 1}]]
1409 set start [expr {$i + 1}]
1410 set j [string first "\n" $cmit]
1411 set ok 0
1412 set listed 1
1413 if {$j >= 0 && [string match "commit *" $cmit]} {
1414 set ids [string range $cmit 7 [expr {$j - 1}]]
1415 if {[string match {[-^<>]*} $ids]} {
1416 switch -- [string index $ids 0] {
1417 "-" {set listed 0}
1418 "^" {set listed 2}
1419 "<" {set listed 3}
1420 ">" {set listed 4}
1422 set ids [string range $ids 1 end]
1424 set ok 1
1425 foreach id $ids {
1426 if {[string length $id] != 40} {
1427 set ok 0
1428 break
1432 if {!$ok} {
1433 set shortcmit $cmit
1434 if {[string length $shortcmit] > 80} {
1435 set shortcmit "[string range $shortcmit 0 80]..."
1437 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1438 exit 1
1440 set id [lindex $ids 0]
1441 set vid $view,$id
1443 if {!$listed && $updating && ![info exists varcid($vid)] &&
1444 $vfilelimit($view) ne {}} {
1445 # git log doesn't rewrite parents for unlisted commits
1446 # when doing path limiting, so work around that here
1447 # by working out the rewritten parent with git rev-list
1448 # and if we already know about it, using the rewritten
1449 # parent as a substitute parent for $id's children.
1450 if {![catch {
1451 set rwid [exec git rev-list --first-parent --max-count=1 \
1452 $id -- $vfilelimit($view)]
1453 }]} {
1454 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1455 # use $rwid in place of $id
1456 rewrite_commit $view $id $rwid
1457 continue
1462 set a 0
1463 if {[info exists varcid($vid)]} {
1464 if {$cmitlisted($vid) || !$listed} continue
1465 set a $varcid($vid)
1467 if {$listed} {
1468 set olds [lrange $ids 1 end]
1469 } else {
1470 set olds {}
1472 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1473 set cmitlisted($vid) $listed
1474 set parents($vid) $olds
1475 if {![info exists children($vid)]} {
1476 set children($vid) {}
1477 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1478 set k [lindex $children($vid) 0]
1479 if {[llength $parents($view,$k)] == 1 &&
1480 (!$vdatemode($view) ||
1481 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1482 set a $varcid($view,$k)
1485 if {$a == 0} {
1486 # new arc
1487 set a [newvarc $view $id]
1489 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1490 modify_arc $view $a
1492 if {![info exists varcid($vid)]} {
1493 set varcid($vid) $a
1494 lappend varccommits($view,$a) $id
1495 incr commitidx($view)
1498 set i 0
1499 foreach p $olds {
1500 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1501 set vp $view,$p
1502 if {[llength [lappend children($vp) $id]] > 1 &&
1503 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1504 set children($vp) [lsort -command [list vtokcmp $view] \
1505 $children($vp)]
1506 catch {unset ordertok}
1508 if {[info exists varcid($view,$p)]} {
1509 fix_reversal $p $a $view
1512 incr i
1515 set scripts [check_interest $id $scripts]
1516 set gotsome 1
1518 if {$gotsome} {
1519 global numcommits hlview
1521 if {$view == $curview} {
1522 set numcommits $commitidx($view)
1523 run chewcommits
1525 if {[info exists hlview] && $view == $hlview} {
1526 # we never actually get here...
1527 run vhighlightmore
1529 foreach s $scripts {
1530 eval $s
1533 return 2
1536 proc chewcommits {} {
1537 global curview hlview viewcomplete
1538 global pending_select
1540 layoutmore
1541 if {$viewcomplete($curview)} {
1542 global commitidx varctok
1543 global numcommits startmsecs
1545 if {[info exists pending_select]} {
1546 update
1547 reset_pending_select {}
1549 if {[commitinview $pending_select $curview]} {
1550 selectline [rowofcommit $pending_select] 1
1551 } else {
1552 set row [first_real_row]
1553 selectline $row 1
1556 if {$commitidx($curview) > 0} {
1557 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1558 #puts "overall $ms ms for $numcommits commits"
1559 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1560 } else {
1561 show_status [mc "No commits selected"]
1563 notbusy layout
1565 return 0
1568 proc do_readcommit {id} {
1569 global tclencoding
1571 # Invoke git-log to handle automatic encoding conversion
1572 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1573 # Read the results using i18n.logoutputencoding
1574 fconfigure $fd -translation lf -eofchar {}
1575 if {$tclencoding != {}} {
1576 fconfigure $fd -encoding $tclencoding
1578 set contents [read $fd]
1579 close $fd
1580 # Remove the heading line
1581 regsub {^commit [0-9a-f]+\n} $contents {} contents
1583 return $contents
1586 proc readcommit {id} {
1587 if {[catch {set contents [do_readcommit $id]}]} return
1588 parsecommit $id $contents 1
1591 proc parsecommit {id contents listed} {
1592 global commitinfo cdate
1594 set inhdr 1
1595 set comment {}
1596 set headline {}
1597 set auname {}
1598 set audate {}
1599 set comname {}
1600 set comdate {}
1601 set hdrend [string first "\n\n" $contents]
1602 if {$hdrend < 0} {
1603 # should never happen...
1604 set hdrend [string length $contents]
1606 set header [string range $contents 0 [expr {$hdrend - 1}]]
1607 set comment [string range $contents [expr {$hdrend + 2}] end]
1608 foreach line [split $header "\n"] {
1609 set line [split $line " "]
1610 set tag [lindex $line 0]
1611 if {$tag == "author"} {
1612 set audate [lindex $line end-1]
1613 set auname [join [lrange $line 1 end-2] " "]
1614 } elseif {$tag == "committer"} {
1615 set comdate [lindex $line end-1]
1616 set comname [join [lrange $line 1 end-2] " "]
1619 set headline {}
1620 # take the first non-blank line of the comment as the headline
1621 set headline [string trimleft $comment]
1622 set i [string first "\n" $headline]
1623 if {$i >= 0} {
1624 set headline [string range $headline 0 $i]
1626 set headline [string trimright $headline]
1627 set i [string first "\r" $headline]
1628 if {$i >= 0} {
1629 set headline [string trimright [string range $headline 0 $i]]
1631 if {!$listed} {
1632 # git log indents the comment by 4 spaces;
1633 # if we got this via git cat-file, add the indentation
1634 set newcomment {}
1635 foreach line [split $comment "\n"] {
1636 append newcomment " "
1637 append newcomment $line
1638 append newcomment "\n"
1640 set comment $newcomment
1642 if {$comdate != {}} {
1643 set cdate($id) $comdate
1645 set commitinfo($id) [list $headline $auname $audate \
1646 $comname $comdate $comment]
1649 proc getcommit {id} {
1650 global commitdata commitinfo
1652 if {[info exists commitdata($id)]} {
1653 parsecommit $id $commitdata($id) 1
1654 } else {
1655 readcommit $id
1656 if {![info exists commitinfo($id)]} {
1657 set commitinfo($id) [list [mc "No commit information available"]]
1660 return 1
1663 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1664 # and are present in the current view.
1665 # This is fairly slow...
1666 proc longid {prefix} {
1667 global varcid curview
1669 set ids {}
1670 foreach match [array names varcid "$curview,$prefix*"] {
1671 lappend ids [lindex [split $match ","] 1]
1673 return $ids
1676 proc readrefs {} {
1677 global tagids idtags headids idheads tagobjid
1678 global otherrefids idotherrefs mainhead mainheadid
1679 global selecthead selectheadid
1680 global hideremotes
1682 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1683 catch {unset $v}
1685 set refd [open [list | git show-ref -d] r]
1686 while {[gets $refd line] >= 0} {
1687 if {[string index $line 40] ne " "} continue
1688 set id [string range $line 0 39]
1689 set ref [string range $line 41 end]
1690 if {![string match "refs/*" $ref]} continue
1691 set name [string range $ref 5 end]
1692 if {[string match "remotes/*" $name]} {
1693 if {![string match "*/HEAD" $name] && !$hideremotes} {
1694 set headids($name) $id
1695 lappend idheads($id) $name
1697 } elseif {[string match "heads/*" $name]} {
1698 set name [string range $name 6 end]
1699 set headids($name) $id
1700 lappend idheads($id) $name
1701 } elseif {[string match "tags/*" $name]} {
1702 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1703 # which is what we want since the former is the commit ID
1704 set name [string range $name 5 end]
1705 if {[string match "*^{}" $name]} {
1706 set name [string range $name 0 end-3]
1707 } else {
1708 set tagobjid($name) $id
1710 set tagids($name) $id
1711 lappend idtags($id) $name
1712 } else {
1713 set otherrefids($name) $id
1714 lappend idotherrefs($id) $name
1717 catch {close $refd}
1718 set mainhead {}
1719 set mainheadid {}
1720 catch {
1721 set mainheadid [exec git rev-parse HEAD]
1722 set thehead [exec git symbolic-ref HEAD]
1723 if {[string match "refs/heads/*" $thehead]} {
1724 set mainhead [string range $thehead 11 end]
1727 set selectheadid {}
1728 if {$selecthead ne {}} {
1729 catch {
1730 set selectheadid [exec git rev-parse --verify $selecthead]
1735 # skip over fake commits
1736 proc first_real_row {} {
1737 global nullid nullid2 numcommits
1739 for {set row 0} {$row < $numcommits} {incr row} {
1740 set id [commitonrow $row]
1741 if {$id ne $nullid && $id ne $nullid2} {
1742 break
1745 return $row
1748 # update things for a head moved to a child of its previous location
1749 proc movehead {id name} {
1750 global headids idheads
1752 removehead $headids($name) $name
1753 set headids($name) $id
1754 lappend idheads($id) $name
1757 # update things when a head has been removed
1758 proc removehead {id name} {
1759 global headids idheads
1761 if {$idheads($id) eq $name} {
1762 unset idheads($id)
1763 } else {
1764 set i [lsearch -exact $idheads($id) $name]
1765 if {$i >= 0} {
1766 set idheads($id) [lreplace $idheads($id) $i $i]
1769 unset headids($name)
1772 proc make_transient {window origin} {
1773 global have_tk85
1775 # In MacOS Tk 8.4 transient appears to work by setting
1776 # overrideredirect, which is utterly useless, since the
1777 # windows get no border, and are not even kept above
1778 # the parent.
1779 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1781 wm transient $window $origin
1783 # Windows fails to place transient windows normally, so
1784 # schedule a callback to center them on the parent.
1785 if {[tk windowingsystem] eq {win32}} {
1786 after idle [list tk::PlaceWindow $window widget $origin]
1790 proc show_error {w top msg} {
1791 message $w.m -text $msg -justify center -aspect 400
1792 pack $w.m -side top -fill x -padx 20 -pady 20
1793 button $w.ok -text [mc OK] -command "destroy $top"
1794 pack $w.ok -side bottom -fill x
1795 bind $top <Visibility> "grab $top; focus $top"
1796 bind $top <Key-Return> "destroy $top"
1797 bind $top <Key-space> "destroy $top"
1798 bind $top <Key-Escape> "destroy $top"
1799 tkwait window $top
1802 proc error_popup {msg {owner .}} {
1803 set w .error
1804 toplevel $w
1805 make_transient $w $owner
1806 show_error $w $w $msg
1809 proc confirm_popup {msg {owner .}} {
1810 global confirm_ok
1811 set confirm_ok 0
1812 set w .confirm
1813 toplevel $w
1814 make_transient $w $owner
1815 message $w.m -text $msg -justify center -aspect 400
1816 pack $w.m -side top -fill x -padx 20 -pady 20
1817 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1818 pack $w.ok -side left -fill x
1819 button $w.cancel -text [mc Cancel] -command "destroy $w"
1820 pack $w.cancel -side right -fill x
1821 bind $w <Visibility> "grab $w; focus $w"
1822 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1823 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1824 bind $w <Key-Escape> "destroy $w"
1825 tkwait window $w
1826 return $confirm_ok
1829 proc setoptions {} {
1830 option add *Panedwindow.showHandle 1 startupFile
1831 option add *Panedwindow.sashRelief raised startupFile
1832 option add *Button.font uifont startupFile
1833 option add *Checkbutton.font uifont startupFile
1834 option add *Radiobutton.font uifont startupFile
1835 if {[tk windowingsystem] ne "aqua"} {
1836 option add *Menu.font uifont startupFile
1838 option add *Menubutton.font uifont startupFile
1839 option add *Label.font uifont startupFile
1840 option add *Message.font uifont startupFile
1841 option add *Entry.font uifont startupFile
1844 # Make a menu and submenus.
1845 # m is the window name for the menu, items is the list of menu items to add.
1846 # Each item is a list {mc label type description options...}
1847 # mc is ignored; it's so we can put mc there to alert xgettext
1848 # label is the string that appears in the menu
1849 # type is cascade, command or radiobutton (should add checkbutton)
1850 # description depends on type; it's the sublist for cascade, the
1851 # command to invoke for command, or {variable value} for radiobutton
1852 proc makemenu {m items} {
1853 menu $m
1854 if {[tk windowingsystem] eq {aqua}} {
1855 set Meta1 Cmd
1856 } else {
1857 set Meta1 Ctrl
1859 foreach i $items {
1860 set name [mc [lindex $i 1]]
1861 set type [lindex $i 2]
1862 set thing [lindex $i 3]
1863 set params [list $type]
1864 if {$name ne {}} {
1865 set u [string first "&" [string map {&& x} $name]]
1866 lappend params -label [string map {&& & & {}} $name]
1867 if {$u >= 0} {
1868 lappend params -underline $u
1871 switch -- $type {
1872 "cascade" {
1873 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1874 lappend params -menu $m.$submenu
1876 "command" {
1877 lappend params -command $thing
1879 "radiobutton" {
1880 lappend params -variable [lindex $thing 0] \
1881 -value [lindex $thing 1]
1884 set tail [lrange $i 4 end]
1885 regsub -all {\yMeta1\y} $tail $Meta1 tail
1886 eval $m add $params $tail
1887 if {$type eq "cascade"} {
1888 makemenu $m.$submenu $thing
1893 # translate string and remove ampersands
1894 proc mca {str} {
1895 return [string map {&& & & {}} [mc $str]]
1898 proc makewindow {} {
1899 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1900 global tabstop
1901 global findtype findtypemenu findloc findstring fstring geometry
1902 global entries sha1entry sha1string sha1but
1903 global diffcontextstring diffcontext
1904 global ignorespace
1905 global maincursor textcursor curtextcursor
1906 global rowctxmenu fakerowmenu mergemax wrapcomment
1907 global highlight_files gdttype
1908 global searchstring sstring
1909 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1910 global headctxmenu progresscanv progressitem progresscoords statusw
1911 global fprogitem fprogcoord lastprogupdate progupdatepending
1912 global rprogitem rprogcoord rownumsel numcommits
1913 global have_tk85
1915 # The "mc" arguments here are purely so that xgettext
1916 # sees the following string as needing to be translated
1917 set file {
1918 mc "File" cascade {
1919 {mc "Update" command updatecommits -accelerator F5}
1920 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1921 {mc "Reread references" command rereadrefs}
1922 {mc "List references" command showrefs -accelerator F2}
1923 {xx "" separator}
1924 {mc "Start git gui" command {exec git gui &}}
1925 {xx "" separator}
1926 {mc "Quit" command doquit -accelerator Meta1-Q}
1928 set edit {
1929 mc "Edit" cascade {
1930 {mc "Preferences" command doprefs}
1932 set view {
1933 mc "View" cascade {
1934 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1935 {mc "Edit view..." command editview -state disabled -accelerator F4}
1936 {mc "Delete view" command delview -state disabled}
1937 {xx "" separator}
1938 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1940 if {[tk windowingsystem] ne "aqua"} {
1941 set help {
1942 mc "Help" cascade {
1943 {mc "About gitk" command about}
1944 {mc "Key bindings" command keys}
1946 set bar [list $file $edit $view $help]
1947 } else {
1948 proc ::tk::mac::ShowPreferences {} {doprefs}
1949 proc ::tk::mac::Quit {} {doquit}
1950 lset file end [lreplace [lindex $file end] end-1 end]
1951 set apple {
1952 xx "Apple" cascade {
1953 {mc "About gitk" command about}
1954 {xx "" separator}
1956 set help {
1957 mc "Help" cascade {
1958 {mc "Key bindings" command keys}
1960 set bar [list $apple $file $view $help]
1962 makemenu .bar $bar
1963 . configure -menu .bar
1965 # the gui has upper and lower half, parts of a paned window.
1966 panedwindow .ctop -orient vertical
1968 # possibly use assumed geometry
1969 if {![info exists geometry(pwsash0)]} {
1970 set geometry(topheight) [expr {15 * $linespc}]
1971 set geometry(topwidth) [expr {80 * $charspc}]
1972 set geometry(botheight) [expr {15 * $linespc}]
1973 set geometry(botwidth) [expr {50 * $charspc}]
1974 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1975 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1978 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1979 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1980 frame .tf.histframe
1981 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1983 # create three canvases
1984 set cscroll .tf.histframe.csb
1985 set canv .tf.histframe.pwclist.canv
1986 canvas $canv \
1987 -selectbackground $selectbgcolor \
1988 -background $bgcolor -bd 0 \
1989 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1990 .tf.histframe.pwclist add $canv
1991 set canv2 .tf.histframe.pwclist.canv2
1992 canvas $canv2 \
1993 -selectbackground $selectbgcolor \
1994 -background $bgcolor -bd 0 -yscrollincr $linespc
1995 .tf.histframe.pwclist add $canv2
1996 set canv3 .tf.histframe.pwclist.canv3
1997 canvas $canv3 \
1998 -selectbackground $selectbgcolor \
1999 -background $bgcolor -bd 0 -yscrollincr $linespc
2000 .tf.histframe.pwclist add $canv3
2001 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2002 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2004 # a scroll bar to rule them
2005 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
2006 pack $cscroll -side right -fill y
2007 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2008 lappend bglist $canv $canv2 $canv3
2009 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2011 # we have two button bars at bottom of top frame. Bar 1
2012 frame .tf.bar
2013 frame .tf.lbar -height 15
2015 set sha1entry .tf.bar.sha1
2016 set entries $sha1entry
2017 set sha1but .tf.bar.sha1label
2018 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
2019 -command gotocommit -width 8
2020 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2021 pack .tf.bar.sha1label -side left
2022 entry $sha1entry -width 40 -font textfont -textvariable sha1string
2023 trace add variable sha1string write sha1change
2024 pack $sha1entry -side left -pady 2
2026 image create bitmap bm-left -data {
2027 #define left_width 16
2028 #define left_height 16
2029 static unsigned char left_bits[] = {
2030 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2031 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2032 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2034 image create bitmap bm-right -data {
2035 #define right_width 16
2036 #define right_height 16
2037 static unsigned char right_bits[] = {
2038 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2039 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2040 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2042 button .tf.bar.leftbut -image bm-left -command goback \
2043 -state disabled -width 26
2044 pack .tf.bar.leftbut -side left -fill y
2045 button .tf.bar.rightbut -image bm-right -command goforw \
2046 -state disabled -width 26
2047 pack .tf.bar.rightbut -side left -fill y
2049 label .tf.bar.rowlabel -text [mc "Row"]
2050 set rownumsel {}
2051 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2052 -relief sunken -anchor e
2053 label .tf.bar.rowlabel2 -text "/"
2054 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2055 -relief sunken -anchor e
2056 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2057 -side left
2058 global selectedline
2059 trace add variable selectedline write selectedline_change
2061 # Status label and progress bar
2062 set statusw .tf.bar.status
2063 label $statusw -width 15 -relief sunken
2064 pack $statusw -side left -padx 5
2065 set h [expr {[font metrics uifont -linespace] + 2}]
2066 set progresscanv .tf.bar.progress
2067 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2068 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2069 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2070 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2071 pack $progresscanv -side right -expand 1 -fill x
2072 set progresscoords {0 0}
2073 set fprogcoord 0
2074 set rprogcoord 0
2075 bind $progresscanv <Configure> adjustprogress
2076 set lastprogupdate [clock clicks -milliseconds]
2077 set progupdatepending 0
2079 # build up the bottom bar of upper window
2080 label .tf.lbar.flabel -text "[mc "Find"] "
2081 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2082 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2083 label .tf.lbar.flab2 -text " [mc "commit"] "
2084 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2085 -side left -fill y
2086 set gdttype [mc "containing:"]
2087 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2088 [mc "containing:"] \
2089 [mc "touching paths:"] \
2090 [mc "adding/removing string:"]]
2091 trace add variable gdttype write gdttype_change
2092 pack .tf.lbar.gdttype -side left -fill y
2094 set findstring {}
2095 set fstring .tf.lbar.findstring
2096 lappend entries $fstring
2097 entry $fstring -width 30 -font textfont -textvariable findstring
2098 trace add variable findstring write find_change
2099 set findtype [mc "Exact"]
2100 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2101 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2102 trace add variable findtype write findcom_change
2103 set findloc [mc "All fields"]
2104 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2105 [mc "Comments"] [mc "Author"] [mc "Committer"]
2106 trace add variable findloc write find_change
2107 pack .tf.lbar.findloc -side right
2108 pack .tf.lbar.findtype -side right
2109 pack $fstring -side left -expand 1 -fill x
2111 # Finish putting the upper half of the viewer together
2112 pack .tf.lbar -in .tf -side bottom -fill x
2113 pack .tf.bar -in .tf -side bottom -fill x
2114 pack .tf.histframe -fill both -side top -expand 1
2115 .ctop add .tf
2116 .ctop paneconfigure .tf -height $geometry(topheight)
2117 .ctop paneconfigure .tf -width $geometry(topwidth)
2119 # now build up the bottom
2120 panedwindow .pwbottom -orient horizontal
2122 # lower left, a text box over search bar, scroll bar to the right
2123 # if we know window height, then that will set the lower text height, otherwise
2124 # we set lower text height which will drive window height
2125 if {[info exists geometry(main)]} {
2126 frame .bleft -width $geometry(botwidth)
2127 } else {
2128 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2130 frame .bleft.top
2131 frame .bleft.mid
2132 frame .bleft.bottom
2134 button .bleft.top.search -text [mc "Search"] -command dosearch
2135 pack .bleft.top.search -side left -padx 5
2136 set sstring .bleft.top.sstring
2137 entry $sstring -width 20 -font textfont -textvariable searchstring
2138 lappend entries $sstring
2139 trace add variable searchstring write incrsearch
2140 pack $sstring -side left -expand 1 -fill x
2141 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2142 -command changediffdisp -variable diffelide -value {0 0}
2143 radiobutton .bleft.mid.old -text [mc "Old version"] \
2144 -command changediffdisp -variable diffelide -value {0 1}
2145 radiobutton .bleft.mid.new -text [mc "New version"] \
2146 -command changediffdisp -variable diffelide -value {1 0}
2147 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2148 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2149 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2150 -from 0 -increment 1 -to 10000000 \
2151 -validate all -validatecommand "diffcontextvalidate %P" \
2152 -textvariable diffcontextstring
2153 .bleft.mid.diffcontext set $diffcontext
2154 trace add variable diffcontextstring write diffcontextchange
2155 lappend entries .bleft.mid.diffcontext
2156 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2157 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2158 -command changeignorespace -variable ignorespace
2159 pack .bleft.mid.ignspace -side left -padx 5
2160 set ctext .bleft.bottom.ctext
2161 text $ctext -background $bgcolor -foreground $fgcolor \
2162 -state disabled -font textfont \
2163 -yscrollcommand scrolltext -wrap none \
2164 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2165 if {$have_tk85} {
2166 $ctext conf -tabstyle wordprocessor
2168 scrollbar .bleft.bottom.sb -command "$ctext yview"
2169 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2170 -width 10
2171 pack .bleft.top -side top -fill x
2172 pack .bleft.mid -side top -fill x
2173 grid $ctext .bleft.bottom.sb -sticky nsew
2174 grid .bleft.bottom.sbhorizontal -sticky ew
2175 grid columnconfigure .bleft.bottom 0 -weight 1
2176 grid rowconfigure .bleft.bottom 0 -weight 1
2177 grid rowconfigure .bleft.bottom 1 -weight 0
2178 pack .bleft.bottom -side top -fill both -expand 1
2179 lappend bglist $ctext
2180 lappend fglist $ctext
2182 $ctext tag conf comment -wrap $wrapcomment
2183 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2184 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2185 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2186 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2187 $ctext tag conf m0 -fore red
2188 $ctext tag conf m1 -fore blue
2189 $ctext tag conf m2 -fore green
2190 $ctext tag conf m3 -fore purple
2191 $ctext tag conf m4 -fore brown
2192 $ctext tag conf m5 -fore "#009090"
2193 $ctext tag conf m6 -fore magenta
2194 $ctext tag conf m7 -fore "#808000"
2195 $ctext tag conf m8 -fore "#009000"
2196 $ctext tag conf m9 -fore "#ff0080"
2197 $ctext tag conf m10 -fore cyan
2198 $ctext tag conf m11 -fore "#b07070"
2199 $ctext tag conf m12 -fore "#70b0f0"
2200 $ctext tag conf m13 -fore "#70f0b0"
2201 $ctext tag conf m14 -fore "#f0b070"
2202 $ctext tag conf m15 -fore "#ff70b0"
2203 $ctext tag conf mmax -fore darkgrey
2204 set mergemax 16
2205 $ctext tag conf mresult -font textfontbold
2206 $ctext tag conf msep -font textfontbold
2207 $ctext tag conf found -back yellow
2209 .pwbottom add .bleft
2210 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2212 # lower right
2213 frame .bright
2214 frame .bright.mode
2215 radiobutton .bright.mode.patch -text [mc "Patch"] \
2216 -command reselectline -variable cmitmode -value "patch"
2217 radiobutton .bright.mode.tree -text [mc "Tree"] \
2218 -command reselectline -variable cmitmode -value "tree"
2219 grid .bright.mode.patch .bright.mode.tree -sticky ew
2220 pack .bright.mode -side top -fill x
2221 set cflist .bright.cfiles
2222 set indent [font measure mainfont "nn"]
2223 text $cflist \
2224 -selectbackground $selectbgcolor \
2225 -background $bgcolor -foreground $fgcolor \
2226 -font mainfont \
2227 -tabs [list $indent [expr {2 * $indent}]] \
2228 -yscrollcommand ".bright.sb set" \
2229 -cursor [. cget -cursor] \
2230 -spacing1 1 -spacing3 1
2231 lappend bglist $cflist
2232 lappend fglist $cflist
2233 scrollbar .bright.sb -command "$cflist yview"
2234 pack .bright.sb -side right -fill y
2235 pack $cflist -side left -fill both -expand 1
2236 $cflist tag configure highlight \
2237 -background [$cflist cget -selectbackground]
2238 $cflist tag configure bold -font mainfontbold
2240 .pwbottom add .bright
2241 .ctop add .pwbottom
2243 # restore window width & height if known
2244 if {[info exists geometry(main)]} {
2245 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2246 if {$w > [winfo screenwidth .]} {
2247 set w [winfo screenwidth .]
2249 if {$h > [winfo screenheight .]} {
2250 set h [winfo screenheight .]
2252 wm geometry . "${w}x$h"
2256 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2257 wm state . $geometry(state)
2260 if {[tk windowingsystem] eq {aqua}} {
2261 set M1B M1
2262 set ::BM "3"
2263 } else {
2264 set M1B Control
2265 set ::BM "2"
2268 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2269 pack .ctop -fill both -expand 1
2270 bindall <1> {selcanvline %W %x %y}
2271 #bindall <B1-Motion> {selcanvline %W %x %y}
2272 if {[tk windowingsystem] == "win32"} {
2273 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2274 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2275 } else {
2276 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2277 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2278 if {[tk windowingsystem] eq "aqua"} {
2279 bindall <MouseWheel> {
2280 set delta [expr {- (%D)}]
2281 allcanvs yview scroll $delta units
2283 bindall <Shift-MouseWheel> {
2284 set delta [expr {- (%D)}]
2285 $canv xview scroll $delta units
2289 bindall <$::BM> "canvscan mark %W %x %y"
2290 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2291 bindkey <Home> selfirstline
2292 bindkey <End> sellastline
2293 bind . <Key-Up> "selnextline -1"
2294 bind . <Key-Down> "selnextline 1"
2295 bind . <Shift-Key-Up> "dofind -1 0"
2296 bind . <Shift-Key-Down> "dofind 1 0"
2297 bindkey <Key-Right> "goforw"
2298 bindkey <Key-Left> "goback"
2299 bind . <Key-Prior> "selnextpage -1"
2300 bind . <Key-Next> "selnextpage 1"
2301 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2302 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2303 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2304 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2305 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2306 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2307 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2308 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2309 bindkey <Key-space> "$ctext yview scroll 1 pages"
2310 bindkey p "selnextline -1"
2311 bindkey n "selnextline 1"
2312 bindkey z "goback"
2313 bindkey x "goforw"
2314 bindkey i "selnextline -1"
2315 bindkey k "selnextline 1"
2316 bindkey j "goback"
2317 bindkey l "goforw"
2318 bindkey b prevfile
2319 bindkey d "$ctext yview scroll 18 units"
2320 bindkey u "$ctext yview scroll -18 units"
2321 bindkey / {focus $fstring}
2322 bindkey <Key-KP_Divide> {focus $fstring}
2323 bindkey <Key-Return> {dofind 1 1}
2324 bindkey ? {dofind -1 1}
2325 bindkey f nextfile
2326 bind . <F5> updatecommits
2327 bind . <$M1B-F5> reloadcommits
2328 bind . <F2> showrefs
2329 bind . <Shift-F4> {newview 0}
2330 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2331 bind . <F4> edit_or_newview
2332 bind . <$M1B-q> doquit
2333 bind . <$M1B-f> {dofind 1 1}
2334 bind . <$M1B-g> {dofind 1 0}
2335 bind . <$M1B-r> dosearchback
2336 bind . <$M1B-s> dosearch
2337 bind . <$M1B-equal> {incrfont 1}
2338 bind . <$M1B-plus> {incrfont 1}
2339 bind . <$M1B-KP_Add> {incrfont 1}
2340 bind . <$M1B-minus> {incrfont -1}
2341 bind . <$M1B-KP_Subtract> {incrfont -1}
2342 wm protocol . WM_DELETE_WINDOW doquit
2343 bind . <Destroy> {stop_backends}
2344 bind . <Button-1> "click %W"
2345 bind $fstring <Key-Return> {dofind 1 1}
2346 bind $sha1entry <Key-Return> {gotocommit; break}
2347 bind $sha1entry <<PasteSelection>> clearsha1
2348 bind $cflist <1> {sel_flist %W %x %y; break}
2349 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2350 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2351 global ctxbut
2352 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2353 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2355 set maincursor [. cget -cursor]
2356 set textcursor [$ctext cget -cursor]
2357 set curtextcursor $textcursor
2359 set rowctxmenu .rowctxmenu
2360 makemenu $rowctxmenu {
2361 {mc "Diff this -> selected" command {diffvssel 0}}
2362 {mc "Diff selected -> this" command {diffvssel 1}}
2363 {mc "Make patch" command mkpatch}
2364 {mc "Create tag" command mktag}
2365 {mc "Write commit to file" command writecommit}
2366 {mc "Create new branch" command mkbranch}
2367 {mc "Cherry-pick this commit" command cherrypick}
2368 {mc "Reset HEAD branch to here" command resethead}
2369 {mc "Mark this commit" command markhere}
2370 {mc "Return to mark" command gotomark}
2371 {mc "Find descendant of this and mark" command find_common_desc}
2372 {mc "Compare with marked commit" command compare_commits}
2374 $rowctxmenu configure -tearoff 0
2376 set fakerowmenu .fakerowmenu
2377 makemenu $fakerowmenu {
2378 {mc "Diff this -> selected" command {diffvssel 0}}
2379 {mc "Diff selected -> this" command {diffvssel 1}}
2380 {mc "Make patch" command mkpatch}
2382 $fakerowmenu configure -tearoff 0
2384 set headctxmenu .headctxmenu
2385 makemenu $headctxmenu {
2386 {mc "Check out this branch" command cobranch}
2387 {mc "Remove this branch" command rmbranch}
2389 $headctxmenu configure -tearoff 0
2391 global flist_menu
2392 set flist_menu .flistctxmenu
2393 makemenu $flist_menu {
2394 {mc "Highlight this too" command {flist_hl 0}}
2395 {mc "Highlight this only" command {flist_hl 1}}
2396 {mc "External diff" command {external_diff}}
2397 {mc "Blame parent commit" command {external_blame 1}}
2399 $flist_menu configure -tearoff 0
2401 global diff_menu
2402 set diff_menu .diffctxmenu
2403 makemenu $diff_menu {
2404 {mc "Show origin of this line" command show_line_source}
2405 {mc "Run git gui blame on this line" command {external_blame_diff}}
2407 $diff_menu configure -tearoff 0
2410 # Windows sends all mouse wheel events to the current focused window, not
2411 # the one where the mouse hovers, so bind those events here and redirect
2412 # to the correct window
2413 proc windows_mousewheel_redirector {W X Y D} {
2414 global canv canv2 canv3
2415 set w [winfo containing -displayof $W $X $Y]
2416 if {$w ne ""} {
2417 set u [expr {$D < 0 ? 5 : -5}]
2418 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2419 allcanvs yview scroll $u units
2420 } else {
2421 catch {
2422 $w yview scroll $u units
2428 # Update row number label when selectedline changes
2429 proc selectedline_change {n1 n2 op} {
2430 global selectedline rownumsel
2432 if {$selectedline eq {}} {
2433 set rownumsel {}
2434 } else {
2435 set rownumsel [expr {$selectedline + 1}]
2439 # mouse-2 makes all windows scan vertically, but only the one
2440 # the cursor is in scans horizontally
2441 proc canvscan {op w x y} {
2442 global canv canv2 canv3
2443 foreach c [list $canv $canv2 $canv3] {
2444 if {$c == $w} {
2445 $c scan $op $x $y
2446 } else {
2447 $c scan $op 0 $y
2452 proc scrollcanv {cscroll f0 f1} {
2453 $cscroll set $f0 $f1
2454 drawvisible
2455 flushhighlights
2458 # when we make a key binding for the toplevel, make sure
2459 # it doesn't get triggered when that key is pressed in the
2460 # find string entry widget.
2461 proc bindkey {ev script} {
2462 global entries
2463 bind . $ev $script
2464 set escript [bind Entry $ev]
2465 if {$escript == {}} {
2466 set escript [bind Entry <Key>]
2468 foreach e $entries {
2469 bind $e $ev "$escript; break"
2473 # set the focus back to the toplevel for any click outside
2474 # the entry widgets
2475 proc click {w} {
2476 global ctext entries
2477 foreach e [concat $entries $ctext] {
2478 if {$w == $e} return
2480 focus .
2483 # Adjust the progress bar for a change in requested extent or canvas size
2484 proc adjustprogress {} {
2485 global progresscanv progressitem progresscoords
2486 global fprogitem fprogcoord lastprogupdate progupdatepending
2487 global rprogitem rprogcoord
2489 set w [expr {[winfo width $progresscanv] - 4}]
2490 set x0 [expr {$w * [lindex $progresscoords 0]}]
2491 set x1 [expr {$w * [lindex $progresscoords 1]}]
2492 set h [winfo height $progresscanv]
2493 $progresscanv coords $progressitem $x0 0 $x1 $h
2494 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2495 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2496 set now [clock clicks -milliseconds]
2497 if {$now >= $lastprogupdate + 100} {
2498 set progupdatepending 0
2499 update
2500 } elseif {!$progupdatepending} {
2501 set progupdatepending 1
2502 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2506 proc doprogupdate {} {
2507 global lastprogupdate progupdatepending
2509 if {$progupdatepending} {
2510 set progupdatepending 0
2511 set lastprogupdate [clock clicks -milliseconds]
2512 update
2516 proc savestuff {w} {
2517 global canv canv2 canv3 mainfont textfont uifont tabstop
2518 global stuffsaved findmergefiles maxgraphpct
2519 global maxwidth showneartags showlocalchanges
2520 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2521 global cmitmode wrapcomment datetimeformat limitdiffs
2522 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2523 global autoselect extdifftool perfile_attrs markbgcolor
2524 global hideremotes
2526 if {$stuffsaved} return
2527 if {![winfo viewable .]} return
2528 catch {
2529 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2530 set f [open "~/.gitk-new" w]
2531 if {$::tcl_platform(platform) eq {windows}} {
2532 file attributes "~/.gitk-new" -hidden true
2534 puts $f [list set mainfont $mainfont]
2535 puts $f [list set textfont $textfont]
2536 puts $f [list set uifont $uifont]
2537 puts $f [list set tabstop $tabstop]
2538 puts $f [list set findmergefiles $findmergefiles]
2539 puts $f [list set maxgraphpct $maxgraphpct]
2540 puts $f [list set maxwidth $maxwidth]
2541 puts $f [list set cmitmode $cmitmode]
2542 puts $f [list set wrapcomment $wrapcomment]
2543 puts $f [list set autoselect $autoselect]
2544 puts $f [list set showneartags $showneartags]
2545 puts $f [list set hideremotes $hideremotes]
2546 puts $f [list set showlocalchanges $showlocalchanges]
2547 puts $f [list set datetimeformat $datetimeformat]
2548 puts $f [list set limitdiffs $limitdiffs]
2549 puts $f [list set bgcolor $bgcolor]
2550 puts $f [list set fgcolor $fgcolor]
2551 puts $f [list set colors $colors]
2552 puts $f [list set diffcolors $diffcolors]
2553 puts $f [list set markbgcolor $markbgcolor]
2554 puts $f [list set diffcontext $diffcontext]
2555 puts $f [list set selectbgcolor $selectbgcolor]
2556 puts $f [list set extdifftool $extdifftool]
2557 puts $f [list set perfile_attrs $perfile_attrs]
2559 puts $f "set geometry(main) [wm geometry .]"
2560 puts $f "set geometry(state) [wm state .]"
2561 puts $f "set geometry(topwidth) [winfo width .tf]"
2562 puts $f "set geometry(topheight) [winfo height .tf]"
2563 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2564 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2565 puts $f "set geometry(botwidth) [winfo width .bleft]"
2566 puts $f "set geometry(botheight) [winfo height .bleft]"
2568 puts -nonewline $f "set permviews {"
2569 for {set v 0} {$v < $nextviewnum} {incr v} {
2570 if {$viewperm($v)} {
2571 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2574 puts $f "}"
2575 close $f
2576 file rename -force "~/.gitk-new" "~/.gitk"
2578 set stuffsaved 1
2581 proc resizeclistpanes {win w} {
2582 global oldwidth
2583 if {[info exists oldwidth($win)]} {
2584 set s0 [$win sash coord 0]
2585 set s1 [$win sash coord 1]
2586 if {$w < 60} {
2587 set sash0 [expr {int($w/2 - 2)}]
2588 set sash1 [expr {int($w*5/6 - 2)}]
2589 } else {
2590 set factor [expr {1.0 * $w / $oldwidth($win)}]
2591 set sash0 [expr {int($factor * [lindex $s0 0])}]
2592 set sash1 [expr {int($factor * [lindex $s1 0])}]
2593 if {$sash0 < 30} {
2594 set sash0 30
2596 if {$sash1 < $sash0 + 20} {
2597 set sash1 [expr {$sash0 + 20}]
2599 if {$sash1 > $w - 10} {
2600 set sash1 [expr {$w - 10}]
2601 if {$sash0 > $sash1 - 20} {
2602 set sash0 [expr {$sash1 - 20}]
2606 $win sash place 0 $sash0 [lindex $s0 1]
2607 $win sash place 1 $sash1 [lindex $s1 1]
2609 set oldwidth($win) $w
2612 proc resizecdetpanes {win w} {
2613 global oldwidth
2614 if {[info exists oldwidth($win)]} {
2615 set s0 [$win sash coord 0]
2616 if {$w < 60} {
2617 set sash0 [expr {int($w*3/4 - 2)}]
2618 } else {
2619 set factor [expr {1.0 * $w / $oldwidth($win)}]
2620 set sash0 [expr {int($factor * [lindex $s0 0])}]
2621 if {$sash0 < 45} {
2622 set sash0 45
2624 if {$sash0 > $w - 15} {
2625 set sash0 [expr {$w - 15}]
2628 $win sash place 0 $sash0 [lindex $s0 1]
2630 set oldwidth($win) $w
2633 proc allcanvs args {
2634 global canv canv2 canv3
2635 eval $canv $args
2636 eval $canv2 $args
2637 eval $canv3 $args
2640 proc bindall {event action} {
2641 global canv canv2 canv3
2642 bind $canv $event $action
2643 bind $canv2 $event $action
2644 bind $canv3 $event $action
2647 proc about {} {
2648 global uifont
2649 set w .about
2650 if {[winfo exists $w]} {
2651 raise $w
2652 return
2654 toplevel $w
2655 wm title $w [mc "About gitk"]
2656 make_transient $w .
2657 message $w.m -text [mc "
2658 Gitk - a commit viewer for git
2660 Copyright © 2005-2008 Paul Mackerras
2662 Use and redistribute under the terms of the GNU General Public License"] \
2663 -justify center -aspect 400 -border 2 -bg white -relief groove
2664 pack $w.m -side top -fill x -padx 2 -pady 2
2665 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2666 pack $w.ok -side bottom
2667 bind $w <Visibility> "focus $w.ok"
2668 bind $w <Key-Escape> "destroy $w"
2669 bind $w <Key-Return> "destroy $w"
2672 proc keys {} {
2673 set w .keys
2674 if {[winfo exists $w]} {
2675 raise $w
2676 return
2678 if {[tk windowingsystem] eq {aqua}} {
2679 set M1T Cmd
2680 } else {
2681 set M1T Ctrl
2683 toplevel $w
2684 wm title $w [mc "Gitk key bindings"]
2685 make_transient $w .
2686 message $w.m -text "
2687 [mc "Gitk key bindings:"]
2689 [mc "<%s-Q> Quit" $M1T]
2690 [mc "<Home> Move to first commit"]
2691 [mc "<End> Move to last commit"]
2692 [mc "<Up>, p, i Move up one commit"]
2693 [mc "<Down>, n, k Move down one commit"]
2694 [mc "<Left>, z, j Go back in history list"]
2695 [mc "<Right>, x, l Go forward in history list"]
2696 [mc "<PageUp> Move up one page in commit list"]
2697 [mc "<PageDown> Move down one page in commit list"]
2698 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2699 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2700 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2701 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2702 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2703 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2704 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2705 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2706 [mc "<Delete>, b Scroll diff view up one page"]
2707 [mc "<Backspace> Scroll diff view up one page"]
2708 [mc "<Space> Scroll diff view down one page"]
2709 [mc "u Scroll diff view up 18 lines"]
2710 [mc "d Scroll diff view down 18 lines"]
2711 [mc "<%s-F> Find" $M1T]
2712 [mc "<%s-G> Move to next find hit" $M1T]
2713 [mc "<Return> Move to next find hit"]
2714 [mc "/ Focus the search box"]
2715 [mc "? Move to previous find hit"]
2716 [mc "f Scroll diff view to next file"]
2717 [mc "<%s-S> Search for next hit in diff view" $M1T]
2718 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2719 [mc "<%s-KP+> Increase font size" $M1T]
2720 [mc "<%s-plus> Increase font size" $M1T]
2721 [mc "<%s-KP-> Decrease font size" $M1T]
2722 [mc "<%s-minus> Decrease font size" $M1T]
2723 [mc "<F5> Update"]
2725 -justify left -bg white -border 2 -relief groove
2726 pack $w.m -side top -fill both -padx 2 -pady 2
2727 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2728 bind $w <Key-Escape> [list destroy $w]
2729 pack $w.ok -side bottom
2730 bind $w <Visibility> "focus $w.ok"
2731 bind $w <Key-Escape> "destroy $w"
2732 bind $w <Key-Return> "destroy $w"
2735 # Procedures for manipulating the file list window at the
2736 # bottom right of the overall window.
2738 proc treeview {w l openlevs} {
2739 global treecontents treediropen treeheight treeparent treeindex
2741 set ix 0
2742 set treeindex() 0
2743 set lev 0
2744 set prefix {}
2745 set prefixend -1
2746 set prefendstack {}
2747 set htstack {}
2748 set ht 0
2749 set treecontents() {}
2750 $w conf -state normal
2751 foreach f $l {
2752 while {[string range $f 0 $prefixend] ne $prefix} {
2753 if {$lev <= $openlevs} {
2754 $w mark set e:$treeindex($prefix) "end -1c"
2755 $w mark gravity e:$treeindex($prefix) left
2757 set treeheight($prefix) $ht
2758 incr ht [lindex $htstack end]
2759 set htstack [lreplace $htstack end end]
2760 set prefixend [lindex $prefendstack end]
2761 set prefendstack [lreplace $prefendstack end end]
2762 set prefix [string range $prefix 0 $prefixend]
2763 incr lev -1
2765 set tail [string range $f [expr {$prefixend+1}] end]
2766 while {[set slash [string first "/" $tail]] >= 0} {
2767 lappend htstack $ht
2768 set ht 0
2769 lappend prefendstack $prefixend
2770 incr prefixend [expr {$slash + 1}]
2771 set d [string range $tail 0 $slash]
2772 lappend treecontents($prefix) $d
2773 set oldprefix $prefix
2774 append prefix $d
2775 set treecontents($prefix) {}
2776 set treeindex($prefix) [incr ix]
2777 set treeparent($prefix) $oldprefix
2778 set tail [string range $tail [expr {$slash+1}] end]
2779 if {$lev <= $openlevs} {
2780 set ht 1
2781 set treediropen($prefix) [expr {$lev < $openlevs}]
2782 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2783 $w mark set d:$ix "end -1c"
2784 $w mark gravity d:$ix left
2785 set str "\n"
2786 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2787 $w insert end $str
2788 $w image create end -align center -image $bm -padx 1 \
2789 -name a:$ix
2790 $w insert end $d [highlight_tag $prefix]
2791 $w mark set s:$ix "end -1c"
2792 $w mark gravity s:$ix left
2794 incr lev
2796 if {$tail ne {}} {
2797 if {$lev <= $openlevs} {
2798 incr ht
2799 set str "\n"
2800 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2801 $w insert end $str
2802 $w insert end $tail [highlight_tag $f]
2804 lappend treecontents($prefix) $tail
2807 while {$htstack ne {}} {
2808 set treeheight($prefix) $ht
2809 incr ht [lindex $htstack end]
2810 set htstack [lreplace $htstack end end]
2811 set prefixend [lindex $prefendstack end]
2812 set prefendstack [lreplace $prefendstack end end]
2813 set prefix [string range $prefix 0 $prefixend]
2815 $w conf -state disabled
2818 proc linetoelt {l} {
2819 global treeheight treecontents
2821 set y 2
2822 set prefix {}
2823 while {1} {
2824 foreach e $treecontents($prefix) {
2825 if {$y == $l} {
2826 return "$prefix$e"
2828 set n 1
2829 if {[string index $e end] eq "/"} {
2830 set n $treeheight($prefix$e)
2831 if {$y + $n > $l} {
2832 append prefix $e
2833 incr y
2834 break
2837 incr y $n
2842 proc highlight_tree {y prefix} {
2843 global treeheight treecontents cflist
2845 foreach e $treecontents($prefix) {
2846 set path $prefix$e
2847 if {[highlight_tag $path] ne {}} {
2848 $cflist tag add bold $y.0 "$y.0 lineend"
2850 incr y
2851 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2852 set y [highlight_tree $y $path]
2855 return $y
2858 proc treeclosedir {w dir} {
2859 global treediropen treeheight treeparent treeindex
2861 set ix $treeindex($dir)
2862 $w conf -state normal
2863 $w delete s:$ix e:$ix
2864 set treediropen($dir) 0
2865 $w image configure a:$ix -image tri-rt
2866 $w conf -state disabled
2867 set n [expr {1 - $treeheight($dir)}]
2868 while {$dir ne {}} {
2869 incr treeheight($dir) $n
2870 set dir $treeparent($dir)
2874 proc treeopendir {w dir} {
2875 global treediropen treeheight treeparent treecontents treeindex
2877 set ix $treeindex($dir)
2878 $w conf -state normal
2879 $w image configure a:$ix -image tri-dn
2880 $w mark set e:$ix s:$ix
2881 $w mark gravity e:$ix right
2882 set lev 0
2883 set str "\n"
2884 set n [llength $treecontents($dir)]
2885 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2886 incr lev
2887 append str "\t"
2888 incr treeheight($x) $n
2890 foreach e $treecontents($dir) {
2891 set de $dir$e
2892 if {[string index $e end] eq "/"} {
2893 set iy $treeindex($de)
2894 $w mark set d:$iy e:$ix
2895 $w mark gravity d:$iy left
2896 $w insert e:$ix $str
2897 set treediropen($de) 0
2898 $w image create e:$ix -align center -image tri-rt -padx 1 \
2899 -name a:$iy
2900 $w insert e:$ix $e [highlight_tag $de]
2901 $w mark set s:$iy e:$ix
2902 $w mark gravity s:$iy left
2903 set treeheight($de) 1
2904 } else {
2905 $w insert e:$ix $str
2906 $w insert e:$ix $e [highlight_tag $de]
2909 $w mark gravity e:$ix right
2910 $w conf -state disabled
2911 set treediropen($dir) 1
2912 set top [lindex [split [$w index @0,0] .] 0]
2913 set ht [$w cget -height]
2914 set l [lindex [split [$w index s:$ix] .] 0]
2915 if {$l < $top} {
2916 $w yview $l.0
2917 } elseif {$l + $n + 1 > $top + $ht} {
2918 set top [expr {$l + $n + 2 - $ht}]
2919 if {$l < $top} {
2920 set top $l
2922 $w yview $top.0
2926 proc treeclick {w x y} {
2927 global treediropen cmitmode ctext cflist cflist_top
2929 if {$cmitmode ne "tree"} return
2930 if {![info exists cflist_top]} return
2931 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2932 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2933 $cflist tag add highlight $l.0 "$l.0 lineend"
2934 set cflist_top $l
2935 if {$l == 1} {
2936 $ctext yview 1.0
2937 return
2939 set e [linetoelt $l]
2940 if {[string index $e end] ne "/"} {
2941 showfile $e
2942 } elseif {$treediropen($e)} {
2943 treeclosedir $w $e
2944 } else {
2945 treeopendir $w $e
2949 proc setfilelist {id} {
2950 global treefilelist cflist jump_to_here
2952 treeview $cflist $treefilelist($id) 0
2953 if {$jump_to_here ne {}} {
2954 set f [lindex $jump_to_here 0]
2955 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2956 showfile $f
2961 image create bitmap tri-rt -background black -foreground blue -data {
2962 #define tri-rt_width 13
2963 #define tri-rt_height 13
2964 static unsigned char tri-rt_bits[] = {
2965 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2966 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2967 0x00, 0x00};
2968 } -maskdata {
2969 #define tri-rt-mask_width 13
2970 #define tri-rt-mask_height 13
2971 static unsigned char tri-rt-mask_bits[] = {
2972 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2973 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2974 0x08, 0x00};
2976 image create bitmap tri-dn -background black -foreground blue -data {
2977 #define tri-dn_width 13
2978 #define tri-dn_height 13
2979 static unsigned char tri-dn_bits[] = {
2980 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2981 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2982 0x00, 0x00};
2983 } -maskdata {
2984 #define tri-dn-mask_width 13
2985 #define tri-dn-mask_height 13
2986 static unsigned char tri-dn-mask_bits[] = {
2987 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2988 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2989 0x00, 0x00};
2992 image create bitmap reficon-T -background black -foreground yellow -data {
2993 #define tagicon_width 13
2994 #define tagicon_height 9
2995 static unsigned char tagicon_bits[] = {
2996 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2997 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2998 } -maskdata {
2999 #define tagicon-mask_width 13
3000 #define tagicon-mask_height 9
3001 static unsigned char tagicon-mask_bits[] = {
3002 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3003 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3005 set rectdata {
3006 #define headicon_width 13
3007 #define headicon_height 9
3008 static unsigned char headicon_bits[] = {
3009 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3010 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3012 set rectmask {
3013 #define headicon-mask_width 13
3014 #define headicon-mask_height 9
3015 static unsigned char headicon-mask_bits[] = {
3016 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3017 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3019 image create bitmap reficon-H -background black -foreground green \
3020 -data $rectdata -maskdata $rectmask
3021 image create bitmap reficon-o -background black -foreground "#ddddff" \
3022 -data $rectdata -maskdata $rectmask
3024 proc init_flist {first} {
3025 global cflist cflist_top difffilestart
3027 $cflist conf -state normal
3028 $cflist delete 0.0 end
3029 if {$first ne {}} {
3030 $cflist insert end $first
3031 set cflist_top 1
3032 $cflist tag add highlight 1.0 "1.0 lineend"
3033 } else {
3034 catch {unset cflist_top}
3036 $cflist conf -state disabled
3037 set difffilestart {}
3040 proc highlight_tag {f} {
3041 global highlight_paths
3043 foreach p $highlight_paths {
3044 if {[string match $p $f]} {
3045 return "bold"
3048 return {}
3051 proc highlight_filelist {} {
3052 global cmitmode cflist
3054 $cflist conf -state normal
3055 if {$cmitmode ne "tree"} {
3056 set end [lindex [split [$cflist index end] .] 0]
3057 for {set l 2} {$l < $end} {incr l} {
3058 set line [$cflist get $l.0 "$l.0 lineend"]
3059 if {[highlight_tag $line] ne {}} {
3060 $cflist tag add bold $l.0 "$l.0 lineend"
3063 } else {
3064 highlight_tree 2 {}
3066 $cflist conf -state disabled
3069 proc unhighlight_filelist {} {
3070 global cflist
3072 $cflist conf -state normal
3073 $cflist tag remove bold 1.0 end
3074 $cflist conf -state disabled
3077 proc add_flist {fl} {
3078 global cflist
3080 $cflist conf -state normal
3081 foreach f $fl {
3082 $cflist insert end "\n"
3083 $cflist insert end $f [highlight_tag $f]
3085 $cflist conf -state disabled
3088 proc sel_flist {w x y} {
3089 global ctext difffilestart cflist cflist_top cmitmode
3091 if {$cmitmode eq "tree"} return
3092 if {![info exists cflist_top]} return
3093 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3094 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3095 $cflist tag add highlight $l.0 "$l.0 lineend"
3096 set cflist_top $l
3097 if {$l == 1} {
3098 $ctext yview 1.0
3099 } else {
3100 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3104 proc pop_flist_menu {w X Y x y} {
3105 global ctext cflist cmitmode flist_menu flist_menu_file
3106 global treediffs diffids
3108 stopfinding
3109 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3110 if {$l <= 1} return
3111 if {$cmitmode eq "tree"} {
3112 set e [linetoelt $l]
3113 if {[string index $e end] eq "/"} return
3114 } else {
3115 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3117 set flist_menu_file $e
3118 set xdiffstate "normal"
3119 if {$cmitmode eq "tree"} {
3120 set xdiffstate "disabled"
3122 # Disable "External diff" item in tree mode
3123 $flist_menu entryconf 2 -state $xdiffstate
3124 tk_popup $flist_menu $X $Y
3127 proc find_ctext_fileinfo {line} {
3128 global ctext_file_names ctext_file_lines
3130 set ok [bsearch $ctext_file_lines $line]
3131 set tline [lindex $ctext_file_lines $ok]
3133 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3134 return {}
3135 } else {
3136 return [list [lindex $ctext_file_names $ok] $tline]
3140 proc pop_diff_menu {w X Y x y} {
3141 global ctext diff_menu flist_menu_file
3142 global diff_menu_txtpos diff_menu_line
3143 global diff_menu_filebase
3145 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3146 set diff_menu_line [lindex $diff_menu_txtpos 0]
3147 # don't pop up the menu on hunk-separator or file-separator lines
3148 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3149 return
3151 stopfinding
3152 set f [find_ctext_fileinfo $diff_menu_line]
3153 if {$f eq {}} return
3154 set flist_menu_file [lindex $f 0]
3155 set diff_menu_filebase [lindex $f 1]
3156 tk_popup $diff_menu $X $Y
3159 proc flist_hl {only} {
3160 global flist_menu_file findstring gdttype
3162 set x [shellquote $flist_menu_file]
3163 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3164 set findstring $x
3165 } else {
3166 append findstring " " $x
3168 set gdttype [mc "touching paths:"]
3171 proc gitknewtmpdir {} {
3172 global diffnum gitktmpdir gitdir
3174 if {![info exists gitktmpdir]} {
3175 set gitktmpdir [file join [file dirname $gitdir] \
3176 [format ".gitk-tmp.%s" [pid]]]
3177 if {[catch {file mkdir $gitktmpdir} err]} {
3178 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3179 unset gitktmpdir
3180 return {}
3182 set diffnum 0
3184 incr diffnum
3185 set diffdir [file join $gitktmpdir $diffnum]
3186 if {[catch {file mkdir $diffdir} err]} {
3187 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3188 return {}
3190 return $diffdir
3193 proc save_file_from_commit {filename output what} {
3194 global nullfile
3196 if {[catch {exec git show $filename -- > $output} err]} {
3197 if {[string match "fatal: bad revision *" $err]} {
3198 return $nullfile
3200 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3201 return {}
3203 return $output
3206 proc external_diff_get_one_file {diffid filename diffdir} {
3207 global nullid nullid2 nullfile
3208 global gitdir
3210 if {$diffid == $nullid} {
3211 set difffile [file join [file dirname $gitdir] $filename]
3212 if {[file exists $difffile]} {
3213 return $difffile
3215 return $nullfile
3217 if {$diffid == $nullid2} {
3218 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3219 return [save_file_from_commit :$filename $difffile index]
3221 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3222 return [save_file_from_commit $diffid:$filename $difffile \
3223 "revision $diffid"]
3226 proc external_diff {} {
3227 global nullid nullid2
3228 global flist_menu_file
3229 global diffids
3230 global extdifftool
3232 if {[llength $diffids] == 1} {
3233 # no reference commit given
3234 set diffidto [lindex $diffids 0]
3235 if {$diffidto eq $nullid} {
3236 # diffing working copy with index
3237 set diffidfrom $nullid2
3238 } elseif {$diffidto eq $nullid2} {
3239 # diffing index with HEAD
3240 set diffidfrom "HEAD"
3241 } else {
3242 # use first parent commit
3243 global parentlist selectedline
3244 set diffidfrom [lindex $parentlist $selectedline 0]
3246 } else {
3247 set diffidfrom [lindex $diffids 0]
3248 set diffidto [lindex $diffids 1]
3251 # make sure that several diffs wont collide
3252 set diffdir [gitknewtmpdir]
3253 if {$diffdir eq {}} return
3255 # gather files to diff
3256 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3257 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3259 if {$difffromfile ne {} && $difftofile ne {}} {
3260 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3261 if {[catch {set fl [open |$cmd r]} err]} {
3262 file delete -force $diffdir
3263 error_popup "$extdifftool: [mc "command failed:"] $err"
3264 } else {
3265 fconfigure $fl -blocking 0
3266 filerun $fl [list delete_at_eof $fl $diffdir]
3271 proc find_hunk_blamespec {base line} {
3272 global ctext
3274 # Find and parse the hunk header
3275 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3276 if {$s_lix eq {}} return
3278 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3279 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3280 s_line old_specs osz osz1 new_line nsz]} {
3281 return
3284 # base lines for the parents
3285 set base_lines [list $new_line]
3286 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3287 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3288 old_spec old_line osz]} {
3289 return
3291 lappend base_lines $old_line
3294 # Now scan the lines to determine offset within the hunk
3295 set max_parent [expr {[llength $base_lines]-2}]
3296 set dline 0
3297 set s_lno [lindex [split $s_lix "."] 0]
3299 # Determine if the line is removed
3300 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3301 if {[string match {[-+ ]*} $chunk]} {
3302 set removed_idx [string first "-" $chunk]
3303 # Choose a parent index
3304 if {$removed_idx >= 0} {
3305 set parent $removed_idx
3306 } else {
3307 set unchanged_idx [string first " " $chunk]
3308 if {$unchanged_idx >= 0} {
3309 set parent $unchanged_idx
3310 } else {
3311 # blame the current commit
3312 set parent -1
3315 # then count other lines that belong to it
3316 for {set i $line} {[incr i -1] > $s_lno} {} {
3317 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3318 # Determine if the line is removed
3319 set removed_idx [string first "-" $chunk]
3320 if {$parent >= 0} {
3321 set code [string index $chunk $parent]
3322 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3323 incr dline
3325 } else {
3326 if {$removed_idx < 0} {
3327 incr dline
3331 incr parent
3332 } else {
3333 set parent 0
3336 incr dline [lindex $base_lines $parent]
3337 return [list $parent $dline]
3340 proc external_blame_diff {} {
3341 global currentid cmitmode
3342 global diff_menu_txtpos diff_menu_line
3343 global diff_menu_filebase flist_menu_file
3345 if {$cmitmode eq "tree"} {
3346 set parent_idx 0
3347 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3348 } else {
3349 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3350 if {$hinfo ne {}} {
3351 set parent_idx [lindex $hinfo 0]
3352 set line [lindex $hinfo 1]
3353 } else {
3354 set parent_idx 0
3355 set line 0
3359 external_blame $parent_idx $line
3362 # Find the SHA1 ID of the blob for file $fname in the index
3363 # at stage 0 or 2
3364 proc index_sha1 {fname} {
3365 set f [open [list | git ls-files -s $fname] r]
3366 while {[gets $f line] >= 0} {
3367 set info [lindex [split $line "\t"] 0]
3368 set stage [lindex $info 2]
3369 if {$stage eq "0" || $stage eq "2"} {
3370 close $f
3371 return [lindex $info 1]
3374 close $f
3375 return {}
3378 # Turn an absolute path into one relative to the current directory
3379 proc make_relative {f} {
3380 set elts [file split $f]
3381 set here [file split [pwd]]
3382 set ei 0
3383 set hi 0
3384 set res {}
3385 foreach d $here {
3386 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3387 lappend res ".."
3388 } else {
3389 incr ei
3391 incr hi
3393 set elts [concat $res [lrange $elts $ei end]]
3394 return [eval file join $elts]
3397 proc external_blame {parent_idx {line {}}} {
3398 global flist_menu_file gitdir
3399 global nullid nullid2
3400 global parentlist selectedline currentid
3402 if {$parent_idx > 0} {
3403 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3404 } else {
3405 set base_commit $currentid
3408 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3409 error_popup [mc "No such commit"]
3410 return
3413 set cmdline [list git gui blame]
3414 if {$line ne {} && $line > 1} {
3415 lappend cmdline "--line=$line"
3417 set f [file join [file dirname $gitdir] $flist_menu_file]
3418 # Unfortunately it seems git gui blame doesn't like
3419 # being given an absolute path...
3420 set f [make_relative $f]
3421 lappend cmdline $base_commit $f
3422 if {[catch {eval exec $cmdline &} err]} {
3423 error_popup "[mc "git gui blame: command failed:"] $err"
3427 proc show_line_source {} {
3428 global cmitmode currentid parents curview blamestuff blameinst
3429 global diff_menu_line diff_menu_filebase flist_menu_file
3430 global nullid nullid2 gitdir
3432 set from_index {}
3433 if {$cmitmode eq "tree"} {
3434 set id $currentid
3435 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3436 } else {
3437 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3438 if {$h eq {}} return
3439 set pi [lindex $h 0]
3440 if {$pi == 0} {
3441 mark_ctext_line $diff_menu_line
3442 return
3444 incr pi -1
3445 if {$currentid eq $nullid} {
3446 if {$pi > 0} {
3447 # must be a merge in progress...
3448 if {[catch {
3449 # get the last line from .git/MERGE_HEAD
3450 set f [open [file join $gitdir MERGE_HEAD] r]
3451 set id [lindex [split [read $f] "\n"] end-1]
3452 close $f
3453 } err]} {
3454 error_popup [mc "Couldn't read merge head: %s" $err]
3455 return
3457 } elseif {$parents($curview,$currentid) eq $nullid2} {
3458 # need to do the blame from the index
3459 if {[catch {
3460 set from_index [index_sha1 $flist_menu_file]
3461 } err]} {
3462 error_popup [mc "Error reading index: %s" $err]
3463 return
3465 } else {
3466 set id $parents($curview,$currentid)
3468 } else {
3469 set id [lindex $parents($curview,$currentid) $pi]
3471 set line [lindex $h 1]
3473 set blameargs {}
3474 if {$from_index ne {}} {
3475 lappend blameargs | git cat-file blob $from_index
3477 lappend blameargs | git blame -p -L$line,+1
3478 if {$from_index ne {}} {
3479 lappend blameargs --contents -
3480 } else {
3481 lappend blameargs $id
3483 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3484 if {[catch {
3485 set f [open $blameargs r]
3486 } err]} {
3487 error_popup [mc "Couldn't start git blame: %s" $err]
3488 return
3490 nowbusy blaming [mc "Searching"]
3491 fconfigure $f -blocking 0
3492 set i [reg_instance $f]
3493 set blamestuff($i) {}
3494 set blameinst $i
3495 filerun $f [list read_line_source $f $i]
3498 proc stopblaming {} {
3499 global blameinst
3501 if {[info exists blameinst]} {
3502 stop_instance $blameinst
3503 unset blameinst
3504 notbusy blaming
3508 proc read_line_source {fd inst} {
3509 global blamestuff curview commfd blameinst nullid nullid2
3511 while {[gets $fd line] >= 0} {
3512 lappend blamestuff($inst) $line
3514 if {![eof $fd]} {
3515 return 1
3517 unset commfd($inst)
3518 unset blameinst
3519 notbusy blaming
3520 fconfigure $fd -blocking 1
3521 if {[catch {close $fd} err]} {
3522 error_popup [mc "Error running git blame: %s" $err]
3523 return 0
3526 set fname {}
3527 set line [split [lindex $blamestuff($inst) 0] " "]
3528 set id [lindex $line 0]
3529 set lnum [lindex $line 1]
3530 if {[string length $id] == 40 && [string is xdigit $id] &&
3531 [string is digit -strict $lnum]} {
3532 # look for "filename" line
3533 foreach l $blamestuff($inst) {
3534 if {[string match "filename *" $l]} {
3535 set fname [string range $l 9 end]
3536 break
3540 if {$fname ne {}} {
3541 # all looks good, select it
3542 if {$id eq $nullid} {
3543 # blame uses all-zeroes to mean not committed,
3544 # which would mean a change in the index
3545 set id $nullid2
3547 if {[commitinview $id $curview]} {
3548 selectline [rowofcommit $id] 1 [list $fname $lnum]
3549 } else {
3550 error_popup [mc "That line comes from commit %s, \
3551 which is not in this view" [shortids $id]]
3553 } else {
3554 puts "oops couldn't parse git blame output"
3556 return 0
3559 # delete $dir when we see eof on $f (presumably because the child has exited)
3560 proc delete_at_eof {f dir} {
3561 while {[gets $f line] >= 0} {}
3562 if {[eof $f]} {
3563 if {[catch {close $f} err]} {
3564 error_popup "[mc "External diff viewer failed:"] $err"
3566 file delete -force $dir
3567 return 0
3569 return 1
3572 # Functions for adding and removing shell-type quoting
3574 proc shellquote {str} {
3575 if {![string match "*\['\"\\ \t]*" $str]} {
3576 return $str
3578 if {![string match "*\['\"\\]*" $str]} {
3579 return "\"$str\""
3581 if {![string match "*'*" $str]} {
3582 return "'$str'"
3584 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3587 proc shellarglist {l} {
3588 set str {}
3589 foreach a $l {
3590 if {$str ne {}} {
3591 append str " "
3593 append str [shellquote $a]
3595 return $str
3598 proc shelldequote {str} {
3599 set ret {}
3600 set used -1
3601 while {1} {
3602 incr used
3603 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3604 append ret [string range $str $used end]
3605 set used [string length $str]
3606 break
3608 set first [lindex $first 0]
3609 set ch [string index $str $first]
3610 if {$first > $used} {
3611 append ret [string range $str $used [expr {$first - 1}]]
3612 set used $first
3614 if {$ch eq " " || $ch eq "\t"} break
3615 incr used
3616 if {$ch eq "'"} {
3617 set first [string first "'" $str $used]
3618 if {$first < 0} {
3619 error "unmatched single-quote"
3621 append ret [string range $str $used [expr {$first - 1}]]
3622 set used $first
3623 continue
3625 if {$ch eq "\\"} {
3626 if {$used >= [string length $str]} {
3627 error "trailing backslash"
3629 append ret [string index $str $used]
3630 continue
3632 # here ch == "\""
3633 while {1} {
3634 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3635 error "unmatched double-quote"
3637 set first [lindex $first 0]
3638 set ch [string index $str $first]
3639 if {$first > $used} {
3640 append ret [string range $str $used [expr {$first - 1}]]
3641 set used $first
3643 if {$ch eq "\""} break
3644 incr used
3645 append ret [string index $str $used]
3646 incr used
3649 return [list $used $ret]
3652 proc shellsplit {str} {
3653 set l {}
3654 while {1} {
3655 set str [string trimleft $str]
3656 if {$str eq {}} break
3657 set dq [shelldequote $str]
3658 set n [lindex $dq 0]
3659 set word [lindex $dq 1]
3660 set str [string range $str $n end]
3661 lappend l $word
3663 return $l
3666 # Code to implement multiple views
3668 proc newview {ishighlight} {
3669 global nextviewnum newviewname newishighlight
3670 global revtreeargs viewargscmd newviewopts curview
3672 set newishighlight $ishighlight
3673 set top .gitkview
3674 if {[winfo exists $top]} {
3675 raise $top
3676 return
3678 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3679 set newviewopts($nextviewnum,perm) 0
3680 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3681 decode_view_opts $nextviewnum $revtreeargs
3682 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3685 set known_view_options {
3686 {perm b . {} {mc "Remember this view"}}
3687 {reflabel l + {} {mc "References (space separated list):"}}
3688 {refs t15 .. {} {mc "Branches & tags:"}}
3689 {allrefs b *. "--all" {mc "All refs"}}
3690 {branches b . "--branches" {mc "All (local) branches"}}
3691 {tags b . "--tags" {mc "All tags"}}
3692 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3693 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3694 {author t15 .. "--author=*" {mc "Author:"}}
3695 {committer t15 . "--committer=*" {mc "Committer:"}}
3696 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3697 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3698 {changes_l l + {} {mc "Changes to Files:"}}
3699 {pickaxe_s r0 . {} {mc "Fixed String"}}
3700 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3701 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3702 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3703 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3704 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3705 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3706 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3707 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3708 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3709 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3710 {lright b . "--left-right" {mc "Mark branch sides"}}
3711 {first b . "--first-parent" {mc "Limit to first parent"}}
3712 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3713 {args t50 *. {} {mc "Additional arguments to git log:"}}
3714 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3715 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3718 proc encode_view_opts {n} {
3719 global known_view_options newviewopts
3721 set rargs [list]
3722 foreach opt $known_view_options {
3723 set patterns [lindex $opt 3]
3724 if {$patterns eq {}} continue
3725 set pattern [lindex $patterns 0]
3727 if {[lindex $opt 1] eq "b"} {
3728 set val $newviewopts($n,[lindex $opt 0])
3729 if {$val} {
3730 lappend rargs $pattern
3732 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3733 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3734 set val $newviewopts($n,$button_id)
3735 if {$val eq $value} {
3736 lappend rargs $pattern
3738 } else {
3739 set val $newviewopts($n,[lindex $opt 0])
3740 set val [string trim $val]
3741 if {$val ne {}} {
3742 set pfix [string range $pattern 0 end-1]
3743 lappend rargs $pfix$val
3747 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3748 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3751 proc decode_view_opts {n view_args} {
3752 global known_view_options newviewopts
3754 foreach opt $known_view_options {
3755 set id [lindex $opt 0]
3756 if {[lindex $opt 1] eq "b"} {
3757 # Checkboxes
3758 set val 0
3759 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3760 # Radiobuttons
3761 regexp {^(.*_)} $id uselessvar id
3762 set val 0
3763 } else {
3764 # Text fields
3765 set val {}
3767 set newviewopts($n,$id) $val
3769 set oargs [list]
3770 set refargs [list]
3771 foreach arg $view_args {
3772 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3773 && ![info exists found(limit)]} {
3774 set newviewopts($n,limit) $cnt
3775 set found(limit) 1
3776 continue
3778 catch { unset val }
3779 foreach opt $known_view_options {
3780 set id [lindex $opt 0]
3781 if {[info exists found($id)]} continue
3782 foreach pattern [lindex $opt 3] {
3783 if {![string match $pattern $arg]} continue
3784 if {[lindex $opt 1] eq "b"} {
3785 # Check buttons
3786 set val 1
3787 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3788 # Radio buttons
3789 regexp {^(.*_)} $id uselessvar id
3790 set val $num
3791 } else {
3792 # Text input fields
3793 set size [string length $pattern]
3794 set val [string range $arg [expr {$size-1}] end]
3796 set newviewopts($n,$id) $val
3797 set found($id) 1
3798 break
3800 if {[info exists val]} break
3802 if {[info exists val]} continue
3803 if {[regexp {^-} $arg]} {
3804 lappend oargs $arg
3805 } else {
3806 lappend refargs $arg
3809 set newviewopts($n,refs) [shellarglist $refargs]
3810 set newviewopts($n,args) [shellarglist $oargs]
3813 proc edit_or_newview {} {
3814 global curview
3816 if {$curview > 0} {
3817 editview
3818 } else {
3819 newview 0
3823 proc editview {} {
3824 global curview
3825 global viewname viewperm newviewname newviewopts
3826 global viewargs viewargscmd
3828 set top .gitkvedit-$curview
3829 if {[winfo exists $top]} {
3830 raise $top
3831 return
3833 set newviewname($curview) $viewname($curview)
3834 set newviewopts($curview,perm) $viewperm($curview)
3835 set newviewopts($curview,cmd) $viewargscmd($curview)
3836 decode_view_opts $curview $viewargs($curview)
3837 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3840 proc vieweditor {top n title} {
3841 global newviewname newviewopts viewfiles bgcolor
3842 global known_view_options
3844 toplevel $top
3845 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3846 make_transient $top .
3848 # View name
3849 frame $top.nfr
3850 label $top.nl -text [mc "View Name:"]
3851 entry $top.name -width 20 -textvariable newviewname($n)
3852 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3853 pack $top.nl -in $top.nfr -side left -padx {0 5}
3854 pack $top.name -in $top.nfr -side left -padx {0 25}
3856 # View options
3857 set cframe $top.nfr
3858 set cexpand 0
3859 set cnt 0
3860 foreach opt $known_view_options {
3861 set id [lindex $opt 0]
3862 set type [lindex $opt 1]
3863 set flags [lindex $opt 2]
3864 set title [eval [lindex $opt 4]]
3865 set lxpad 0
3867 if {$flags eq "+" || $flags eq "*"} {
3868 set cframe $top.fr$cnt
3869 incr cnt
3870 frame $cframe
3871 pack $cframe -in $top -fill x -pady 3 -padx 3
3872 set cexpand [expr {$flags eq "*"}]
3873 } elseif {$flags eq ".." || $flags eq "*."} {
3874 set cframe $top.fr$cnt
3875 incr cnt
3876 frame $cframe
3877 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
3878 set cexpand [expr {$flags eq "*."}]
3879 } else {
3880 set lxpad 5
3883 if {$type eq "l"} {
3884 label $cframe.l_$id -text $title
3885 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
3886 } elseif {$type eq "b"} {
3887 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3888 pack $cframe.c_$id -in $cframe -side left \
3889 -padx [list $lxpad 0] -expand $cexpand -anchor w
3890 } elseif {[regexp {^r(\d+)$} $type type sz]} {
3891 regexp {^(.*_)} $id uselessvar button_id
3892 radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
3893 pack $cframe.c_$id -in $cframe -side left \
3894 -padx [list $lxpad 0] -expand $cexpand -anchor w
3895 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3896 message $cframe.l_$id -aspect 1500 -text $title
3897 entry $cframe.e_$id -width $sz -background $bgcolor \
3898 -textvariable newviewopts($n,$id)
3899 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3900 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3901 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3902 message $cframe.l_$id -aspect 1500 -text $title
3903 entry $cframe.e_$id -width $sz -background $bgcolor \
3904 -textvariable newviewopts($n,$id)
3905 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3906 pack $cframe.e_$id -in $cframe -side top -fill x
3907 } elseif {$type eq "path"} {
3908 message $top.l -aspect 1500 -text $title
3909 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
3910 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3911 if {[info exists viewfiles($n)]} {
3912 foreach f $viewfiles($n) {
3913 $top.t insert end $f
3914 $top.t insert end "\n"
3916 $top.t delete {end - 1c} end
3917 $top.t mark set insert 0.0
3919 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3923 frame $top.buts
3924 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3925 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3926 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3927 bind $top <Control-Return> [list newviewok $top $n]
3928 bind $top <F5> [list newviewok $top $n 1]
3929 bind $top <Escape> [list destroy $top]
3930 grid $top.buts.ok $top.buts.apply $top.buts.can
3931 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3932 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3933 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3934 pack $top.buts -in $top -side top -fill x
3935 focus $top.t
3938 proc doviewmenu {m first cmd op argv} {
3939 set nmenu [$m index end]
3940 for {set i $first} {$i <= $nmenu} {incr i} {
3941 if {[$m entrycget $i -command] eq $cmd} {
3942 eval $m $op $i $argv
3943 break
3948 proc allviewmenus {n op args} {
3949 # global viewhlmenu
3951 doviewmenu .bar.view 5 [list showview $n] $op $args
3952 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3955 proc newviewok {top n {apply 0}} {
3956 global nextviewnum newviewperm newviewname newishighlight
3957 global viewname viewfiles viewperm selectedview curview
3958 global viewargs viewargscmd newviewopts viewhlmenu
3960 if {[catch {
3961 set newargs [encode_view_opts $n]
3962 } err]} {
3963 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3964 return
3966 set files {}
3967 foreach f [split [$top.t get 0.0 end] "\n"] {
3968 set ft [string trim $f]
3969 if {$ft ne {}} {
3970 lappend files $ft
3973 if {![info exists viewfiles($n)]} {
3974 # creating a new view
3975 incr nextviewnum
3976 set viewname($n) $newviewname($n)
3977 set viewperm($n) $newviewopts($n,perm)
3978 set viewfiles($n) $files
3979 set viewargs($n) $newargs
3980 set viewargscmd($n) $newviewopts($n,cmd)
3981 addviewmenu $n
3982 if {!$newishighlight} {
3983 run showview $n
3984 } else {
3985 run addvhighlight $n
3987 } else {
3988 # editing an existing view
3989 set viewperm($n) $newviewopts($n,perm)
3990 if {$newviewname($n) ne $viewname($n)} {
3991 set viewname($n) $newviewname($n)
3992 doviewmenu .bar.view 5 [list showview $n] \
3993 entryconf [list -label $viewname($n)]
3994 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3995 # entryconf [list -label $viewname($n) -value $viewname($n)]
3997 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3998 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3999 set viewfiles($n) $files
4000 set viewargs($n) $newargs
4001 set viewargscmd($n) $newviewopts($n,cmd)
4002 if {$curview == $n} {
4003 run reloadcommits
4007 if {$apply} return
4008 catch {destroy $top}
4011 proc delview {} {
4012 global curview viewperm hlview selectedhlview
4014 if {$curview == 0} return
4015 if {[info exists hlview] && $hlview == $curview} {
4016 set selectedhlview [mc "None"]
4017 unset hlview
4019 allviewmenus $curview delete
4020 set viewperm($curview) 0
4021 showview 0
4024 proc addviewmenu {n} {
4025 global viewname viewhlmenu
4027 .bar.view add radiobutton -label $viewname($n) \
4028 -command [list showview $n] -variable selectedview -value $n
4029 #$viewhlmenu add radiobutton -label $viewname($n) \
4030 # -command [list addvhighlight $n] -variable selectedhlview
4033 proc showview {n} {
4034 global curview cached_commitrow ordertok
4035 global displayorder parentlist rowidlist rowisopt rowfinal
4036 global colormap rowtextx nextcolor canvxmax
4037 global numcommits viewcomplete
4038 global selectedline currentid canv canvy0
4039 global treediffs
4040 global pending_select mainheadid
4041 global commitidx
4042 global selectedview
4043 global hlview selectedhlview commitinterest
4045 if {$n == $curview} return
4046 set selid {}
4047 set ymax [lindex [$canv cget -scrollregion] 3]
4048 set span [$canv yview]
4049 set ytop [expr {[lindex $span 0] * $ymax}]
4050 set ybot [expr {[lindex $span 1] * $ymax}]
4051 set yscreen [expr {($ybot - $ytop) / 2}]
4052 if {$selectedline ne {}} {
4053 set selid $currentid
4054 set y [yc $selectedline]
4055 if {$ytop < $y && $y < $ybot} {
4056 set yscreen [expr {$y - $ytop}]
4058 } elseif {[info exists pending_select]} {
4059 set selid $pending_select
4060 unset pending_select
4062 unselectline
4063 normalline
4064 catch {unset treediffs}
4065 clear_display
4066 if {[info exists hlview] && $hlview == $n} {
4067 unset hlview
4068 set selectedhlview [mc "None"]
4070 catch {unset commitinterest}
4071 catch {unset cached_commitrow}
4072 catch {unset ordertok}
4074 set curview $n
4075 set selectedview $n
4076 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4077 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4079 run refill_reflist
4080 if {![info exists viewcomplete($n)]} {
4081 getcommits $selid
4082 return
4085 set displayorder {}
4086 set parentlist {}
4087 set rowidlist {}
4088 set rowisopt {}
4089 set rowfinal {}
4090 set numcommits $commitidx($n)
4092 catch {unset colormap}
4093 catch {unset rowtextx}
4094 set nextcolor 0
4095 set canvxmax [$canv cget -width]
4096 set curview $n
4097 set row 0
4098 setcanvscroll
4099 set yf 0
4100 set row {}
4101 if {$selid ne {} && [commitinview $selid $n]} {
4102 set row [rowofcommit $selid]
4103 # try to get the selected row in the same position on the screen
4104 set ymax [lindex [$canv cget -scrollregion] 3]
4105 set ytop [expr {[yc $row] - $yscreen}]
4106 if {$ytop < 0} {
4107 set ytop 0
4109 set yf [expr {$ytop * 1.0 / $ymax}]
4111 allcanvs yview moveto $yf
4112 drawvisible
4113 if {$row ne {}} {
4114 selectline $row 0
4115 } elseif {!$viewcomplete($n)} {
4116 reset_pending_select $selid
4117 } else {
4118 reset_pending_select {}
4120 if {[commitinview $pending_select $curview]} {
4121 selectline [rowofcommit $pending_select] 1
4122 } else {
4123 set row [first_real_row]
4124 if {$row < $numcommits} {
4125 selectline $row 0
4129 if {!$viewcomplete($n)} {
4130 if {$numcommits == 0} {
4131 show_status [mc "Reading commits..."]
4133 } elseif {$numcommits == 0} {
4134 show_status [mc "No commits selected"]
4138 # Stuff relating to the highlighting facility
4140 proc ishighlighted {id} {
4141 global vhighlights fhighlights nhighlights rhighlights
4143 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4144 return $nhighlights($id)
4146 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4147 return $vhighlights($id)
4149 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4150 return $fhighlights($id)
4152 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4153 return $rhighlights($id)
4155 return 0
4158 proc bolden {id font} {
4159 global canv linehtag currentid boldids need_redisplay markedid
4161 # need_redisplay = 1 means the display is stale and about to be redrawn
4162 if {$need_redisplay} return
4163 lappend boldids $id
4164 $canv itemconf $linehtag($id) -font $font
4165 if {[info exists currentid] && $id eq $currentid} {
4166 $canv delete secsel
4167 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4168 -outline {{}} -tags secsel \
4169 -fill [$canv cget -selectbackground]]
4170 $canv lower $t
4172 if {[info exists markedid] && $id eq $markedid} {
4173 make_idmark $id
4177 proc bolden_name {id font} {
4178 global canv2 linentag currentid boldnameids need_redisplay
4180 if {$need_redisplay} return
4181 lappend boldnameids $id
4182 $canv2 itemconf $linentag($id) -font $font
4183 if {[info exists currentid] && $id eq $currentid} {
4184 $canv2 delete secsel
4185 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4186 -outline {{}} -tags secsel \
4187 -fill [$canv2 cget -selectbackground]]
4188 $canv2 lower $t
4192 proc unbolden {} {
4193 global boldids
4195 set stillbold {}
4196 foreach id $boldids {
4197 if {![ishighlighted $id]} {
4198 bolden $id mainfont
4199 } else {
4200 lappend stillbold $id
4203 set boldids $stillbold
4206 proc addvhighlight {n} {
4207 global hlview viewcomplete curview vhl_done commitidx
4209 if {[info exists hlview]} {
4210 delvhighlight
4212 set hlview $n
4213 if {$n != $curview && ![info exists viewcomplete($n)]} {
4214 start_rev_list $n
4216 set vhl_done $commitidx($hlview)
4217 if {$vhl_done > 0} {
4218 drawvisible
4222 proc delvhighlight {} {
4223 global hlview vhighlights
4225 if {![info exists hlview]} return
4226 unset hlview
4227 catch {unset vhighlights}
4228 unbolden
4231 proc vhighlightmore {} {
4232 global hlview vhl_done commitidx vhighlights curview
4234 set max $commitidx($hlview)
4235 set vr [visiblerows]
4236 set r0 [lindex $vr 0]
4237 set r1 [lindex $vr 1]
4238 for {set i $vhl_done} {$i < $max} {incr i} {
4239 set id [commitonrow $i $hlview]
4240 if {[commitinview $id $curview]} {
4241 set row [rowofcommit $id]
4242 if {$r0 <= $row && $row <= $r1} {
4243 if {![highlighted $row]} {
4244 bolden $id mainfontbold
4246 set vhighlights($id) 1
4250 set vhl_done $max
4251 return 0
4254 proc askvhighlight {row id} {
4255 global hlview vhighlights iddrawn
4257 if {[commitinview $id $hlview]} {
4258 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4259 bolden $id mainfontbold
4261 set vhighlights($id) 1
4262 } else {
4263 set vhighlights($id) 0
4267 proc hfiles_change {} {
4268 global highlight_files filehighlight fhighlights fh_serial
4269 global highlight_paths
4271 if {[info exists filehighlight]} {
4272 # delete previous highlights
4273 catch {close $filehighlight}
4274 unset filehighlight
4275 catch {unset fhighlights}
4276 unbolden
4277 unhighlight_filelist
4279 set highlight_paths {}
4280 after cancel do_file_hl $fh_serial
4281 incr fh_serial
4282 if {$highlight_files ne {}} {
4283 after 300 do_file_hl $fh_serial
4287 proc gdttype_change {name ix op} {
4288 global gdttype highlight_files findstring findpattern
4290 stopfinding
4291 if {$findstring ne {}} {
4292 if {$gdttype eq [mc "containing:"]} {
4293 if {$highlight_files ne {}} {
4294 set highlight_files {}
4295 hfiles_change
4297 findcom_change
4298 } else {
4299 if {$findpattern ne {}} {
4300 set findpattern {}
4301 findcom_change
4303 set highlight_files $findstring
4304 hfiles_change
4306 drawvisible
4308 # enable/disable findtype/findloc menus too
4311 proc find_change {name ix op} {
4312 global gdttype findstring highlight_files
4314 stopfinding
4315 if {$gdttype eq [mc "containing:"]} {
4316 findcom_change
4317 } else {
4318 if {$highlight_files ne $findstring} {
4319 set highlight_files $findstring
4320 hfiles_change
4323 drawvisible
4326 proc findcom_change args {
4327 global nhighlights boldnameids
4328 global findpattern findtype findstring gdttype
4330 stopfinding
4331 # delete previous highlights, if any
4332 foreach id $boldnameids {
4333 bolden_name $id mainfont
4335 set boldnameids {}
4336 catch {unset nhighlights}
4337 unbolden
4338 unmarkmatches
4339 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4340 set findpattern {}
4341 } elseif {$findtype eq [mc "Regexp"]} {
4342 set findpattern $findstring
4343 } else {
4344 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4345 $findstring]
4346 set findpattern "*$e*"
4350 proc makepatterns {l} {
4351 set ret {}
4352 foreach e $l {
4353 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4354 if {[string index $ee end] eq "/"} {
4355 lappend ret "$ee*"
4356 } else {
4357 lappend ret $ee
4358 lappend ret "$ee/*"
4361 return $ret
4364 proc do_file_hl {serial} {
4365 global highlight_files filehighlight highlight_paths gdttype fhl_list
4367 if {$gdttype eq [mc "touching paths:"]} {
4368 if {[catch {set paths [shellsplit $highlight_files]}]} return
4369 set highlight_paths [makepatterns $paths]
4370 highlight_filelist
4371 set gdtargs [concat -- $paths]
4372 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4373 set gdtargs [list "-S$highlight_files"]
4374 } else {
4375 # must be "containing:", i.e. we're searching commit info
4376 return
4378 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4379 set filehighlight [open $cmd r+]
4380 fconfigure $filehighlight -blocking 0
4381 filerun $filehighlight readfhighlight
4382 set fhl_list {}
4383 drawvisible
4384 flushhighlights
4387 proc flushhighlights {} {
4388 global filehighlight fhl_list
4390 if {[info exists filehighlight]} {
4391 lappend fhl_list {}
4392 puts $filehighlight ""
4393 flush $filehighlight
4397 proc askfilehighlight {row id} {
4398 global filehighlight fhighlights fhl_list
4400 lappend fhl_list $id
4401 set fhighlights($id) -1
4402 puts $filehighlight $id
4405 proc readfhighlight {} {
4406 global filehighlight fhighlights curview iddrawn
4407 global fhl_list find_dirn
4409 if {![info exists filehighlight]} {
4410 return 0
4412 set nr 0
4413 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4414 set line [string trim $line]
4415 set i [lsearch -exact $fhl_list $line]
4416 if {$i < 0} continue
4417 for {set j 0} {$j < $i} {incr j} {
4418 set id [lindex $fhl_list $j]
4419 set fhighlights($id) 0
4421 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4422 if {$line eq {}} continue
4423 if {![commitinview $line $curview]} continue
4424 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4425 bolden $line mainfontbold
4427 set fhighlights($line) 1
4429 if {[eof $filehighlight]} {
4430 # strange...
4431 puts "oops, git diff-tree died"
4432 catch {close $filehighlight}
4433 unset filehighlight
4434 return 0
4436 if {[info exists find_dirn]} {
4437 run findmore
4439 return 1
4442 proc doesmatch {f} {
4443 global findtype findpattern
4445 if {$findtype eq [mc "Regexp"]} {
4446 return [regexp $findpattern $f]
4447 } elseif {$findtype eq [mc "IgnCase"]} {
4448 return [string match -nocase $findpattern $f]
4449 } else {
4450 return [string match $findpattern $f]
4454 proc askfindhighlight {row id} {
4455 global nhighlights commitinfo iddrawn
4456 global findloc
4457 global markingmatches
4459 if {![info exists commitinfo($id)]} {
4460 getcommit $id
4462 set info $commitinfo($id)
4463 set isbold 0
4464 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4465 foreach f $info ty $fldtypes {
4466 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4467 [doesmatch $f]} {
4468 if {$ty eq [mc "Author"]} {
4469 set isbold 2
4470 break
4472 set isbold 1
4475 if {$isbold && [info exists iddrawn($id)]} {
4476 if {![ishighlighted $id]} {
4477 bolden $id mainfontbold
4478 if {$isbold > 1} {
4479 bolden_name $id mainfontbold
4482 if {$markingmatches} {
4483 markrowmatches $row $id
4486 set nhighlights($id) $isbold
4489 proc markrowmatches {row id} {
4490 global canv canv2 linehtag linentag commitinfo findloc
4492 set headline [lindex $commitinfo($id) 0]
4493 set author [lindex $commitinfo($id) 1]
4494 $canv delete match$row
4495 $canv2 delete match$row
4496 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4497 set m [findmatches $headline]
4498 if {$m ne {}} {
4499 markmatches $canv $row $headline $linehtag($id) $m \
4500 [$canv itemcget $linehtag($id) -font] $row
4503 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4504 set m [findmatches $author]
4505 if {$m ne {}} {
4506 markmatches $canv2 $row $author $linentag($id) $m \
4507 [$canv2 itemcget $linentag($id) -font] $row
4512 proc vrel_change {name ix op} {
4513 global highlight_related
4515 rhighlight_none
4516 if {$highlight_related ne [mc "None"]} {
4517 run drawvisible
4521 # prepare for testing whether commits are descendents or ancestors of a
4522 proc rhighlight_sel {a} {
4523 global descendent desc_todo ancestor anc_todo
4524 global highlight_related
4526 catch {unset descendent}
4527 set desc_todo [list $a]
4528 catch {unset ancestor}
4529 set anc_todo [list $a]
4530 if {$highlight_related ne [mc "None"]} {
4531 rhighlight_none
4532 run drawvisible
4536 proc rhighlight_none {} {
4537 global rhighlights
4539 catch {unset rhighlights}
4540 unbolden
4543 proc is_descendent {a} {
4544 global curview children descendent desc_todo
4546 set v $curview
4547 set la [rowofcommit $a]
4548 set todo $desc_todo
4549 set leftover {}
4550 set done 0
4551 for {set i 0} {$i < [llength $todo]} {incr i} {
4552 set do [lindex $todo $i]
4553 if {[rowofcommit $do] < $la} {
4554 lappend leftover $do
4555 continue
4557 foreach nk $children($v,$do) {
4558 if {![info exists descendent($nk)]} {
4559 set descendent($nk) 1
4560 lappend todo $nk
4561 if {$nk eq $a} {
4562 set done 1
4566 if {$done} {
4567 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4568 return
4571 set descendent($a) 0
4572 set desc_todo $leftover
4575 proc is_ancestor {a} {
4576 global curview parents ancestor anc_todo
4578 set v $curview
4579 set la [rowofcommit $a]
4580 set todo $anc_todo
4581 set leftover {}
4582 set done 0
4583 for {set i 0} {$i < [llength $todo]} {incr i} {
4584 set do [lindex $todo $i]
4585 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4586 lappend leftover $do
4587 continue
4589 foreach np $parents($v,$do) {
4590 if {![info exists ancestor($np)]} {
4591 set ancestor($np) 1
4592 lappend todo $np
4593 if {$np eq $a} {
4594 set done 1
4598 if {$done} {
4599 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4600 return
4603 set ancestor($a) 0
4604 set anc_todo $leftover
4607 proc askrelhighlight {row id} {
4608 global descendent highlight_related iddrawn rhighlights
4609 global selectedline ancestor
4611 if {$selectedline eq {}} return
4612 set isbold 0
4613 if {$highlight_related eq [mc "Descendant"] ||
4614 $highlight_related eq [mc "Not descendant"]} {
4615 if {![info exists descendent($id)]} {
4616 is_descendent $id
4618 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4619 set isbold 1
4621 } elseif {$highlight_related eq [mc "Ancestor"] ||
4622 $highlight_related eq [mc "Not ancestor"]} {
4623 if {![info exists ancestor($id)]} {
4624 is_ancestor $id
4626 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4627 set isbold 1
4630 if {[info exists iddrawn($id)]} {
4631 if {$isbold && ![ishighlighted $id]} {
4632 bolden $id mainfontbold
4635 set rhighlights($id) $isbold
4638 # Graph layout functions
4640 proc shortids {ids} {
4641 set res {}
4642 foreach id $ids {
4643 if {[llength $id] > 1} {
4644 lappend res [shortids $id]
4645 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4646 lappend res [string range $id 0 7]
4647 } else {
4648 lappend res $id
4651 return $res
4654 proc ntimes {n o} {
4655 set ret {}
4656 set o [list $o]
4657 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4658 if {($n & $mask) != 0} {
4659 set ret [concat $ret $o]
4661 set o [concat $o $o]
4663 return $ret
4666 proc ordertoken {id} {
4667 global ordertok curview varcid varcstart varctok curview parents children
4668 global nullid nullid2
4670 if {[info exists ordertok($id)]} {
4671 return $ordertok($id)
4673 set origid $id
4674 set todo {}
4675 while {1} {
4676 if {[info exists varcid($curview,$id)]} {
4677 set a $varcid($curview,$id)
4678 set p [lindex $varcstart($curview) $a]
4679 } else {
4680 set p [lindex $children($curview,$id) 0]
4682 if {[info exists ordertok($p)]} {
4683 set tok $ordertok($p)
4684 break
4686 set id [first_real_child $curview,$p]
4687 if {$id eq {}} {
4688 # it's a root
4689 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4690 break
4692 if {[llength $parents($curview,$id)] == 1} {
4693 lappend todo [list $p {}]
4694 } else {
4695 set j [lsearch -exact $parents($curview,$id) $p]
4696 if {$j < 0} {
4697 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4699 lappend todo [list $p [strrep $j]]
4702 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4703 set p [lindex $todo $i 0]
4704 append tok [lindex $todo $i 1]
4705 set ordertok($p) $tok
4707 set ordertok($origid) $tok
4708 return $tok
4711 # Work out where id should go in idlist so that order-token
4712 # values increase from left to right
4713 proc idcol {idlist id {i 0}} {
4714 set t [ordertoken $id]
4715 if {$i < 0} {
4716 set i 0
4718 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4719 if {$i > [llength $idlist]} {
4720 set i [llength $idlist]
4722 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4723 incr i
4724 } else {
4725 if {$t > [ordertoken [lindex $idlist $i]]} {
4726 while {[incr i] < [llength $idlist] &&
4727 $t >= [ordertoken [lindex $idlist $i]]} {}
4730 return $i
4733 proc initlayout {} {
4734 global rowidlist rowisopt rowfinal displayorder parentlist
4735 global numcommits canvxmax canv
4736 global nextcolor
4737 global colormap rowtextx
4739 set numcommits 0
4740 set displayorder {}
4741 set parentlist {}
4742 set nextcolor 0
4743 set rowidlist {}
4744 set rowisopt {}
4745 set rowfinal {}
4746 set canvxmax [$canv cget -width]
4747 catch {unset colormap}
4748 catch {unset rowtextx}
4749 setcanvscroll
4752 proc setcanvscroll {} {
4753 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4754 global lastscrollset lastscrollrows
4756 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4757 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4758 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4759 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4760 set lastscrollset [clock clicks -milliseconds]
4761 set lastscrollrows $numcommits
4764 proc visiblerows {} {
4765 global canv numcommits linespc
4767 set ymax [lindex [$canv cget -scrollregion] 3]
4768 if {$ymax eq {} || $ymax == 0} return
4769 set f [$canv yview]
4770 set y0 [expr {int([lindex $f 0] * $ymax)}]
4771 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4772 if {$r0 < 0} {
4773 set r0 0
4775 set y1 [expr {int([lindex $f 1] * $ymax)}]
4776 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4777 if {$r1 >= $numcommits} {
4778 set r1 [expr {$numcommits - 1}]
4780 return [list $r0 $r1]
4783 proc layoutmore {} {
4784 global commitidx viewcomplete curview
4785 global numcommits pending_select curview
4786 global lastscrollset lastscrollrows
4788 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4789 [clock clicks -milliseconds] - $lastscrollset > 500} {
4790 setcanvscroll
4792 if {[info exists pending_select] &&
4793 [commitinview $pending_select $curview]} {
4794 update
4795 selectline [rowofcommit $pending_select] 1
4797 drawvisible
4800 # With path limiting, we mightn't get the actual HEAD commit,
4801 # so ask git rev-list what is the first ancestor of HEAD that
4802 # touches a file in the path limit.
4803 proc get_viewmainhead {view} {
4804 global viewmainheadid vfilelimit viewinstances mainheadid
4806 catch {
4807 set rfd [open [concat | git rev-list -1 $mainheadid \
4808 -- $vfilelimit($view)] r]
4809 set j [reg_instance $rfd]
4810 lappend viewinstances($view) $j
4811 fconfigure $rfd -blocking 0
4812 filerun $rfd [list getviewhead $rfd $j $view]
4813 set viewmainheadid($curview) {}
4817 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4818 proc getviewhead {fd inst view} {
4819 global viewmainheadid commfd curview viewinstances showlocalchanges
4821 set id {}
4822 if {[gets $fd line] < 0} {
4823 if {![eof $fd]} {
4824 return 1
4826 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4827 set id $line
4829 set viewmainheadid($view) $id
4830 close $fd
4831 unset commfd($inst)
4832 set i [lsearch -exact $viewinstances($view) $inst]
4833 if {$i >= 0} {
4834 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4836 if {$showlocalchanges && $id ne {} && $view == $curview} {
4837 doshowlocalchanges
4839 return 0
4842 proc doshowlocalchanges {} {
4843 global curview viewmainheadid
4845 if {$viewmainheadid($curview) eq {}} return
4846 if {[commitinview $viewmainheadid($curview) $curview]} {
4847 dodiffindex
4848 } else {
4849 interestedin $viewmainheadid($curview) dodiffindex
4853 proc dohidelocalchanges {} {
4854 global nullid nullid2 lserial curview
4856 if {[commitinview $nullid $curview]} {
4857 removefakerow $nullid
4859 if {[commitinview $nullid2 $curview]} {
4860 removefakerow $nullid2
4862 incr lserial
4865 # spawn off a process to do git diff-index --cached HEAD
4866 proc dodiffindex {} {
4867 global lserial showlocalchanges vfilelimit curview
4868 global isworktree
4870 if {!$showlocalchanges || !$isworktree} return
4871 incr lserial
4872 set cmd "|git diff-index --cached HEAD"
4873 if {$vfilelimit($curview) ne {}} {
4874 set cmd [concat $cmd -- $vfilelimit($curview)]
4876 set fd [open $cmd r]
4877 fconfigure $fd -blocking 0
4878 set i [reg_instance $fd]
4879 filerun $fd [list readdiffindex $fd $lserial $i]
4882 proc readdiffindex {fd serial inst} {
4883 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4884 global vfilelimit
4886 set isdiff 1
4887 if {[gets $fd line] < 0} {
4888 if {![eof $fd]} {
4889 return 1
4891 set isdiff 0
4893 # we only need to see one line and we don't really care what it says...
4894 stop_instance $inst
4896 if {$serial != $lserial} {
4897 return 0
4900 # now see if there are any local changes not checked in to the index
4901 set cmd "|git diff-files"
4902 if {$vfilelimit($curview) ne {}} {
4903 set cmd [concat $cmd -- $vfilelimit($curview)]
4905 set fd [open $cmd r]
4906 fconfigure $fd -blocking 0
4907 set i [reg_instance $fd]
4908 filerun $fd [list readdifffiles $fd $serial $i]
4910 if {$isdiff && ![commitinview $nullid2 $curview]} {
4911 # add the line for the changes in the index to the graph
4912 set hl [mc "Local changes checked in to index but not committed"]
4913 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4914 set commitdata($nullid2) "\n $hl\n"
4915 if {[commitinview $nullid $curview]} {
4916 removefakerow $nullid
4918 insertfakerow $nullid2 $viewmainheadid($curview)
4919 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4920 if {[commitinview $nullid $curview]} {
4921 removefakerow $nullid
4923 removefakerow $nullid2
4925 return 0
4928 proc readdifffiles {fd serial inst} {
4929 global viewmainheadid nullid nullid2 curview
4930 global commitinfo commitdata lserial
4932 set isdiff 1
4933 if {[gets $fd line] < 0} {
4934 if {![eof $fd]} {
4935 return 1
4937 set isdiff 0
4939 # we only need to see one line and we don't really care what it says...
4940 stop_instance $inst
4942 if {$serial != $lserial} {
4943 return 0
4946 if {$isdiff && ![commitinview $nullid $curview]} {
4947 # add the line for the local diff to the graph
4948 set hl [mc "Local uncommitted changes, not checked in to index"]
4949 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4950 set commitdata($nullid) "\n $hl\n"
4951 if {[commitinview $nullid2 $curview]} {
4952 set p $nullid2
4953 } else {
4954 set p $viewmainheadid($curview)
4956 insertfakerow $nullid $p
4957 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4958 removefakerow $nullid
4960 return 0
4963 proc nextuse {id row} {
4964 global curview children
4966 if {[info exists children($curview,$id)]} {
4967 foreach kid $children($curview,$id) {
4968 if {![commitinview $kid $curview]} {
4969 return -1
4971 if {[rowofcommit $kid] > $row} {
4972 return [rowofcommit $kid]
4976 if {[commitinview $id $curview]} {
4977 return [rowofcommit $id]
4979 return -1
4982 proc prevuse {id row} {
4983 global curview children
4985 set ret -1
4986 if {[info exists children($curview,$id)]} {
4987 foreach kid $children($curview,$id) {
4988 if {![commitinview $kid $curview]} break
4989 if {[rowofcommit $kid] < $row} {
4990 set ret [rowofcommit $kid]
4994 return $ret
4997 proc make_idlist {row} {
4998 global displayorder parentlist uparrowlen downarrowlen mingaplen
4999 global commitidx curview children
5001 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5002 if {$r < 0} {
5003 set r 0
5005 set ra [expr {$row - $downarrowlen}]
5006 if {$ra < 0} {
5007 set ra 0
5009 set rb [expr {$row + $uparrowlen}]
5010 if {$rb > $commitidx($curview)} {
5011 set rb $commitidx($curview)
5013 make_disporder $r [expr {$rb + 1}]
5014 set ids {}
5015 for {} {$r < $ra} {incr r} {
5016 set nextid [lindex $displayorder [expr {$r + 1}]]
5017 foreach p [lindex $parentlist $r] {
5018 if {$p eq $nextid} continue
5019 set rn [nextuse $p $r]
5020 if {$rn >= $row &&
5021 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5022 lappend ids [list [ordertoken $p] $p]
5026 for {} {$r < $row} {incr r} {
5027 set nextid [lindex $displayorder [expr {$r + 1}]]
5028 foreach p [lindex $parentlist $r] {
5029 if {$p eq $nextid} continue
5030 set rn [nextuse $p $r]
5031 if {$rn < 0 || $rn >= $row} {
5032 lappend ids [list [ordertoken $p] $p]
5036 set id [lindex $displayorder $row]
5037 lappend ids [list [ordertoken $id] $id]
5038 while {$r < $rb} {
5039 foreach p [lindex $parentlist $r] {
5040 set firstkid [lindex $children($curview,$p) 0]
5041 if {[rowofcommit $firstkid] < $row} {
5042 lappend ids [list [ordertoken $p] $p]
5045 incr r
5046 set id [lindex $displayorder $r]
5047 if {$id ne {}} {
5048 set firstkid [lindex $children($curview,$id) 0]
5049 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5050 lappend ids [list [ordertoken $id] $id]
5054 set idlist {}
5055 foreach idx [lsort -unique $ids] {
5056 lappend idlist [lindex $idx 1]
5058 return $idlist
5061 proc rowsequal {a b} {
5062 while {[set i [lsearch -exact $a {}]] >= 0} {
5063 set a [lreplace $a $i $i]
5065 while {[set i [lsearch -exact $b {}]] >= 0} {
5066 set b [lreplace $b $i $i]
5068 return [expr {$a eq $b}]
5071 proc makeupline {id row rend col} {
5072 global rowidlist uparrowlen downarrowlen mingaplen
5074 for {set r $rend} {1} {set r $rstart} {
5075 set rstart [prevuse $id $r]
5076 if {$rstart < 0} return
5077 if {$rstart < $row} break
5079 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5080 set rstart [expr {$rend - $uparrowlen - 1}]
5082 for {set r $rstart} {[incr r] <= $row} {} {
5083 set idlist [lindex $rowidlist $r]
5084 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5085 set col [idcol $idlist $id $col]
5086 lset rowidlist $r [linsert $idlist $col $id]
5087 changedrow $r
5092 proc layoutrows {row endrow} {
5093 global rowidlist rowisopt rowfinal displayorder
5094 global uparrowlen downarrowlen maxwidth mingaplen
5095 global children parentlist
5096 global commitidx viewcomplete curview
5098 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5099 set idlist {}
5100 if {$row > 0} {
5101 set rm1 [expr {$row - 1}]
5102 foreach id [lindex $rowidlist $rm1] {
5103 if {$id ne {}} {
5104 lappend idlist $id
5107 set final [lindex $rowfinal $rm1]
5109 for {} {$row < $endrow} {incr row} {
5110 set rm1 [expr {$row - 1}]
5111 if {$rm1 < 0 || $idlist eq {}} {
5112 set idlist [make_idlist $row]
5113 set final 1
5114 } else {
5115 set id [lindex $displayorder $rm1]
5116 set col [lsearch -exact $idlist $id]
5117 set idlist [lreplace $idlist $col $col]
5118 foreach p [lindex $parentlist $rm1] {
5119 if {[lsearch -exact $idlist $p] < 0} {
5120 set col [idcol $idlist $p $col]
5121 set idlist [linsert $idlist $col $p]
5122 # if not the first child, we have to insert a line going up
5123 if {$id ne [lindex $children($curview,$p) 0]} {
5124 makeupline $p $rm1 $row $col
5128 set id [lindex $displayorder $row]
5129 if {$row > $downarrowlen} {
5130 set termrow [expr {$row - $downarrowlen - 1}]
5131 foreach p [lindex $parentlist $termrow] {
5132 set i [lsearch -exact $idlist $p]
5133 if {$i < 0} continue
5134 set nr [nextuse $p $termrow]
5135 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5136 set idlist [lreplace $idlist $i $i]
5140 set col [lsearch -exact $idlist $id]
5141 if {$col < 0} {
5142 set col [idcol $idlist $id]
5143 set idlist [linsert $idlist $col $id]
5144 if {$children($curview,$id) ne {}} {
5145 makeupline $id $rm1 $row $col
5148 set r [expr {$row + $uparrowlen - 1}]
5149 if {$r < $commitidx($curview)} {
5150 set x $col
5151 foreach p [lindex $parentlist $r] {
5152 if {[lsearch -exact $idlist $p] >= 0} continue
5153 set fk [lindex $children($curview,$p) 0]
5154 if {[rowofcommit $fk] < $row} {
5155 set x [idcol $idlist $p $x]
5156 set idlist [linsert $idlist $x $p]
5159 if {[incr r] < $commitidx($curview)} {
5160 set p [lindex $displayorder $r]
5161 if {[lsearch -exact $idlist $p] < 0} {
5162 set fk [lindex $children($curview,$p) 0]
5163 if {$fk ne {} && [rowofcommit $fk] < $row} {
5164 set x [idcol $idlist $p $x]
5165 set idlist [linsert $idlist $x $p]
5171 if {$final && !$viewcomplete($curview) &&
5172 $row + $uparrowlen + $mingaplen + $downarrowlen
5173 >= $commitidx($curview)} {
5174 set final 0
5176 set l [llength $rowidlist]
5177 if {$row == $l} {
5178 lappend rowidlist $idlist
5179 lappend rowisopt 0
5180 lappend rowfinal $final
5181 } elseif {$row < $l} {
5182 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5183 lset rowidlist $row $idlist
5184 changedrow $row
5186 lset rowfinal $row $final
5187 } else {
5188 set pad [ntimes [expr {$row - $l}] {}]
5189 set rowidlist [concat $rowidlist $pad]
5190 lappend rowidlist $idlist
5191 set rowfinal [concat $rowfinal $pad]
5192 lappend rowfinal $final
5193 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5196 return $row
5199 proc changedrow {row} {
5200 global displayorder iddrawn rowisopt need_redisplay
5202 set l [llength $rowisopt]
5203 if {$row < $l} {
5204 lset rowisopt $row 0
5205 if {$row + 1 < $l} {
5206 lset rowisopt [expr {$row + 1}] 0
5207 if {$row + 2 < $l} {
5208 lset rowisopt [expr {$row + 2}] 0
5212 set id [lindex $displayorder $row]
5213 if {[info exists iddrawn($id)]} {
5214 set need_redisplay 1
5218 proc insert_pad {row col npad} {
5219 global rowidlist
5221 set pad [ntimes $npad {}]
5222 set idlist [lindex $rowidlist $row]
5223 set bef [lrange $idlist 0 [expr {$col - 1}]]
5224 set aft [lrange $idlist $col end]
5225 set i [lsearch -exact $aft {}]
5226 if {$i > 0} {
5227 set aft [lreplace $aft $i $i]
5229 lset rowidlist $row [concat $bef $pad $aft]
5230 changedrow $row
5233 proc optimize_rows {row col endrow} {
5234 global rowidlist rowisopt displayorder curview children
5236 if {$row < 1} {
5237 set row 1
5239 for {} {$row < $endrow} {incr row; set col 0} {
5240 if {[lindex $rowisopt $row]} continue
5241 set haspad 0
5242 set y0 [expr {$row - 1}]
5243 set ym [expr {$row - 2}]
5244 set idlist [lindex $rowidlist $row]
5245 set previdlist [lindex $rowidlist $y0]
5246 if {$idlist eq {} || $previdlist eq {}} continue
5247 if {$ym >= 0} {
5248 set pprevidlist [lindex $rowidlist $ym]
5249 if {$pprevidlist eq {}} continue
5250 } else {
5251 set pprevidlist {}
5253 set x0 -1
5254 set xm -1
5255 for {} {$col < [llength $idlist]} {incr col} {
5256 set id [lindex $idlist $col]
5257 if {[lindex $previdlist $col] eq $id} continue
5258 if {$id eq {}} {
5259 set haspad 1
5260 continue
5262 set x0 [lsearch -exact $previdlist $id]
5263 if {$x0 < 0} continue
5264 set z [expr {$x0 - $col}]
5265 set isarrow 0
5266 set z0 {}
5267 if {$ym >= 0} {
5268 set xm [lsearch -exact $pprevidlist $id]
5269 if {$xm >= 0} {
5270 set z0 [expr {$xm - $x0}]
5273 if {$z0 eq {}} {
5274 # if row y0 is the first child of $id then it's not an arrow
5275 if {[lindex $children($curview,$id) 0] ne
5276 [lindex $displayorder $y0]} {
5277 set isarrow 1
5280 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5281 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5282 set isarrow 1
5284 # Looking at lines from this row to the previous row,
5285 # make them go straight up if they end in an arrow on
5286 # the previous row; otherwise make them go straight up
5287 # or at 45 degrees.
5288 if {$z < -1 || ($z < 0 && $isarrow)} {
5289 # Line currently goes left too much;
5290 # insert pads in the previous row, then optimize it
5291 set npad [expr {-1 - $z + $isarrow}]
5292 insert_pad $y0 $x0 $npad
5293 if {$y0 > 0} {
5294 optimize_rows $y0 $x0 $row
5296 set previdlist [lindex $rowidlist $y0]
5297 set x0 [lsearch -exact $previdlist $id]
5298 set z [expr {$x0 - $col}]
5299 if {$z0 ne {}} {
5300 set pprevidlist [lindex $rowidlist $ym]
5301 set xm [lsearch -exact $pprevidlist $id]
5302 set z0 [expr {$xm - $x0}]
5304 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5305 # Line currently goes right too much;
5306 # insert pads in this line
5307 set npad [expr {$z - 1 + $isarrow}]
5308 insert_pad $row $col $npad
5309 set idlist [lindex $rowidlist $row]
5310 incr col $npad
5311 set z [expr {$x0 - $col}]
5312 set haspad 1
5314 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5315 # this line links to its first child on row $row-2
5316 set id [lindex $displayorder $ym]
5317 set xc [lsearch -exact $pprevidlist $id]
5318 if {$xc >= 0} {
5319 set z0 [expr {$xc - $x0}]
5322 # avoid lines jigging left then immediately right
5323 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5324 insert_pad $y0 $x0 1
5325 incr x0
5326 optimize_rows $y0 $x0 $row
5327 set previdlist [lindex $rowidlist $y0]
5330 if {!$haspad} {
5331 # Find the first column that doesn't have a line going right
5332 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5333 set id [lindex $idlist $col]
5334 if {$id eq {}} break
5335 set x0 [lsearch -exact $previdlist $id]
5336 if {$x0 < 0} {
5337 # check if this is the link to the first child
5338 set kid [lindex $displayorder $y0]
5339 if {[lindex $children($curview,$id) 0] eq $kid} {
5340 # it is, work out offset to child
5341 set x0 [lsearch -exact $previdlist $kid]
5344 if {$x0 <= $col} break
5346 # Insert a pad at that column as long as it has a line and
5347 # isn't the last column
5348 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5349 set idlist [linsert $idlist $col {}]
5350 lset rowidlist $row $idlist
5351 changedrow $row
5357 proc xc {row col} {
5358 global canvx0 linespc
5359 return [expr {$canvx0 + $col * $linespc}]
5362 proc yc {row} {
5363 global canvy0 linespc
5364 return [expr {$canvy0 + $row * $linespc}]
5367 proc linewidth {id} {
5368 global thickerline lthickness
5370 set wid $lthickness
5371 if {[info exists thickerline] && $id eq $thickerline} {
5372 set wid [expr {2 * $lthickness}]
5374 return $wid
5377 proc rowranges {id} {
5378 global curview children uparrowlen downarrowlen
5379 global rowidlist
5381 set kids $children($curview,$id)
5382 if {$kids eq {}} {
5383 return {}
5385 set ret {}
5386 lappend kids $id
5387 foreach child $kids {
5388 if {![commitinview $child $curview]} break
5389 set row [rowofcommit $child]
5390 if {![info exists prev]} {
5391 lappend ret [expr {$row + 1}]
5392 } else {
5393 if {$row <= $prevrow} {
5394 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5396 # see if the line extends the whole way from prevrow to row
5397 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5398 [lsearch -exact [lindex $rowidlist \
5399 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5400 # it doesn't, see where it ends
5401 set r [expr {$prevrow + $downarrowlen}]
5402 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5403 while {[incr r -1] > $prevrow &&
5404 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5405 } else {
5406 while {[incr r] <= $row &&
5407 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5408 incr r -1
5410 lappend ret $r
5411 # see where it starts up again
5412 set r [expr {$row - $uparrowlen}]
5413 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5414 while {[incr r] < $row &&
5415 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5416 } else {
5417 while {[incr r -1] >= $prevrow &&
5418 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5419 incr r
5421 lappend ret $r
5424 if {$child eq $id} {
5425 lappend ret $row
5427 set prev $child
5428 set prevrow $row
5430 return $ret
5433 proc drawlineseg {id row endrow arrowlow} {
5434 global rowidlist displayorder iddrawn linesegs
5435 global canv colormap linespc curview maxlinelen parentlist
5437 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5438 set le [expr {$row + 1}]
5439 set arrowhigh 1
5440 while {1} {
5441 set c [lsearch -exact [lindex $rowidlist $le] $id]
5442 if {$c < 0} {
5443 incr le -1
5444 break
5446 lappend cols $c
5447 set x [lindex $displayorder $le]
5448 if {$x eq $id} {
5449 set arrowhigh 0
5450 break
5452 if {[info exists iddrawn($x)] || $le == $endrow} {
5453 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5454 if {$c >= 0} {
5455 lappend cols $c
5456 set arrowhigh 0
5458 break
5460 incr le
5462 if {$le <= $row} {
5463 return $row
5466 set lines {}
5467 set i 0
5468 set joinhigh 0
5469 if {[info exists linesegs($id)]} {
5470 set lines $linesegs($id)
5471 foreach li $lines {
5472 set r0 [lindex $li 0]
5473 if {$r0 > $row} {
5474 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5475 set joinhigh 1
5477 break
5479 incr i
5482 set joinlow 0
5483 if {$i > 0} {
5484 set li [lindex $lines [expr {$i-1}]]
5485 set r1 [lindex $li 1]
5486 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5487 set joinlow 1
5491 set x [lindex $cols [expr {$le - $row}]]
5492 set xp [lindex $cols [expr {$le - 1 - $row}]]
5493 set dir [expr {$xp - $x}]
5494 if {$joinhigh} {
5495 set ith [lindex $lines $i 2]
5496 set coords [$canv coords $ith]
5497 set ah [$canv itemcget $ith -arrow]
5498 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5499 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5500 if {$x2 ne {} && $x - $x2 == $dir} {
5501 set coords [lrange $coords 0 end-2]
5503 } else {
5504 set coords [list [xc $le $x] [yc $le]]
5506 if {$joinlow} {
5507 set itl [lindex $lines [expr {$i-1}] 2]
5508 set al [$canv itemcget $itl -arrow]
5509 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5510 } elseif {$arrowlow} {
5511 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5512 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5513 set arrowlow 0
5516 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5517 for {set y $le} {[incr y -1] > $row} {} {
5518 set x $xp
5519 set xp [lindex $cols [expr {$y - 1 - $row}]]
5520 set ndir [expr {$xp - $x}]
5521 if {$dir != $ndir || $xp < 0} {
5522 lappend coords [xc $y $x] [yc $y]
5524 set dir $ndir
5526 if {!$joinlow} {
5527 if {$xp < 0} {
5528 # join parent line to first child
5529 set ch [lindex $displayorder $row]
5530 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5531 if {$xc < 0} {
5532 puts "oops: drawlineseg: child $ch not on row $row"
5533 } elseif {$xc != $x} {
5534 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5535 set d [expr {int(0.5 * $linespc)}]
5536 set x1 [xc $row $x]
5537 if {$xc < $x} {
5538 set x2 [expr {$x1 - $d}]
5539 } else {
5540 set x2 [expr {$x1 + $d}]
5542 set y2 [yc $row]
5543 set y1 [expr {$y2 + $d}]
5544 lappend coords $x1 $y1 $x2 $y2
5545 } elseif {$xc < $x - 1} {
5546 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5547 } elseif {$xc > $x + 1} {
5548 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5550 set x $xc
5552 lappend coords [xc $row $x] [yc $row]
5553 } else {
5554 set xn [xc $row $xp]
5555 set yn [yc $row]
5556 lappend coords $xn $yn
5558 if {!$joinhigh} {
5559 assigncolor $id
5560 set t [$canv create line $coords -width [linewidth $id] \
5561 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5562 $canv lower $t
5563 bindline $t $id
5564 set lines [linsert $lines $i [list $row $le $t]]
5565 } else {
5566 $canv coords $ith $coords
5567 if {$arrow ne $ah} {
5568 $canv itemconf $ith -arrow $arrow
5570 lset lines $i 0 $row
5572 } else {
5573 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5574 set ndir [expr {$xo - $xp}]
5575 set clow [$canv coords $itl]
5576 if {$dir == $ndir} {
5577 set clow [lrange $clow 2 end]
5579 set coords [concat $coords $clow]
5580 if {!$joinhigh} {
5581 lset lines [expr {$i-1}] 1 $le
5582 } else {
5583 # coalesce two pieces
5584 $canv delete $ith
5585 set b [lindex $lines [expr {$i-1}] 0]
5586 set e [lindex $lines $i 1]
5587 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5589 $canv coords $itl $coords
5590 if {$arrow ne $al} {
5591 $canv itemconf $itl -arrow $arrow
5595 set linesegs($id) $lines
5596 return $le
5599 proc drawparentlinks {id row} {
5600 global rowidlist canv colormap curview parentlist
5601 global idpos linespc
5603 set rowids [lindex $rowidlist $row]
5604 set col [lsearch -exact $rowids $id]
5605 if {$col < 0} return
5606 set olds [lindex $parentlist $row]
5607 set row2 [expr {$row + 1}]
5608 set x [xc $row $col]
5609 set y [yc $row]
5610 set y2 [yc $row2]
5611 set d [expr {int(0.5 * $linespc)}]
5612 set ymid [expr {$y + $d}]
5613 set ids [lindex $rowidlist $row2]
5614 # rmx = right-most X coord used
5615 set rmx 0
5616 foreach p $olds {
5617 set i [lsearch -exact $ids $p]
5618 if {$i < 0} {
5619 puts "oops, parent $p of $id not in list"
5620 continue
5622 set x2 [xc $row2 $i]
5623 if {$x2 > $rmx} {
5624 set rmx $x2
5626 set j [lsearch -exact $rowids $p]
5627 if {$j < 0} {
5628 # drawlineseg will do this one for us
5629 continue
5631 assigncolor $p
5632 # should handle duplicated parents here...
5633 set coords [list $x $y]
5634 if {$i != $col} {
5635 # if attaching to a vertical segment, draw a smaller
5636 # slant for visual distinctness
5637 if {$i == $j} {
5638 if {$i < $col} {
5639 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5640 } else {
5641 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5643 } elseif {$i < $col && $i < $j} {
5644 # segment slants towards us already
5645 lappend coords [xc $row $j] $y
5646 } else {
5647 if {$i < $col - 1} {
5648 lappend coords [expr {$x2 + $linespc}] $y
5649 } elseif {$i > $col + 1} {
5650 lappend coords [expr {$x2 - $linespc}] $y
5652 lappend coords $x2 $y2
5654 } else {
5655 lappend coords $x2 $y2
5657 set t [$canv create line $coords -width [linewidth $p] \
5658 -fill $colormap($p) -tags lines.$p]
5659 $canv lower $t
5660 bindline $t $p
5662 if {$rmx > [lindex $idpos($id) 1]} {
5663 lset idpos($id) 1 $rmx
5664 redrawtags $id
5668 proc drawlines {id} {
5669 global canv
5671 $canv itemconf lines.$id -width [linewidth $id]
5674 proc drawcmittext {id row col} {
5675 global linespc canv canv2 canv3 fgcolor curview
5676 global cmitlisted commitinfo rowidlist parentlist
5677 global rowtextx idpos idtags idheads idotherrefs
5678 global linehtag linentag linedtag selectedline
5679 global canvxmax boldids boldnameids fgcolor markedid
5680 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5682 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5683 set listed $cmitlisted($curview,$id)
5684 if {$id eq $nullid} {
5685 set ofill red
5686 } elseif {$id eq $nullid2} {
5687 set ofill green
5688 } elseif {$id eq $mainheadid} {
5689 set ofill yellow
5690 } else {
5691 set ofill [lindex $circlecolors $listed]
5693 set x [xc $row $col]
5694 set y [yc $row]
5695 set orad [expr {$linespc / 3}]
5696 if {$listed <= 2} {
5697 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5698 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5699 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5700 } elseif {$listed == 3} {
5701 # triangle pointing left for left-side commits
5702 set t [$canv create polygon \
5703 [expr {$x - $orad}] $y \
5704 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5705 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5706 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5707 } else {
5708 # triangle pointing right for right-side commits
5709 set t [$canv create polygon \
5710 [expr {$x + $orad - 1}] $y \
5711 [expr {$x - $orad}] [expr {$y - $orad}] \
5712 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5713 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5715 set circleitem($row) $t
5716 $canv raise $t
5717 $canv bind $t <1> {selcanvline {} %x %y}
5718 set rmx [llength [lindex $rowidlist $row]]
5719 set olds [lindex $parentlist $row]
5720 if {$olds ne {}} {
5721 set nextids [lindex $rowidlist [expr {$row + 1}]]
5722 foreach p $olds {
5723 set i [lsearch -exact $nextids $p]
5724 if {$i > $rmx} {
5725 set rmx $i
5729 set xt [xc $row $rmx]
5730 set rowtextx($row) $xt
5731 set idpos($id) [list $x $xt $y]
5732 if {[info exists idtags($id)] || [info exists idheads($id)]
5733 || [info exists idotherrefs($id)]} {
5734 set xt [drawtags $id $x $xt $y]
5736 set headline [lindex $commitinfo($id) 0]
5737 set name [lindex $commitinfo($id) 1]
5738 set date [lindex $commitinfo($id) 2]
5739 set date [formatdate $date]
5740 set font mainfont
5741 set nfont mainfont
5742 set isbold [ishighlighted $id]
5743 if {$isbold > 0} {
5744 lappend boldids $id
5745 set font mainfontbold
5746 if {$isbold > 1} {
5747 lappend boldnameids $id
5748 set nfont mainfontbold
5751 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5752 -text $headline -font $font -tags text]
5753 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5754 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5755 -text $name -font $nfont -tags text]
5756 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5757 -text $date -font mainfont -tags text]
5758 if {$selectedline == $row} {
5759 make_secsel $id
5761 if {[info exists markedid] && $markedid eq $id} {
5762 make_idmark $id
5764 set xr [expr {$xt + [font measure $font $headline]}]
5765 if {$xr > $canvxmax} {
5766 set canvxmax $xr
5767 setcanvscroll
5771 proc drawcmitrow {row} {
5772 global displayorder rowidlist nrows_drawn
5773 global iddrawn markingmatches
5774 global commitinfo numcommits
5775 global filehighlight fhighlights findpattern nhighlights
5776 global hlview vhighlights
5777 global highlight_related rhighlights
5779 if {$row >= $numcommits} return
5781 set id [lindex $displayorder $row]
5782 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5783 askvhighlight $row $id
5785 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5786 askfilehighlight $row $id
5788 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5789 askfindhighlight $row $id
5791 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5792 askrelhighlight $row $id
5794 if {![info exists iddrawn($id)]} {
5795 set col [lsearch -exact [lindex $rowidlist $row] $id]
5796 if {$col < 0} {
5797 puts "oops, row $row id $id not in list"
5798 return
5800 if {![info exists commitinfo($id)]} {
5801 getcommit $id
5803 assigncolor $id
5804 drawcmittext $id $row $col
5805 set iddrawn($id) 1
5806 incr nrows_drawn
5808 if {$markingmatches} {
5809 markrowmatches $row $id
5813 proc drawcommits {row {endrow {}}} {
5814 global numcommits iddrawn displayorder curview need_redisplay
5815 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5817 if {$row < 0} {
5818 set row 0
5820 if {$endrow eq {}} {
5821 set endrow $row
5823 if {$endrow >= $numcommits} {
5824 set endrow [expr {$numcommits - 1}]
5827 set rl1 [expr {$row - $downarrowlen - 3}]
5828 if {$rl1 < 0} {
5829 set rl1 0
5831 set ro1 [expr {$row - 3}]
5832 if {$ro1 < 0} {
5833 set ro1 0
5835 set r2 [expr {$endrow + $uparrowlen + 3}]
5836 if {$r2 > $numcommits} {
5837 set r2 $numcommits
5839 for {set r $rl1} {$r < $r2} {incr r} {
5840 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5841 if {$rl1 < $r} {
5842 layoutrows $rl1 $r
5844 set rl1 [expr {$r + 1}]
5847 if {$rl1 < $r} {
5848 layoutrows $rl1 $r
5850 optimize_rows $ro1 0 $r2
5851 if {$need_redisplay || $nrows_drawn > 2000} {
5852 clear_display
5855 # make the lines join to already-drawn rows either side
5856 set r [expr {$row - 1}]
5857 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5858 set r $row
5860 set er [expr {$endrow + 1}]
5861 if {$er >= $numcommits ||
5862 ![info exists iddrawn([lindex $displayorder $er])]} {
5863 set er $endrow
5865 for {} {$r <= $er} {incr r} {
5866 set id [lindex $displayorder $r]
5867 set wasdrawn [info exists iddrawn($id)]
5868 drawcmitrow $r
5869 if {$r == $er} break
5870 set nextid [lindex $displayorder [expr {$r + 1}]]
5871 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5872 drawparentlinks $id $r
5874 set rowids [lindex $rowidlist $r]
5875 foreach lid $rowids {
5876 if {$lid eq {}} continue
5877 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5878 if {$lid eq $id} {
5879 # see if this is the first child of any of its parents
5880 foreach p [lindex $parentlist $r] {
5881 if {[lsearch -exact $rowids $p] < 0} {
5882 # make this line extend up to the child
5883 set lineend($p) [drawlineseg $p $r $er 0]
5886 } else {
5887 set lineend($lid) [drawlineseg $lid $r $er 1]
5893 proc undolayout {row} {
5894 global uparrowlen mingaplen downarrowlen
5895 global rowidlist rowisopt rowfinal need_redisplay
5897 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5898 if {$r < 0} {
5899 set r 0
5901 if {[llength $rowidlist] > $r} {
5902 incr r -1
5903 set rowidlist [lrange $rowidlist 0 $r]
5904 set rowfinal [lrange $rowfinal 0 $r]
5905 set rowisopt [lrange $rowisopt 0 $r]
5906 set need_redisplay 1
5907 run drawvisible
5911 proc drawvisible {} {
5912 global canv linespc curview vrowmod selectedline targetrow targetid
5913 global need_redisplay cscroll numcommits
5915 set fs [$canv yview]
5916 set ymax [lindex [$canv cget -scrollregion] 3]
5917 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5918 set f0 [lindex $fs 0]
5919 set f1 [lindex $fs 1]
5920 set y0 [expr {int($f0 * $ymax)}]
5921 set y1 [expr {int($f1 * $ymax)}]
5923 if {[info exists targetid]} {
5924 if {[commitinview $targetid $curview]} {
5925 set r [rowofcommit $targetid]
5926 if {$r != $targetrow} {
5927 # Fix up the scrollregion and change the scrolling position
5928 # now that our target row has moved.
5929 set diff [expr {($r - $targetrow) * $linespc}]
5930 set targetrow $r
5931 setcanvscroll
5932 set ymax [lindex [$canv cget -scrollregion] 3]
5933 incr y0 $diff
5934 incr y1 $diff
5935 set f0 [expr {$y0 / $ymax}]
5936 set f1 [expr {$y1 / $ymax}]
5937 allcanvs yview moveto $f0
5938 $cscroll set $f0 $f1
5939 set need_redisplay 1
5941 } else {
5942 unset targetid
5946 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5947 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5948 if {$endrow >= $vrowmod($curview)} {
5949 update_arcrows $curview
5951 if {$selectedline ne {} &&
5952 $row <= $selectedline && $selectedline <= $endrow} {
5953 set targetrow $selectedline
5954 } elseif {[info exists targetid]} {
5955 set targetrow [expr {int(($row + $endrow) / 2)}]
5957 if {[info exists targetrow]} {
5958 if {$targetrow >= $numcommits} {
5959 set targetrow [expr {$numcommits - 1}]
5961 set targetid [commitonrow $targetrow]
5963 drawcommits $row $endrow
5966 proc clear_display {} {
5967 global iddrawn linesegs need_redisplay nrows_drawn
5968 global vhighlights fhighlights nhighlights rhighlights
5969 global linehtag linentag linedtag boldids boldnameids
5971 allcanvs delete all
5972 catch {unset iddrawn}
5973 catch {unset linesegs}
5974 catch {unset linehtag}
5975 catch {unset linentag}
5976 catch {unset linedtag}
5977 set boldids {}
5978 set boldnameids {}
5979 catch {unset vhighlights}
5980 catch {unset fhighlights}
5981 catch {unset nhighlights}
5982 catch {unset rhighlights}
5983 set need_redisplay 0
5984 set nrows_drawn 0
5987 proc findcrossings {id} {
5988 global rowidlist parentlist numcommits displayorder
5990 set cross {}
5991 set ccross {}
5992 foreach {s e} [rowranges $id] {
5993 if {$e >= $numcommits} {
5994 set e [expr {$numcommits - 1}]
5996 if {$e <= $s} continue
5997 for {set row $e} {[incr row -1] >= $s} {} {
5998 set x [lsearch -exact [lindex $rowidlist $row] $id]
5999 if {$x < 0} break
6000 set olds [lindex $parentlist $row]
6001 set kid [lindex $displayorder $row]
6002 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6003 if {$kidx < 0} continue
6004 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6005 foreach p $olds {
6006 set px [lsearch -exact $nextrow $p]
6007 if {$px < 0} continue
6008 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6009 if {[lsearch -exact $ccross $p] >= 0} continue
6010 if {$x == $px + ($kidx < $px? -1: 1)} {
6011 lappend ccross $p
6012 } elseif {[lsearch -exact $cross $p] < 0} {
6013 lappend cross $p
6019 return [concat $ccross {{}} $cross]
6022 proc assigncolor {id} {
6023 global colormap colors nextcolor
6024 global parents children children curview
6026 if {[info exists colormap($id)]} return
6027 set ncolors [llength $colors]
6028 if {[info exists children($curview,$id)]} {
6029 set kids $children($curview,$id)
6030 } else {
6031 set kids {}
6033 if {[llength $kids] == 1} {
6034 set child [lindex $kids 0]
6035 if {[info exists colormap($child)]
6036 && [llength $parents($curview,$child)] == 1} {
6037 set colormap($id) $colormap($child)
6038 return
6041 set badcolors {}
6042 set origbad {}
6043 foreach x [findcrossings $id] {
6044 if {$x eq {}} {
6045 # delimiter between corner crossings and other crossings
6046 if {[llength $badcolors] >= $ncolors - 1} break
6047 set origbad $badcolors
6049 if {[info exists colormap($x)]
6050 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6051 lappend badcolors $colormap($x)
6054 if {[llength $badcolors] >= $ncolors} {
6055 set badcolors $origbad
6057 set origbad $badcolors
6058 if {[llength $badcolors] < $ncolors - 1} {
6059 foreach child $kids {
6060 if {[info exists colormap($child)]
6061 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6062 lappend badcolors $colormap($child)
6064 foreach p $parents($curview,$child) {
6065 if {[info exists colormap($p)]
6066 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6067 lappend badcolors $colormap($p)
6071 if {[llength $badcolors] >= $ncolors} {
6072 set badcolors $origbad
6075 for {set i 0} {$i <= $ncolors} {incr i} {
6076 set c [lindex $colors $nextcolor]
6077 if {[incr nextcolor] >= $ncolors} {
6078 set nextcolor 0
6080 if {[lsearch -exact $badcolors $c]} break
6082 set colormap($id) $c
6085 proc bindline {t id} {
6086 global canv
6088 $canv bind $t <Enter> "lineenter %x %y $id"
6089 $canv bind $t <Motion> "linemotion %x %y $id"
6090 $canv bind $t <Leave> "lineleave $id"
6091 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6094 proc drawtags {id x xt y1} {
6095 global idtags idheads idotherrefs mainhead
6096 global linespc lthickness
6097 global canv rowtextx curview fgcolor bgcolor ctxbut
6099 set marks {}
6100 set ntags 0
6101 set nheads 0
6102 if {[info exists idtags($id)]} {
6103 set marks $idtags($id)
6104 set ntags [llength $marks]
6106 if {[info exists idheads($id)]} {
6107 set marks [concat $marks $idheads($id)]
6108 set nheads [llength $idheads($id)]
6110 if {[info exists idotherrefs($id)]} {
6111 set marks [concat $marks $idotherrefs($id)]
6113 if {$marks eq {}} {
6114 return $xt
6117 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6118 set yt [expr {$y1 - 0.5 * $linespc}]
6119 set yb [expr {$yt + $linespc - 1}]
6120 set xvals {}
6121 set wvals {}
6122 set i -1
6123 foreach tag $marks {
6124 incr i
6125 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6126 set wid [font measure mainfontbold $tag]
6127 } else {
6128 set wid [font measure mainfont $tag]
6130 lappend xvals $xt
6131 lappend wvals $wid
6132 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6134 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6135 -width $lthickness -fill black -tags tag.$id]
6136 $canv lower $t
6137 foreach tag $marks x $xvals wid $wvals {
6138 set xl [expr {$x + $delta}]
6139 set xr [expr {$x + $delta + $wid + $lthickness}]
6140 set font mainfont
6141 if {[incr ntags -1] >= 0} {
6142 # draw a tag
6143 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6144 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6145 -width 1 -outline black -fill yellow -tags tag.$id]
6146 $canv bind $t <1> [list showtag $tag 1]
6147 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6148 } else {
6149 # draw a head or other ref
6150 if {[incr nheads -1] >= 0} {
6151 set col green
6152 if {$tag eq $mainhead} {
6153 set font mainfontbold
6155 } else {
6156 set col "#ddddff"
6158 set xl [expr {$xl - $delta/2}]
6159 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6160 -width 1 -outline black -fill $col -tags tag.$id
6161 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6162 set rwid [font measure mainfont $remoteprefix]
6163 set xi [expr {$x + 1}]
6164 set yti [expr {$yt + 1}]
6165 set xri [expr {$x + $rwid}]
6166 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6167 -width 0 -fill "#ffddaa" -tags tag.$id
6170 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6171 -font $font -tags [list tag.$id text]]
6172 if {$ntags >= 0} {
6173 $canv bind $t <1> [list showtag $tag 1]
6174 } elseif {$nheads >= 0} {
6175 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6178 return $xt
6181 proc xcoord {i level ln} {
6182 global canvx0 xspc1 xspc2
6184 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6185 if {$i > 0 && $i == $level} {
6186 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6187 } elseif {$i > $level} {
6188 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6190 return $x
6193 proc show_status {msg} {
6194 global canv fgcolor
6196 clear_display
6197 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6198 -tags text -fill $fgcolor
6201 # Don't change the text pane cursor if it is currently the hand cursor,
6202 # showing that we are over a sha1 ID link.
6203 proc settextcursor {c} {
6204 global ctext curtextcursor
6206 if {[$ctext cget -cursor] == $curtextcursor} {
6207 $ctext config -cursor $c
6209 set curtextcursor $c
6212 proc nowbusy {what {name {}}} {
6213 global isbusy busyname statusw
6215 if {[array names isbusy] eq {}} {
6216 . config -cursor watch
6217 settextcursor watch
6219 set isbusy($what) 1
6220 set busyname($what) $name
6221 if {$name ne {}} {
6222 $statusw conf -text $name
6226 proc notbusy {what} {
6227 global isbusy maincursor textcursor busyname statusw
6229 catch {
6230 unset isbusy($what)
6231 if {$busyname($what) ne {} &&
6232 [$statusw cget -text] eq $busyname($what)} {
6233 $statusw conf -text {}
6236 if {[array names isbusy] eq {}} {
6237 . config -cursor $maincursor
6238 settextcursor $textcursor
6242 proc findmatches {f} {
6243 global findtype findstring
6244 if {$findtype == [mc "Regexp"]} {
6245 set matches [regexp -indices -all -inline $findstring $f]
6246 } else {
6247 set fs $findstring
6248 if {$findtype == [mc "IgnCase"]} {
6249 set f [string tolower $f]
6250 set fs [string tolower $fs]
6252 set matches {}
6253 set i 0
6254 set l [string length $fs]
6255 while {[set j [string first $fs $f $i]] >= 0} {
6256 lappend matches [list $j [expr {$j+$l-1}]]
6257 set i [expr {$j + $l}]
6260 return $matches
6263 proc dofind {{dirn 1} {wrap 1}} {
6264 global findstring findstartline findcurline selectedline numcommits
6265 global gdttype filehighlight fh_serial find_dirn findallowwrap
6267 if {[info exists find_dirn]} {
6268 if {$find_dirn == $dirn} return
6269 stopfinding
6271 focus .
6272 if {$findstring eq {} || $numcommits == 0} return
6273 if {$selectedline eq {}} {
6274 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6275 } else {
6276 set findstartline $selectedline
6278 set findcurline $findstartline
6279 nowbusy finding [mc "Searching"]
6280 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6281 after cancel do_file_hl $fh_serial
6282 do_file_hl $fh_serial
6284 set find_dirn $dirn
6285 set findallowwrap $wrap
6286 run findmore
6289 proc stopfinding {} {
6290 global find_dirn findcurline fprogcoord
6292 if {[info exists find_dirn]} {
6293 unset find_dirn
6294 unset findcurline
6295 notbusy finding
6296 set fprogcoord 0
6297 adjustprogress
6299 stopblaming
6302 proc findmore {} {
6303 global commitdata commitinfo numcommits findpattern findloc
6304 global findstartline findcurline findallowwrap
6305 global find_dirn gdttype fhighlights fprogcoord
6306 global curview varcorder vrownum varccommits vrowmod
6308 if {![info exists find_dirn]} {
6309 return 0
6311 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6312 set l $findcurline
6313 set moretodo 0
6314 if {$find_dirn > 0} {
6315 incr l
6316 if {$l >= $numcommits} {
6317 set l 0
6319 if {$l <= $findstartline} {
6320 set lim [expr {$findstartline + 1}]
6321 } else {
6322 set lim $numcommits
6323 set moretodo $findallowwrap
6325 } else {
6326 if {$l == 0} {
6327 set l $numcommits
6329 incr l -1
6330 if {$l >= $findstartline} {
6331 set lim [expr {$findstartline - 1}]
6332 } else {
6333 set lim -1
6334 set moretodo $findallowwrap
6337 set n [expr {($lim - $l) * $find_dirn}]
6338 if {$n > 500} {
6339 set n 500
6340 set moretodo 1
6342 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6343 update_arcrows $curview
6345 set found 0
6346 set domore 1
6347 set ai [bsearch $vrownum($curview) $l]
6348 set a [lindex $varcorder($curview) $ai]
6349 set arow [lindex $vrownum($curview) $ai]
6350 set ids [lindex $varccommits($curview,$a)]
6351 set arowend [expr {$arow + [llength $ids]}]
6352 if {$gdttype eq [mc "containing:"]} {
6353 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6354 if {$l < $arow || $l >= $arowend} {
6355 incr ai $find_dirn
6356 set a [lindex $varcorder($curview) $ai]
6357 set arow [lindex $vrownum($curview) $ai]
6358 set ids [lindex $varccommits($curview,$a)]
6359 set arowend [expr {$arow + [llength $ids]}]
6361 set id [lindex $ids [expr {$l - $arow}]]
6362 # shouldn't happen unless git log doesn't give all the commits...
6363 if {![info exists commitdata($id)] ||
6364 ![doesmatch $commitdata($id)]} {
6365 continue
6367 if {![info exists commitinfo($id)]} {
6368 getcommit $id
6370 set info $commitinfo($id)
6371 foreach f $info ty $fldtypes {
6372 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6373 [doesmatch $f]} {
6374 set found 1
6375 break
6378 if {$found} break
6380 } else {
6381 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6382 if {$l < $arow || $l >= $arowend} {
6383 incr ai $find_dirn
6384 set a [lindex $varcorder($curview) $ai]
6385 set arow [lindex $vrownum($curview) $ai]
6386 set ids [lindex $varccommits($curview,$a)]
6387 set arowend [expr {$arow + [llength $ids]}]
6389 set id [lindex $ids [expr {$l - $arow}]]
6390 if {![info exists fhighlights($id)]} {
6391 # this sets fhighlights($id) to -1
6392 askfilehighlight $l $id
6394 if {$fhighlights($id) > 0} {
6395 set found $domore
6396 break
6398 if {$fhighlights($id) < 0} {
6399 if {$domore} {
6400 set domore 0
6401 set findcurline [expr {$l - $find_dirn}]
6406 if {$found || ($domore && !$moretodo)} {
6407 unset findcurline
6408 unset find_dirn
6409 notbusy finding
6410 set fprogcoord 0
6411 adjustprogress
6412 if {$found} {
6413 findselectline $l
6414 } else {
6415 bell
6417 return 0
6419 if {!$domore} {
6420 flushhighlights
6421 } else {
6422 set findcurline [expr {$l - $find_dirn}]
6424 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6425 if {$n < 0} {
6426 incr n $numcommits
6428 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6429 adjustprogress
6430 return $domore
6433 proc findselectline {l} {
6434 global findloc commentend ctext findcurline markingmatches gdttype
6436 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6437 set findcurline $l
6438 selectline $l 1
6439 if {$markingmatches &&
6440 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6441 # highlight the matches in the comments
6442 set f [$ctext get 1.0 $commentend]
6443 set matches [findmatches $f]
6444 foreach match $matches {
6445 set start [lindex $match 0]
6446 set end [expr {[lindex $match 1] + 1}]
6447 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6450 drawvisible
6453 # mark the bits of a headline or author that match a find string
6454 proc markmatches {canv l str tag matches font row} {
6455 global selectedline
6457 set bbox [$canv bbox $tag]
6458 set x0 [lindex $bbox 0]
6459 set y0 [lindex $bbox 1]
6460 set y1 [lindex $bbox 3]
6461 foreach match $matches {
6462 set start [lindex $match 0]
6463 set end [lindex $match 1]
6464 if {$start > $end} continue
6465 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6466 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6467 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6468 [expr {$x0+$xlen+2}] $y1 \
6469 -outline {} -tags [list match$l matches] -fill yellow]
6470 $canv lower $t
6471 if {$row == $selectedline} {
6472 $canv raise $t secsel
6477 proc unmarkmatches {} {
6478 global markingmatches
6480 allcanvs delete matches
6481 set markingmatches 0
6482 stopfinding
6485 proc selcanvline {w x y} {
6486 global canv canvy0 ctext linespc
6487 global rowtextx
6488 set ymax [lindex [$canv cget -scrollregion] 3]
6489 if {$ymax == {}} return
6490 set yfrac [lindex [$canv yview] 0]
6491 set y [expr {$y + $yfrac * $ymax}]
6492 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6493 if {$l < 0} {
6494 set l 0
6496 if {$w eq $canv} {
6497 set xmax [lindex [$canv cget -scrollregion] 2]
6498 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6499 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6501 unmarkmatches
6502 selectline $l 1
6505 proc commit_descriptor {p} {
6506 global commitinfo
6507 if {![info exists commitinfo($p)]} {
6508 getcommit $p
6510 set l "..."
6511 if {[llength $commitinfo($p)] > 1} {
6512 set l [lindex $commitinfo($p) 0]
6514 return "$p ($l)\n"
6517 # append some text to the ctext widget, and make any SHA1 ID
6518 # that we know about be a clickable link.
6519 proc appendwithlinks {text tags} {
6520 global ctext linknum curview
6522 set start [$ctext index "end - 1c"]
6523 $ctext insert end $text $tags
6524 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6525 foreach l $links {
6526 set s [lindex $l 0]
6527 set e [lindex $l 1]
6528 set linkid [string range $text $s $e]
6529 incr e
6530 $ctext tag delete link$linknum
6531 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6532 setlink $linkid link$linknum
6533 incr linknum
6537 proc setlink {id lk} {
6538 global curview ctext pendinglinks
6540 set known 0
6541 if {[string length $id] < 40} {
6542 set matches [longid $id]
6543 if {[llength $matches] > 0} {
6544 if {[llength $matches] > 1} return
6545 set known 1
6546 set id [lindex $matches 0]
6548 } else {
6549 set known [commitinview $id $curview]
6551 if {$known} {
6552 $ctext tag conf $lk -foreground blue -underline 1
6553 $ctext tag bind $lk <1> [list selbyid $id]
6554 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6555 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6556 } else {
6557 lappend pendinglinks($id) $lk
6558 interestedin $id {makelink %P}
6562 proc appendshortlink {id {pre {}} {post {}}} {
6563 global ctext linknum
6565 $ctext insert end $pre
6566 $ctext tag delete link$linknum
6567 $ctext insert end [string range $id 0 7] link$linknum
6568 $ctext insert end $post
6569 setlink $id link$linknum
6570 incr linknum
6573 proc makelink {id} {
6574 global pendinglinks
6576 if {![info exists pendinglinks($id)]} return
6577 foreach lk $pendinglinks($id) {
6578 setlink $id $lk
6580 unset pendinglinks($id)
6583 proc linkcursor {w inc} {
6584 global linkentercount curtextcursor
6586 if {[incr linkentercount $inc] > 0} {
6587 $w configure -cursor hand2
6588 } else {
6589 $w configure -cursor $curtextcursor
6590 if {$linkentercount < 0} {
6591 set linkentercount 0
6596 proc viewnextline {dir} {
6597 global canv linespc
6599 $canv delete hover
6600 set ymax [lindex [$canv cget -scrollregion] 3]
6601 set wnow [$canv yview]
6602 set wtop [expr {[lindex $wnow 0] * $ymax}]
6603 set newtop [expr {$wtop + $dir * $linespc}]
6604 if {$newtop < 0} {
6605 set newtop 0
6606 } elseif {$newtop > $ymax} {
6607 set newtop $ymax
6609 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6612 # add a list of tag or branch names at position pos
6613 # returns the number of names inserted
6614 proc appendrefs {pos ids var} {
6615 global ctext linknum curview $var maxrefs
6617 if {[catch {$ctext index $pos}]} {
6618 return 0
6620 $ctext conf -state normal
6621 $ctext delete $pos "$pos lineend"
6622 set tags {}
6623 foreach id $ids {
6624 foreach tag [set $var\($id\)] {
6625 lappend tags [list $tag $id]
6628 if {[llength $tags] > $maxrefs} {
6629 $ctext insert $pos "[mc "many"] ([llength $tags])"
6630 } else {
6631 set tags [lsort -index 0 -decreasing $tags]
6632 set sep {}
6633 foreach ti $tags {
6634 set id [lindex $ti 1]
6635 set lk link$linknum
6636 incr linknum
6637 $ctext tag delete $lk
6638 $ctext insert $pos $sep
6639 $ctext insert $pos [lindex $ti 0] $lk
6640 setlink $id $lk
6641 set sep ", "
6644 $ctext conf -state disabled
6645 return [llength $tags]
6648 # called when we have finished computing the nearby tags
6649 proc dispneartags {delay} {
6650 global selectedline currentid showneartags tagphase
6652 if {$selectedline eq {} || !$showneartags} return
6653 after cancel dispnexttag
6654 if {$delay} {
6655 after 200 dispnexttag
6656 set tagphase -1
6657 } else {
6658 after idle dispnexttag
6659 set tagphase 0
6663 proc dispnexttag {} {
6664 global selectedline currentid showneartags tagphase ctext
6666 if {$selectedline eq {} || !$showneartags} return
6667 switch -- $tagphase {
6669 set dtags [desctags $currentid]
6670 if {$dtags ne {}} {
6671 appendrefs precedes $dtags idtags
6675 set atags [anctags $currentid]
6676 if {$atags ne {}} {
6677 appendrefs follows $atags idtags
6681 set dheads [descheads $currentid]
6682 if {$dheads ne {}} {
6683 if {[appendrefs branch $dheads idheads] > 1
6684 && [$ctext get "branch -3c"] eq "h"} {
6685 # turn "Branch" into "Branches"
6686 $ctext conf -state normal
6687 $ctext insert "branch -2c" "es"
6688 $ctext conf -state disabled
6693 if {[incr tagphase] <= 2} {
6694 after idle dispnexttag
6698 proc make_secsel {id} {
6699 global linehtag linentag linedtag canv canv2 canv3
6701 if {![info exists linehtag($id)]} return
6702 $canv delete secsel
6703 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6704 -tags secsel -fill [$canv cget -selectbackground]]
6705 $canv lower $t
6706 $canv2 delete secsel
6707 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6708 -tags secsel -fill [$canv2 cget -selectbackground]]
6709 $canv2 lower $t
6710 $canv3 delete secsel
6711 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6712 -tags secsel -fill [$canv3 cget -selectbackground]]
6713 $canv3 lower $t
6716 proc make_idmark {id} {
6717 global linehtag canv fgcolor
6719 if {![info exists linehtag($id)]} return
6720 $canv delete markid
6721 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6722 -tags markid -outline $fgcolor]
6723 $canv raise $t
6726 proc selectline {l isnew {desired_loc {}}} {
6727 global canv ctext commitinfo selectedline
6728 global canvy0 linespc parents children curview
6729 global currentid sha1entry
6730 global commentend idtags linknum
6731 global mergemax numcommits pending_select
6732 global cmitmode showneartags allcommits
6733 global targetrow targetid lastscrollrows
6734 global autoselect jump_to_here
6736 catch {unset pending_select}
6737 $canv delete hover
6738 normalline
6739 unsel_reflist
6740 stopfinding
6741 if {$l < 0 || $l >= $numcommits} return
6742 set id [commitonrow $l]
6743 set targetid $id
6744 set targetrow $l
6745 set selectedline $l
6746 set currentid $id
6747 if {$lastscrollrows < $numcommits} {
6748 setcanvscroll
6751 set y [expr {$canvy0 + $l * $linespc}]
6752 set ymax [lindex [$canv cget -scrollregion] 3]
6753 set ytop [expr {$y - $linespc - 1}]
6754 set ybot [expr {$y + $linespc + 1}]
6755 set wnow [$canv yview]
6756 set wtop [expr {[lindex $wnow 0] * $ymax}]
6757 set wbot [expr {[lindex $wnow 1] * $ymax}]
6758 set wh [expr {$wbot - $wtop}]
6759 set newtop $wtop
6760 if {$ytop < $wtop} {
6761 if {$ybot < $wtop} {
6762 set newtop [expr {$y - $wh / 2.0}]
6763 } else {
6764 set newtop $ytop
6765 if {$newtop > $wtop - $linespc} {
6766 set newtop [expr {$wtop - $linespc}]
6769 } elseif {$ybot > $wbot} {
6770 if {$ytop > $wbot} {
6771 set newtop [expr {$y - $wh / 2.0}]
6772 } else {
6773 set newtop [expr {$ybot - $wh}]
6774 if {$newtop < $wtop + $linespc} {
6775 set newtop [expr {$wtop + $linespc}]
6779 if {$newtop != $wtop} {
6780 if {$newtop < 0} {
6781 set newtop 0
6783 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6784 drawvisible
6787 make_secsel $id
6789 if {$isnew} {
6790 addtohistory [list selbyid $id]
6793 $sha1entry delete 0 end
6794 $sha1entry insert 0 $id
6795 if {$autoselect} {
6796 $sha1entry selection from 0
6797 $sha1entry selection to end
6799 rhighlight_sel $id
6801 $ctext conf -state normal
6802 clear_ctext
6803 set linknum 0
6804 if {![info exists commitinfo($id)]} {
6805 getcommit $id
6807 set info $commitinfo($id)
6808 set date [formatdate [lindex $info 2]]
6809 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6810 set date [formatdate [lindex $info 4]]
6811 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6812 if {[info exists idtags($id)]} {
6813 $ctext insert end [mc "Tags:"]
6814 foreach tag $idtags($id) {
6815 $ctext insert end " $tag"
6817 $ctext insert end "\n"
6820 set headers {}
6821 set olds $parents($curview,$id)
6822 if {[llength $olds] > 1} {
6823 set np 0
6824 foreach p $olds {
6825 if {$np >= $mergemax} {
6826 set tag mmax
6827 } else {
6828 set tag m$np
6830 $ctext insert end "[mc "Parent"]: " $tag
6831 appendwithlinks [commit_descriptor $p] {}
6832 incr np
6834 } else {
6835 foreach p $olds {
6836 append headers "[mc "Parent"]: [commit_descriptor $p]"
6840 foreach c $children($curview,$id) {
6841 append headers "[mc "Child"]: [commit_descriptor $c]"
6844 # make anything that looks like a SHA1 ID be a clickable link
6845 appendwithlinks $headers {}
6846 if {$showneartags} {
6847 if {![info exists allcommits]} {
6848 getallcommits
6850 $ctext insert end "[mc "Branch"]: "
6851 $ctext mark set branch "end -1c"
6852 $ctext mark gravity branch left
6853 $ctext insert end "\n[mc "Follows"]: "
6854 $ctext mark set follows "end -1c"
6855 $ctext mark gravity follows left
6856 $ctext insert end "\n[mc "Precedes"]: "
6857 $ctext mark set precedes "end -1c"
6858 $ctext mark gravity precedes left
6859 $ctext insert end "\n"
6860 dispneartags 1
6862 $ctext insert end "\n"
6863 set comment [lindex $info 5]
6864 if {[string first "\r" $comment] >= 0} {
6865 set comment [string map {"\r" "\n "} $comment]
6867 appendwithlinks $comment {comment}
6869 $ctext tag remove found 1.0 end
6870 $ctext conf -state disabled
6871 set commentend [$ctext index "end - 1c"]
6873 set jump_to_here $desired_loc
6874 init_flist [mc "Comments"]
6875 if {$cmitmode eq "tree"} {
6876 gettree $id
6877 } elseif {[llength $olds] <= 1} {
6878 startdiff $id
6879 } else {
6880 mergediff $id
6884 proc selfirstline {} {
6885 unmarkmatches
6886 selectline 0 1
6889 proc sellastline {} {
6890 global numcommits
6891 unmarkmatches
6892 set l [expr {$numcommits - 1}]
6893 selectline $l 1
6896 proc selnextline {dir} {
6897 global selectedline
6898 focus .
6899 if {$selectedline eq {}} return
6900 set l [expr {$selectedline + $dir}]
6901 unmarkmatches
6902 selectline $l 1
6905 proc selnextpage {dir} {
6906 global canv linespc selectedline numcommits
6908 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6909 if {$lpp < 1} {
6910 set lpp 1
6912 allcanvs yview scroll [expr {$dir * $lpp}] units
6913 drawvisible
6914 if {$selectedline eq {}} return
6915 set l [expr {$selectedline + $dir * $lpp}]
6916 if {$l < 0} {
6917 set l 0
6918 } elseif {$l >= $numcommits} {
6919 set l [expr $numcommits - 1]
6921 unmarkmatches
6922 selectline $l 1
6925 proc unselectline {} {
6926 global selectedline currentid
6928 set selectedline {}
6929 catch {unset currentid}
6930 allcanvs delete secsel
6931 rhighlight_none
6934 proc reselectline {} {
6935 global selectedline
6937 if {$selectedline ne {}} {
6938 selectline $selectedline 0
6942 proc addtohistory {cmd} {
6943 global history historyindex curview
6945 set elt [list $curview $cmd]
6946 if {$historyindex > 0
6947 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6948 return
6951 if {$historyindex < [llength $history]} {
6952 set history [lreplace $history $historyindex end $elt]
6953 } else {
6954 lappend history $elt
6956 incr historyindex
6957 if {$historyindex > 1} {
6958 .tf.bar.leftbut conf -state normal
6959 } else {
6960 .tf.bar.leftbut conf -state disabled
6962 .tf.bar.rightbut conf -state disabled
6965 proc godo {elt} {
6966 global curview
6968 set view [lindex $elt 0]
6969 set cmd [lindex $elt 1]
6970 if {$curview != $view} {
6971 showview $view
6973 eval $cmd
6976 proc goback {} {
6977 global history historyindex
6978 focus .
6980 if {$historyindex > 1} {
6981 incr historyindex -1
6982 godo [lindex $history [expr {$historyindex - 1}]]
6983 .tf.bar.rightbut conf -state normal
6985 if {$historyindex <= 1} {
6986 .tf.bar.leftbut conf -state disabled
6990 proc goforw {} {
6991 global history historyindex
6992 focus .
6994 if {$historyindex < [llength $history]} {
6995 set cmd [lindex $history $historyindex]
6996 incr historyindex
6997 godo $cmd
6998 .tf.bar.leftbut conf -state normal
7000 if {$historyindex >= [llength $history]} {
7001 .tf.bar.rightbut conf -state disabled
7005 proc gettree {id} {
7006 global treefilelist treeidlist diffids diffmergeid treepending
7007 global nullid nullid2
7009 set diffids $id
7010 catch {unset diffmergeid}
7011 if {![info exists treefilelist($id)]} {
7012 if {![info exists treepending]} {
7013 if {$id eq $nullid} {
7014 set cmd [list | git ls-files]
7015 } elseif {$id eq $nullid2} {
7016 set cmd [list | git ls-files --stage -t]
7017 } else {
7018 set cmd [list | git ls-tree -r $id]
7020 if {[catch {set gtf [open $cmd r]}]} {
7021 return
7023 set treepending $id
7024 set treefilelist($id) {}
7025 set treeidlist($id) {}
7026 fconfigure $gtf -blocking 0 -encoding binary
7027 filerun $gtf [list gettreeline $gtf $id]
7029 } else {
7030 setfilelist $id
7034 proc gettreeline {gtf id} {
7035 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7037 set nl 0
7038 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7039 if {$diffids eq $nullid} {
7040 set fname $line
7041 } else {
7042 set i [string first "\t" $line]
7043 if {$i < 0} continue
7044 set fname [string range $line [expr {$i+1}] end]
7045 set line [string range $line 0 [expr {$i-1}]]
7046 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7047 set sha1 [lindex $line 2]
7048 lappend treeidlist($id) $sha1
7050 if {[string index $fname 0] eq "\""} {
7051 set fname [lindex $fname 0]
7053 set fname [encoding convertfrom $fname]
7054 lappend treefilelist($id) $fname
7056 if {![eof $gtf]} {
7057 return [expr {$nl >= 1000? 2: 1}]
7059 close $gtf
7060 unset treepending
7061 if {$cmitmode ne "tree"} {
7062 if {![info exists diffmergeid]} {
7063 gettreediffs $diffids
7065 } elseif {$id ne $diffids} {
7066 gettree $diffids
7067 } else {
7068 setfilelist $id
7070 return 0
7073 proc showfile {f} {
7074 global treefilelist treeidlist diffids nullid nullid2
7075 global ctext_file_names ctext_file_lines
7076 global ctext commentend
7078 set i [lsearch -exact $treefilelist($diffids) $f]
7079 if {$i < 0} {
7080 puts "oops, $f not in list for id $diffids"
7081 return
7083 if {$diffids eq $nullid} {
7084 if {[catch {set bf [open $f r]} err]} {
7085 puts "oops, can't read $f: $err"
7086 return
7088 } else {
7089 set blob [lindex $treeidlist($diffids) $i]
7090 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7091 puts "oops, error reading blob $blob: $err"
7092 return
7095 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7096 filerun $bf [list getblobline $bf $diffids]
7097 $ctext config -state normal
7098 clear_ctext $commentend
7099 lappend ctext_file_names $f
7100 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7101 $ctext insert end "\n"
7102 $ctext insert end "$f\n" filesep
7103 $ctext config -state disabled
7104 $ctext yview $commentend
7105 settabs 0
7108 proc getblobline {bf id} {
7109 global diffids cmitmode ctext
7111 if {$id ne $diffids || $cmitmode ne "tree"} {
7112 catch {close $bf}
7113 return 0
7115 $ctext config -state normal
7116 set nl 0
7117 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7118 $ctext insert end "$line\n"
7120 if {[eof $bf]} {
7121 global jump_to_here ctext_file_names commentend
7123 # delete last newline
7124 $ctext delete "end - 2c" "end - 1c"
7125 close $bf
7126 if {$jump_to_here ne {} &&
7127 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7128 set lnum [expr {[lindex $jump_to_here 1] +
7129 [lindex [split $commentend .] 0]}]
7130 mark_ctext_line $lnum
7132 return 0
7134 $ctext config -state disabled
7135 return [expr {$nl >= 1000? 2: 1}]
7138 proc mark_ctext_line {lnum} {
7139 global ctext markbgcolor
7141 $ctext tag delete omark
7142 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7143 $ctext tag conf omark -background $markbgcolor
7144 $ctext see $lnum.0
7147 proc mergediff {id} {
7148 global diffmergeid
7149 global diffids treediffs
7150 global parents curview
7152 set diffmergeid $id
7153 set diffids $id
7154 set treediffs($id) {}
7155 set np [llength $parents($curview,$id)]
7156 settabs $np
7157 getblobdiffs $id
7160 proc startdiff {ids} {
7161 global treediffs diffids treepending diffmergeid nullid nullid2
7163 settabs 1
7164 set diffids $ids
7165 catch {unset diffmergeid}
7166 if {![info exists treediffs($ids)] ||
7167 [lsearch -exact $ids $nullid] >= 0 ||
7168 [lsearch -exact $ids $nullid2] >= 0} {
7169 if {![info exists treepending]} {
7170 gettreediffs $ids
7172 } else {
7173 addtocflist $ids
7177 proc path_filter {filter name} {
7178 foreach p $filter {
7179 set l [string length $p]
7180 if {[string index $p end] eq "/"} {
7181 if {[string compare -length $l $p $name] == 0} {
7182 return 1
7184 } else {
7185 if {[string compare -length $l $p $name] == 0 &&
7186 ([string length $name] == $l ||
7187 [string index $name $l] eq "/")} {
7188 return 1
7192 return 0
7195 proc addtocflist {ids} {
7196 global treediffs
7198 add_flist $treediffs($ids)
7199 getblobdiffs $ids
7202 proc diffcmd {ids flags} {
7203 global nullid nullid2
7205 set i [lsearch -exact $ids $nullid]
7206 set j [lsearch -exact $ids $nullid2]
7207 if {$i >= 0} {
7208 if {[llength $ids] > 1 && $j < 0} {
7209 # comparing working directory with some specific revision
7210 set cmd [concat | git diff-index $flags]
7211 if {$i == 0} {
7212 lappend cmd -R [lindex $ids 1]
7213 } else {
7214 lappend cmd [lindex $ids 0]
7216 } else {
7217 # comparing working directory with index
7218 set cmd [concat | git diff-files $flags]
7219 if {$j == 1} {
7220 lappend cmd -R
7223 } elseif {$j >= 0} {
7224 set cmd [concat | git diff-index --cached $flags]
7225 if {[llength $ids] > 1} {
7226 # comparing index with specific revision
7227 if {$i == 0} {
7228 lappend cmd -R [lindex $ids 1]
7229 } else {
7230 lappend cmd [lindex $ids 0]
7232 } else {
7233 # comparing index with HEAD
7234 lappend cmd HEAD
7236 } else {
7237 set cmd [concat | git diff-tree -r $flags $ids]
7239 return $cmd
7242 proc gettreediffs {ids} {
7243 global treediff treepending
7245 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7247 set treepending $ids
7248 set treediff {}
7249 fconfigure $gdtf -blocking 0 -encoding binary
7250 filerun $gdtf [list gettreediffline $gdtf $ids]
7253 proc gettreediffline {gdtf ids} {
7254 global treediff treediffs treepending diffids diffmergeid
7255 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7257 set nr 0
7258 set sublist {}
7259 set max 1000
7260 if {$perfile_attrs} {
7261 # cache_gitattr is slow, and even slower on win32 where we
7262 # have to invoke it for only about 30 paths at a time
7263 set max 500
7264 if {[tk windowingsystem] == "win32"} {
7265 set max 120
7268 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7269 set i [string first "\t" $line]
7270 if {$i >= 0} {
7271 set file [string range $line [expr {$i+1}] end]
7272 if {[string index $file 0] eq "\""} {
7273 set file [lindex $file 0]
7275 set file [encoding convertfrom $file]
7276 if {$file ne [lindex $treediff end]} {
7277 lappend treediff $file
7278 lappend sublist $file
7282 if {$perfile_attrs} {
7283 cache_gitattr encoding $sublist
7285 if {![eof $gdtf]} {
7286 return [expr {$nr >= $max? 2: 1}]
7288 close $gdtf
7289 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7290 set flist {}
7291 foreach f $treediff {
7292 if {[path_filter $vfilelimit($curview) $f]} {
7293 lappend flist $f
7296 set treediffs($ids) $flist
7297 } else {
7298 set treediffs($ids) $treediff
7300 unset treepending
7301 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7302 gettree $diffids
7303 } elseif {$ids != $diffids} {
7304 if {![info exists diffmergeid]} {
7305 gettreediffs $diffids
7307 } else {
7308 addtocflist $ids
7310 return 0
7313 # empty string or positive integer
7314 proc diffcontextvalidate {v} {
7315 return [regexp {^(|[1-9][0-9]*)$} $v]
7318 proc diffcontextchange {n1 n2 op} {
7319 global diffcontextstring diffcontext
7321 if {[string is integer -strict $diffcontextstring]} {
7322 if {$diffcontextstring >= 0} {
7323 set diffcontext $diffcontextstring
7324 reselectline
7329 proc changeignorespace {} {
7330 reselectline
7333 proc getblobdiffs {ids} {
7334 global blobdifffd diffids env
7335 global diffinhdr treediffs
7336 global diffcontext
7337 global ignorespace
7338 global limitdiffs vfilelimit curview
7339 global diffencoding targetline diffnparents
7340 global git_version
7342 set textconv {}
7343 if {[package vcompare $git_version "1.6.1"] >= 0} {
7344 set textconv "--textconv"
7346 set cmd [diffcmd $ids "-p $textconv -C --cc --no-commit-id -U$diffcontext"]
7347 if {$ignorespace} {
7348 append cmd " -w"
7350 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7351 set cmd [concat $cmd -- $vfilelimit($curview)]
7353 if {[catch {set bdf [open $cmd r]} err]} {
7354 error_popup [mc "Error getting diffs: %s" $err]
7355 return
7357 set targetline {}
7358 set diffnparents 0
7359 set diffinhdr 0
7360 set diffencoding [get_path_encoding {}]
7361 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7362 set blobdifffd($ids) $bdf
7363 filerun $bdf [list getblobdiffline $bdf $diffids]
7366 proc setinlist {var i val} {
7367 global $var
7369 while {[llength [set $var]] < $i} {
7370 lappend $var {}
7372 if {[llength [set $var]] == $i} {
7373 lappend $var $val
7374 } else {
7375 lset $var $i $val
7379 proc makediffhdr {fname ids} {
7380 global ctext curdiffstart treediffs diffencoding
7381 global ctext_file_names jump_to_here targetline diffline
7383 set fname [encoding convertfrom $fname]
7384 set diffencoding [get_path_encoding $fname]
7385 set i [lsearch -exact $treediffs($ids) $fname]
7386 if {$i >= 0} {
7387 setinlist difffilestart $i $curdiffstart
7389 lset ctext_file_names end $fname
7390 set l [expr {(78 - [string length $fname]) / 2}]
7391 set pad [string range "----------------------------------------" 1 $l]
7392 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7393 set targetline {}
7394 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7395 set targetline [lindex $jump_to_here 1]
7397 set diffline 0
7400 proc getblobdiffline {bdf ids} {
7401 global diffids blobdifffd ctext curdiffstart
7402 global diffnexthead diffnextnote difffilestart
7403 global ctext_file_names ctext_file_lines
7404 global diffinhdr treediffs mergemax diffnparents
7405 global diffencoding jump_to_here targetline diffline
7407 set nr 0
7408 $ctext conf -state normal
7409 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7410 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7411 catch {close $bdf}
7412 return 0
7414 if {![string compare -length 5 "diff " $line]} {
7415 if {![regexp {^diff (--cc|--git) } $line m type]} {
7416 set line [encoding convertfrom $line]
7417 $ctext insert end "$line\n" hunksep
7418 continue
7420 # start of a new file
7421 set diffinhdr 1
7422 $ctext insert end "\n"
7423 set curdiffstart [$ctext index "end - 1c"]
7424 lappend ctext_file_names ""
7425 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7426 $ctext insert end "\n" filesep
7428 if {$type eq "--cc"} {
7429 # start of a new file in a merge diff
7430 set fname [string range $line 10 end]
7431 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7432 lappend treediffs($ids) $fname
7433 add_flist [list $fname]
7436 } else {
7437 set line [string range $line 11 end]
7438 # If the name hasn't changed the length will be odd,
7439 # the middle char will be a space, and the two bits either
7440 # side will be a/name and b/name, or "a/name" and "b/name".
7441 # If the name has changed we'll get "rename from" and
7442 # "rename to" or "copy from" and "copy to" lines following
7443 # this, and we'll use them to get the filenames.
7444 # This complexity is necessary because spaces in the
7445 # filename(s) don't get escaped.
7446 set l [string length $line]
7447 set i [expr {$l / 2}]
7448 if {!(($l & 1) && [string index $line $i] eq " " &&
7449 [string range $line 2 [expr {$i - 1}]] eq \
7450 [string range $line [expr {$i + 3}] end])} {
7451 continue
7453 # unescape if quoted and chop off the a/ from the front
7454 if {[string index $line 0] eq "\""} {
7455 set fname [string range [lindex $line 0] 2 end]
7456 } else {
7457 set fname [string range $line 2 [expr {$i - 1}]]
7460 makediffhdr $fname $ids
7462 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7463 set fname [encoding convertfrom [string range $line 16 end]]
7464 $ctext insert end "\n"
7465 set curdiffstart [$ctext index "end - 1c"]
7466 lappend ctext_file_names $fname
7467 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7468 $ctext insert end "$line\n" filesep
7469 set i [lsearch -exact $treediffs($ids) $fname]
7470 if {$i >= 0} {
7471 setinlist difffilestart $i $curdiffstart
7474 } elseif {![string compare -length 2 "@@" $line]} {
7475 regexp {^@@+} $line ats
7476 set line [encoding convertfrom $diffencoding $line]
7477 $ctext insert end "$line\n" hunksep
7478 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7479 set diffline $nl
7481 set diffnparents [expr {[string length $ats] - 1}]
7482 set diffinhdr 0
7484 } elseif {$diffinhdr} {
7485 if {![string compare -length 12 "rename from " $line]} {
7486 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7487 if {[string index $fname 0] eq "\""} {
7488 set fname [lindex $fname 0]
7490 set fname [encoding convertfrom $fname]
7491 set i [lsearch -exact $treediffs($ids) $fname]
7492 if {$i >= 0} {
7493 setinlist difffilestart $i $curdiffstart
7495 } elseif {![string compare -length 10 $line "rename to "] ||
7496 ![string compare -length 8 $line "copy to "]} {
7497 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7498 if {[string index $fname 0] eq "\""} {
7499 set fname [lindex $fname 0]
7501 makediffhdr $fname $ids
7502 } elseif {[string compare -length 3 $line "---"] == 0} {
7503 # do nothing
7504 continue
7505 } elseif {[string compare -length 3 $line "+++"] == 0} {
7506 set diffinhdr 0
7507 continue
7509 $ctext insert end "$line\n" filesep
7511 } else {
7512 set line [string map {\x1A ^Z} \
7513 [encoding convertfrom $diffencoding $line]]
7514 # parse the prefix - one ' ', '-' or '+' for each parent
7515 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7516 set tag [expr {$diffnparents > 1? "m": "d"}]
7517 if {[string trim $prefix " -+"] eq {}} {
7518 # prefix only has " ", "-" and "+" in it: normal diff line
7519 set num [string first "-" $prefix]
7520 if {$num >= 0} {
7521 # removed line, first parent with line is $num
7522 if {$num >= $mergemax} {
7523 set num "max"
7525 $ctext insert end "$line\n" $tag$num
7526 } else {
7527 set tags {}
7528 if {[string first "+" $prefix] >= 0} {
7529 # added line
7530 lappend tags ${tag}result
7531 if {$diffnparents > 1} {
7532 set num [string first " " $prefix]
7533 if {$num >= 0} {
7534 if {$num >= $mergemax} {
7535 set num "max"
7537 lappend tags m$num
7541 if {$targetline ne {}} {
7542 if {$diffline == $targetline} {
7543 set seehere [$ctext index "end - 1 chars"]
7544 set targetline {}
7545 } else {
7546 incr diffline
7549 $ctext insert end "$line\n" $tags
7551 } else {
7552 # "\ No newline at end of file",
7553 # or something else we don't recognize
7554 $ctext insert end "$line\n" hunksep
7558 if {[info exists seehere]} {
7559 mark_ctext_line [lindex [split $seehere .] 0]
7561 $ctext conf -state disabled
7562 if {[eof $bdf]} {
7563 catch {close $bdf}
7564 return 0
7566 return [expr {$nr >= 1000? 2: 1}]
7569 proc changediffdisp {} {
7570 global ctext diffelide
7572 $ctext tag conf d0 -elide [lindex $diffelide 0]
7573 $ctext tag conf dresult -elide [lindex $diffelide 1]
7576 proc highlightfile {loc cline} {
7577 global ctext cflist cflist_top
7579 $ctext yview $loc
7580 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7581 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7582 $cflist see $cline.0
7583 set cflist_top $cline
7586 proc prevfile {} {
7587 global difffilestart ctext cmitmode
7589 if {$cmitmode eq "tree"} return
7590 set prev 0.0
7591 set prevline 1
7592 set here [$ctext index @0,0]
7593 foreach loc $difffilestart {
7594 if {[$ctext compare $loc >= $here]} {
7595 highlightfile $prev $prevline
7596 return
7598 set prev $loc
7599 incr prevline
7601 highlightfile $prev $prevline
7604 proc nextfile {} {
7605 global difffilestart ctext cmitmode
7607 if {$cmitmode eq "tree"} return
7608 set here [$ctext index @0,0]
7609 set line 1
7610 foreach loc $difffilestart {
7611 incr line
7612 if {[$ctext compare $loc > $here]} {
7613 highlightfile $loc $line
7614 return
7619 proc clear_ctext {{first 1.0}} {
7620 global ctext smarktop smarkbot
7621 global ctext_file_names ctext_file_lines
7622 global pendinglinks
7624 set l [lindex [split $first .] 0]
7625 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7626 set smarktop $l
7628 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7629 set smarkbot $l
7631 $ctext delete $first end
7632 if {$first eq "1.0"} {
7633 catch {unset pendinglinks}
7635 set ctext_file_names {}
7636 set ctext_file_lines {}
7639 proc settabs {{firstab {}}} {
7640 global firsttabstop tabstop ctext have_tk85
7642 if {$firstab ne {} && $have_tk85} {
7643 set firsttabstop $firstab
7645 set w [font measure textfont "0"]
7646 if {$firsttabstop != 0} {
7647 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7648 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7649 } elseif {$have_tk85 || $tabstop != 8} {
7650 $ctext conf -tabs [expr {$tabstop * $w}]
7651 } else {
7652 $ctext conf -tabs {}
7656 proc incrsearch {name ix op} {
7657 global ctext searchstring searchdirn
7659 $ctext tag remove found 1.0 end
7660 if {[catch {$ctext index anchor}]} {
7661 # no anchor set, use start of selection, or of visible area
7662 set sel [$ctext tag ranges sel]
7663 if {$sel ne {}} {
7664 $ctext mark set anchor [lindex $sel 0]
7665 } elseif {$searchdirn eq "-forwards"} {
7666 $ctext mark set anchor @0,0
7667 } else {
7668 $ctext mark set anchor @0,[winfo height $ctext]
7671 if {$searchstring ne {}} {
7672 set here [$ctext search $searchdirn -- $searchstring anchor]
7673 if {$here ne {}} {
7674 $ctext see $here
7676 searchmarkvisible 1
7680 proc dosearch {} {
7681 global sstring ctext searchstring searchdirn
7683 focus $sstring
7684 $sstring icursor end
7685 set searchdirn -forwards
7686 if {$searchstring ne {}} {
7687 set sel [$ctext tag ranges sel]
7688 if {$sel ne {}} {
7689 set start "[lindex $sel 0] + 1c"
7690 } elseif {[catch {set start [$ctext index anchor]}]} {
7691 set start "@0,0"
7693 set match [$ctext search -count mlen -- $searchstring $start]
7694 $ctext tag remove sel 1.0 end
7695 if {$match eq {}} {
7696 bell
7697 return
7699 $ctext see $match
7700 set mend "$match + $mlen c"
7701 $ctext tag add sel $match $mend
7702 $ctext mark unset anchor
7706 proc dosearchback {} {
7707 global sstring ctext searchstring searchdirn
7709 focus $sstring
7710 $sstring icursor end
7711 set searchdirn -backwards
7712 if {$searchstring ne {}} {
7713 set sel [$ctext tag ranges sel]
7714 if {$sel ne {}} {
7715 set start [lindex $sel 0]
7716 } elseif {[catch {set start [$ctext index anchor]}]} {
7717 set start @0,[winfo height $ctext]
7719 set match [$ctext search -backwards -count ml -- $searchstring $start]
7720 $ctext tag remove sel 1.0 end
7721 if {$match eq {}} {
7722 bell
7723 return
7725 $ctext see $match
7726 set mend "$match + $ml c"
7727 $ctext tag add sel $match $mend
7728 $ctext mark unset anchor
7732 proc searchmark {first last} {
7733 global ctext searchstring
7735 set mend $first.0
7736 while {1} {
7737 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7738 if {$match eq {}} break
7739 set mend "$match + $mlen c"
7740 $ctext tag add found $match $mend
7744 proc searchmarkvisible {doall} {
7745 global ctext smarktop smarkbot
7747 set topline [lindex [split [$ctext index @0,0] .] 0]
7748 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7749 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7750 # no overlap with previous
7751 searchmark $topline $botline
7752 set smarktop $topline
7753 set smarkbot $botline
7754 } else {
7755 if {$topline < $smarktop} {
7756 searchmark $topline [expr {$smarktop-1}]
7757 set smarktop $topline
7759 if {$botline > $smarkbot} {
7760 searchmark [expr {$smarkbot+1}] $botline
7761 set smarkbot $botline
7766 proc scrolltext {f0 f1} {
7767 global searchstring
7769 .bleft.bottom.sb set $f0 $f1
7770 if {$searchstring ne {}} {
7771 searchmarkvisible 0
7775 proc setcoords {} {
7776 global linespc charspc canvx0 canvy0
7777 global xspc1 xspc2 lthickness
7779 set linespc [font metrics mainfont -linespace]
7780 set charspc [font measure mainfont "m"]
7781 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7782 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7783 set lthickness [expr {int($linespc / 9) + 1}]
7784 set xspc1(0) $linespc
7785 set xspc2 $linespc
7788 proc redisplay {} {
7789 global canv
7790 global selectedline
7792 set ymax [lindex [$canv cget -scrollregion] 3]
7793 if {$ymax eq {} || $ymax == 0} return
7794 set span [$canv yview]
7795 clear_display
7796 setcanvscroll
7797 allcanvs yview moveto [lindex $span 0]
7798 drawvisible
7799 if {$selectedline ne {}} {
7800 selectline $selectedline 0
7801 allcanvs yview moveto [lindex $span 0]
7805 proc parsefont {f n} {
7806 global fontattr
7808 set fontattr($f,family) [lindex $n 0]
7809 set s [lindex $n 1]
7810 if {$s eq {} || $s == 0} {
7811 set s 10
7812 } elseif {$s < 0} {
7813 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7815 set fontattr($f,size) $s
7816 set fontattr($f,weight) normal
7817 set fontattr($f,slant) roman
7818 foreach style [lrange $n 2 end] {
7819 switch -- $style {
7820 "normal" -
7821 "bold" {set fontattr($f,weight) $style}
7822 "roman" -
7823 "italic" {set fontattr($f,slant) $style}
7828 proc fontflags {f {isbold 0}} {
7829 global fontattr
7831 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7832 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7833 -slant $fontattr($f,slant)]
7836 proc fontname {f} {
7837 global fontattr
7839 set n [list $fontattr($f,family) $fontattr($f,size)]
7840 if {$fontattr($f,weight) eq "bold"} {
7841 lappend n "bold"
7843 if {$fontattr($f,slant) eq "italic"} {
7844 lappend n "italic"
7846 return $n
7849 proc incrfont {inc} {
7850 global mainfont textfont ctext canv cflist showrefstop
7851 global stopped entries fontattr
7853 unmarkmatches
7854 set s $fontattr(mainfont,size)
7855 incr s $inc
7856 if {$s < 1} {
7857 set s 1
7859 set fontattr(mainfont,size) $s
7860 font config mainfont -size $s
7861 font config mainfontbold -size $s
7862 set mainfont [fontname mainfont]
7863 set s $fontattr(textfont,size)
7864 incr s $inc
7865 if {$s < 1} {
7866 set s 1
7868 set fontattr(textfont,size) $s
7869 font config textfont -size $s
7870 font config textfontbold -size $s
7871 set textfont [fontname textfont]
7872 setcoords
7873 settabs
7874 redisplay
7877 proc clearsha1 {} {
7878 global sha1entry sha1string
7879 if {[string length $sha1string] == 40} {
7880 $sha1entry delete 0 end
7884 proc sha1change {n1 n2 op} {
7885 global sha1string currentid sha1but
7886 if {$sha1string == {}
7887 || ([info exists currentid] && $sha1string == $currentid)} {
7888 set state disabled
7889 } else {
7890 set state normal
7892 if {[$sha1but cget -state] == $state} return
7893 if {$state == "normal"} {
7894 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7895 } else {
7896 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7900 proc gotocommit {} {
7901 global sha1string tagids headids curview varcid
7903 if {$sha1string == {}
7904 || ([info exists currentid] && $sha1string == $currentid)} return
7905 if {[info exists tagids($sha1string)]} {
7906 set id $tagids($sha1string)
7907 } elseif {[info exists headids($sha1string)]} {
7908 set id $headids($sha1string)
7909 } else {
7910 set id [string tolower $sha1string]
7911 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7912 set matches [longid $id]
7913 if {$matches ne {}} {
7914 if {[llength $matches] > 1} {
7915 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7916 return
7918 set id [lindex $matches 0]
7920 } else {
7921 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
7922 error_popup [mc "Revision %s is not known" $sha1string]
7923 return
7927 if {[commitinview $id $curview]} {
7928 selectline [rowofcommit $id] 1
7929 return
7931 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7932 set msg [mc "SHA1 id %s is not known" $sha1string]
7933 } else {
7934 set msg [mc "Revision %s is not in the current view" $sha1string]
7936 error_popup $msg
7939 proc lineenter {x y id} {
7940 global hoverx hovery hoverid hovertimer
7941 global commitinfo canv
7943 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7944 set hoverx $x
7945 set hovery $y
7946 set hoverid $id
7947 if {[info exists hovertimer]} {
7948 after cancel $hovertimer
7950 set hovertimer [after 500 linehover]
7951 $canv delete hover
7954 proc linemotion {x y id} {
7955 global hoverx hovery hoverid hovertimer
7957 if {[info exists hoverid] && $id == $hoverid} {
7958 set hoverx $x
7959 set hovery $y
7960 if {[info exists hovertimer]} {
7961 after cancel $hovertimer
7963 set hovertimer [after 500 linehover]
7967 proc lineleave {id} {
7968 global hoverid hovertimer canv
7970 if {[info exists hoverid] && $id == $hoverid} {
7971 $canv delete hover
7972 if {[info exists hovertimer]} {
7973 after cancel $hovertimer
7974 unset hovertimer
7976 unset hoverid
7980 proc linehover {} {
7981 global hoverx hovery hoverid hovertimer
7982 global canv linespc lthickness
7983 global commitinfo
7985 set text [lindex $commitinfo($hoverid) 0]
7986 set ymax [lindex [$canv cget -scrollregion] 3]
7987 if {$ymax == {}} return
7988 set yfrac [lindex [$canv yview] 0]
7989 set x [expr {$hoverx + 2 * $linespc}]
7990 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7991 set x0 [expr {$x - 2 * $lthickness}]
7992 set y0 [expr {$y - 2 * $lthickness}]
7993 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7994 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7995 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7996 -fill \#ffff80 -outline black -width 1 -tags hover]
7997 $canv raise $t
7998 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7999 -font mainfont]
8000 $canv raise $t
8003 proc clickisonarrow {id y} {
8004 global lthickness
8006 set ranges [rowranges $id]
8007 set thresh [expr {2 * $lthickness + 6}]
8008 set n [expr {[llength $ranges] - 1}]
8009 for {set i 1} {$i < $n} {incr i} {
8010 set row [lindex $ranges $i]
8011 if {abs([yc $row] - $y) < $thresh} {
8012 return $i
8015 return {}
8018 proc arrowjump {id n y} {
8019 global canv
8021 # 1 <-> 2, 3 <-> 4, etc...
8022 set n [expr {(($n - 1) ^ 1) + 1}]
8023 set row [lindex [rowranges $id] $n]
8024 set yt [yc $row]
8025 set ymax [lindex [$canv cget -scrollregion] 3]
8026 if {$ymax eq {} || $ymax <= 0} return
8027 set view [$canv yview]
8028 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8029 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8030 if {$yfrac < 0} {
8031 set yfrac 0
8033 allcanvs yview moveto $yfrac
8036 proc lineclick {x y id isnew} {
8037 global ctext commitinfo children canv thickerline curview
8039 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8040 unmarkmatches
8041 unselectline
8042 normalline
8043 $canv delete hover
8044 # draw this line thicker than normal
8045 set thickerline $id
8046 drawlines $id
8047 if {$isnew} {
8048 set ymax [lindex [$canv cget -scrollregion] 3]
8049 if {$ymax eq {}} return
8050 set yfrac [lindex [$canv yview] 0]
8051 set y [expr {$y + $yfrac * $ymax}]
8053 set dirn [clickisonarrow $id $y]
8054 if {$dirn ne {}} {
8055 arrowjump $id $dirn $y
8056 return
8059 if {$isnew} {
8060 addtohistory [list lineclick $x $y $id 0]
8062 # fill the details pane with info about this line
8063 $ctext conf -state normal
8064 clear_ctext
8065 settabs 0
8066 $ctext insert end "[mc "Parent"]:\t"
8067 $ctext insert end $id link0
8068 setlink $id link0
8069 set info $commitinfo($id)
8070 $ctext insert end "\n\t[lindex $info 0]\n"
8071 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8072 set date [formatdate [lindex $info 2]]
8073 $ctext insert end "\t[mc "Date"]:\t$date\n"
8074 set kids $children($curview,$id)
8075 if {$kids ne {}} {
8076 $ctext insert end "\n[mc "Children"]:"
8077 set i 0
8078 foreach child $kids {
8079 incr i
8080 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8081 set info $commitinfo($child)
8082 $ctext insert end "\n\t"
8083 $ctext insert end $child link$i
8084 setlink $child link$i
8085 $ctext insert end "\n\t[lindex $info 0]"
8086 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8087 set date [formatdate [lindex $info 2]]
8088 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8091 $ctext conf -state disabled
8092 init_flist {}
8095 proc normalline {} {
8096 global thickerline
8097 if {[info exists thickerline]} {
8098 set id $thickerline
8099 unset thickerline
8100 drawlines $id
8104 proc selbyid {id} {
8105 global curview
8106 if {[commitinview $id $curview]} {
8107 selectline [rowofcommit $id] 1
8111 proc mstime {} {
8112 global startmstime
8113 if {![info exists startmstime]} {
8114 set startmstime [clock clicks -milliseconds]
8116 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8119 proc rowmenu {x y id} {
8120 global rowctxmenu selectedline rowmenuid curview
8121 global nullid nullid2 fakerowmenu mainhead markedid
8123 stopfinding
8124 set rowmenuid $id
8125 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8126 set state disabled
8127 } else {
8128 set state normal
8130 if {$id ne $nullid && $id ne $nullid2} {
8131 set menu $rowctxmenu
8132 if {$mainhead ne {}} {
8133 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8134 } else {
8135 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8137 if {[info exists markedid] && $markedid ne $id} {
8138 $menu entryconfigure 9 -state normal
8139 $menu entryconfigure 10 -state normal
8140 $menu entryconfigure 11 -state normal
8141 } else {
8142 $menu entryconfigure 9 -state disabled
8143 $menu entryconfigure 10 -state disabled
8144 $menu entryconfigure 11 -state disabled
8146 } else {
8147 set menu $fakerowmenu
8149 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8150 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8151 $menu entryconfigure [mca "Make patch"] -state $state
8152 tk_popup $menu $x $y
8155 proc markhere {} {
8156 global rowmenuid markedid canv
8158 set markedid $rowmenuid
8159 make_idmark $markedid
8162 proc gotomark {} {
8163 global markedid
8165 if {[info exists markedid]} {
8166 selbyid $markedid
8170 proc replace_by_kids {l r} {
8171 global curview children
8173 set id [commitonrow $r]
8174 set l [lreplace $l 0 0]
8175 foreach kid $children($curview,$id) {
8176 lappend l [rowofcommit $kid]
8178 return [lsort -integer -decreasing -unique $l]
8181 proc find_common_desc {} {
8182 global markedid rowmenuid curview children
8184 if {![info exists markedid]} return
8185 if {![commitinview $markedid $curview] ||
8186 ![commitinview $rowmenuid $curview]} return
8187 #set t1 [clock clicks -milliseconds]
8188 set l1 [list [rowofcommit $markedid]]
8189 set l2 [list [rowofcommit $rowmenuid]]
8190 while 1 {
8191 set r1 [lindex $l1 0]
8192 set r2 [lindex $l2 0]
8193 if {$r1 eq {} || $r2 eq {}} break
8194 if {$r1 == $r2} {
8195 selectline $r1 1
8196 break
8198 if {$r1 > $r2} {
8199 set l1 [replace_by_kids $l1 $r1]
8200 } else {
8201 set l2 [replace_by_kids $l2 $r2]
8204 #set t2 [clock clicks -milliseconds]
8205 #puts "took [expr {$t2-$t1}]ms"
8208 proc compare_commits {} {
8209 global markedid rowmenuid curview children
8211 if {![info exists markedid]} return
8212 if {![commitinview $markedid $curview]} return
8213 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8214 do_cmp_commits $markedid $rowmenuid
8217 proc getpatchid {id} {
8218 global patchids
8220 if {![info exists patchids($id)]} {
8221 set cmd [diffcmd [list $id] {-p --root}]
8222 # trim off the initial "|"
8223 set cmd [lrange $cmd 1 end]
8224 if {[catch {
8225 set x [eval exec $cmd | git patch-id]
8226 set patchids($id) [lindex $x 0]
8227 }]} {
8228 set patchids($id) "error"
8231 return $patchids($id)
8234 proc do_cmp_commits {a b} {
8235 global ctext curview parents children patchids commitinfo
8237 $ctext conf -state normal
8238 clear_ctext
8239 init_flist {}
8240 for {set i 0} {$i < 100} {incr i} {
8241 set skipa 0
8242 set skipb 0
8243 if {[llength $parents($curview,$a)] > 1} {
8244 appendshortlink $a [mc "Skipping merge commit "] "\n"
8245 set skipa 1
8246 } else {
8247 set patcha [getpatchid $a]
8249 if {[llength $parents($curview,$b)] > 1} {
8250 appendshortlink $b [mc "Skipping merge commit "] "\n"
8251 set skipb 1
8252 } else {
8253 set patchb [getpatchid $b]
8255 if {!$skipa && !$skipb} {
8256 set heada [lindex $commitinfo($a) 0]
8257 set headb [lindex $commitinfo($b) 0]
8258 if {$patcha eq "error"} {
8259 appendshortlink $a [mc "Error getting patch ID for "] \
8260 [mc " - stopping\n"]
8261 break
8263 if {$patchb eq "error"} {
8264 appendshortlink $b [mc "Error getting patch ID for "] \
8265 [mc " - stopping\n"]
8266 break
8268 if {$patcha eq $patchb} {
8269 if {$heada eq $headb} {
8270 appendshortlink $a [mc "Commit "]
8271 appendshortlink $b " == " " $heada\n"
8272 } else {
8273 appendshortlink $a [mc "Commit "] " $heada\n"
8274 appendshortlink $b [mc " is the same patch as\n "] \
8275 " $headb\n"
8277 set skipa 1
8278 set skipb 1
8279 } else {
8280 $ctext insert end "\n"
8281 appendshortlink $a [mc "Commit "] " $heada\n"
8282 appendshortlink $b [mc " differs from\n "] \
8283 " $headb\n"
8284 $ctext insert end [mc "Diff of commits:\n\n"]
8285 $ctext conf -state disabled
8286 update
8287 diffcommits $a $b
8288 return
8291 if {$skipa} {
8292 if {[llength $children($curview,$a)] != 1} {
8293 $ctext insert end "\n"
8294 appendshortlink $a [mc "Commit "] \
8295 [mc " has %s children - stopping\n" \
8296 [llength $children($curview,$a)]]
8297 break
8299 set a [lindex $children($curview,$a) 0]
8301 if {$skipb} {
8302 if {[llength $children($curview,$b)] != 1} {
8303 appendshortlink $b [mc "Commit "] \
8304 [mc " has %s children - stopping\n" \
8305 [llength $children($curview,$b)]]
8306 break
8308 set b [lindex $children($curview,$b) 0]
8311 $ctext conf -state disabled
8314 proc diffcommits {a b} {
8315 global diffcontext diffids blobdifffd diffinhdr
8317 set tmpdir [gitknewtmpdir]
8318 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8319 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8320 if {[catch {
8321 exec git diff-tree -p --pretty $a >$fna
8322 exec git diff-tree -p --pretty $b >$fnb
8323 } err]} {
8324 error_popup [mc "Error writing commit to file: %s" $err]
8325 return
8327 if {[catch {
8328 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8329 } err]} {
8330 error_popup [mc "Error diffing commits: %s" $err]
8331 return
8333 set diffids [list commits $a $b]
8334 set blobdifffd($diffids) $fd
8335 set diffinhdr 0
8336 filerun $fd [list getblobdiffline $fd $diffids]
8339 proc diffvssel {dirn} {
8340 global rowmenuid selectedline
8342 if {$selectedline eq {}} return
8343 if {$dirn} {
8344 set oldid [commitonrow $selectedline]
8345 set newid $rowmenuid
8346 } else {
8347 set oldid $rowmenuid
8348 set newid [commitonrow $selectedline]
8350 addtohistory [list doseldiff $oldid $newid]
8351 doseldiff $oldid $newid
8354 proc doseldiff {oldid newid} {
8355 global ctext
8356 global commitinfo
8358 $ctext conf -state normal
8359 clear_ctext
8360 init_flist [mc "Top"]
8361 $ctext insert end "[mc "From"] "
8362 $ctext insert end $oldid link0
8363 setlink $oldid link0
8364 $ctext insert end "\n "
8365 $ctext insert end [lindex $commitinfo($oldid) 0]
8366 $ctext insert end "\n\n[mc "To"] "
8367 $ctext insert end $newid link1
8368 setlink $newid link1
8369 $ctext insert end "\n "
8370 $ctext insert end [lindex $commitinfo($newid) 0]
8371 $ctext insert end "\n"
8372 $ctext conf -state disabled
8373 $ctext tag remove found 1.0 end
8374 startdiff [list $oldid $newid]
8377 proc mkpatch {} {
8378 global rowmenuid currentid commitinfo patchtop patchnum
8380 if {![info exists currentid]} return
8381 set oldid $currentid
8382 set oldhead [lindex $commitinfo($oldid) 0]
8383 set newid $rowmenuid
8384 set newhead [lindex $commitinfo($newid) 0]
8385 set top .patch
8386 set patchtop $top
8387 catch {destroy $top}
8388 toplevel $top
8389 make_transient $top .
8390 label $top.title -text [mc "Generate patch"]
8391 grid $top.title - -pady 10
8392 label $top.from -text [mc "From:"]
8393 entry $top.fromsha1 -width 40 -relief flat
8394 $top.fromsha1 insert 0 $oldid
8395 $top.fromsha1 conf -state readonly
8396 grid $top.from $top.fromsha1 -sticky w
8397 entry $top.fromhead -width 60 -relief flat
8398 $top.fromhead insert 0 $oldhead
8399 $top.fromhead conf -state readonly
8400 grid x $top.fromhead -sticky w
8401 label $top.to -text [mc "To:"]
8402 entry $top.tosha1 -width 40 -relief flat
8403 $top.tosha1 insert 0 $newid
8404 $top.tosha1 conf -state readonly
8405 grid $top.to $top.tosha1 -sticky w
8406 entry $top.tohead -width 60 -relief flat
8407 $top.tohead insert 0 $newhead
8408 $top.tohead conf -state readonly
8409 grid x $top.tohead -sticky w
8410 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8411 grid $top.rev x -pady 10
8412 label $top.flab -text [mc "Output file:"]
8413 entry $top.fname -width 60
8414 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8415 incr patchnum
8416 grid $top.flab $top.fname -sticky w
8417 frame $top.buts
8418 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8419 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8420 bind $top <Key-Return> mkpatchgo
8421 bind $top <Key-Escape> mkpatchcan
8422 grid $top.buts.gen $top.buts.can
8423 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8424 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8425 grid $top.buts - -pady 10 -sticky ew
8426 focus $top.fname
8429 proc mkpatchrev {} {
8430 global patchtop
8432 set oldid [$patchtop.fromsha1 get]
8433 set oldhead [$patchtop.fromhead get]
8434 set newid [$patchtop.tosha1 get]
8435 set newhead [$patchtop.tohead get]
8436 foreach e [list fromsha1 fromhead tosha1 tohead] \
8437 v [list $newid $newhead $oldid $oldhead] {
8438 $patchtop.$e conf -state normal
8439 $patchtop.$e delete 0 end
8440 $patchtop.$e insert 0 $v
8441 $patchtop.$e conf -state readonly
8445 proc mkpatchgo {} {
8446 global patchtop nullid nullid2
8448 set oldid [$patchtop.fromsha1 get]
8449 set newid [$patchtop.tosha1 get]
8450 set fname [$patchtop.fname get]
8451 set cmd [diffcmd [list $oldid $newid] -p]
8452 # trim off the initial "|"
8453 set cmd [lrange $cmd 1 end]
8454 lappend cmd >$fname &
8455 if {[catch {eval exec $cmd} err]} {
8456 error_popup "[mc "Error creating patch:"] $err" $patchtop
8458 catch {destroy $patchtop}
8459 unset patchtop
8462 proc mkpatchcan {} {
8463 global patchtop
8465 catch {destroy $patchtop}
8466 unset patchtop
8469 proc mktag {} {
8470 global rowmenuid mktagtop commitinfo
8472 set top .maketag
8473 set mktagtop $top
8474 catch {destroy $top}
8475 toplevel $top
8476 make_transient $top .
8477 label $top.title -text [mc "Create tag"]
8478 grid $top.title - -pady 10
8479 label $top.id -text [mc "ID:"]
8480 entry $top.sha1 -width 40 -relief flat
8481 $top.sha1 insert 0 $rowmenuid
8482 $top.sha1 conf -state readonly
8483 grid $top.id $top.sha1 -sticky w
8484 entry $top.head -width 60 -relief flat
8485 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8486 $top.head conf -state readonly
8487 grid x $top.head -sticky w
8488 label $top.tlab -text [mc "Tag name:"]
8489 entry $top.tag -width 60
8490 grid $top.tlab $top.tag -sticky w
8491 frame $top.buts
8492 button $top.buts.gen -text [mc "Create"] -command mktaggo
8493 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8494 bind $top <Key-Return> mktaggo
8495 bind $top <Key-Escape> mktagcan
8496 grid $top.buts.gen $top.buts.can
8497 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8498 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8499 grid $top.buts - -pady 10 -sticky ew
8500 focus $top.tag
8503 proc domktag {} {
8504 global mktagtop env tagids idtags
8506 set id [$mktagtop.sha1 get]
8507 set tag [$mktagtop.tag get]
8508 if {$tag == {}} {
8509 error_popup [mc "No tag name specified"] $mktagtop
8510 return 0
8512 if {[info exists tagids($tag)]} {
8513 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8514 return 0
8516 if {[catch {
8517 exec git tag $tag $id
8518 } err]} {
8519 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8520 return 0
8523 set tagids($tag) $id
8524 lappend idtags($id) $tag
8525 redrawtags $id
8526 addedtag $id
8527 dispneartags 0
8528 run refill_reflist
8529 return 1
8532 proc redrawtags {id} {
8533 global canv linehtag idpos currentid curview cmitlisted markedid
8534 global canvxmax iddrawn circleitem mainheadid circlecolors
8536 if {![commitinview $id $curview]} return
8537 if {![info exists iddrawn($id)]} return
8538 set row [rowofcommit $id]
8539 if {$id eq $mainheadid} {
8540 set ofill yellow
8541 } else {
8542 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8544 $canv itemconf $circleitem($row) -fill $ofill
8545 $canv delete tag.$id
8546 set xt [eval drawtags $id $idpos($id)]
8547 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8548 set text [$canv itemcget $linehtag($id) -text]
8549 set font [$canv itemcget $linehtag($id) -font]
8550 set xr [expr {$xt + [font measure $font $text]}]
8551 if {$xr > $canvxmax} {
8552 set canvxmax $xr
8553 setcanvscroll
8555 if {[info exists currentid] && $currentid == $id} {
8556 make_secsel $id
8558 if {[info exists markedid] && $markedid eq $id} {
8559 make_idmark $id
8563 proc mktagcan {} {
8564 global mktagtop
8566 catch {destroy $mktagtop}
8567 unset mktagtop
8570 proc mktaggo {} {
8571 if {![domktag]} return
8572 mktagcan
8575 proc writecommit {} {
8576 global rowmenuid wrcomtop commitinfo wrcomcmd
8578 set top .writecommit
8579 set wrcomtop $top
8580 catch {destroy $top}
8581 toplevel $top
8582 make_transient $top .
8583 label $top.title -text [mc "Write commit to file"]
8584 grid $top.title - -pady 10
8585 label $top.id -text [mc "ID:"]
8586 entry $top.sha1 -width 40 -relief flat
8587 $top.sha1 insert 0 $rowmenuid
8588 $top.sha1 conf -state readonly
8589 grid $top.id $top.sha1 -sticky w
8590 entry $top.head -width 60 -relief flat
8591 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8592 $top.head conf -state readonly
8593 grid x $top.head -sticky w
8594 label $top.clab -text [mc "Command:"]
8595 entry $top.cmd -width 60 -textvariable wrcomcmd
8596 grid $top.clab $top.cmd -sticky w -pady 10
8597 label $top.flab -text [mc "Output file:"]
8598 entry $top.fname -width 60
8599 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8600 grid $top.flab $top.fname -sticky w
8601 frame $top.buts
8602 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8603 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8604 bind $top <Key-Return> wrcomgo
8605 bind $top <Key-Escape> wrcomcan
8606 grid $top.buts.gen $top.buts.can
8607 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8608 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8609 grid $top.buts - -pady 10 -sticky ew
8610 focus $top.fname
8613 proc wrcomgo {} {
8614 global wrcomtop
8616 set id [$wrcomtop.sha1 get]
8617 set cmd "echo $id | [$wrcomtop.cmd get]"
8618 set fname [$wrcomtop.fname get]
8619 if {[catch {exec sh -c $cmd >$fname &} err]} {
8620 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8622 catch {destroy $wrcomtop}
8623 unset wrcomtop
8626 proc wrcomcan {} {
8627 global wrcomtop
8629 catch {destroy $wrcomtop}
8630 unset wrcomtop
8633 proc mkbranch {} {
8634 global rowmenuid mkbrtop
8636 set top .makebranch
8637 catch {destroy $top}
8638 toplevel $top
8639 make_transient $top .
8640 label $top.title -text [mc "Create new branch"]
8641 grid $top.title - -pady 10
8642 label $top.id -text [mc "ID:"]
8643 entry $top.sha1 -width 40 -relief flat
8644 $top.sha1 insert 0 $rowmenuid
8645 $top.sha1 conf -state readonly
8646 grid $top.id $top.sha1 -sticky w
8647 label $top.nlab -text [mc "Name:"]
8648 entry $top.name -width 40
8649 grid $top.nlab $top.name -sticky w
8650 frame $top.buts
8651 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8652 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8653 bind $top <Key-Return> [list mkbrgo $top]
8654 bind $top <Key-Escape> "catch {destroy $top}"
8655 grid $top.buts.go $top.buts.can
8656 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8657 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8658 grid $top.buts - -pady 10 -sticky ew
8659 focus $top.name
8662 proc mkbrgo {top} {
8663 global headids idheads
8665 set name [$top.name get]
8666 set id [$top.sha1 get]
8667 set cmdargs {}
8668 set old_id {}
8669 if {$name eq {}} {
8670 error_popup [mc "Please specify a name for the new branch"] $top
8671 return
8673 if {[info exists headids($name)]} {
8674 if {![confirm_popup [mc \
8675 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8676 return
8678 set old_id $headids($name)
8679 lappend cmdargs -f
8681 catch {destroy $top}
8682 lappend cmdargs $name $id
8683 nowbusy newbranch
8684 update
8685 if {[catch {
8686 eval exec git branch $cmdargs
8687 } err]} {
8688 notbusy newbranch
8689 error_popup $err
8690 } else {
8691 notbusy newbranch
8692 if {$old_id ne {}} {
8693 movehead $id $name
8694 movedhead $id $name
8695 redrawtags $old_id
8696 redrawtags $id
8697 } else {
8698 set headids($name) $id
8699 lappend idheads($id) $name
8700 addedhead $id $name
8701 redrawtags $id
8703 dispneartags 0
8704 run refill_reflist
8708 proc exec_citool {tool_args {baseid {}}} {
8709 global commitinfo env
8711 set save_env [array get env GIT_AUTHOR_*]
8713 if {$baseid ne {}} {
8714 if {![info exists commitinfo($baseid)]} {
8715 getcommit $baseid
8717 set author [lindex $commitinfo($baseid) 1]
8718 set date [lindex $commitinfo($baseid) 2]
8719 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8720 $author author name email]
8721 && $date ne {}} {
8722 set env(GIT_AUTHOR_NAME) $name
8723 set env(GIT_AUTHOR_EMAIL) $email
8724 set env(GIT_AUTHOR_DATE) $date
8728 eval exec git citool $tool_args &
8730 array unset env GIT_AUTHOR_*
8731 array set env $save_env
8734 proc cherrypick {} {
8735 global rowmenuid curview
8736 global mainhead mainheadid
8738 set oldhead [exec git rev-parse HEAD]
8739 set dheads [descheads $rowmenuid]
8740 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8741 set ok [confirm_popup [mc "Commit %s is already\
8742 included in branch %s -- really re-apply it?" \
8743 [string range $rowmenuid 0 7] $mainhead]]
8744 if {!$ok} return
8746 nowbusy cherrypick [mc "Cherry-picking"]
8747 update
8748 # Unfortunately git-cherry-pick writes stuff to stderr even when
8749 # no error occurs, and exec takes that as an indication of error...
8750 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8751 notbusy cherrypick
8752 if {[regexp -line \
8753 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8754 $err msg fname]} {
8755 error_popup [mc "Cherry-pick failed because of local changes\
8756 to file '%s'.\nPlease commit, reset or stash\
8757 your changes and try again." $fname]
8758 } elseif {[regexp -line \
8759 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8760 $err]} {
8761 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8762 conflict.\nDo you wish to run git citool to\
8763 resolve it?"]]} {
8764 # Force citool to read MERGE_MSG
8765 file delete [file join [gitdir] "GITGUI_MSG"]
8766 exec_citool {} $rowmenuid
8768 } else {
8769 error_popup $err
8771 run updatecommits
8772 return
8774 set newhead [exec git rev-parse HEAD]
8775 if {$newhead eq $oldhead} {
8776 notbusy cherrypick
8777 error_popup [mc "No changes committed"]
8778 return
8780 addnewchild $newhead $oldhead
8781 if {[commitinview $oldhead $curview]} {
8782 # XXX this isn't right if we have a path limit...
8783 insertrow $newhead $oldhead $curview
8784 if {$mainhead ne {}} {
8785 movehead $newhead $mainhead
8786 movedhead $newhead $mainhead
8788 set mainheadid $newhead
8789 redrawtags $oldhead
8790 redrawtags $newhead
8791 selbyid $newhead
8793 notbusy cherrypick
8796 proc resethead {} {
8797 global mainhead rowmenuid confirm_ok resettype
8799 set confirm_ok 0
8800 set w ".confirmreset"
8801 toplevel $w
8802 make_transient $w .
8803 wm title $w [mc "Confirm reset"]
8804 message $w.m -text \
8805 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8806 -justify center -aspect 1000
8807 pack $w.m -side top -fill x -padx 20 -pady 20
8808 frame $w.f -relief sunken -border 2
8809 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8810 grid $w.f.rt -sticky w
8811 set resettype mixed
8812 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8813 -text [mc "Soft: Leave working tree and index untouched"]
8814 grid $w.f.soft -sticky w
8815 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8816 -text [mc "Mixed: Leave working tree untouched, reset index"]
8817 grid $w.f.mixed -sticky w
8818 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8819 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8820 grid $w.f.hard -sticky w
8821 pack $w.f -side top -fill x
8822 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8823 pack $w.ok -side left -fill x -padx 20 -pady 20
8824 button $w.cancel -text [mc Cancel] -command "destroy $w"
8825 bind $w <Key-Escape> [list destroy $w]
8826 pack $w.cancel -side right -fill x -padx 20 -pady 20
8827 bind $w <Visibility> "grab $w; focus $w"
8828 tkwait window $w
8829 if {!$confirm_ok} return
8830 if {[catch {set fd [open \
8831 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8832 error_popup $err
8833 } else {
8834 dohidelocalchanges
8835 filerun $fd [list readresetstat $fd]
8836 nowbusy reset [mc "Resetting"]
8837 selbyid $rowmenuid
8841 proc readresetstat {fd} {
8842 global mainhead mainheadid showlocalchanges rprogcoord
8844 if {[gets $fd line] >= 0} {
8845 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8846 set rprogcoord [expr {1.0 * $m / $n}]
8847 adjustprogress
8849 return 1
8851 set rprogcoord 0
8852 adjustprogress
8853 notbusy reset
8854 if {[catch {close $fd} err]} {
8855 error_popup $err
8857 set oldhead $mainheadid
8858 set newhead [exec git rev-parse HEAD]
8859 if {$newhead ne $oldhead} {
8860 movehead $newhead $mainhead
8861 movedhead $newhead $mainhead
8862 set mainheadid $newhead
8863 redrawtags $oldhead
8864 redrawtags $newhead
8866 if {$showlocalchanges} {
8867 doshowlocalchanges
8869 return 0
8872 # context menu for a head
8873 proc headmenu {x y id head} {
8874 global headmenuid headmenuhead headctxmenu mainhead
8876 stopfinding
8877 set headmenuid $id
8878 set headmenuhead $head
8879 set state normal
8880 if {$head eq $mainhead} {
8881 set state disabled
8883 $headctxmenu entryconfigure 0 -state $state
8884 $headctxmenu entryconfigure 1 -state $state
8885 tk_popup $headctxmenu $x $y
8888 proc cobranch {} {
8889 global headmenuid headmenuhead headids
8890 global showlocalchanges
8892 # check the tree is clean first??
8893 nowbusy checkout [mc "Checking out"]
8894 update
8895 dohidelocalchanges
8896 if {[catch {
8897 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8898 } err]} {
8899 notbusy checkout
8900 error_popup $err
8901 if {$showlocalchanges} {
8902 dodiffindex
8904 } else {
8905 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8909 proc readcheckoutstat {fd newhead newheadid} {
8910 global mainhead mainheadid headids showlocalchanges progresscoords
8911 global viewmainheadid curview
8913 if {[gets $fd line] >= 0} {
8914 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8915 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8916 adjustprogress
8918 return 1
8920 set progresscoords {0 0}
8921 adjustprogress
8922 notbusy checkout
8923 if {[catch {close $fd} err]} {
8924 error_popup $err
8926 set oldmainid $mainheadid
8927 set mainhead $newhead
8928 set mainheadid $newheadid
8929 set viewmainheadid($curview) $newheadid
8930 redrawtags $oldmainid
8931 redrawtags $newheadid
8932 selbyid $newheadid
8933 if {$showlocalchanges} {
8934 dodiffindex
8938 proc rmbranch {} {
8939 global headmenuid headmenuhead mainhead
8940 global idheads
8942 set head $headmenuhead
8943 set id $headmenuid
8944 # this check shouldn't be needed any more...
8945 if {$head eq $mainhead} {
8946 error_popup [mc "Cannot delete the currently checked-out branch"]
8947 return
8949 set dheads [descheads $id]
8950 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8951 # the stuff on this branch isn't on any other branch
8952 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8953 branch.\nReally delete branch %s?" $head $head]]} return
8955 nowbusy rmbranch
8956 update
8957 if {[catch {exec git branch -D $head} err]} {
8958 notbusy rmbranch
8959 error_popup $err
8960 return
8962 removehead $id $head
8963 removedhead $id $head
8964 redrawtags $id
8965 notbusy rmbranch
8966 dispneartags 0
8967 run refill_reflist
8970 # Display a list of tags and heads
8971 proc showrefs {} {
8972 global showrefstop bgcolor fgcolor selectbgcolor
8973 global bglist fglist reflistfilter reflist maincursor
8975 set top .showrefs
8976 set showrefstop $top
8977 if {[winfo exists $top]} {
8978 raise $top
8979 refill_reflist
8980 return
8982 toplevel $top
8983 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8984 make_transient $top .
8985 text $top.list -background $bgcolor -foreground $fgcolor \
8986 -selectbackground $selectbgcolor -font mainfont \
8987 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8988 -width 30 -height 20 -cursor $maincursor \
8989 -spacing1 1 -spacing3 1 -state disabled
8990 $top.list tag configure highlight -background $selectbgcolor
8991 lappend bglist $top.list
8992 lappend fglist $top.list
8993 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8994 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8995 grid $top.list $top.ysb -sticky nsew
8996 grid $top.xsb x -sticky ew
8997 frame $top.f
8998 label $top.f.l -text "[mc "Filter"]: "
8999 entry $top.f.e -width 20 -textvariable reflistfilter
9000 set reflistfilter "*"
9001 trace add variable reflistfilter write reflistfilter_change
9002 pack $top.f.e -side right -fill x -expand 1
9003 pack $top.f.l -side left
9004 grid $top.f - -sticky ew -pady 2
9005 button $top.close -command [list destroy $top] -text [mc "Close"]
9006 bind $top <Key-Escape> [list destroy $top]
9007 grid $top.close -
9008 grid columnconfigure $top 0 -weight 1
9009 grid rowconfigure $top 0 -weight 1
9010 bind $top.list <1> {break}
9011 bind $top.list <B1-Motion> {break}
9012 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9013 set reflist {}
9014 refill_reflist
9017 proc sel_reflist {w x y} {
9018 global showrefstop reflist headids tagids otherrefids
9020 if {![winfo exists $showrefstop]} return
9021 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9022 set ref [lindex $reflist [expr {$l-1}]]
9023 set n [lindex $ref 0]
9024 switch -- [lindex $ref 1] {
9025 "H" {selbyid $headids($n)}
9026 "T" {selbyid $tagids($n)}
9027 "o" {selbyid $otherrefids($n)}
9029 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9032 proc unsel_reflist {} {
9033 global showrefstop
9035 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9036 $showrefstop.list tag remove highlight 0.0 end
9039 proc reflistfilter_change {n1 n2 op} {
9040 global reflistfilter
9042 after cancel refill_reflist
9043 after 200 refill_reflist
9046 proc refill_reflist {} {
9047 global reflist reflistfilter showrefstop headids tagids otherrefids
9048 global curview
9050 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9051 set refs {}
9052 foreach n [array names headids] {
9053 if {[string match $reflistfilter $n]} {
9054 if {[commitinview $headids($n) $curview]} {
9055 lappend refs [list $n H]
9056 } else {
9057 interestedin $headids($n) {run refill_reflist}
9061 foreach n [array names tagids] {
9062 if {[string match $reflistfilter $n]} {
9063 if {[commitinview $tagids($n) $curview]} {
9064 lappend refs [list $n T]
9065 } else {
9066 interestedin $tagids($n) {run refill_reflist}
9070 foreach n [array names otherrefids] {
9071 if {[string match $reflistfilter $n]} {
9072 if {[commitinview $otherrefids($n) $curview]} {
9073 lappend refs [list $n o]
9074 } else {
9075 interestedin $otherrefids($n) {run refill_reflist}
9079 set refs [lsort -index 0 $refs]
9080 if {$refs eq $reflist} return
9082 # Update the contents of $showrefstop.list according to the
9083 # differences between $reflist (old) and $refs (new)
9084 $showrefstop.list conf -state normal
9085 $showrefstop.list insert end "\n"
9086 set i 0
9087 set j 0
9088 while {$i < [llength $reflist] || $j < [llength $refs]} {
9089 if {$i < [llength $reflist]} {
9090 if {$j < [llength $refs]} {
9091 set cmp [string compare [lindex $reflist $i 0] \
9092 [lindex $refs $j 0]]
9093 if {$cmp == 0} {
9094 set cmp [string compare [lindex $reflist $i 1] \
9095 [lindex $refs $j 1]]
9097 } else {
9098 set cmp -1
9100 } else {
9101 set cmp 1
9103 switch -- $cmp {
9104 -1 {
9105 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9106 incr i
9109 incr i
9110 incr j
9113 set l [expr {$j + 1}]
9114 $showrefstop.list image create $l.0 -align baseline \
9115 -image reficon-[lindex $refs $j 1] -padx 2
9116 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9117 incr j
9121 set reflist $refs
9122 # delete last newline
9123 $showrefstop.list delete end-2c end-1c
9124 $showrefstop.list conf -state disabled
9127 # Stuff for finding nearby tags
9128 proc getallcommits {} {
9129 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9130 global idheads idtags idotherrefs allparents tagobjid
9132 if {![info exists allcommits]} {
9133 set nextarc 0
9134 set allcommits 0
9135 set seeds {}
9136 set allcwait 0
9137 set cachedarcs 0
9138 set allccache [file join [gitdir] "gitk.cache"]
9139 if {![catch {
9140 set f [open $allccache r]
9141 set allcwait 1
9142 getcache $f
9143 }]} return
9146 if {$allcwait} {
9147 return
9149 set cmd [list | git rev-list --parents]
9150 set allcupdate [expr {$seeds ne {}}]
9151 if {!$allcupdate} {
9152 set ids "--all"
9153 } else {
9154 set refs [concat [array names idheads] [array names idtags] \
9155 [array names idotherrefs]]
9156 set ids {}
9157 set tagobjs {}
9158 foreach name [array names tagobjid] {
9159 lappend tagobjs $tagobjid($name)
9161 foreach id [lsort -unique $refs] {
9162 if {![info exists allparents($id)] &&
9163 [lsearch -exact $tagobjs $id] < 0} {
9164 lappend ids $id
9167 if {$ids ne {}} {
9168 foreach id $seeds {
9169 lappend ids "^$id"
9173 if {$ids ne {}} {
9174 set fd [open [concat $cmd $ids] r]
9175 fconfigure $fd -blocking 0
9176 incr allcommits
9177 nowbusy allcommits
9178 filerun $fd [list getallclines $fd]
9179 } else {
9180 dispneartags 0
9184 # Since most commits have 1 parent and 1 child, we group strings of
9185 # such commits into "arcs" joining branch/merge points (BMPs), which
9186 # are commits that either don't have 1 parent or don't have 1 child.
9188 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9189 # arcout(id) - outgoing arcs for BMP
9190 # arcids(a) - list of IDs on arc including end but not start
9191 # arcstart(a) - BMP ID at start of arc
9192 # arcend(a) - BMP ID at end of arc
9193 # growing(a) - arc a is still growing
9194 # arctags(a) - IDs out of arcids (excluding end) that have tags
9195 # archeads(a) - IDs out of arcids (excluding end) that have heads
9196 # The start of an arc is at the descendent end, so "incoming" means
9197 # coming from descendents, and "outgoing" means going towards ancestors.
9199 proc getallclines {fd} {
9200 global allparents allchildren idtags idheads nextarc
9201 global arcnos arcids arctags arcout arcend arcstart archeads growing
9202 global seeds allcommits cachedarcs allcupdate
9204 set nid 0
9205 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9206 set id [lindex $line 0]
9207 if {[info exists allparents($id)]} {
9208 # seen it already
9209 continue
9211 set cachedarcs 0
9212 set olds [lrange $line 1 end]
9213 set allparents($id) $olds
9214 if {![info exists allchildren($id)]} {
9215 set allchildren($id) {}
9216 set arcnos($id) {}
9217 lappend seeds $id
9218 } else {
9219 set a $arcnos($id)
9220 if {[llength $olds] == 1 && [llength $a] == 1} {
9221 lappend arcids($a) $id
9222 if {[info exists idtags($id)]} {
9223 lappend arctags($a) $id
9225 if {[info exists idheads($id)]} {
9226 lappend archeads($a) $id
9228 if {[info exists allparents($olds)]} {
9229 # seen parent already
9230 if {![info exists arcout($olds)]} {
9231 splitarc $olds
9233 lappend arcids($a) $olds
9234 set arcend($a) $olds
9235 unset growing($a)
9237 lappend allchildren($olds) $id
9238 lappend arcnos($olds) $a
9239 continue
9242 foreach a $arcnos($id) {
9243 lappend arcids($a) $id
9244 set arcend($a) $id
9245 unset growing($a)
9248 set ao {}
9249 foreach p $olds {
9250 lappend allchildren($p) $id
9251 set a [incr nextarc]
9252 set arcstart($a) $id
9253 set archeads($a) {}
9254 set arctags($a) {}
9255 set archeads($a) {}
9256 set arcids($a) {}
9257 lappend ao $a
9258 set growing($a) 1
9259 if {[info exists allparents($p)]} {
9260 # seen it already, may need to make a new branch
9261 if {![info exists arcout($p)]} {
9262 splitarc $p
9264 lappend arcids($a) $p
9265 set arcend($a) $p
9266 unset growing($a)
9268 lappend arcnos($p) $a
9270 set arcout($id) $ao
9272 if {$nid > 0} {
9273 global cached_dheads cached_dtags cached_atags
9274 catch {unset cached_dheads}
9275 catch {unset cached_dtags}
9276 catch {unset cached_atags}
9278 if {![eof $fd]} {
9279 return [expr {$nid >= 1000? 2: 1}]
9281 set cacheok 1
9282 if {[catch {
9283 fconfigure $fd -blocking 1
9284 close $fd
9285 } err]} {
9286 # got an error reading the list of commits
9287 # if we were updating, try rereading the whole thing again
9288 if {$allcupdate} {
9289 incr allcommits -1
9290 dropcache $err
9291 return
9293 error_popup "[mc "Error reading commit topology information;\
9294 branch and preceding/following tag information\
9295 will be incomplete."]\n($err)"
9296 set cacheok 0
9298 if {[incr allcommits -1] == 0} {
9299 notbusy allcommits
9300 if {$cacheok} {
9301 run savecache
9304 dispneartags 0
9305 return 0
9308 proc recalcarc {a} {
9309 global arctags archeads arcids idtags idheads
9311 set at {}
9312 set ah {}
9313 foreach id [lrange $arcids($a) 0 end-1] {
9314 if {[info exists idtags($id)]} {
9315 lappend at $id
9317 if {[info exists idheads($id)]} {
9318 lappend ah $id
9321 set arctags($a) $at
9322 set archeads($a) $ah
9325 proc splitarc {p} {
9326 global arcnos arcids nextarc arctags archeads idtags idheads
9327 global arcstart arcend arcout allparents growing
9329 set a $arcnos($p)
9330 if {[llength $a] != 1} {
9331 puts "oops splitarc called but [llength $a] arcs already"
9332 return
9334 set a [lindex $a 0]
9335 set i [lsearch -exact $arcids($a) $p]
9336 if {$i < 0} {
9337 puts "oops splitarc $p not in arc $a"
9338 return
9340 set na [incr nextarc]
9341 if {[info exists arcend($a)]} {
9342 set arcend($na) $arcend($a)
9343 } else {
9344 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9345 set j [lsearch -exact $arcnos($l) $a]
9346 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9348 set tail [lrange $arcids($a) [expr {$i+1}] end]
9349 set arcids($a) [lrange $arcids($a) 0 $i]
9350 set arcend($a) $p
9351 set arcstart($na) $p
9352 set arcout($p) $na
9353 set arcids($na) $tail
9354 if {[info exists growing($a)]} {
9355 set growing($na) 1
9356 unset growing($a)
9359 foreach id $tail {
9360 if {[llength $arcnos($id)] == 1} {
9361 set arcnos($id) $na
9362 } else {
9363 set j [lsearch -exact $arcnos($id) $a]
9364 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9368 # reconstruct tags and heads lists
9369 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9370 recalcarc $a
9371 recalcarc $na
9372 } else {
9373 set arctags($na) {}
9374 set archeads($na) {}
9378 # Update things for a new commit added that is a child of one
9379 # existing commit. Used when cherry-picking.
9380 proc addnewchild {id p} {
9381 global allparents allchildren idtags nextarc
9382 global arcnos arcids arctags arcout arcend arcstart archeads growing
9383 global seeds allcommits
9385 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9386 set allparents($id) [list $p]
9387 set allchildren($id) {}
9388 set arcnos($id) {}
9389 lappend seeds $id
9390 lappend allchildren($p) $id
9391 set a [incr nextarc]
9392 set arcstart($a) $id
9393 set archeads($a) {}
9394 set arctags($a) {}
9395 set arcids($a) [list $p]
9396 set arcend($a) $p
9397 if {![info exists arcout($p)]} {
9398 splitarc $p
9400 lappend arcnos($p) $a
9401 set arcout($id) [list $a]
9404 # This implements a cache for the topology information.
9405 # The cache saves, for each arc, the start and end of the arc,
9406 # the ids on the arc, and the outgoing arcs from the end.
9407 proc readcache {f} {
9408 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9409 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9410 global allcwait
9412 set a $nextarc
9413 set lim $cachedarcs
9414 if {$lim - $a > 500} {
9415 set lim [expr {$a + 500}]
9417 if {[catch {
9418 if {$a == $lim} {
9419 # finish reading the cache and setting up arctags, etc.
9420 set line [gets $f]
9421 if {$line ne "1"} {error "bad final version"}
9422 close $f
9423 foreach id [array names idtags] {
9424 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9425 [llength $allparents($id)] == 1} {
9426 set a [lindex $arcnos($id) 0]
9427 if {$arctags($a) eq {}} {
9428 recalcarc $a
9432 foreach id [array names idheads] {
9433 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9434 [llength $allparents($id)] == 1} {
9435 set a [lindex $arcnos($id) 0]
9436 if {$archeads($a) eq {}} {
9437 recalcarc $a
9441 foreach id [lsort -unique $possible_seeds] {
9442 if {$arcnos($id) eq {}} {
9443 lappend seeds $id
9446 set allcwait 0
9447 } else {
9448 while {[incr a] <= $lim} {
9449 set line [gets $f]
9450 if {[llength $line] != 3} {error "bad line"}
9451 set s [lindex $line 0]
9452 set arcstart($a) $s
9453 lappend arcout($s) $a
9454 if {![info exists arcnos($s)]} {
9455 lappend possible_seeds $s
9456 set arcnos($s) {}
9458 set e [lindex $line 1]
9459 if {$e eq {}} {
9460 set growing($a) 1
9461 } else {
9462 set arcend($a) $e
9463 if {![info exists arcout($e)]} {
9464 set arcout($e) {}
9467 set arcids($a) [lindex $line 2]
9468 foreach id $arcids($a) {
9469 lappend allparents($s) $id
9470 set s $id
9471 lappend arcnos($id) $a
9473 if {![info exists allparents($s)]} {
9474 set allparents($s) {}
9476 set arctags($a) {}
9477 set archeads($a) {}
9479 set nextarc [expr {$a - 1}]
9481 } err]} {
9482 dropcache $err
9483 return 0
9485 if {!$allcwait} {
9486 getallcommits
9488 return $allcwait
9491 proc getcache {f} {
9492 global nextarc cachedarcs possible_seeds
9494 if {[catch {
9495 set line [gets $f]
9496 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9497 # make sure it's an integer
9498 set cachedarcs [expr {int([lindex $line 1])}]
9499 if {$cachedarcs < 0} {error "bad number of arcs"}
9500 set nextarc 0
9501 set possible_seeds {}
9502 run readcache $f
9503 } err]} {
9504 dropcache $err
9506 return 0
9509 proc dropcache {err} {
9510 global allcwait nextarc cachedarcs seeds
9512 #puts "dropping cache ($err)"
9513 foreach v {arcnos arcout arcids arcstart arcend growing \
9514 arctags archeads allparents allchildren} {
9515 global $v
9516 catch {unset $v}
9518 set allcwait 0
9519 set nextarc 0
9520 set cachedarcs 0
9521 set seeds {}
9522 getallcommits
9525 proc writecache {f} {
9526 global cachearc cachedarcs allccache
9527 global arcstart arcend arcnos arcids arcout
9529 set a $cachearc
9530 set lim $cachedarcs
9531 if {$lim - $a > 1000} {
9532 set lim [expr {$a + 1000}]
9534 if {[catch {
9535 while {[incr a] <= $lim} {
9536 if {[info exists arcend($a)]} {
9537 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9538 } else {
9539 puts $f [list $arcstart($a) {} $arcids($a)]
9542 } err]} {
9543 catch {close $f}
9544 catch {file delete $allccache}
9545 #puts "writing cache failed ($err)"
9546 return 0
9548 set cachearc [expr {$a - 1}]
9549 if {$a > $cachedarcs} {
9550 puts $f "1"
9551 close $f
9552 return 0
9554 return 1
9557 proc savecache {} {
9558 global nextarc cachedarcs cachearc allccache
9560 if {$nextarc == $cachedarcs} return
9561 set cachearc 0
9562 set cachedarcs $nextarc
9563 catch {
9564 set f [open $allccache w]
9565 puts $f [list 1 $cachedarcs]
9566 run writecache $f
9570 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9571 # or 0 if neither is true.
9572 proc anc_or_desc {a b} {
9573 global arcout arcstart arcend arcnos cached_isanc
9575 if {$arcnos($a) eq $arcnos($b)} {
9576 # Both are on the same arc(s); either both are the same BMP,
9577 # or if one is not a BMP, the other is also not a BMP or is
9578 # the BMP at end of the arc (and it only has 1 incoming arc).
9579 # Or both can be BMPs with no incoming arcs.
9580 if {$a eq $b || $arcnos($a) eq {}} {
9581 return 0
9583 # assert {[llength $arcnos($a)] == 1}
9584 set arc [lindex $arcnos($a) 0]
9585 set i [lsearch -exact $arcids($arc) $a]
9586 set j [lsearch -exact $arcids($arc) $b]
9587 if {$i < 0 || $i > $j} {
9588 return 1
9589 } else {
9590 return -1
9594 if {![info exists arcout($a)]} {
9595 set arc [lindex $arcnos($a) 0]
9596 if {[info exists arcend($arc)]} {
9597 set aend $arcend($arc)
9598 } else {
9599 set aend {}
9601 set a $arcstart($arc)
9602 } else {
9603 set aend $a
9605 if {![info exists arcout($b)]} {
9606 set arc [lindex $arcnos($b) 0]
9607 if {[info exists arcend($arc)]} {
9608 set bend $arcend($arc)
9609 } else {
9610 set bend {}
9612 set b $arcstart($arc)
9613 } else {
9614 set bend $b
9616 if {$a eq $bend} {
9617 return 1
9619 if {$b eq $aend} {
9620 return -1
9622 if {[info exists cached_isanc($a,$bend)]} {
9623 if {$cached_isanc($a,$bend)} {
9624 return 1
9627 if {[info exists cached_isanc($b,$aend)]} {
9628 if {$cached_isanc($b,$aend)} {
9629 return -1
9631 if {[info exists cached_isanc($a,$bend)]} {
9632 return 0
9636 set todo [list $a $b]
9637 set anc($a) a
9638 set anc($b) b
9639 for {set i 0} {$i < [llength $todo]} {incr i} {
9640 set x [lindex $todo $i]
9641 if {$anc($x) eq {}} {
9642 continue
9644 foreach arc $arcnos($x) {
9645 set xd $arcstart($arc)
9646 if {$xd eq $bend} {
9647 set cached_isanc($a,$bend) 1
9648 set cached_isanc($b,$aend) 0
9649 return 1
9650 } elseif {$xd eq $aend} {
9651 set cached_isanc($b,$aend) 1
9652 set cached_isanc($a,$bend) 0
9653 return -1
9655 if {![info exists anc($xd)]} {
9656 set anc($xd) $anc($x)
9657 lappend todo $xd
9658 } elseif {$anc($xd) ne $anc($x)} {
9659 set anc($xd) {}
9663 set cached_isanc($a,$bend) 0
9664 set cached_isanc($b,$aend) 0
9665 return 0
9668 # This identifies whether $desc has an ancestor that is
9669 # a growing tip of the graph and which is not an ancestor of $anc
9670 # and returns 0 if so and 1 if not.
9671 # If we subsequently discover a tag on such a growing tip, and that
9672 # turns out to be a descendent of $anc (which it could, since we
9673 # don't necessarily see children before parents), then $desc
9674 # isn't a good choice to display as a descendent tag of
9675 # $anc (since it is the descendent of another tag which is
9676 # a descendent of $anc). Similarly, $anc isn't a good choice to
9677 # display as a ancestor tag of $desc.
9679 proc is_certain {desc anc} {
9680 global arcnos arcout arcstart arcend growing problems
9682 set certain {}
9683 if {[llength $arcnos($anc)] == 1} {
9684 # tags on the same arc are certain
9685 if {$arcnos($desc) eq $arcnos($anc)} {
9686 return 1
9688 if {![info exists arcout($anc)]} {
9689 # if $anc is partway along an arc, use the start of the arc instead
9690 set a [lindex $arcnos($anc) 0]
9691 set anc $arcstart($a)
9694 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9695 set x $desc
9696 } else {
9697 set a [lindex $arcnos($desc) 0]
9698 set x $arcend($a)
9700 if {$x == $anc} {
9701 return 1
9703 set anclist [list $x]
9704 set dl($x) 1
9705 set nnh 1
9706 set ngrowanc 0
9707 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9708 set x [lindex $anclist $i]
9709 if {$dl($x)} {
9710 incr nnh -1
9712 set done($x) 1
9713 foreach a $arcout($x) {
9714 if {[info exists growing($a)]} {
9715 if {![info exists growanc($x)] && $dl($x)} {
9716 set growanc($x) 1
9717 incr ngrowanc
9719 } else {
9720 set y $arcend($a)
9721 if {[info exists dl($y)]} {
9722 if {$dl($y)} {
9723 if {!$dl($x)} {
9724 set dl($y) 0
9725 if {![info exists done($y)]} {
9726 incr nnh -1
9728 if {[info exists growanc($x)]} {
9729 incr ngrowanc -1
9731 set xl [list $y]
9732 for {set k 0} {$k < [llength $xl]} {incr k} {
9733 set z [lindex $xl $k]
9734 foreach c $arcout($z) {
9735 if {[info exists arcend($c)]} {
9736 set v $arcend($c)
9737 if {[info exists dl($v)] && $dl($v)} {
9738 set dl($v) 0
9739 if {![info exists done($v)]} {
9740 incr nnh -1
9742 if {[info exists growanc($v)]} {
9743 incr ngrowanc -1
9745 lappend xl $v
9752 } elseif {$y eq $anc || !$dl($x)} {
9753 set dl($y) 0
9754 lappend anclist $y
9755 } else {
9756 set dl($y) 1
9757 lappend anclist $y
9758 incr nnh
9763 foreach x [array names growanc] {
9764 if {$dl($x)} {
9765 return 0
9767 return 0
9769 return 1
9772 proc validate_arctags {a} {
9773 global arctags idtags
9775 set i -1
9776 set na $arctags($a)
9777 foreach id $arctags($a) {
9778 incr i
9779 if {![info exists idtags($id)]} {
9780 set na [lreplace $na $i $i]
9781 incr i -1
9784 set arctags($a) $na
9787 proc validate_archeads {a} {
9788 global archeads idheads
9790 set i -1
9791 set na $archeads($a)
9792 foreach id $archeads($a) {
9793 incr i
9794 if {![info exists idheads($id)]} {
9795 set na [lreplace $na $i $i]
9796 incr i -1
9799 set archeads($a) $na
9802 # Return the list of IDs that have tags that are descendents of id,
9803 # ignoring IDs that are descendents of IDs already reported.
9804 proc desctags {id} {
9805 global arcnos arcstart arcids arctags idtags allparents
9806 global growing cached_dtags
9808 if {![info exists allparents($id)]} {
9809 return {}
9811 set t1 [clock clicks -milliseconds]
9812 set argid $id
9813 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9814 # part-way along an arc; check that arc first
9815 set a [lindex $arcnos($id) 0]
9816 if {$arctags($a) ne {}} {
9817 validate_arctags $a
9818 set i [lsearch -exact $arcids($a) $id]
9819 set tid {}
9820 foreach t $arctags($a) {
9821 set j [lsearch -exact $arcids($a) $t]
9822 if {$j >= $i} break
9823 set tid $t
9825 if {$tid ne {}} {
9826 return $tid
9829 set id $arcstart($a)
9830 if {[info exists idtags($id)]} {
9831 return $id
9834 if {[info exists cached_dtags($id)]} {
9835 return $cached_dtags($id)
9838 set origid $id
9839 set todo [list $id]
9840 set queued($id) 1
9841 set nc 1
9842 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9843 set id [lindex $todo $i]
9844 set done($id) 1
9845 set ta [info exists hastaggedancestor($id)]
9846 if {!$ta} {
9847 incr nc -1
9849 # ignore tags on starting node
9850 if {!$ta && $i > 0} {
9851 if {[info exists idtags($id)]} {
9852 set tagloc($id) $id
9853 set ta 1
9854 } elseif {[info exists cached_dtags($id)]} {
9855 set tagloc($id) $cached_dtags($id)
9856 set ta 1
9859 foreach a $arcnos($id) {
9860 set d $arcstart($a)
9861 if {!$ta && $arctags($a) ne {}} {
9862 validate_arctags $a
9863 if {$arctags($a) ne {}} {
9864 lappend tagloc($id) [lindex $arctags($a) end]
9867 if {$ta || $arctags($a) ne {}} {
9868 set tomark [list $d]
9869 for {set j 0} {$j < [llength $tomark]} {incr j} {
9870 set dd [lindex $tomark $j]
9871 if {![info exists hastaggedancestor($dd)]} {
9872 if {[info exists done($dd)]} {
9873 foreach b $arcnos($dd) {
9874 lappend tomark $arcstart($b)
9876 if {[info exists tagloc($dd)]} {
9877 unset tagloc($dd)
9879 } elseif {[info exists queued($dd)]} {
9880 incr nc -1
9882 set hastaggedancestor($dd) 1
9886 if {![info exists queued($d)]} {
9887 lappend todo $d
9888 set queued($d) 1
9889 if {![info exists hastaggedancestor($d)]} {
9890 incr nc
9895 set tags {}
9896 foreach id [array names tagloc] {
9897 if {![info exists hastaggedancestor($id)]} {
9898 foreach t $tagloc($id) {
9899 if {[lsearch -exact $tags $t] < 0} {
9900 lappend tags $t
9905 set t2 [clock clicks -milliseconds]
9906 set loopix $i
9908 # remove tags that are descendents of other tags
9909 for {set i 0} {$i < [llength $tags]} {incr i} {
9910 set a [lindex $tags $i]
9911 for {set j 0} {$j < $i} {incr j} {
9912 set b [lindex $tags $j]
9913 set r [anc_or_desc $a $b]
9914 if {$r == 1} {
9915 set tags [lreplace $tags $j $j]
9916 incr j -1
9917 incr i -1
9918 } elseif {$r == -1} {
9919 set tags [lreplace $tags $i $i]
9920 incr i -1
9921 break
9926 if {[array names growing] ne {}} {
9927 # graph isn't finished, need to check if any tag could get
9928 # eclipsed by another tag coming later. Simply ignore any
9929 # tags that could later get eclipsed.
9930 set ctags {}
9931 foreach t $tags {
9932 if {[is_certain $t $origid]} {
9933 lappend ctags $t
9936 if {$tags eq $ctags} {
9937 set cached_dtags($origid) $tags
9938 } else {
9939 set tags $ctags
9941 } else {
9942 set cached_dtags($origid) $tags
9944 set t3 [clock clicks -milliseconds]
9945 if {0 && $t3 - $t1 >= 100} {
9946 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9947 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9949 return $tags
9952 proc anctags {id} {
9953 global arcnos arcids arcout arcend arctags idtags allparents
9954 global growing cached_atags
9956 if {![info exists allparents($id)]} {
9957 return {}
9959 set t1 [clock clicks -milliseconds]
9960 set argid $id
9961 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9962 # part-way along an arc; check that arc first
9963 set a [lindex $arcnos($id) 0]
9964 if {$arctags($a) ne {}} {
9965 validate_arctags $a
9966 set i [lsearch -exact $arcids($a) $id]
9967 foreach t $arctags($a) {
9968 set j [lsearch -exact $arcids($a) $t]
9969 if {$j > $i} {
9970 return $t
9974 if {![info exists arcend($a)]} {
9975 return {}
9977 set id $arcend($a)
9978 if {[info exists idtags($id)]} {
9979 return $id
9982 if {[info exists cached_atags($id)]} {
9983 return $cached_atags($id)
9986 set origid $id
9987 set todo [list $id]
9988 set queued($id) 1
9989 set taglist {}
9990 set nc 1
9991 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9992 set id [lindex $todo $i]
9993 set done($id) 1
9994 set td [info exists hastaggeddescendent($id)]
9995 if {!$td} {
9996 incr nc -1
9998 # ignore tags on starting node
9999 if {!$td && $i > 0} {
10000 if {[info exists idtags($id)]} {
10001 set tagloc($id) $id
10002 set td 1
10003 } elseif {[info exists cached_atags($id)]} {
10004 set tagloc($id) $cached_atags($id)
10005 set td 1
10008 foreach a $arcout($id) {
10009 if {!$td && $arctags($a) ne {}} {
10010 validate_arctags $a
10011 if {$arctags($a) ne {}} {
10012 lappend tagloc($id) [lindex $arctags($a) 0]
10015 if {![info exists arcend($a)]} continue
10016 set d $arcend($a)
10017 if {$td || $arctags($a) ne {}} {
10018 set tomark [list $d]
10019 for {set j 0} {$j < [llength $tomark]} {incr j} {
10020 set dd [lindex $tomark $j]
10021 if {![info exists hastaggeddescendent($dd)]} {
10022 if {[info exists done($dd)]} {
10023 foreach b $arcout($dd) {
10024 if {[info exists arcend($b)]} {
10025 lappend tomark $arcend($b)
10028 if {[info exists tagloc($dd)]} {
10029 unset tagloc($dd)
10031 } elseif {[info exists queued($dd)]} {
10032 incr nc -1
10034 set hastaggeddescendent($dd) 1
10038 if {![info exists queued($d)]} {
10039 lappend todo $d
10040 set queued($d) 1
10041 if {![info exists hastaggeddescendent($d)]} {
10042 incr nc
10047 set t2 [clock clicks -milliseconds]
10048 set loopix $i
10049 set tags {}
10050 foreach id [array names tagloc] {
10051 if {![info exists hastaggeddescendent($id)]} {
10052 foreach t $tagloc($id) {
10053 if {[lsearch -exact $tags $t] < 0} {
10054 lappend tags $t
10060 # remove tags that are ancestors of other tags
10061 for {set i 0} {$i < [llength $tags]} {incr i} {
10062 set a [lindex $tags $i]
10063 for {set j 0} {$j < $i} {incr j} {
10064 set b [lindex $tags $j]
10065 set r [anc_or_desc $a $b]
10066 if {$r == -1} {
10067 set tags [lreplace $tags $j $j]
10068 incr j -1
10069 incr i -1
10070 } elseif {$r == 1} {
10071 set tags [lreplace $tags $i $i]
10072 incr i -1
10073 break
10078 if {[array names growing] ne {}} {
10079 # graph isn't finished, need to check if any tag could get
10080 # eclipsed by another tag coming later. Simply ignore any
10081 # tags that could later get eclipsed.
10082 set ctags {}
10083 foreach t $tags {
10084 if {[is_certain $origid $t]} {
10085 lappend ctags $t
10088 if {$tags eq $ctags} {
10089 set cached_atags($origid) $tags
10090 } else {
10091 set tags $ctags
10093 } else {
10094 set cached_atags($origid) $tags
10096 set t3 [clock clicks -milliseconds]
10097 if {0 && $t3 - $t1 >= 100} {
10098 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10099 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10101 return $tags
10104 # Return the list of IDs that have heads that are descendents of id,
10105 # including id itself if it has a head.
10106 proc descheads {id} {
10107 global arcnos arcstart arcids archeads idheads cached_dheads
10108 global allparents
10110 if {![info exists allparents($id)]} {
10111 return {}
10113 set aret {}
10114 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10115 # part-way along an arc; check it first
10116 set a [lindex $arcnos($id) 0]
10117 if {$archeads($a) ne {}} {
10118 validate_archeads $a
10119 set i [lsearch -exact $arcids($a) $id]
10120 foreach t $archeads($a) {
10121 set j [lsearch -exact $arcids($a) $t]
10122 if {$j > $i} break
10123 lappend aret $t
10126 set id $arcstart($a)
10128 set origid $id
10129 set todo [list $id]
10130 set seen($id) 1
10131 set ret {}
10132 for {set i 0} {$i < [llength $todo]} {incr i} {
10133 set id [lindex $todo $i]
10134 if {[info exists cached_dheads($id)]} {
10135 set ret [concat $ret $cached_dheads($id)]
10136 } else {
10137 if {[info exists idheads($id)]} {
10138 lappend ret $id
10140 foreach a $arcnos($id) {
10141 if {$archeads($a) ne {}} {
10142 validate_archeads $a
10143 if {$archeads($a) ne {}} {
10144 set ret [concat $ret $archeads($a)]
10147 set d $arcstart($a)
10148 if {![info exists seen($d)]} {
10149 lappend todo $d
10150 set seen($d) 1
10155 set ret [lsort -unique $ret]
10156 set cached_dheads($origid) $ret
10157 return [concat $ret $aret]
10160 proc addedtag {id} {
10161 global arcnos arcout cached_dtags cached_atags
10163 if {![info exists arcnos($id)]} return
10164 if {![info exists arcout($id)]} {
10165 recalcarc [lindex $arcnos($id) 0]
10167 catch {unset cached_dtags}
10168 catch {unset cached_atags}
10171 proc addedhead {hid head} {
10172 global arcnos arcout cached_dheads
10174 if {![info exists arcnos($hid)]} return
10175 if {![info exists arcout($hid)]} {
10176 recalcarc [lindex $arcnos($hid) 0]
10178 catch {unset cached_dheads}
10181 proc removedhead {hid head} {
10182 global cached_dheads
10184 catch {unset cached_dheads}
10187 proc movedhead {hid head} {
10188 global arcnos arcout cached_dheads
10190 if {![info exists arcnos($hid)]} return
10191 if {![info exists arcout($hid)]} {
10192 recalcarc [lindex $arcnos($hid) 0]
10194 catch {unset cached_dheads}
10197 proc changedrefs {} {
10198 global cached_dheads cached_dtags cached_atags
10199 global arctags archeads arcnos arcout idheads idtags
10201 foreach id [concat [array names idheads] [array names idtags]] {
10202 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10203 set a [lindex $arcnos($id) 0]
10204 if {![info exists donearc($a)]} {
10205 recalcarc $a
10206 set donearc($a) 1
10210 catch {unset cached_dtags}
10211 catch {unset cached_atags}
10212 catch {unset cached_dheads}
10215 proc rereadrefs {} {
10216 global idtags idheads idotherrefs mainheadid
10218 set refids [concat [array names idtags] \
10219 [array names idheads] [array names idotherrefs]]
10220 foreach id $refids {
10221 if {![info exists ref($id)]} {
10222 set ref($id) [listrefs $id]
10225 set oldmainhead $mainheadid
10226 readrefs
10227 changedrefs
10228 set refids [lsort -unique [concat $refids [array names idtags] \
10229 [array names idheads] [array names idotherrefs]]]
10230 foreach id $refids {
10231 set v [listrefs $id]
10232 if {![info exists ref($id)] || $ref($id) != $v} {
10233 redrawtags $id
10236 if {$oldmainhead ne $mainheadid} {
10237 redrawtags $oldmainhead
10238 redrawtags $mainheadid
10240 run refill_reflist
10243 proc listrefs {id} {
10244 global idtags idheads idotherrefs
10246 set x {}
10247 if {[info exists idtags($id)]} {
10248 set x $idtags($id)
10250 set y {}
10251 if {[info exists idheads($id)]} {
10252 set y $idheads($id)
10254 set z {}
10255 if {[info exists idotherrefs($id)]} {
10256 set z $idotherrefs($id)
10258 return [list $x $y $z]
10261 proc showtag {tag isnew} {
10262 global ctext tagcontents tagids linknum tagobjid
10264 if {$isnew} {
10265 addtohistory [list showtag $tag 0]
10267 $ctext conf -state normal
10268 clear_ctext
10269 settabs 0
10270 set linknum 0
10271 if {![info exists tagcontents($tag)]} {
10272 catch {
10273 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
10276 if {[info exists tagcontents($tag)]} {
10277 set text $tagcontents($tag)
10278 } else {
10279 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10281 appendwithlinks $text {}
10282 $ctext conf -state disabled
10283 init_flist {}
10286 proc doquit {} {
10287 global stopped
10288 global gitktmpdir
10290 set stopped 100
10291 savestuff .
10292 destroy .
10294 if {[info exists gitktmpdir]} {
10295 catch {file delete -force $gitktmpdir}
10299 proc mkfontdisp {font top which} {
10300 global fontattr fontpref $font
10302 set fontpref($font) [set $font]
10303 button $top.${font}but -text $which -font optionfont \
10304 -command [list choosefont $font $which]
10305 label $top.$font -relief flat -font $font \
10306 -text $fontattr($font,family) -justify left
10307 grid x $top.${font}but $top.$font -sticky w
10310 proc choosefont {font which} {
10311 global fontparam fontlist fonttop fontattr
10312 global prefstop
10314 set fontparam(which) $which
10315 set fontparam(font) $font
10316 set fontparam(family) [font actual $font -family]
10317 set fontparam(size) $fontattr($font,size)
10318 set fontparam(weight) $fontattr($font,weight)
10319 set fontparam(slant) $fontattr($font,slant)
10320 set top .gitkfont
10321 set fonttop $top
10322 if {![winfo exists $top]} {
10323 font create sample
10324 eval font config sample [font actual $font]
10325 toplevel $top
10326 make_transient $top $prefstop
10327 wm title $top [mc "Gitk font chooser"]
10328 label $top.l -textvariable fontparam(which)
10329 pack $top.l -side top
10330 set fontlist [lsort [font families]]
10331 frame $top.f
10332 listbox $top.f.fam -listvariable fontlist \
10333 -yscrollcommand [list $top.f.sb set]
10334 bind $top.f.fam <<ListboxSelect>> selfontfam
10335 scrollbar $top.f.sb -command [list $top.f.fam yview]
10336 pack $top.f.sb -side right -fill y
10337 pack $top.f.fam -side left -fill both -expand 1
10338 pack $top.f -side top -fill both -expand 1
10339 frame $top.g
10340 spinbox $top.g.size -from 4 -to 40 -width 4 \
10341 -textvariable fontparam(size) \
10342 -validatecommand {string is integer -strict %s}
10343 checkbutton $top.g.bold -padx 5 \
10344 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10345 -variable fontparam(weight) -onvalue bold -offvalue normal
10346 checkbutton $top.g.ital -padx 5 \
10347 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10348 -variable fontparam(slant) -onvalue italic -offvalue roman
10349 pack $top.g.size $top.g.bold $top.g.ital -side left
10350 pack $top.g -side top
10351 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10352 -background white
10353 $top.c create text 100 25 -anchor center -text $which -font sample \
10354 -fill black -tags text
10355 bind $top.c <Configure> [list centertext $top.c]
10356 pack $top.c -side top -fill x
10357 frame $top.buts
10358 button $top.buts.ok -text [mc "OK"] -command fontok -default active
10359 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10360 bind $top <Key-Return> fontok
10361 bind $top <Key-Escape> fontcan
10362 grid $top.buts.ok $top.buts.can
10363 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10364 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10365 pack $top.buts -side bottom -fill x
10366 trace add variable fontparam write chg_fontparam
10367 } else {
10368 raise $top
10369 $top.c itemconf text -text $which
10371 set i [lsearch -exact $fontlist $fontparam(family)]
10372 if {$i >= 0} {
10373 $top.f.fam selection set $i
10374 $top.f.fam see $i
10378 proc centertext {w} {
10379 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10382 proc fontok {} {
10383 global fontparam fontpref prefstop
10385 set f $fontparam(font)
10386 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10387 if {$fontparam(weight) eq "bold"} {
10388 lappend fontpref($f) "bold"
10390 if {$fontparam(slant) eq "italic"} {
10391 lappend fontpref($f) "italic"
10393 set w $prefstop.$f
10394 $w conf -text $fontparam(family) -font $fontpref($f)
10396 fontcan
10399 proc fontcan {} {
10400 global fonttop fontparam
10402 if {[info exists fonttop]} {
10403 catch {destroy $fonttop}
10404 catch {font delete sample}
10405 unset fonttop
10406 unset fontparam
10410 proc selfontfam {} {
10411 global fonttop fontparam
10413 set i [$fonttop.f.fam curselection]
10414 if {$i ne {}} {
10415 set fontparam(family) [$fonttop.f.fam get $i]
10419 proc chg_fontparam {v sub op} {
10420 global fontparam
10422 font config sample -$sub $fontparam($sub)
10425 proc doprefs {} {
10426 global maxwidth maxgraphpct
10427 global oldprefs prefstop showneartags showlocalchanges
10428 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10429 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10430 global hideremotes
10432 set top .gitkprefs
10433 set prefstop $top
10434 if {[winfo exists $top]} {
10435 raise $top
10436 return
10438 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10439 limitdiffs tabstop perfile_attrs hideremotes} {
10440 set oldprefs($v) [set $v]
10442 toplevel $top
10443 wm title $top [mc "Gitk preferences"]
10444 make_transient $top .
10445 label $top.ldisp -text [mc "Commit list display options"]
10446 grid $top.ldisp - -sticky w -pady 10
10447 label $top.spacer -text " "
10448 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10449 -font optionfont
10450 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10451 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10452 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10453 -font optionfont
10454 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10455 grid x $top.maxpctl $top.maxpct -sticky w
10456 checkbutton $top.showlocal -text [mc "Show local changes"] \
10457 -font optionfont -variable showlocalchanges
10458 grid x $top.showlocal -sticky w
10459 checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10460 -font optionfont -variable autoselect
10461 grid x $top.autoselect -sticky w
10463 label $top.ddisp -text [mc "Diff display options"]
10464 grid $top.ddisp - -sticky w -pady 10
10465 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10466 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10467 grid x $top.tabstopl $top.tabstop -sticky w
10468 checkbutton $top.ntag -text [mc "Display nearby tags"] \
10469 -font optionfont -variable showneartags
10470 grid x $top.ntag -sticky w
10471 checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10472 -font optionfont -variable hideremotes
10473 grid x $top.hideremotes -sticky w
10474 checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10475 -font optionfont -variable limitdiffs
10476 grid x $top.ldiff -sticky w
10477 checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10478 -font optionfont -variable perfile_attrs
10479 grid x $top.lattr -sticky w
10481 entry $top.extdifft -textvariable extdifftool
10482 frame $top.extdifff
10483 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10484 -padx 10
10485 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10486 -command choose_extdiff
10487 pack $top.extdifff.l $top.extdifff.b -side left
10488 grid x $top.extdifff $top.extdifft -sticky w
10490 label $top.cdisp -text [mc "Colors: press to choose"]
10491 grid $top.cdisp - -sticky w -pady 10
10492 label $top.bg -padx 40 -relief sunk -background $bgcolor
10493 button $top.bgbut -text [mc "Background"] -font optionfont \
10494 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10495 grid x $top.bgbut $top.bg -sticky w
10496 label $top.fg -padx 40 -relief sunk -background $fgcolor
10497 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10498 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10499 grid x $top.fgbut $top.fg -sticky w
10500 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10501 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10502 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10503 [list $ctext tag conf d0 -foreground]]
10504 grid x $top.diffoldbut $top.diffold -sticky w
10505 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10506 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10507 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10508 [list $ctext tag conf dresult -foreground]]
10509 grid x $top.diffnewbut $top.diffnew -sticky w
10510 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10511 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10512 -command [list choosecolor diffcolors 2 $top.hunksep \
10513 [mc "diff hunk header"] \
10514 [list $ctext tag conf hunksep -foreground]]
10515 grid x $top.hunksepbut $top.hunksep -sticky w
10516 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10517 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10518 -command [list choosecolor markbgcolor {} $top.markbgsep \
10519 [mc "marked line background"] \
10520 [list $ctext tag conf omark -background]]
10521 grid x $top.markbgbut $top.markbgsep -sticky w
10522 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10523 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10524 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10525 grid x $top.selbgbut $top.selbgsep -sticky w
10527 label $top.cfont -text [mc "Fonts: press to choose"]
10528 grid $top.cfont - -sticky w -pady 10
10529 mkfontdisp mainfont $top [mc "Main font"]
10530 mkfontdisp textfont $top [mc "Diff display font"]
10531 mkfontdisp uifont $top [mc "User interface font"]
10533 frame $top.buts
10534 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10535 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10536 bind $top <Key-Return> prefsok
10537 bind $top <Key-Escape> prefscan
10538 grid $top.buts.ok $top.buts.can
10539 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10540 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10541 grid $top.buts - - -pady 10 -sticky ew
10542 bind $top <Visibility> "focus $top.buts.ok"
10545 proc choose_extdiff {} {
10546 global extdifftool
10548 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10549 if {$prog ne {}} {
10550 set extdifftool $prog
10554 proc choosecolor {v vi w x cmd} {
10555 global $v
10557 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10558 -title [mc "Gitk: choose color for %s" $x]]
10559 if {$c eq {}} return
10560 $w conf -background $c
10561 lset $v $vi $c
10562 eval $cmd $c
10565 proc setselbg {c} {
10566 global bglist cflist
10567 foreach w $bglist {
10568 $w configure -selectbackground $c
10570 $cflist tag configure highlight \
10571 -background [$cflist cget -selectbackground]
10572 allcanvs itemconf secsel -fill $c
10575 proc setbg {c} {
10576 global bglist
10578 foreach w $bglist {
10579 $w conf -background $c
10583 proc setfg {c} {
10584 global fglist canv
10586 foreach w $fglist {
10587 $w conf -foreground $c
10589 allcanvs itemconf text -fill $c
10590 $canv itemconf circle -outline $c
10591 $canv itemconf markid -outline $c
10594 proc prefscan {} {
10595 global oldprefs prefstop
10597 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10598 limitdiffs tabstop perfile_attrs hideremotes} {
10599 global $v
10600 set $v $oldprefs($v)
10602 catch {destroy $prefstop}
10603 unset prefstop
10604 fontcan
10607 proc prefsok {} {
10608 global maxwidth maxgraphpct
10609 global oldprefs prefstop showneartags showlocalchanges
10610 global fontpref mainfont textfont uifont
10611 global limitdiffs treediffs perfile_attrs
10612 global hideremotes
10614 catch {destroy $prefstop}
10615 unset prefstop
10616 fontcan
10617 set fontchanged 0
10618 if {$mainfont ne $fontpref(mainfont)} {
10619 set mainfont $fontpref(mainfont)
10620 parsefont mainfont $mainfont
10621 eval font configure mainfont [fontflags mainfont]
10622 eval font configure mainfontbold [fontflags mainfont 1]
10623 setcoords
10624 set fontchanged 1
10626 if {$textfont ne $fontpref(textfont)} {
10627 set textfont $fontpref(textfont)
10628 parsefont textfont $textfont
10629 eval font configure textfont [fontflags textfont]
10630 eval font configure textfontbold [fontflags textfont 1]
10632 if {$uifont ne $fontpref(uifont)} {
10633 set uifont $fontpref(uifont)
10634 parsefont uifont $uifont
10635 eval font configure uifont [fontflags uifont]
10637 settabs
10638 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10639 if {$showlocalchanges} {
10640 doshowlocalchanges
10641 } else {
10642 dohidelocalchanges
10645 if {$limitdiffs != $oldprefs(limitdiffs) ||
10646 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10647 # treediffs elements are limited by path;
10648 # won't have encodings cached if perfile_attrs was just turned on
10649 catch {unset treediffs}
10651 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10652 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10653 redisplay
10654 } elseif {$showneartags != $oldprefs(showneartags) ||
10655 $limitdiffs != $oldprefs(limitdiffs)} {
10656 reselectline
10658 if {$hideremotes != $oldprefs(hideremotes)} {
10659 rereadrefs
10663 proc formatdate {d} {
10664 global datetimeformat
10665 if {$d ne {}} {
10666 set d [clock format $d -format $datetimeformat]
10668 return $d
10671 # This list of encoding names and aliases is distilled from
10672 # http://www.iana.org/assignments/character-sets.
10673 # Not all of them are supported by Tcl.
10674 set encoding_aliases {
10675 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10676 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10677 { ISO-10646-UTF-1 csISO10646UTF1 }
10678 { ISO_646.basic:1983 ref csISO646basic1983 }
10679 { INVARIANT csINVARIANT }
10680 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10681 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10682 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10683 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10684 { NATS-DANO iso-ir-9-1 csNATSDANO }
10685 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10686 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10687 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10688 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10689 { ISO-2022-KR csISO2022KR }
10690 { EUC-KR csEUCKR }
10691 { ISO-2022-JP csISO2022JP }
10692 { ISO-2022-JP-2 csISO2022JP2 }
10693 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10694 csISO13JISC6220jp }
10695 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10696 { IT iso-ir-15 ISO646-IT csISO15Italian }
10697 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10698 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10699 { greek7-old iso-ir-18 csISO18Greek7Old }
10700 { latin-greek iso-ir-19 csISO19LatinGreek }
10701 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10702 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10703 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10704 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10705 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10706 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10707 { INIS iso-ir-49 csISO49INIS }
10708 { INIS-8 iso-ir-50 csISO50INIS8 }
10709 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10710 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10711 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10712 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10713 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10714 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10715 csISO60Norwegian1 }
10716 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10717 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10718 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10719 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10720 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10721 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10722 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10723 { greek7 iso-ir-88 csISO88Greek7 }
10724 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10725 { iso-ir-90 csISO90 }
10726 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10727 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10728 csISO92JISC62991984b }
10729 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10730 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10731 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10732 csISO95JIS62291984handadd }
10733 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10734 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10735 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10736 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10737 CP819 csISOLatin1 }
10738 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10739 { T.61-7bit iso-ir-102 csISO102T617bit }
10740 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10741 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10742 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10743 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10744 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10745 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10746 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10747 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10748 arabic csISOLatinArabic }
10749 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10750 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10751 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10752 greek greek8 csISOLatinGreek }
10753 { T.101-G2 iso-ir-128 csISO128T101G2 }
10754 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10755 csISOLatinHebrew }
10756 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10757 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10758 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10759 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10760 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10761 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10762 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10763 csISOLatinCyrillic }
10764 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10765 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10766 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10767 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10768 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10769 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10770 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10771 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10772 { ISO_10367-box iso-ir-155 csISO10367Box }
10773 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10774 { latin-lap lap iso-ir-158 csISO158Lap }
10775 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10776 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10777 { us-dk csUSDK }
10778 { dk-us csDKUS }
10779 { JIS_X0201 X0201 csHalfWidthKatakana }
10780 { KSC5636 ISO646-KR csKSC5636 }
10781 { ISO-10646-UCS-2 csUnicode }
10782 { ISO-10646-UCS-4 csUCS4 }
10783 { DEC-MCS dec csDECMCS }
10784 { hp-roman8 roman8 r8 csHPRoman8 }
10785 { macintosh mac csMacintosh }
10786 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10787 csIBM037 }
10788 { IBM038 EBCDIC-INT cp038 csIBM038 }
10789 { IBM273 CP273 csIBM273 }
10790 { IBM274 EBCDIC-BE CP274 csIBM274 }
10791 { IBM275 EBCDIC-BR cp275 csIBM275 }
10792 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10793 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10794 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10795 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10796 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10797 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10798 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10799 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10800 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10801 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10802 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10803 { IBM437 cp437 437 csPC8CodePage437 }
10804 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10805 { IBM775 cp775 csPC775Baltic }
10806 { IBM850 cp850 850 csPC850Multilingual }
10807 { IBM851 cp851 851 csIBM851 }
10808 { IBM852 cp852 852 csPCp852 }
10809 { IBM855 cp855 855 csIBM855 }
10810 { IBM857 cp857 857 csIBM857 }
10811 { IBM860 cp860 860 csIBM860 }
10812 { IBM861 cp861 861 cp-is csIBM861 }
10813 { IBM862 cp862 862 csPC862LatinHebrew }
10814 { IBM863 cp863 863 csIBM863 }
10815 { IBM864 cp864 csIBM864 }
10816 { IBM865 cp865 865 csIBM865 }
10817 { IBM866 cp866 866 csIBM866 }
10818 { IBM868 CP868 cp-ar csIBM868 }
10819 { IBM869 cp869 869 cp-gr csIBM869 }
10820 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10821 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10822 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10823 { IBM891 cp891 csIBM891 }
10824 { IBM903 cp903 csIBM903 }
10825 { IBM904 cp904 904 csIBBM904 }
10826 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10827 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10828 { IBM1026 CP1026 csIBM1026 }
10829 { EBCDIC-AT-DE csIBMEBCDICATDE }
10830 { EBCDIC-AT-DE-A csEBCDICATDEA }
10831 { EBCDIC-CA-FR csEBCDICCAFR }
10832 { EBCDIC-DK-NO csEBCDICDKNO }
10833 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10834 { EBCDIC-FI-SE csEBCDICFISE }
10835 { EBCDIC-FI-SE-A csEBCDICFISEA }
10836 { EBCDIC-FR csEBCDICFR }
10837 { EBCDIC-IT csEBCDICIT }
10838 { EBCDIC-PT csEBCDICPT }
10839 { EBCDIC-ES csEBCDICES }
10840 { EBCDIC-ES-A csEBCDICESA }
10841 { EBCDIC-ES-S csEBCDICESS }
10842 { EBCDIC-UK csEBCDICUK }
10843 { EBCDIC-US csEBCDICUS }
10844 { UNKNOWN-8BIT csUnknown8BiT }
10845 { MNEMONIC csMnemonic }
10846 { MNEM csMnem }
10847 { VISCII csVISCII }
10848 { VIQR csVIQR }
10849 { KOI8-R csKOI8R }
10850 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10851 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10852 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10853 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10854 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10855 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10856 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10857 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10858 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10859 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10860 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10861 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10862 { IBM1047 IBM-1047 }
10863 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10864 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10865 { UNICODE-1-1 csUnicode11 }
10866 { CESU-8 csCESU-8 }
10867 { BOCU-1 csBOCU-1 }
10868 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10869 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10870 l8 }
10871 { ISO-8859-15 ISO_8859-15 Latin-9 }
10872 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10873 { GBK CP936 MS936 windows-936 }
10874 { JIS_Encoding csJISEncoding }
10875 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10876 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10877 EUC-JP }
10878 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10879 { ISO-10646-UCS-Basic csUnicodeASCII }
10880 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10881 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10882 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10883 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10884 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10885 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10886 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10887 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10888 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10889 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10890 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10891 { Ventura-US csVenturaUS }
10892 { Ventura-International csVenturaInternational }
10893 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10894 { PC8-Turkish csPC8Turkish }
10895 { IBM-Symbols csIBMSymbols }
10896 { IBM-Thai csIBMThai }
10897 { HP-Legal csHPLegal }
10898 { HP-Pi-font csHPPiFont }
10899 { HP-Math8 csHPMath8 }
10900 { Adobe-Symbol-Encoding csHPPSMath }
10901 { HP-DeskTop csHPDesktop }
10902 { Ventura-Math csVenturaMath }
10903 { Microsoft-Publishing csMicrosoftPublishing }
10904 { Windows-31J csWindows31J }
10905 { GB2312 csGB2312 }
10906 { Big5 csBig5 }
10909 proc tcl_encoding {enc} {
10910 global encoding_aliases tcl_encoding_cache
10911 if {[info exists tcl_encoding_cache($enc)]} {
10912 return $tcl_encoding_cache($enc)
10914 set names [encoding names]
10915 set lcnames [string tolower $names]
10916 set enc [string tolower $enc]
10917 set i [lsearch -exact $lcnames $enc]
10918 if {$i < 0} {
10919 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10920 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10921 set i [lsearch -exact $lcnames $encx]
10924 if {$i < 0} {
10925 foreach l $encoding_aliases {
10926 set ll [string tolower $l]
10927 if {[lsearch -exact $ll $enc] < 0} continue
10928 # look through the aliases for one that tcl knows about
10929 foreach e $ll {
10930 set i [lsearch -exact $lcnames $e]
10931 if {$i < 0} {
10932 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10933 set i [lsearch -exact $lcnames $ex]
10936 if {$i >= 0} break
10938 break
10941 set tclenc {}
10942 if {$i >= 0} {
10943 set tclenc [lindex $names $i]
10945 set tcl_encoding_cache($enc) $tclenc
10946 return $tclenc
10949 proc gitattr {path attr default} {
10950 global path_attr_cache
10951 if {[info exists path_attr_cache($attr,$path)]} {
10952 set r $path_attr_cache($attr,$path)
10953 } else {
10954 set r "unspecified"
10955 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10956 regexp "(.*): $attr: (.*)" $line m f r
10958 set path_attr_cache($attr,$path) $r
10960 if {$r eq "unspecified"} {
10961 return $default
10963 return $r
10966 proc cache_gitattr {attr pathlist} {
10967 global path_attr_cache
10968 set newlist {}
10969 foreach path $pathlist {
10970 if {![info exists path_attr_cache($attr,$path)]} {
10971 lappend newlist $path
10974 set lim 1000
10975 if {[tk windowingsystem] == "win32"} {
10976 # windows has a 32k limit on the arguments to a command...
10977 set lim 30
10979 while {$newlist ne {}} {
10980 set head [lrange $newlist 0 [expr {$lim - 1}]]
10981 set newlist [lrange $newlist $lim end]
10982 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10983 foreach row [split $rlist "\n"] {
10984 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
10985 if {[string index $path 0] eq "\""} {
10986 set path [encoding convertfrom [lindex $path 0]]
10988 set path_attr_cache($attr,$path) $value
10995 proc get_path_encoding {path} {
10996 global gui_encoding perfile_attrs
10997 set tcl_enc $gui_encoding
10998 if {$path ne {} && $perfile_attrs} {
10999 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11000 if {$enc2 ne {}} {
11001 set tcl_enc $enc2
11004 return $tcl_enc
11007 # First check that Tcl/Tk is recent enough
11008 if {[catch {package require Tk 8.4} err]} {
11009 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11010 Gitk requires at least Tcl/Tk 8.4."]
11011 exit 1
11014 # defaults...
11015 set wrcomcmd "git diff-tree --stdin -p --pretty"
11017 set gitencoding {}
11018 catch {
11019 set gitencoding [exec git config --get i18n.commitencoding]
11021 catch {
11022 set gitencoding [exec git config --get i18n.logoutputencoding]
11024 if {$gitencoding == ""} {
11025 set gitencoding "utf-8"
11027 set tclencoding [tcl_encoding $gitencoding]
11028 if {$tclencoding == {}} {
11029 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11032 set gui_encoding [encoding system]
11033 catch {
11034 set enc [exec git config --get gui.encoding]
11035 if {$enc ne {}} {
11036 set tclenc [tcl_encoding $enc]
11037 if {$tclenc ne {}} {
11038 set gui_encoding $tclenc
11039 } else {
11040 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11045 if {[tk windowingsystem] eq "aqua"} {
11046 set mainfont {{Lucida Grande} 9}
11047 set textfont {Monaco 9}
11048 set uifont {{Lucida Grande} 9 bold}
11049 } else {
11050 set mainfont {Helvetica 9}
11051 set textfont {Courier 9}
11052 set uifont {Helvetica 9 bold}
11054 set tabstop 8
11055 set findmergefiles 0
11056 set maxgraphpct 50
11057 set maxwidth 16
11058 set revlistorder 0
11059 set fastdate 0
11060 set uparrowlen 5
11061 set downarrowlen 5
11062 set mingaplen 100
11063 set cmitmode "patch"
11064 set wrapcomment "none"
11065 set showneartags 1
11066 set hideremotes 0
11067 set maxrefs 20
11068 set maxlinelen 200
11069 set showlocalchanges 1
11070 set limitdiffs 1
11071 set datetimeformat "%Y-%m-%d %H:%M:%S"
11072 set autoselect 1
11073 set perfile_attrs 0
11075 if {[tk windowingsystem] eq "aqua"} {
11076 set extdifftool "opendiff"
11077 } else {
11078 set extdifftool "meld"
11081 set colors {green red blue magenta darkgrey brown orange}
11082 set bgcolor white
11083 set fgcolor black
11084 set diffcolors {red "#00a000" blue}
11085 set diffcontext 3
11086 set ignorespace 0
11087 set selectbgcolor gray85
11088 set markbgcolor "#e0e0ff"
11090 set circlecolors {white blue gray blue blue}
11092 # button for popping up context menus
11093 if {[tk windowingsystem] eq "aqua"} {
11094 set ctxbut <Button-2>
11095 } else {
11096 set ctxbut <Button-3>
11099 ## For msgcat loading, first locate the installation location.
11100 if { [info exists ::env(GITK_MSGSDIR)] } {
11101 ## Msgsdir was manually set in the environment.
11102 set gitk_msgsdir $::env(GITK_MSGSDIR)
11103 } else {
11104 ## Let's guess the prefix from argv0.
11105 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11106 set gitk_libdir [file join $gitk_prefix share gitk lib]
11107 set gitk_msgsdir [file join $gitk_libdir msgs]
11108 unset gitk_prefix
11111 ## Internationalization (i18n) through msgcat and gettext. See
11112 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11113 package require msgcat
11114 namespace import ::msgcat::mc
11115 ## And eventually load the actual message catalog
11116 ::msgcat::mcload $gitk_msgsdir
11118 catch {source ~/.gitk}
11120 font create optionfont -family sans-serif -size -12
11122 parsefont mainfont $mainfont
11123 eval font create mainfont [fontflags mainfont]
11124 eval font create mainfontbold [fontflags mainfont 1]
11126 parsefont textfont $textfont
11127 eval font create textfont [fontflags textfont]
11128 eval font create textfontbold [fontflags textfont 1]
11130 parsefont uifont $uifont
11131 eval font create uifont [fontflags uifont]
11133 setoptions
11135 # check that we can find a .git directory somewhere...
11136 if {[catch {set gitdir [gitdir]}]} {
11137 show_error {} . [mc "Cannot find a git repository here."]
11138 exit 1
11140 if {![file isdirectory $gitdir]} {
11141 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11142 exit 1
11145 set selecthead {}
11146 set selectheadid {}
11148 set revtreeargs {}
11149 set cmdline_files {}
11150 set i 0
11151 set revtreeargscmd {}
11152 foreach arg $argv {
11153 switch -glob -- $arg {
11154 "" { }
11155 "--" {
11156 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11157 break
11159 "--select-commit=*" {
11160 set selecthead [string range $arg 16 end]
11162 "--argscmd=*" {
11163 set revtreeargscmd [string range $arg 10 end]
11165 default {
11166 lappend revtreeargs $arg
11169 incr i
11172 if {$selecthead eq "HEAD"} {
11173 set selecthead {}
11176 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11177 # no -- on command line, but some arguments (other than --argscmd)
11178 if {[catch {
11179 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11180 set cmdline_files [split $f "\n"]
11181 set n [llength $cmdline_files]
11182 set revtreeargs [lrange $revtreeargs 0 end-$n]
11183 # Unfortunately git rev-parse doesn't produce an error when
11184 # something is both a revision and a filename. To be consistent
11185 # with git log and git rev-list, check revtreeargs for filenames.
11186 foreach arg $revtreeargs {
11187 if {[file exists $arg]} {
11188 show_error {} . [mc "Ambiguous argument '%s': both revision\
11189 and filename" $arg]
11190 exit 1
11193 } err]} {
11194 # unfortunately we get both stdout and stderr in $err,
11195 # so look for "fatal:".
11196 set i [string first "fatal:" $err]
11197 if {$i > 0} {
11198 set err [string range $err [expr {$i + 6}] end]
11200 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11201 exit 1
11205 set nullid "0000000000000000000000000000000000000000"
11206 set nullid2 "0000000000000000000000000000000000000001"
11207 set nullfile "/dev/null"
11209 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11210 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11212 set runq {}
11213 set history {}
11214 set historyindex 0
11215 set fh_serial 0
11216 set nhl_names {}
11217 set highlight_paths {}
11218 set findpattern {}
11219 set searchdirn -forwards
11220 set boldids {}
11221 set boldnameids {}
11222 set diffelide {0 0}
11223 set markingmatches 0
11224 set linkentercount 0
11225 set need_redisplay 0
11226 set nrows_drawn 0
11227 set firsttabstop 0
11229 set nextviewnum 1
11230 set curview 0
11231 set selectedview 0
11232 set selectedhlview [mc "None"]
11233 set highlight_related [mc "None"]
11234 set highlight_files {}
11235 set viewfiles(0) {}
11236 set viewperm(0) 0
11237 set viewargs(0) {}
11238 set viewargscmd(0) {}
11240 set selectedline {}
11241 set numcommits 0
11242 set loginstance 0
11243 set cmdlineok 0
11244 set stopped 0
11245 set stuffsaved 0
11246 set patchnum 0
11247 set lserial 0
11248 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11249 setcoords
11250 makewindow
11251 catch {
11252 image create photo gitlogo -width 16 -height 16
11254 image create photo gitlogominus -width 4 -height 2
11255 gitlogominus put #C00000 -to 0 0 4 2
11256 gitlogo copy gitlogominus -to 1 5
11257 gitlogo copy gitlogominus -to 6 5
11258 gitlogo copy gitlogominus -to 11 5
11259 image delete gitlogominus
11261 image create photo gitlogoplus -width 4 -height 4
11262 gitlogoplus put #008000 -to 1 0 3 4
11263 gitlogoplus put #008000 -to 0 1 4 3
11264 gitlogo copy gitlogoplus -to 1 9
11265 gitlogo copy gitlogoplus -to 6 9
11266 gitlogo copy gitlogoplus -to 11 9
11267 image delete gitlogoplus
11269 image create photo gitlogo32 -width 32 -height 32
11270 gitlogo32 copy gitlogo -zoom 2 2
11272 wm iconphoto . -default gitlogo gitlogo32
11274 # wait for the window to become visible
11275 tkwait visibility .
11276 wm title . "[file tail $argv0]: [file tail [pwd]]"
11277 update
11278 readrefs
11280 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11281 # create a view for the files/dirs specified on the command line
11282 set curview 1
11283 set selectedview 1
11284 set nextviewnum 2
11285 set viewname(1) [mc "Command line"]
11286 set viewfiles(1) $cmdline_files
11287 set viewargs(1) $revtreeargs
11288 set viewargscmd(1) $revtreeargscmd
11289 set viewperm(1) 0
11290 set vdatemode(1) 0
11291 addviewmenu 1
11292 .bar.view entryconf [mca "Edit view..."] -state normal
11293 .bar.view entryconf [mca "Delete view"] -state normal
11296 if {[info exists permviews]} {
11297 foreach v $permviews {
11298 set n $nextviewnum
11299 incr nextviewnum
11300 set viewname($n) [lindex $v 0]
11301 set viewfiles($n) [lindex $v 1]
11302 set viewargs($n) [lindex $v 2]
11303 set viewargscmd($n) [lindex $v 3]
11304 set viewperm($n) 1
11305 addviewmenu $n
11309 if {[tk windowingsystem] eq "win32"} {
11310 focus -force .
11313 getcommits {}