2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright (C) 2005-2006 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.
12 if {[info exists env
(GIT_DIR
)]} {
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.
28 if {[info exists isonrunq
($script)]} return
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} {
43 fileevent
$fd readable
{}
47 lappend runq
[list
$fd $script]
53 for {set i
0} {$i < [llength
$runq]} {} {
54 if {[lindex
$runq $i 0] eq
$fd} {
55 set runq
[lreplace
$runq $i $i]
65 set tstart
[clock clicks
-milliseconds]
67 while {[llength
$runq] > 0} {
68 set fd
[lindex
$runq 0 0]
69 set script [lindex
$runq 0 1]
70 set repeat
[eval $script]
71 set t1
[clock clicks
-milliseconds]
72 set t
[expr {$t1 - $t0}]
73 set runq
[lrange
$runq 1 end
]
74 if {$repeat ne
{} && $repeat} {
75 if {$fd eq
{} ||
$repeat == 2} {
76 # script returns 1 if it wants to be readded
77 # file readers return 2 if they could do more straight away
78 lappend runq
[list
$fd $script]
80 fileevent
$fd readable
[list filereadable
$fd $script]
82 } elseif
{$fd eq
{}} {
83 unset isonrunq
($script)
86 if {$t1 - $tstart >= 80} break
93 # Start off a git rev-list process and arrange to read its output
94 proc start_rev_list
{view
} {
96 global commfd leftover tclencoding datemode
97 global viewargs viewfiles commitidx viewcomplete vnextroot
98 global showlocalchanges commitinterest mainheadid
99 global progressdirn progresscoords proglastnc curview
100 global viewincl viewactive loginstance viewinstances
102 set startmsecs
[clock clicks
-milliseconds]
103 set commitidx
($view) 0
104 set viewcomplete
($view) 0
105 set viewactive
($view) 1
106 set vnextroot
($view) 0
109 set commits
[eval exec git rev-parse
--default HEAD
--revs-only \
111 set viewincl
($view) {}
113 if {![string match
"^*" $c]} {
114 lappend viewincl
($view) $c
118 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
119 --boundary $commits "--" $viewfiles($view)] r
]
121 error_popup
"Error executing git log: $err"
124 set i
[incr loginstance
]
125 set viewinstances
($view) [list
$i]
128 if {$showlocalchanges} {
129 lappend commitinterest
($mainheadid) {dodiffindex
}
131 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
132 if {$tclencoding != {}} {
133 fconfigure
$fd -encoding $tclencoding
135 filerun
$fd [list getcommitlines
$fd $i $view]
136 nowbusy
$view "Reading"
137 if {$view == $curview} {
139 set progresscoords
{0 0}
144 proc stop_rev_list
{view
} {
145 global commfd viewinstances leftover
147 foreach inst
$viewinstances($view) {
148 set fd
$commfd($inst)
156 unset leftover
($inst)
158 set viewinstances
($view) {}
165 start_rev_list
$curview
166 show_status
"Reading commits..."
169 proc updatecommits
{} {
170 global curview viewargs viewfiles viewincl viewinstances
171 global viewactive viewcomplete loginstance tclencoding
172 global varcid startmsecs commfd getdbg showneartags leftover
176 set commits
[exec git rev-parse
--default HEAD
--revs-only \
181 if {[string match
"^*" $c]} {
184 if {!([info exists varcid
($view,$c)] ||
185 [lsearch
-exact $viewincl($view) $c] >= 0)} {
193 foreach id
$viewincl($view) {
196 set viewincl
($view) [concat
$viewincl($view) $pos]
198 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
199 --boundary $pos $neg "--" $viewfiles($view)] r
]
201 error_popup
"Error executing git log: $err"
204 if {$viewactive($view) == 0} {
205 set startmsecs
[clock clicks
-milliseconds]
207 set i
[incr loginstance
]
208 lappend viewinstances
($view) $i
211 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
212 if {$tclencoding != {}} {
213 fconfigure
$fd -encoding $tclencoding
215 filerun
$fd [list getcommitlines
$fd $i $view]
216 incr viewactive
($view)
217 set viewcomplete
($view) 0
218 nowbusy
$view "Reading"
226 proc reloadcommits
{} {
227 global curview viewcomplete selectedline currentid thickerline
228 global showneartags treediffs commitinterest cached_commitrow
229 global progresscoords
231 if {!$viewcomplete($curview)} {
232 stop_rev_list
$curview
233 set progresscoords
{0 0}
237 catch
{unset selectedline
}
238 catch
{unset currentid
}
239 catch
{unset thickerline
}
240 catch
{unset treediffs
}
247 catch
{unset commitinterest
}
248 catch
{unset cached_commitrow
}
253 # This makes a string representation of a positive integer which
254 # sorts as a string in numerical order
257 return [format
"%x" $n]
258 } elseif
{$n < 256} {
259 return [format
"x%.2x" $n]
260 } elseif
{$n < 65536} {
261 return [format
"y%.4x" $n]
263 return [format
"z%.8x" $n]
266 # Procedures used in reordering commits from git log (without
267 # --topo-order) into the order for display.
269 proc varcinit
{view
} {
270 global vseeds varcstart vupptr vdownptr vleftptr varctok varcrow
271 global vtokmod varcmod varcix uat
274 set varcstart
($view) {{}}
275 set vupptr
($view) {0}
276 set vdownptr
($view) {0}
277 set vleftptr
($view) {0}
278 set varctok
($view) {{}}
279 set varcrow
($view) {{}}
280 set vtokmod
($view) {}
282 set varcix
($view) {{}}
286 proc resetvarcs
{view
} {
287 global varcid varccommits parents children vseedcount ordertok
289 foreach vid
[array names varcid
$view,*] {
294 # some commits might have children but haven't been seen yet
295 foreach vid
[array names children
$view,*] {
298 foreach va
[array names varccommits
$view,*] {
299 unset varccommits
($va)
301 foreach vd
[array names vseedcount
$view,*] {
302 unset vseedcount
($vd)
304 catch
{unset ordertok
}
307 proc newvarc
{view id
} {
308 global varcid varctok parents children vseeds
309 global vupptr vdownptr vleftptr varcrow varcix varcstart
310 global commitdata commitinfo vseedcount
312 set a
[llength
$varctok($view)]
314 if {[llength
$children($vid)] == 0} {
315 if {![info exists commitinfo
($id)]} {
316 parsecommit
$id $commitdata($id) 1
318 set cdate
[lindex
$commitinfo($id) 4]
319 if {![string is integer
-strict $cdate]} {
322 if {![info exists vseedcount
($view,$cdate)]} {
323 set vseedcount
($view,$cdate) -1
325 set c
[incr vseedcount
($view,$cdate)]
326 set cdate
[expr {$cdate ^
0xffffffff}]
327 set tok
"s[strrep $cdate][strrep $c]"
328 lappend vseeds
($view) $id
329 lappend vupptr
($view) 0
330 set ka
[lindex
$vdownptr($view) 0]
332 [string compare
$tok [lindex
$varctok($view) $ka]] < 0} {
333 lset vdownptr
($view) 0 $a
334 lappend vleftptr
($view) $ka
336 while {[set b
[lindex
$vleftptr($view) $ka]] != 0 &&
337 [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
340 lset vleftptr
($view) $ka $a
341 lappend vleftptr
($view) $b
345 foreach k
$children($vid) {
346 set ka
$varcid($view,$k)
347 if {[string compare
[lindex
$varctok($view) $ka] $tok] > 0} {
349 set tok
[lindex
$varctok($view) $ka]
352 set ka
$varcid($view,$ki)
353 lappend vupptr
($view) $ka
354 set i
[lsearch
-exact $parents($view,$ki) $id]
355 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
357 while {[incr i
] < [llength
$parents($view,$ki)]} {
358 set bi
[lindex
$parents($view,$ki) $i]
359 if {[info exists varcid
($view,$bi)]} {
360 set b
$varcid($view,$bi)
361 if {[lindex
$vupptr($view) $b] == $ka} {
363 lappend vleftptr
($view) [lindex
$vleftptr($view) $b]
364 lset vleftptr
($view) $b $a
370 lappend vleftptr
($view) [lindex
$vdownptr($view) $ka]
371 lset vdownptr
($view) $ka $a
373 append tok
[strrep
$j]
375 lappend varctok
($view) $tok
376 lappend varcstart
($view) $id
377 lappend vdownptr
($view) 0
378 lappend varcrow
($view) {}
379 lappend varcix
($view) {}
383 proc splitvarc
{p v
} {
384 global varcid varcstart varccommits varctok
385 global vupptr vdownptr vleftptr varcix varcrow
387 set oa
$varcid($v,$p)
388 set ac
$varccommits($v,$oa)
389 set i
[lsearch
-exact $varccommits($v,$oa) $p]
391 set na
[llength
$varctok($v)]
392 # "%" sorts before "0"...
393 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
394 lappend varctok
($v) $tok
395 lappend varcrow
($v) {}
396 lappend varcix
($v) {}
397 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
398 set varccommits
($v,$na) [lrange
$ac $i end
]
399 lappend varcstart
($v) $p
400 foreach id
$varccommits($v,$na) {
401 set varcid
($v,$id) $na
403 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
404 lset vdownptr
($v) $oa $na
405 lappend vupptr
($v) $oa
406 lappend vleftptr
($v) 0
407 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
408 lset vupptr
($v) $b $na
412 proc renumbervarc
{a v
} {
413 global parents children varctok varcstart varccommits
414 global vupptr vdownptr vleftptr varcid vtokmod
416 set t1
[clock clicks
-milliseconds]
421 if {[info exists isrelated
($a)]} {
423 set id
[lindex
$varccommits($v,$a) end
]
424 foreach p
$parents($v,$id) {
425 if {[info exists varcid
($v,$p)]} {
426 set isrelated
($varcid($v,$p)) 1
431 set b
[lindex
$vdownptr($v) $a]
434 set b
[lindex
$vleftptr($v) $a]
436 set a
[lindex
$vupptr($v) $a]
442 set id
[lindex
$varcstart($v) $a]
444 foreach k
$children($v,$id) {
445 set ka
$varcid($v,$k)
446 if {[string compare
[lindex
$varctok($v) $ka] $tok] > 0} {
448 set tok
[lindex
$varctok($v) $ka]
452 set ka
$varcid($v,$ki)
453 set i
[lsearch
-exact $parents($v,$ki) $id]
454 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
455 append tok
[strrep
$j]
456 set oldtok
[lindex
$varctok($v) $a]
457 if {$tok eq
$oldtok} continue
458 lset varctok
($v) $a $tok
462 set b
[lindex
$vupptr($v) $a]
464 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
467 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
470 set c
[lindex
$vdownptr($v) $b]
472 lset vdownptr
($v) $b [lindex
$vleftptr($v) $a]
475 while {$b != 0 && [lindex
$vleftptr($v) $b] != $a} {
476 set b
[lindex
$vleftptr($v) $b]
479 lset vleftptr
($v) $b [lindex
$vleftptr($v) $a]
481 puts
"oops couldn't find $a in chain for [lindex $vupptr($v) $a]"
484 lset vupptr
($v) $a $ka
486 while {[incr i
] < [llength
$parents($v,$ki)]} {
487 set bi
[lindex
$parents($v,$ki) $i]
488 if {[info exists varcid
($v,$bi)]} {
489 set b
$varcid($v,$bi)
490 if {[lindex
$vupptr($v) $b] == $ka} {
492 lset vleftptr
($v) $a [lindex
$vleftptr($v) $b]
493 lset vleftptr
($v) $b $a
499 lset vleftptr
($v) $a [lindex
$vdownptr($v) $ka]
500 lset vdownptr
($v) $ka $a
504 set t2
[clock clicks
-milliseconds]
505 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
508 proc fix_reversal
{p a v
} {
509 global varcid varcstart varctok vupptr vseeds
511 set pa
$varcid($v,$p)
512 if {$p ne
[lindex
$varcstart($v) $pa]} {
514 set pa
$varcid($v,$p)
516 # seeds always need to be renumbered (and taken out of the seeds list)
517 if {[lindex
$vupptr($v) $pa] == 0} {
518 set i
[lsearch
-exact $vseeds($v) $p]
520 set vseeds
($v) [lreplace
$vseeds($v) $i $i]
522 puts
"oops couldn't find [shortids $p] in seeds"
525 } elseif
{[string compare
[lindex
$varctok($v) $a] \
526 [lindex
$varctok($v) $pa]] > 0} {
531 proc insertrow
{id p v
} {
532 global varcid varccommits parents children cmitlisted
533 global commitidx varctok vtokmod
536 set i
[lsearch
-exact $varccommits($v,$a) $p]
538 puts
"oops: insertrow can't find [shortids $p] on arc $a"
541 set children
($v,$id) {}
542 set parents
($v,$id) [list
$p]
543 set varcid
($v,$id) $a
544 lappend children
($v,$p) $id
545 set cmitlisted
($v,$id) 1
547 # note we deliberately don't update varcstart($v) even if $i == 0
548 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
549 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
555 proc removerow
{id v
} {
556 global varcid varccommits parents children commitidx
557 global varctok vtokmod
559 if {[llength
$parents($v,$id)] != 1} {
560 puts
"oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
563 set p
[lindex
$parents($v,$id) 0]
564 set a
$varcid($v,$id)
565 set i
[lsearch
-exact $varccommits($v,$a) $id]
567 puts
"oops: removerow can't find [shortids $id] on arc $a"
571 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
572 unset parents
($v,$id)
573 unset children
($v,$id)
574 unset cmitlisted
($v,$id)
575 incr commitidx
($v) -1
576 set j
[lsearch
-exact $children($v,$p) $id]
578 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
580 set tok
[lindex
$varctok($v) $a]
581 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
587 proc vtokcmp
{v a b
} {
588 global varctok varcid
590 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
591 [lindex
$varctok($v) $varcid($v,$b)]]
594 proc modify_arc
{v a
} {
595 global varctok vtokmod varcmod varcrow vupptr curview
597 set vtokmod
($v) [lindex
$varctok($v) $a]
599 if {$v == $curview} {
600 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
601 set a
[lindex
$vupptr($v) $a]
603 undolayout
[lindex
$varcrow($v) $a]
607 proc update_arcrows
{v
} {
608 global vtokmod varcmod varcrow commitidx currentid selectedline
609 global varcid vseeds vrownum varcorder varcix varccommits
610 global vupptr vdownptr vleftptr varctok
611 global uat displayorder parentlist curview cached_commitrow
613 set t1
[clock clicks
-milliseconds]
614 set narctot
[expr {[llength
$varctok($v)] - 1}]
616 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
617 # go up the tree until we find something that has a row number,
618 # or we get to a seed
619 set a
[lindex
$vupptr($v) $a]
622 set a
[lindex
$vdownptr($v) 0]
625 set varcorder
($v) [list
$a]
627 lset varcrow
($v) $a 0
631 set arcn
[lindex
$varcix($v) $a]
632 # see if a is the last arc; if so, nothing to do
633 if {$arcn == $narctot - 1} {
636 if {[llength
$vrownum($v)] > $arcn + 1} {
637 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
638 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
640 set row
[lindex
$varcrow($v) $a]
642 if {[llength
$displayorder] > $row} {
643 set displayorder
[lrange
$displayorder 0 [expr {$row - 1}]]
644 set parentlist
[lrange
$parentlist 0 [expr {$row - 1}]]
646 if {$v == $curview} {
647 catch
{unset cached_commitrow
}
651 incr row
[llength
$varccommits($v,$a)]
652 # go down if possible
653 set b
[lindex
$vdownptr($v) $a]
655 # if not, go left, or go up until we can go left
657 set b
[lindex
$vleftptr($v) $a]
659 set a
[lindex
$vupptr($v) $a]
665 lappend vrownum
($v) $row
666 lappend varcorder
($v) $a
667 lset varcix
($v) $a $arcn
668 lset varcrow
($v) $a $row
670 if {[info exists currentid
]} {
671 set selectedline
[rowofcommit
$currentid]
673 set vtokmod
($v) [lindex
$varctok($v) $p]
675 set t2
[clock clicks
-milliseconds]
676 incr uat
[expr {$t2-$t1}]
679 # Test whether view $v contains commit $id
680 proc commitinview
{id v
} {
683 return [info exists varcid
($v,$id)]
686 # Return the row number for commit $id in the current view
687 proc rowofcommit
{id
} {
688 global varcid varccommits varcrow curview cached_commitrow
689 global varctok vtokmod
691 if {[info exists cached_commitrow
($id)]} {
692 return $cached_commitrow($id)
695 if {![info exists varcid
($v,$id)]} {
696 puts
"oops rowofcommit no arc for [shortids $id]"
699 set a
$varcid($v,$id)
700 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] > 0} {
703 set i
[lsearch
-exact $varccommits($v,$a) $id]
705 puts
"oops didn't find commit [shortids $id] in arc $a"
708 incr i
[lindex
$varcrow($v) $a]
709 set cached_commitrow
($id) $i
713 proc bsearch
{l elt
} {
714 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
719 while {$hi - $lo > 1} {
720 set mid
[expr {int
(($lo + $hi) / 2)}]
721 set t
[lindex
$l $mid]
724 } elseif
{$elt > $t} {
733 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
734 proc make_disporder
{start end
} {
735 global vrownum curview commitidx displayorder parentlist
736 global varccommits varcorder parents varcmod varcrow
737 global d_valid_start d_valid_end
739 set la
$varcmod($curview)
740 set lrow
[lindex
$varcrow($curview) $la]
741 if {$la == 0 ||
$lrow eq
{} || \
742 $end < $lrow + [llength
$varccommits($curview,$la)]} {
743 update_arcrows
$curview
745 set ai
[bsearch
$vrownum($curview) $start]
746 set start
[lindex
$vrownum($curview) $ai]
747 set narc
[llength
$vrownum($curview)]
748 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
749 set a
[lindex
$varcorder($curview) $ai]
750 set l
[llength
$displayorder]
751 set al
[llength
$varccommits($curview,$a)]
754 set pad
[ntimes
[expr {$r - $l}] {}]
755 set displayorder
[concat
$displayorder $pad]
756 set parentlist
[concat
$parentlist $pad]
758 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
759 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
761 foreach id
$varccommits($curview,$a) {
762 lappend displayorder
$id
763 lappend parentlist
$parents($curview,$id)
765 } elseif
{[lindex
$displayorder $r] eq
{}} {
767 foreach id
$varccommits($curview,$a) {
768 lset displayorder
$i $id
769 lset parentlist
$i $parents($curview,$id)
777 proc commitonrow
{row
} {
780 set id
[lindex
$displayorder $row]
782 make_disporder
$row [expr {$row + 1}]
783 set id
[lindex
$displayorder $row]
788 proc closevarcs
{v
} {
789 global varctok varccommits varcid parents children
790 global cmitlisted commitidx commitinterest vtokmod
792 set missing_parents
0
794 set narcs
[llength
$varctok($v)]
795 for {set a
1} {$a < $narcs} {incr a
} {
796 set id
[lindex
$varccommits($v,$a) end
]
797 foreach p
$parents($v,$id) {
798 if {[info exists varcid
($v,$p)]} continue
799 # add p as a new commit
801 set cmitlisted
($v,$p) 0
802 set parents
($v,$p) {}
803 if {[llength
$children($v,$p)] == 1 &&
804 [llength
$parents($v,$id)] == 1} {
807 set b
[newvarc
$v $p]
810 lappend varccommits
($v,$b) $p
811 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
815 if {[info exists commitinterest
($p)]} {
816 foreach
script $commitinterest($p) {
817 lappend scripts
[string map
[list
"%I" $p] $script]
819 unset commitinterest
($id)
823 if {$missing_parents > 0} {
830 proc getcommitlines
{fd inst view
} {
831 global cmitlisted commitinterest leftover getdbg
832 global commitidx commitdata
833 global parents children curview hlview
834 global vnextroot idpending ordertok
835 global varccommits varcid varctok vtokmod
837 set stuff
[read $fd 500000]
838 # git log doesn't terminate the last commit with a null...
839 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
846 global commfd viewcomplete viewactive viewname progresscoords
849 set i
[lsearch
-exact $viewinstances($view) $inst]
851 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
853 # set it blocking so we wait for the process to terminate
854 fconfigure
$fd -blocking 1
855 if {[catch
{close
$fd} err
]} {
857 if {$view != $curview} {
858 set fv
" for the \"$viewname($view)\" view"
860 if {[string range
$err 0 4] == "usage"} {
861 set err
"Gitk: error reading commits$fv:\
862 bad arguments to git rev-list."
863 if {$viewname($view) eq
"Command line"} {
865 " (Note: arguments to gitk are passed to git rev-list\
866 to allow selection of commits to be displayed.)"
869 set err
"Error reading commits$fv: $err"
873 if {[incr viewactive
($view) -1] <= 0} {
874 set viewcomplete
($view) 1
875 # Check if we have seen any ids listed as parents that haven't
876 # appeared in the list
879 set progresscoords
{0 0}
882 if {$view == $curview} {
883 run chewcommits
$view
891 set i
[string first
"\0" $stuff $start]
893 append leftover
($inst) [string range
$stuff $start end
]
897 set cmit
$leftover($inst)
898 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
899 set leftover
($inst) {}
901 set cmit
[string range
$stuff $start [expr {$i - 1}]]
903 set start
[expr {$i + 1}]
904 set j
[string first
"\n" $cmit]
907 if {$j >= 0 && [string match
"commit *" $cmit]} {
908 set ids
[string range
$cmit 7 [expr {$j - 1}]]
909 if {[string match
{[-<>]*} $ids]} {
910 switch
-- [string index
$ids 0] {
915 set ids
[string range
$ids 1 end
]
919 if {[string length
$id] != 40} {
927 if {[string length
$shortcmit] > 80} {
928 set shortcmit
"[string range $shortcmit 0 80]..."
930 error_popup
"Can't parse git log output: {$shortcmit}"
933 set id
[lindex
$ids 0]
935 if {!$listed && [info exists parents
($vid)]} continue
937 set olds
[lrange
$ids 1 end
]
941 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
942 set cmitlisted
($vid) $listed
943 set parents
($vid) $olds
945 if {![info exists children
($vid)]} {
946 set children
($vid) {}
948 if {[llength
$children($vid)] == 1} {
949 set k
[lindex
$children($vid) 0]
950 if {[llength
$parents($view,$k)] == 1} {
951 set a
$varcid($view,$k)
957 set a
[newvarc
$view $id]
960 lappend varccommits
($view,$a) $id
961 set tok
[lindex
$varctok($view) $a]
964 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
966 if {[llength
[lappend children
($vp) $id]] > 1 &&
967 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
968 set children
($vp) [lsort
-command [list vtokcmp
$view] \
970 catch
{unset ordertok
}
973 if {[info exists varcid
($view,$p)]} {
974 fix_reversal
$p $a $view
978 if {[string compare
$tok $vtokmod($view)] < 0} {
982 incr commitidx
($view)
983 if {[info exists commitinterest
($id)]} {
984 foreach
script $commitinterest($id) {
985 lappend scripts
[string map
[list
"%I" $id] $script]
987 unset commitinterest
($id)
992 run chewcommits
$view
996 if {$view == $curview} {
997 # update progress bar
998 global progressdirn progresscoords proglastnc
999 set inc
[expr {($commitidx($view) - $proglastnc) * 0.0002}]
1000 set proglastnc
$commitidx($view)
1001 set l
[lindex
$progresscoords 0]
1002 set r
[lindex
$progresscoords 1]
1003 if {$progressdirn} {
1004 set r
[expr {$r + $inc}]
1010 set l
[expr {$r - 0.2}]
1013 set l
[expr {$l - $inc}]
1018 set r
[expr {$l + 0.2}]
1020 set progresscoords
[list
$l $r]
1027 proc chewcommits
{view
} {
1028 global curview hlview viewcomplete
1029 global pending_select
1031 if {$view == $curview} {
1033 if {$viewcomplete($view)} {
1035 global numcommits startmsecs
1036 global mainheadid commitinfo nullid
1038 if {[info exists pending_select
]} {
1039 set row
[first_real_row
]
1042 if {$commitidx($curview) > 0} {
1043 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1044 #puts "overall $ms ms for $numcommits commits"
1046 #puts "${uat}ms in update_arcrows"
1048 show_status
"No commits selected"
1053 if {[info exists hlview
] && $view == $hlview} {
1059 proc readcommit
{id
} {
1060 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1061 parsecommit
$id $contents 0
1064 proc parsecommit
{id contents listed
} {
1065 global commitinfo cdate
1074 set hdrend
[string first
"\n\n" $contents]
1076 # should never happen...
1077 set hdrend
[string length
$contents]
1079 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1080 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1081 foreach line
[split $header "\n"] {
1082 set tag
[lindex
$line 0]
1083 if {$tag == "author"} {
1084 set audate
[lindex
$line end-1
]
1085 set auname
[lrange
$line 1 end-2
]
1086 } elseif
{$tag == "committer"} {
1087 set comdate
[lindex
$line end-1
]
1088 set comname
[lrange
$line 1 end-2
]
1092 # take the first non-blank line of the comment as the headline
1093 set headline
[string trimleft
$comment]
1094 set i
[string first
"\n" $headline]
1096 set headline
[string range
$headline 0 $i]
1098 set headline
[string trimright
$headline]
1099 set i
[string first
"\r" $headline]
1101 set headline
[string trimright
[string range
$headline 0 $i]]
1104 # git rev-list indents the comment by 4 spaces;
1105 # if we got this via git cat-file, add the indentation
1107 foreach line
[split $comment "\n"] {
1108 append newcomment
" "
1109 append newcomment
$line
1110 append newcomment
"\n"
1112 set comment
$newcomment
1114 if {$comdate != {}} {
1115 set cdate
($id) $comdate
1117 set commitinfo
($id) [list
$headline $auname $audate \
1118 $comname $comdate $comment]
1121 proc getcommit
{id
} {
1122 global commitdata commitinfo
1124 if {[info exists commitdata
($id)]} {
1125 parsecommit
$id $commitdata($id) 1
1128 if {![info exists commitinfo
($id)]} {
1129 set commitinfo
($id) {"No commit information available"}
1136 global tagids idtags headids idheads tagobjid
1137 global otherrefids idotherrefs mainhead mainheadid
1139 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1142 set refd
[open
[list | git show-ref
-d] r
]
1143 while {[gets
$refd line
] >= 0} {
1144 if {[string index
$line 40] ne
" "} continue
1145 set id
[string range
$line 0 39]
1146 set ref
[string range
$line 41 end
]
1147 if {![string match
"refs/*" $ref]} continue
1148 set name
[string range
$ref 5 end
]
1149 if {[string match
"remotes/*" $name]} {
1150 if {![string match
"*/HEAD" $name]} {
1151 set headids
($name) $id
1152 lappend idheads
($id) $name
1154 } elseif
{[string match
"heads/*" $name]} {
1155 set name
[string range
$name 6 end
]
1156 set headids
($name) $id
1157 lappend idheads
($id) $name
1158 } elseif
{[string match
"tags/*" $name]} {
1159 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1160 # which is what we want since the former is the commit ID
1161 set name
[string range
$name 5 end
]
1162 if {[string match
"*^{}" $name]} {
1163 set name
[string range
$name 0 end-3
]
1165 set tagobjid
($name) $id
1167 set tagids
($name) $id
1168 lappend idtags
($id) $name
1170 set otherrefids
($name) $id
1171 lappend idotherrefs
($id) $name
1178 set thehead
[exec git symbolic-ref HEAD
]
1179 if {[string match
"refs/heads/*" $thehead]} {
1180 set mainhead
[string range
$thehead 11 end
]
1181 if {[info exists headids
($mainhead)]} {
1182 set mainheadid
$headids($mainhead)
1188 # skip over fake commits
1189 proc first_real_row
{} {
1190 global nullid nullid2 numcommits
1192 for {set row
0} {$row < $numcommits} {incr row
} {
1193 set id
[commitonrow
$row]
1194 if {$id ne
$nullid && $id ne
$nullid2} {
1201 # update things for a head moved to a child of its previous location
1202 proc movehead
{id name
} {
1203 global headids idheads
1205 removehead
$headids($name) $name
1206 set headids
($name) $id
1207 lappend idheads
($id) $name
1210 # update things when a head has been removed
1211 proc removehead
{id name
} {
1212 global headids idheads
1214 if {$idheads($id) eq
$name} {
1217 set i
[lsearch
-exact $idheads($id) $name]
1219 set idheads
($id) [lreplace
$idheads($id) $i $i]
1222 unset headids
($name)
1225 proc show_error
{w top msg
} {
1226 message
$w.m
-text $msg -justify center
-aspect 400
1227 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1228 button
$w.ok
-text OK
-command "destroy $top"
1229 pack
$w.ok
-side bottom
-fill x
1230 bind $top <Visibility
> "grab $top; focus $top"
1231 bind $top <Key-Return
> "destroy $top"
1235 proc error_popup msg
{
1239 show_error
$w $w $msg
1242 proc confirm_popup msg
{
1248 message
$w.m
-text $msg -justify center
-aspect 400
1249 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1250 button
$w.ok
-text OK
-command "set confirm_ok 1; destroy $w"
1251 pack
$w.ok
-side left
-fill x
1252 button
$w.cancel
-text Cancel
-command "destroy $w"
1253 pack
$w.cancel
-side right
-fill x
1254 bind $w <Visibility
> "grab $w; focus $w"
1259 proc makewindow
{} {
1260 global canv canv2 canv3 linespc charspc ctext cflist
1262 global findtype findtypemenu findloc findstring fstring geometry
1263 global entries sha1entry sha1string sha1but
1264 global diffcontextstring diffcontext
1265 global maincursor textcursor curtextcursor
1266 global rowctxmenu fakerowmenu mergemax wrapcomment
1267 global highlight_files gdttype
1268 global searchstring sstring
1269 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1270 global headctxmenu progresscanv progressitem progresscoords statusw
1271 global fprogitem fprogcoord lastprogupdate progupdatepending
1272 global rprogitem rprogcoord
1276 .bar add cascade
-label "File" -menu .bar.
file
1277 .bar configure
-font uifont
1279 .bar.
file add
command -label "Update" -command updatecommits
1280 .bar.
file add
command -label "Reload" -command reloadcommits
1281 .bar.
file add
command -label "Reread references" -command rereadrefs
1282 .bar.
file add
command -label "List references" -command showrefs
1283 .bar.
file add
command -label "Quit" -command doquit
1284 .bar.
file configure
-font uifont
1286 .bar add cascade
-label "Edit" -menu .bar.edit
1287 .bar.edit add
command -label "Preferences" -command doprefs
1288 .bar.edit configure
-font uifont
1290 menu .bar.view
-font uifont
1291 .bar add cascade
-label "View" -menu .bar.view
1292 .bar.view add
command -label "New view..." -command {newview
0}
1293 .bar.view add
command -label "Edit view..." -command editview \
1295 .bar.view add
command -label "Delete view" -command delview
-state disabled
1296 .bar.view add separator
1297 .bar.view add radiobutton
-label "All files" -command {showview
0} \
1298 -variable selectedview
-value 0
1301 .bar add cascade
-label "Help" -menu .bar.
help
1302 .bar.
help add
command -label "About gitk" -command about
1303 .bar.
help add
command -label "Key bindings" -command keys
1304 .bar.
help configure
-font uifont
1305 . configure
-menu .bar
1307 # the gui has upper and lower half, parts of a paned window.
1308 panedwindow .ctop
-orient vertical
1310 # possibly use assumed geometry
1311 if {![info exists geometry
(pwsash0
)]} {
1312 set geometry
(topheight
) [expr {15 * $linespc}]
1313 set geometry
(topwidth
) [expr {80 * $charspc}]
1314 set geometry
(botheight
) [expr {15 * $linespc}]
1315 set geometry
(botwidth
) [expr {50 * $charspc}]
1316 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1317 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1320 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1321 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1323 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1325 # create three canvases
1326 set cscroll .tf.histframe.csb
1327 set canv .tf.histframe.pwclist.canv
1329 -selectbackground $selectbgcolor \
1330 -background $bgcolor -bd 0 \
1331 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1332 .tf.histframe.pwclist add
$canv
1333 set canv2 .tf.histframe.pwclist.canv2
1335 -selectbackground $selectbgcolor \
1336 -background $bgcolor -bd 0 -yscrollincr $linespc
1337 .tf.histframe.pwclist add
$canv2
1338 set canv3 .tf.histframe.pwclist.canv3
1340 -selectbackground $selectbgcolor \
1341 -background $bgcolor -bd 0 -yscrollincr $linespc
1342 .tf.histframe.pwclist add
$canv3
1343 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1344 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1346 # a scroll bar to rule them
1347 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1348 pack
$cscroll -side right
-fill y
1349 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1350 lappend bglist
$canv $canv2 $canv3
1351 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1353 # we have two button bars at bottom of top frame. Bar 1
1355 frame .tf.lbar
-height 15
1357 set sha1entry .tf.bar.sha1
1358 set entries
$sha1entry
1359 set sha1but .tf.bar.sha1label
1360 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
1361 -command gotocommit
-width 8 -font uifont
1362 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1363 pack .tf.bar.sha1label
-side left
1364 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1365 trace add variable sha1string
write sha1change
1366 pack
$sha1entry -side left
-pady 2
1368 image create bitmap bm-left
-data {
1369 #define left_width 16
1370 #define left_height 16
1371 static unsigned char left_bits
[] = {
1372 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1373 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1374 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1376 image create bitmap bm-right
-data {
1377 #define right_width 16
1378 #define right_height 16
1379 static unsigned char right_bits
[] = {
1380 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1381 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1382 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1384 button .tf.bar.leftbut
-image bm-left
-command goback \
1385 -state disabled
-width 26
1386 pack .tf.bar.leftbut
-side left
-fill y
1387 button .tf.bar.rightbut
-image bm-right
-command goforw \
1388 -state disabled
-width 26
1389 pack .tf.bar.rightbut
-side left
-fill y
1391 # Status label and progress bar
1392 set statusw .tf.bar.status
1393 label
$statusw -width 15 -relief sunken
-font uifont
1394 pack
$statusw -side left
-padx 5
1395 set h
[expr {[font metrics uifont
-linespace] + 2}]
1396 set progresscanv .tf.bar.progress
1397 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1398 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1399 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1400 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1401 pack
$progresscanv -side right
-expand 1 -fill x
1402 set progresscoords
{0 0}
1405 bind $progresscanv <Configure
> adjustprogress
1406 set lastprogupdate
[clock clicks
-milliseconds]
1407 set progupdatepending
0
1409 # build up the bottom bar of upper window
1410 label .tf.lbar.flabel
-text "Find " -font uifont
1411 button .tf.lbar.fnext
-text "next" -command {dofind
1 1} -font uifont
1412 button .tf.lbar.fprev
-text "prev" -command {dofind
-1 1} -font uifont
1413 label .tf.lbar.flab2
-text " commit " -font uifont
1414 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1416 set gdttype
"containing:"
1417 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1420 "adding/removing string:"]
1421 trace add variable gdttype
write gdttype_change
1422 $gm conf
-font uifont
1423 .tf.lbar.gdttype conf
-font uifont
1424 pack .tf.lbar.gdttype
-side left
-fill y
1427 set fstring .tf.lbar.findstring
1428 lappend entries
$fstring
1429 entry
$fstring -width 30 -font textfont
-textvariable findstring
1430 trace add variable findstring
write find_change
1432 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1433 findtype Exact IgnCase Regexp
]
1434 trace add variable findtype
write findcom_change
1435 .tf.lbar.findtype configure
-font uifont
1436 .tf.lbar.findtype.menu configure
-font uifont
1437 set findloc
"All fields"
1438 tk_optionMenu .tf.lbar.findloc findloc
"All fields" Headline \
1439 Comments Author Committer
1440 trace add variable findloc
write find_change
1441 .tf.lbar.findloc configure
-font uifont
1442 .tf.lbar.findloc.menu configure
-font uifont
1443 pack .tf.lbar.findloc
-side right
1444 pack .tf.lbar.findtype
-side right
1445 pack
$fstring -side left
-expand 1 -fill x
1447 # Finish putting the upper half of the viewer together
1448 pack .tf.lbar
-in .tf
-side bottom
-fill x
1449 pack .tf.bar
-in .tf
-side bottom
-fill x
1450 pack .tf.histframe
-fill both
-side top
-expand 1
1452 .ctop paneconfigure .tf
-height $geometry(topheight
)
1453 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1455 # now build up the bottom
1456 panedwindow .pwbottom
-orient horizontal
1458 # lower left, a text box over search bar, scroll bar to the right
1459 # if we know window height, then that will set the lower text height, otherwise
1460 # we set lower text height which will drive window height
1461 if {[info exists geometry
(main
)]} {
1462 frame .bleft
-width $geometry(botwidth
)
1464 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
1469 button .bleft.top.search
-text "Search" -command dosearch \
1471 pack .bleft.top.search
-side left
-padx 5
1472 set sstring .bleft.top.sstring
1473 entry
$sstring -width 20 -font textfont
-textvariable searchstring
1474 lappend entries
$sstring
1475 trace add variable searchstring
write incrsearch
1476 pack
$sstring -side left
-expand 1 -fill x
1477 radiobutton .bleft.mid.
diff -text "Diff" -font uifont \
1478 -command changediffdisp
-variable diffelide
-value {0 0}
1479 radiobutton .bleft.mid.old
-text "Old version" -font uifont \
1480 -command changediffdisp
-variable diffelide
-value {0 1}
1481 radiobutton .bleft.mid.new
-text "New version" -font uifont \
1482 -command changediffdisp
-variable diffelide
-value {1 0}
1483 label .bleft.mid.labeldiffcontext
-text " Lines of context: " \
1485 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
1486 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
1487 -from 1 -increment 1 -to 10000000 \
1488 -validate all
-validatecommand "diffcontextvalidate %P" \
1489 -textvariable diffcontextstring
1490 .bleft.mid.diffcontext
set $diffcontext
1491 trace add variable diffcontextstring
write diffcontextchange
1492 lappend entries .bleft.mid.diffcontext
1493 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
1494 set ctext .bleft.ctext
1495 text
$ctext -background $bgcolor -foreground $fgcolor \
1496 -state disabled
-font textfont \
1497 -yscrollcommand scrolltext
-wrap none
1499 $ctext conf
-tabstyle wordprocessor
1501 scrollbar .bleft.sb
-command "$ctext yview"
1502 pack .bleft.top
-side top
-fill x
1503 pack .bleft.mid
-side top
-fill x
1504 pack .bleft.sb
-side right
-fill y
1505 pack
$ctext -side left
-fill both
-expand 1
1506 lappend bglist
$ctext
1507 lappend fglist
$ctext
1509 $ctext tag conf comment
-wrap $wrapcomment
1510 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
1511 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
1512 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
1513 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
1514 $ctext tag conf m0
-fore red
1515 $ctext tag conf m1
-fore blue
1516 $ctext tag conf m2
-fore green
1517 $ctext tag conf m3
-fore purple
1518 $ctext tag conf
m4 -fore brown
1519 $ctext tag conf m5
-fore "#009090"
1520 $ctext tag conf m6
-fore magenta
1521 $ctext tag conf m7
-fore "#808000"
1522 $ctext tag conf m8
-fore "#009000"
1523 $ctext tag conf m9
-fore "#ff0080"
1524 $ctext tag conf m10
-fore cyan
1525 $ctext tag conf m11
-fore "#b07070"
1526 $ctext tag conf m12
-fore "#70b0f0"
1527 $ctext tag conf m13
-fore "#70f0b0"
1528 $ctext tag conf m14
-fore "#f0b070"
1529 $ctext tag conf m15
-fore "#ff70b0"
1530 $ctext tag conf mmax
-fore darkgrey
1532 $ctext tag conf mresult
-font textfontbold
1533 $ctext tag conf msep
-font textfontbold
1534 $ctext tag conf found
-back yellow
1536 .pwbottom add .bleft
1537 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
1542 radiobutton .bright.mode.
patch -text "Patch" \
1543 -command reselectline
-variable cmitmode
-value "patch"
1544 .bright.mode.
patch configure
-font uifont
1545 radiobutton .bright.mode.tree
-text "Tree" \
1546 -command reselectline
-variable cmitmode
-value "tree"
1547 .bright.mode.tree configure
-font uifont
1548 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
1549 pack .bright.mode
-side top
-fill x
1550 set cflist .bright.cfiles
1551 set indent
[font measure mainfont
"nn"]
1553 -selectbackground $selectbgcolor \
1554 -background $bgcolor -foreground $fgcolor \
1556 -tabs [list
$indent [expr {2 * $indent}]] \
1557 -yscrollcommand ".bright.sb set" \
1558 -cursor [. cget
-cursor] \
1559 -spacing1 1 -spacing3 1
1560 lappend bglist
$cflist
1561 lappend fglist
$cflist
1562 scrollbar .bright.sb
-command "$cflist yview"
1563 pack .bright.sb
-side right
-fill y
1564 pack
$cflist -side left
-fill both
-expand 1
1565 $cflist tag configure highlight \
1566 -background [$cflist cget
-selectbackground]
1567 $cflist tag configure bold
-font mainfontbold
1569 .pwbottom add .bright
1572 # restore window position if known
1573 if {[info exists geometry
(main
)]} {
1574 wm geometry .
"$geometry(main)"
1577 if {[tk windowingsystem
] eq
{aqua
}} {
1583 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
1584 pack .ctop
-fill both
-expand 1
1585 bindall
<1> {selcanvline
%W
%x
%y
}
1586 #bindall <B1-Motion> {selcanvline %W %x %y}
1587 if {[tk windowingsystem
] == "win32"} {
1588 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
1589 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
1591 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
1592 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
1593 if {[tk windowingsystem
] eq
"aqua"} {
1594 bindall
<MouseWheel
> {
1595 set delta
[expr {- (%D
)}]
1596 allcanvs yview scroll
$delta units
1600 bindall
<2> "canvscan mark %W %x %y"
1601 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
1602 bindkey
<Home
> selfirstline
1603 bindkey
<End
> sellastline
1604 bind .
<Key-Up
> "selnextline -1"
1605 bind .
<Key-Down
> "selnextline 1"
1606 bind .
<Shift-Key-Up
> "dofind -1 0"
1607 bind .
<Shift-Key-Down
> "dofind 1 0"
1608 bindkey
<Key-Right
> "goforw"
1609 bindkey
<Key-Left
> "goback"
1610 bind .
<Key-Prior
> "selnextpage -1"
1611 bind .
<Key-Next
> "selnextpage 1"
1612 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
1613 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
1614 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
1615 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
1616 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1617 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1618 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
1619 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
1620 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
1621 bindkey p
"selnextline -1"
1622 bindkey n
"selnextline 1"
1625 bindkey i
"selnextline -1"
1626 bindkey k
"selnextline 1"
1629 bindkey b
"$ctext yview scroll -1 pages"
1630 bindkey d
"$ctext yview scroll 18 units"
1631 bindkey u
"$ctext yview scroll -18 units"
1632 bindkey
/ {dofind
1 1}
1633 bindkey
<Key-Return
> {dofind
1 1}
1634 bindkey ?
{dofind
-1 1}
1636 bindkey
<F5
> updatecommits
1637 bind .
<$M1B-q> doquit
1638 bind .
<$M1B-f> {dofind
1 1}
1639 bind .
<$M1B-g> {dofind
1 0}
1640 bind .
<$M1B-r> dosearchback
1641 bind .
<$M1B-s> dosearch
1642 bind .
<$M1B-equal> {incrfont
1}
1643 bind .
<$M1B-KP_Add> {incrfont
1}
1644 bind .
<$M1B-minus> {incrfont
-1}
1645 bind .
<$M1B-KP_Subtract> {incrfont
-1}
1646 wm protocol . WM_DELETE_WINDOW doquit
1647 bind .
<Button-1
> "click %W"
1648 bind $fstring <Key-Return
> {dofind
1 1}
1649 bind $sha1entry <Key-Return
> gotocommit
1650 bind $sha1entry <<PasteSelection>> clearsha1
1651 bind $cflist <1> {sel_flist %W %x %y; break}
1652 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1653 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1654 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1656 set maincursor [. cget -cursor]
1657 set textcursor [$ctext cget -cursor]
1658 set curtextcursor $textcursor
1660 set rowctxmenu .rowctxmenu
1661 menu $rowctxmenu -tearoff 0
1662 $rowctxmenu add command -label "Diff this -> selected" \
1663 -command {diffvssel 0}
1664 $rowctxmenu add command -label "Diff selected -> this" \
1665 -command {diffvssel 1}
1666 $rowctxmenu add command -label "Make patch" -command mkpatch
1667 $rowctxmenu add command -label "Create tag" -command mktag
1668 $rowctxmenu add command -label "Write commit to file" -command writecommit
1669 $rowctxmenu add command -label "Create new branch" -command mkbranch
1670 $rowctxmenu add command -label "Cherry-pick this commit" \
1672 $rowctxmenu add command -label "Reset HEAD branch to here" \
1675 set fakerowmenu .fakerowmenu
1676 menu $fakerowmenu -tearoff 0
1677 $fakerowmenu add command -label "Diff this -> selected" \
1678 -command {diffvssel 0}
1679 $fakerowmenu add command -label "Diff selected -> this" \
1680 -command {diffvssel 1}
1681 $fakerowmenu add command -label "Make patch" -command mkpatch
1682 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1683 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1684 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
1686 set headctxmenu .headctxmenu
1687 menu $headctxmenu -tearoff 0
1688 $headctxmenu add command -label "Check out this branch" \
1690 $headctxmenu add command -label "Remove this branch" \
1694 set flist_menu .flistctxmenu
1695 menu $flist_menu -tearoff 0
1696 $flist_menu add command -label "Highlight this too" \
1697 -command {flist_hl 0}
1698 $flist_menu add command -label "Highlight this only" \
1699 -command {flist_hl 1}
1702 # Windows sends all mouse wheel events to the current focused window, not
1703 # the one where the mouse hovers, so bind those events here and redirect
1704 # to the correct window
1705 proc windows_mousewheel_redirector {W X Y D} {
1706 global canv canv2 canv3
1707 set w [winfo containing -displayof $W $X $Y]
1709 set u [expr {$D < 0 ? 5 : -5}]
1710 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1711 allcanvs yview scroll $u units
1714 $w yview scroll $u units
1720 # mouse-2 makes all windows scan vertically, but only the one
1721 # the cursor is in scans horizontally
1722 proc canvscan {op w x y} {
1723 global canv canv2 canv3
1724 foreach c [list $canv $canv2 $canv3] {
1733 proc scrollcanv {cscroll f0 f1} {
1734 $cscroll set $f0 $f1
1739 # when we make a key binding for the toplevel, make sure
1740 # it doesn't get triggered when that key is pressed in the
1741 # find string entry widget.
1742 proc bindkey {ev script} {
1745 set escript [bind Entry $ev]
1746 if {$escript == {}} {
1747 set escript [bind Entry <Key>]
1749 foreach e $entries {
1750 bind $e $ev "$escript; break"
1754 # set the focus back to the toplevel for any click outside
1757 global ctext entries
1758 foreach e [concat $entries $ctext] {
1759 if {$w == $e} return
1764 # Adjust the progress bar for a change in requested extent or canvas size
1765 proc adjustprogress {} {
1766 global progresscanv progressitem progresscoords
1767 global fprogitem fprogcoord lastprogupdate progupdatepending
1768 global rprogitem rprogcoord
1770 set w [expr {[winfo width $progresscanv] - 4}]
1771 set x0 [expr {$w * [lindex $progresscoords 0]}]
1772 set x1 [expr {$w * [lindex $progresscoords 1]}]
1773 set h [winfo height $progresscanv]
1774 $progresscanv coords $progressitem $x0 0 $x1 $h
1775 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1776 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1777 set now [clock clicks -milliseconds]
1778 if {$now >= $lastprogupdate + 100} {
1779 set progupdatepending 0
1781 } elseif {!$progupdatepending} {
1782 set progupdatepending 1
1783 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1787 proc doprogupdate {} {
1788 global lastprogupdate progupdatepending
1790 if {$progupdatepending} {
1791 set progupdatepending 0
1792 set lastprogupdate [clock clicks -milliseconds]
1797 proc savestuff {w} {
1798 global canv canv2 canv3 mainfont textfont uifont tabstop
1799 global stuffsaved findmergefiles maxgraphpct
1800 global maxwidth showneartags showlocalchanges
1801 global viewname viewfiles viewargs viewperm nextviewnum
1802 global cmitmode wrapcomment datetimeformat limitdiffs
1803 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1805 if {$stuffsaved} return
1806 if {![winfo viewable .]} return
1808 set f [open "~/.gitk-new" w]
1809 puts $f [list set mainfont $mainfont]
1810 puts $f [list set textfont $textfont]
1811 puts $f [list set uifont $uifont]
1812 puts $f [list set tabstop $tabstop]
1813 puts $f [list set findmergefiles $findmergefiles]
1814 puts $f [list set maxgraphpct $maxgraphpct]
1815 puts $f [list set maxwidth $maxwidth]
1816 puts $f [list set cmitmode $cmitmode]
1817 puts $f [list set wrapcomment $wrapcomment]
1818 puts $f [list set showneartags $showneartags]
1819 puts $f [list set showlocalchanges $showlocalchanges]
1820 puts $f [list set datetimeformat $datetimeformat]
1821 puts $f [list set limitdiffs $limitdiffs]
1822 puts $f [list set bgcolor $bgcolor]
1823 puts $f [list set fgcolor $fgcolor]
1824 puts $f [list set colors $colors]
1825 puts $f [list set diffcolors $diffcolors]
1826 puts $f [list set diffcontext $diffcontext]
1827 puts $f [list set selectbgcolor $selectbgcolor]
1829 puts $f "set geometry(main) [wm geometry .]"
1830 puts $f "set geometry(topwidth) [winfo width .tf]"
1831 puts $f "set geometry(topheight) [winfo height .tf]"
1832 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1833 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1834 puts $f "set geometry(botwidth) [winfo width .bleft]"
1835 puts $f "set geometry(botheight) [winfo height .bleft]"
1837 puts -nonewline $f "set permviews {"
1838 for {set v 0} {$v < $nextviewnum} {incr v} {
1839 if {$viewperm($v)} {
1840 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1845 file rename -force "~/.gitk-new" "~/.gitk"
1850 proc resizeclistpanes {win w} {
1852 if {[info exists oldwidth($win)]} {
1853 set s0 [$win sash coord 0]
1854 set s1 [$win sash coord 1]
1856 set sash0 [expr {int($w/2 - 2)}]
1857 set sash1 [expr {int($w*5/6 - 2)}]
1859 set factor [expr {1.0 * $w / $oldwidth($win)}]
1860 set sash0 [expr {int($factor * [lindex $s0 0])}]
1861 set sash1 [expr {int($factor * [lindex $s1 0])}]
1865 if {$sash1 < $sash0 + 20} {
1866 set sash1 [expr {$sash0 + 20}]
1868 if {$sash1 > $w - 10} {
1869 set sash1 [expr {$w - 10}]
1870 if {$sash0 > $sash1 - 20} {
1871 set sash0 [expr {$sash1 - 20}]
1875 $win sash place 0 $sash0 [lindex $s0 1]
1876 $win sash place 1 $sash1 [lindex $s1 1]
1878 set oldwidth($win) $w
1881 proc resizecdetpanes {win w} {
1883 if {[info exists oldwidth($win)]} {
1884 set s0 [$win sash coord 0]
1886 set sash0 [expr {int($w*3/4 - 2)}]
1888 set factor [expr {1.0 * $w / $oldwidth($win)}]
1889 set sash0 [expr {int($factor * [lindex $s0 0])}]
1893 if {$sash0 > $w - 15} {
1894 set sash0 [expr {$w - 15}]
1897 $win sash place 0 $sash0 [lindex $s0 1]
1899 set oldwidth($win) $w
1902 proc allcanvs args {
1903 global canv canv2 canv3
1909 proc bindall {event action} {
1910 global canv canv2 canv3
1911 bind $canv $event $action
1912 bind $canv2 $event $action
1913 bind $canv3 $event $action
1919 if {[winfo exists $w]} {
1924 wm title $w "About gitk"
1925 message $w.m -text {
1926 Gitk - a commit viewer for git
1928 Copyright © 2005-2007 Paul Mackerras
1930 Use and redistribute under the terms of the GNU General Public License} \
1931 -justify center -aspect 400 -border 2 -bg white -relief groove
1932 pack $w.m -side top -fill x -padx 2 -pady 2
1933 $w.m configure -font uifont
1934 button $w.ok -text Close -command "destroy $w" -default active
1935 pack $w.ok -side bottom
1936 $w.ok configure -font uifont
1937 bind $w <Visibility> "focus $w.ok"
1938 bind $w <Key-Escape> "destroy $w"
1939 bind $w <Key-Return> "destroy $w"
1945 if {[winfo exists $w]} {
1949 if {[tk windowingsystem] eq {aqua}} {
1955 wm title $w "Gitk key bindings"
1956 message $w.m -text "
1960 <Home> Move to first commit
1961 <End> Move to last commit
1962 <Up>, p, i Move up one commit
1963 <Down>, n, k Move down one commit
1964 <Left>, z, j Go back in history list
1965 <Right>, x, l Go forward in history list
1966 <PageUp> Move up one page in commit list
1967 <PageDown> Move down one page in commit list
1968 <$M1T-Home> Scroll to top of commit list
1969 <$M1T-End> Scroll to bottom of commit list
1970 <$M1T-Up> Scroll commit list up one line
1971 <$M1T-Down> Scroll commit list down one line
1972 <$M1T-PageUp> Scroll commit list up one page
1973 <$M1T-PageDown> Scroll commit list down one page
1974 <Shift-Up> Find backwards (upwards, later commits)
1975 <Shift-Down> Find forwards (downwards, earlier commits)
1976 <Delete>, b Scroll diff view up one page
1977 <Backspace> Scroll diff view up one page
1978 <Space> Scroll diff view down one page
1979 u Scroll diff view up 18 lines
1980 d Scroll diff view down 18 lines
1982 <$M1T-G> Move to next find hit
1983 <Return> Move to next find hit
1984 / Move to next find hit, or redo find
1985 ? Move to previous find hit
1986 f Scroll diff view to next file
1987 <$M1T-S> Search for next hit in diff view
1988 <$M1T-R> Search for previous hit in diff view
1989 <$M1T-KP+> Increase font size
1990 <$M1T-plus> Increase font size
1991 <$M1T-KP-> Decrease font size
1992 <$M1T-minus> Decrease font size
1995 -justify left -bg white -border 2 -relief groove
1996 pack $w.m -side top -fill both -padx 2 -pady 2
1997 $w.m configure -font uifont
1998 button $w.ok -text Close -command "destroy $w" -default active
1999 pack $w.ok -side bottom
2000 $w.ok configure -font uifont
2001 bind $w <Visibility> "focus $w.ok"
2002 bind $w <Key-Escape> "destroy $w"
2003 bind $w <Key-Return> "destroy $w"
2006 # Procedures for manipulating the file list window at the
2007 # bottom right of the overall window.
2009 proc treeview {w l openlevs} {
2010 global treecontents treediropen treeheight treeparent treeindex
2020 set treecontents() {}
2021 $w conf -state normal
2023 while {[string range $f 0 $prefixend] ne $prefix} {
2024 if {$lev <= $openlevs} {
2025 $w mark set e:$treeindex($prefix) "end -1c"
2026 $w mark gravity e:$treeindex($prefix) left
2028 set treeheight($prefix) $ht
2029 incr ht [lindex $htstack end]
2030 set htstack [lreplace $htstack end end]
2031 set prefixend [lindex $prefendstack end]
2032 set prefendstack [lreplace $prefendstack end end]
2033 set prefix [string range $prefix 0 $prefixend]
2036 set tail [string range $f [expr {$prefixend+1}] end]
2037 while {[set slash [string first "/" $tail]] >= 0} {
2040 lappend prefendstack $prefixend
2041 incr prefixend [expr {$slash + 1}]
2042 set d [string range $tail 0 $slash]
2043 lappend treecontents($prefix) $d
2044 set oldprefix $prefix
2046 set treecontents($prefix) {}
2047 set treeindex($prefix) [incr ix]
2048 set treeparent($prefix) $oldprefix
2049 set tail [string range $tail [expr {$slash+1}] end]
2050 if {$lev <= $openlevs} {
2052 set treediropen($prefix) [expr {$lev < $openlevs}]
2053 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2054 $w mark set d:$ix "end -1c"
2055 $w mark gravity d:$ix left
2057 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2059 $w image create end -align center -image $bm -padx 1 \
2061 $w insert end $d [highlight_tag $prefix]
2062 $w mark set s:$ix "end -1c"
2063 $w mark gravity s:$ix left
2068 if {$lev <= $openlevs} {
2071 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2073 $w insert end $tail [highlight_tag $f]
2075 lappend treecontents($prefix) $tail
2078 while {$htstack ne {}} {
2079 set treeheight($prefix) $ht
2080 incr ht [lindex $htstack end]
2081 set htstack [lreplace $htstack end end]
2082 set prefixend [lindex $prefendstack end]
2083 set prefendstack [lreplace $prefendstack end end]
2084 set prefix [string range $prefix 0 $prefixend]
2086 $w conf -state disabled
2089 proc linetoelt {l} {
2090 global treeheight treecontents
2095 foreach e $treecontents($prefix) {
2100 if {[string index $e end] eq "/"} {
2101 set n $treeheight($prefix$e)
2113 proc highlight_tree {y prefix} {
2114 global treeheight treecontents cflist
2116 foreach e $treecontents($prefix) {
2118 if {[highlight_tag $path] ne {}} {
2119 $cflist tag add bold $y.0 "$y.0 lineend"
2122 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2123 set y [highlight_tree $y $path]
2129 proc treeclosedir {w dir} {
2130 global treediropen treeheight treeparent treeindex
2132 set ix $treeindex($dir)
2133 $w conf -state normal
2134 $w delete s:$ix e:$ix
2135 set treediropen($dir) 0
2136 $w image configure a:$ix -image tri-rt
2137 $w conf -state disabled
2138 set n [expr {1 - $treeheight($dir)}]
2139 while {$dir ne {}} {
2140 incr treeheight($dir) $n
2141 set dir $treeparent($dir)
2145 proc treeopendir {w dir} {
2146 global treediropen treeheight treeparent treecontents treeindex
2148 set ix $treeindex($dir)
2149 $w conf -state normal
2150 $w image configure a:$ix -image tri-dn
2151 $w mark set e:$ix s:$ix
2152 $w mark gravity e:$ix right
2155 set n [llength $treecontents($dir)]
2156 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2159 incr treeheight($x) $n
2161 foreach e $treecontents($dir) {
2163 if {[string index $e end] eq "/"} {
2164 set iy $treeindex($de)
2165 $w mark set d:$iy e:$ix
2166 $w mark gravity d:$iy left
2167 $w insert e:$ix $str
2168 set treediropen($de) 0
2169 $w image create e:$ix -align center -image tri-rt -padx 1 \
2171 $w insert e:$ix $e [highlight_tag $de]
2172 $w mark set s:$iy e:$ix
2173 $w mark gravity s:$iy left
2174 set treeheight($de) 1
2176 $w insert e:$ix $str
2177 $w insert e:$ix $e [highlight_tag $de]
2180 $w mark gravity e:$ix left
2181 $w conf -state disabled
2182 set treediropen($dir) 1
2183 set top [lindex [split [$w index @0,0] .] 0]
2184 set ht [$w cget -height]
2185 set l [lindex [split [$w index s:$ix] .] 0]
2188 } elseif {$l + $n + 1 > $top + $ht} {
2189 set top [expr {$l + $n + 2 - $ht}]
2197 proc treeclick {w x y} {
2198 global treediropen cmitmode ctext cflist cflist_top
2200 if {$cmitmode ne "tree"} return
2201 if {![info exists cflist_top]} return
2202 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2203 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2204 $cflist tag add highlight $l.0 "$l.0 lineend"
2210 set e [linetoelt $l]
2211 if {[string index $e end] ne "/"} {
2213 } elseif {$treediropen($e)} {
2220 proc setfilelist {id} {
2221 global treefilelist cflist
2223 treeview $cflist $treefilelist($id) 0
2226 image create bitmap tri-rt -background black -foreground blue -data {
2227 #define tri-rt_width 13
2228 #define tri-rt_height 13
2229 static unsigned char tri-rt_bits[] = {
2230 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2231 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2234 #define tri-rt-mask_width 13
2235 #define tri-rt-mask_height 13
2236 static unsigned char tri-rt-mask_bits[] = {
2237 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2238 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2241 image create bitmap tri-dn -background black -foreground blue -data {
2242 #define tri-dn_width 13
2243 #define tri-dn_height 13
2244 static unsigned char tri-dn_bits[] = {
2245 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2246 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2249 #define tri-dn-mask_width 13
2250 #define tri-dn-mask_height 13
2251 static unsigned char tri-dn-mask_bits[] = {
2252 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2253 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2257 image create bitmap reficon-T -background black -foreground yellow -data {
2258 #define tagicon_width 13
2259 #define tagicon_height 9
2260 static unsigned char tagicon_bits[] = {
2261 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2262 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2264 #define tagicon-mask_width 13
2265 #define tagicon-mask_height 9
2266 static unsigned char tagicon-mask_bits[] = {
2267 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2268 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2271 #define headicon_width 13
2272 #define headicon_height 9
2273 static unsigned char headicon_bits[] = {
2274 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2275 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2278 #define headicon-mask_width 13
2279 #define headicon-mask_height 9
2280 static unsigned char headicon-mask_bits[] = {
2281 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2282 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2284 image create bitmap reficon-H -background black -foreground green \
2285 -data $rectdata -maskdata $rectmask
2286 image create bitmap reficon-o -background black -foreground "#ddddff" \
2287 -data $rectdata -maskdata $rectmask
2289 proc init_flist {first} {
2290 global cflist cflist_top difffilestart
2292 $cflist conf -state normal
2293 $cflist delete 0.0 end
2295 $cflist insert end $first
2297 $cflist tag add highlight 1.0 "1.0 lineend"
2299 catch {unset cflist_top}
2301 $cflist conf -state disabled
2302 set difffilestart {}
2305 proc highlight_tag {f} {
2306 global highlight_paths
2308 foreach p $highlight_paths {
2309 if {[string match $p $f]} {
2316 proc highlight_filelist {} {
2317 global cmitmode cflist
2319 $cflist conf -state normal
2320 if {$cmitmode ne "tree"} {
2321 set end [lindex [split [$cflist index end] .] 0]
2322 for {set l 2} {$l < $end} {incr l} {
2323 set line [$cflist get $l.0 "$l.0 lineend"]
2324 if {[highlight_tag $line] ne {}} {
2325 $cflist tag add bold $l.0 "$l.0 lineend"
2331 $cflist conf -state disabled
2334 proc unhighlight_filelist {} {
2337 $cflist conf -state normal
2338 $cflist tag remove bold 1.0 end
2339 $cflist conf -state disabled
2342 proc add_flist {fl} {
2345 $cflist conf -state normal
2347 $cflist insert end "\n"
2348 $cflist insert end $f [highlight_tag $f]
2350 $cflist conf -state disabled
2353 proc sel_flist {w x y} {
2354 global ctext difffilestart cflist cflist_top cmitmode
2356 if {$cmitmode eq "tree"} return
2357 if {![info exists cflist_top]} return
2358 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2359 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2360 $cflist tag add highlight $l.0 "$l.0 lineend"
2365 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2369 proc pop_flist_menu {w X Y x y} {
2370 global ctext cflist cmitmode flist_menu flist_menu_file
2371 global treediffs diffids
2374 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2376 if {$cmitmode eq "tree"} {
2377 set e [linetoelt $l]
2378 if {[string index $e end] eq "/"} return
2380 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2382 set flist_menu_file $e
2383 tk_popup $flist_menu $X $Y
2386 proc flist_hl {only} {
2387 global flist_menu_file findstring gdttype
2389 set x [shellquote $flist_menu_file]
2390 if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
2393 append findstring " " $x
2395 set gdttype "touching paths:"
2398 # Functions for adding and removing shell-type quoting
2400 proc shellquote {str} {
2401 if {![string match "*\['\"\\ \t]*" $str]} {
2404 if {![string match "*\['\"\\]*" $str]} {
2407 if {![string match "*'*" $str]} {
2410 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2413 proc shellarglist {l} {
2419 append str [shellquote $a]
2424 proc shelldequote {str} {
2429 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2430 append ret [string range $str $used end]
2431 set used [string length $str]
2434 set first [lindex $first 0]
2435 set ch [string index $str $first]
2436 if {$first > $used} {
2437 append ret [string range $str $used [expr {$first - 1}]]
2440 if {$ch eq " " || $ch eq "\t"} break
2443 set first [string first "'" $str $used]
2445 error "unmatched single-quote"
2447 append ret [string range $str $used [expr {$first - 1}]]
2452 if {$used >= [string length $str]} {
2453 error "trailing backslash"
2455 append ret [string index $str $used]
2460 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2461 error "unmatched double-quote"
2463 set first [lindex $first 0]
2464 set ch [string index $str $first]
2465 if {$first > $used} {
2466 append ret [string range $str $used [expr {$first - 1}]]
2469 if {$ch eq "\""} break
2471 append ret [string index $str $used]
2475 return [list $used $ret]
2478 proc shellsplit {str} {
2481 set str [string trimleft $str]
2482 if {$str eq {}} break
2483 set dq [shelldequote $str]
2484 set n [lindex $dq 0]
2485 set word [lindex $dq 1]
2486 set str [string range $str $n end]
2492 # Code to implement multiple views
2494 proc newview {ishighlight} {
2495 global nextviewnum newviewname newviewperm uifont newishighlight
2496 global newviewargs revtreeargs
2498 set newishighlight $ishighlight
2500 if {[winfo exists $top]} {
2504 set newviewname($nextviewnum) "View $nextviewnum"
2505 set newviewperm($nextviewnum) 0
2506 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2507 vieweditor $top $nextviewnum "Gitk view definition"
2512 global viewname viewperm newviewname newviewperm
2513 global viewargs newviewargs
2515 set top .gitkvedit-$curview
2516 if {[winfo exists $top]} {
2520 set newviewname($curview) $viewname($curview)
2521 set newviewperm($curview) $viewperm($curview)
2522 set newviewargs($curview) [shellarglist $viewargs($curview)]
2523 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2526 proc vieweditor {top n title} {
2527 global newviewname newviewperm viewfiles
2531 wm title $top $title
2532 label $top.nl -text "Name" -font uifont
2533 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
2534 grid $top.nl $top.name -sticky w -pady 5
2535 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
2537 grid $top.perm - -pady 5 -sticky w
2538 message $top.al -aspect 1000 -font uifont \
2539 -text "Commits to include (arguments to git rev-list):"
2540 grid $top.al - -sticky w -pady 5
2541 entry $top.args -width 50 -textvariable newviewargs($n) \
2542 -background white -font uifont
2543 grid $top.args - -sticky ew -padx 5
2544 message $top.l -aspect 1000 -font uifont \
2545 -text "Enter files and directories to include, one per line:"
2546 grid $top.l - -sticky w
2547 text $top.t -width 40 -height 10 -background white -font uifont
2548 if {[info exists viewfiles($n)]} {
2549 foreach f $viewfiles($n) {
2550 $top.t insert end $f
2551 $top.t insert end "\n"
2553 $top.t delete {end - 1c} end
2554 $top.t mark set insert 0.0
2556 grid $top.t - -sticky ew -padx 5
2558 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
2560 button $top.buts.can -text "Cancel" -command [list destroy $top] \
2562 grid $top.buts.ok $top.buts.can
2563 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2564 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2565 grid $top.buts - -pady 10 -sticky ew
2569 proc doviewmenu {m first cmd op argv} {
2570 set nmenu [$m index end]
2571 for {set i $first} {$i <= $nmenu} {incr i} {
2572 if {[$m entrycget $i -command] eq $cmd} {
2573 eval $m $op $i $argv
2579 proc allviewmenus {n op args} {
2582 doviewmenu .bar.view 5 [list showview $n] $op $args
2583 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2586 proc newviewok {top n} {
2587 global nextviewnum newviewperm newviewname newishighlight
2588 global viewname viewfiles viewperm selectedview curview
2589 global viewargs newviewargs viewhlmenu
2592 set newargs [shellsplit $newviewargs($n)]
2594 error_popup "Error in commit selection arguments: $err"
2600 foreach f [split [$top.t get 0.0 end] "\n"] {
2601 set ft [string trim $f]
2606 if {![info exists viewfiles($n)]} {
2607 # creating a new view
2609 set viewname($n) $newviewname($n)
2610 set viewperm($n) $newviewperm($n)
2611 set viewfiles($n) $files
2612 set viewargs($n) $newargs
2614 if {!$newishighlight} {
2617 run addvhighlight $n
2620 # editing an existing view
2621 set viewperm($n) $newviewperm($n)
2622 if {$newviewname($n) ne $viewname($n)} {
2623 set viewname($n) $newviewname($n)
2624 doviewmenu .bar.view 5 [list showview $n] \
2625 entryconf [list -label $viewname($n)]
2626 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2627 # entryconf [list -label $viewname($n) -value $viewname($n)]
2629 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2630 set viewfiles($n) $files
2631 set viewargs($n) $newargs
2632 if {$curview == $n} {
2637 catch {destroy $top}
2641 global curview viewperm hlview selectedhlview
2643 if {$curview == 0} return
2644 if {[info exists hlview] && $hlview == $curview} {
2645 set selectedhlview None
2648 allviewmenus $curview delete
2649 set viewperm($curview) 0
2653 proc addviewmenu {n} {
2654 global viewname viewhlmenu
2656 .bar.view add radiobutton -label $viewname($n) \
2657 -command [list showview $n] -variable selectedview -value $n
2658 #$viewhlmenu add radiobutton -label $viewname($n) \
2659 # -command [list addvhighlight $n] -variable selectedhlview
2663 global curview viewfiles cached_commitrow ordertok
2664 global displayorder parentlist rowidlist rowisopt rowfinal
2665 global colormap rowtextx nextcolor canvxmax
2666 global numcommits viewcomplete
2667 global selectedline currentid canv canvy0
2669 global pending_select
2671 global selectedview selectfirst
2672 global hlview selectedhlview commitinterest
2674 if {$n == $curview} return
2676 set ymax [lindex [$canv cget -scrollregion] 3]
2677 set span [$canv yview]
2678 set ytop [expr {[lindex $span 0] * $ymax}]
2679 set ybot [expr {[lindex $span 1] * $ymax}]
2680 set yscreen [expr {($ybot - $ytop) / 2}]
2681 if {[info exists selectedline]} {
2682 set selid $currentid
2683 set y [yc $selectedline]
2684 if {$ytop < $y && $y < $ybot} {
2685 set yscreen [expr {$y - $ytop}]
2687 } elseif {[info exists pending_select]} {
2688 set selid $pending_select
2689 unset pending_select
2693 catch {unset treediffs}
2695 if {[info exists hlview] && $hlview == $n} {
2697 set selectedhlview None
2699 catch {unset commitinterest}
2700 catch {unset cached_commitrow}
2701 catch {unset ordertok}
2705 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2706 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2709 if {![info exists viewcomplete($n)]} {
2711 set pending_select $selid
2722 set numcommits $commitidx($n)
2724 catch {unset colormap}
2725 catch {unset rowtextx}
2727 set canvxmax [$canv cget -width]
2734 if {$selid ne {} && [commitinview $selid $n]} {
2735 set row [rowofcommit $selid]
2736 # try to get the selected row in the same position on the screen
2737 set ymax [lindex [$canv cget -scrollregion] 3]
2738 set ytop [expr {[yc $row] - $yscreen}]
2742 set yf [expr {$ytop * 1.0 / $ymax}]
2744 allcanvs yview moveto $yf
2748 } elseif {$selid ne {}} {
2749 set pending_select $selid
2751 set row [first_real_row]
2752 if {$row < $numcommits} {
2758 if {!$viewcomplete($n)} {
2759 if {$numcommits == 0} {
2760 show_status "Reading commits..."
2764 } elseif {$numcommits == 0} {
2765 show_status "No commits selected"
2769 # Stuff relating to the highlighting facility
2771 proc ishighlighted {row} {
2772 global vhighlights fhighlights nhighlights rhighlights
2774 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2775 return $nhighlights($row)
2777 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2778 return $vhighlights($row)
2780 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2781 return $fhighlights($row)
2783 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2784 return $rhighlights($row)
2789 proc bolden {row font} {
2790 global canv linehtag selectedline boldrows
2792 lappend boldrows $row
2793 $canv itemconf $linehtag($row) -font $font
2794 if {[info exists selectedline] && $row == $selectedline} {
2796 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2797 -outline {{}} -tags secsel \
2798 -fill [$canv cget -selectbackground]]
2803 proc bolden_name {row font} {
2804 global canv2 linentag selectedline boldnamerows
2806 lappend boldnamerows $row
2807 $canv2 itemconf $linentag($row) -font $font
2808 if {[info exists selectedline] && $row == $selectedline} {
2809 $canv2 delete secsel
2810 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2811 -outline {{}} -tags secsel \
2812 -fill [$canv2 cget -selectbackground]]
2821 foreach row $boldrows {
2822 if {![ishighlighted $row]} {
2823 bolden $row mainfont
2825 lappend stillbold $row
2828 set boldrows $stillbold
2831 proc addvhighlight {n} {
2832 global hlview viewcomplete curview vhl_done vhighlights commitidx
2834 if {[info exists hlview]} {
2838 if {$n != $curview && ![info exists viewcomplete($n)]} {
2841 set vhl_done $commitidx($hlview)
2842 if {$vhl_done > 0} {
2847 proc delvhighlight {} {
2848 global hlview vhighlights
2850 if {![info exists hlview]} return
2852 catch {unset vhighlights}
2856 proc vhighlightmore {} {
2857 global hlview vhl_done commitidx vhighlights curview
2859 set max $commitidx($hlview)
2860 set vr [visiblerows]
2861 set r0 [lindex $vr 0]
2862 set r1 [lindex $vr 1]
2863 for {set i $vhl_done} {$i < $max} {incr i} {
2864 set id [commitonrow $i $hlview]
2865 if {[commitinview $id $curview]} {
2866 set row [rowofcommit $id]
2867 if {$r0 <= $row && $row <= $r1} {
2868 if {![highlighted $row]} {
2869 bolden $row mainfontbold
2871 set vhighlights($row) 1
2878 proc askvhighlight {row id} {
2879 global hlview vhighlights iddrawn
2881 if {[commitinview $id $hlview]} {
2882 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2883 bolden $row mainfontbold
2885 set vhighlights($row) 1
2887 set vhighlights($row) 0
2891 proc hfiles_change {} {
2892 global highlight_files filehighlight fhighlights fh_serial
2893 global highlight_paths gdttype
2895 if {[info exists filehighlight]} {
2896 # delete previous highlights
2897 catch {close $filehighlight}
2899 catch {unset fhighlights}
2901 unhighlight_filelist
2903 set highlight_paths {}
2904 after cancel do_file_hl $fh_serial
2906 if {$highlight_files ne {}} {
2907 after 300 do_file_hl $fh_serial
2911 proc gdttype_change {name ix op} {
2912 global gdttype highlight_files findstring findpattern
2915 if {$findstring ne {}} {
2916 if {$gdttype eq "containing:"} {
2917 if {$highlight_files ne {}} {
2918 set highlight_files {}
2923 if {$findpattern ne {}} {
2927 set highlight_files $findstring
2932 # enable/disable findtype/findloc menus too
2935 proc find_change {name ix op} {
2936 global gdttype findstring highlight_files
2939 if {$gdttype eq "containing:"} {
2942 if {$highlight_files ne $findstring} {
2943 set highlight_files $findstring
2950 proc findcom_change args {
2951 global nhighlights boldnamerows
2952 global findpattern findtype findstring gdttype
2955 # delete previous highlights, if any
2956 foreach row $boldnamerows {
2957 bolden_name $row mainfont
2960 catch {unset nhighlights}
2963 if {$gdttype ne "containing:" || $findstring eq {}} {
2965 } elseif {$findtype eq "Regexp"} {
2966 set findpattern $findstring
2968 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2970 set findpattern "*$e*"
2974 proc makepatterns {l} {
2977 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2978 if {[string index $ee end] eq "/"} {
2988 proc do_file_hl {serial} {
2989 global highlight_files filehighlight highlight_paths gdttype fhl_list
2991 if {$gdttype eq "touching paths:"} {
2992 if {[catch {set paths [shellsplit $highlight_files]}]} return
2993 set highlight_paths [makepatterns $paths]
2995 set gdtargs [concat -- $paths]
2996 } elseif {$gdttype eq "adding/removing string:"} {
2997 set gdtargs [list "-S$highlight_files"]
2999 # must be "containing:", i.e. we're searching commit info
3002 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3003 set filehighlight [open $cmd r+]
3004 fconfigure $filehighlight -blocking 0
3005 filerun $filehighlight readfhighlight
3011 proc flushhighlights {} {
3012 global filehighlight fhl_list
3014 if {[info exists filehighlight]} {
3016 puts $filehighlight ""
3017 flush $filehighlight
3021 proc askfilehighlight {row id} {
3022 global filehighlight fhighlights fhl_list
3024 lappend fhl_list $id
3025 set fhighlights($row) -1
3026 puts $filehighlight $id
3029 proc readfhighlight {} {
3030 global filehighlight fhighlights curview iddrawn
3031 global fhl_list find_dirn
3033 if {![info exists filehighlight]} {
3037 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3038 set line [string trim $line]
3039 set i [lsearch -exact $fhl_list $line]
3040 if {$i < 0} continue
3041 for {set j 0} {$j < $i} {incr j} {
3042 set id [lindex $fhl_list $j]
3043 if {[commitinview $id $curview]} {
3044 set fhighlights([rowofcommit $id]) 0
3047 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3048 if {$line eq {}} continue
3049 if {![commitinview $line $curview]} continue
3050 set row [rowofcommit $line]
3051 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
3052 bolden $row mainfontbold
3054 set fhighlights($row) 1
3056 if {[eof $filehighlight]} {
3058 puts "oops, git diff-tree died"
3059 catch {close $filehighlight}
3063 if {[info exists find_dirn]} {
3069 proc doesmatch {f} {
3070 global findtype findpattern
3072 if {$findtype eq "Regexp"} {
3073 return [regexp $findpattern $f]
3074 } elseif {$findtype eq "IgnCase"} {
3075 return [string match -nocase $findpattern $f]
3077 return [string match $findpattern $f]
3081 proc askfindhighlight {row id} {
3082 global nhighlights commitinfo iddrawn
3084 global markingmatches
3086 if {![info exists commitinfo($id)]} {
3089 set info $commitinfo($id)
3091 set fldtypes {Headline Author Date Committer CDate Comments}
3092 foreach f $info ty $fldtypes {
3093 if {($findloc eq "All fields" || $findloc eq $ty) &&
3095 if {$ty eq "Author"} {
3102 if {$isbold && [info exists iddrawn($id)]} {
3103 if {![ishighlighted $row]} {
3104 bolden $row mainfontbold
3106 bolden_name $row mainfontbold
3109 if {$markingmatches} {
3110 markrowmatches $row $id
3113 set nhighlights($row) $isbold
3116 proc markrowmatches {row id} {
3117 global canv canv2 linehtag linentag commitinfo findloc
3119 set headline [lindex $commitinfo($id) 0]
3120 set author [lindex $commitinfo($id) 1]
3121 $canv delete match$row
3122 $canv2 delete match$row
3123 if {$findloc eq "All fields" || $findloc eq "Headline"} {
3124 set m [findmatches $headline]
3126 markmatches $canv $row $headline $linehtag($row) $m \
3127 [$canv itemcget $linehtag($row) -font] $row
3130 if {$findloc eq "All fields" || $findloc eq "Author"} {
3131 set m [findmatches $author]
3133 markmatches $canv2 $row $author $linentag($row) $m \
3134 [$canv2 itemcget $linentag($row) -font] $row
3139 proc vrel_change {name ix op} {
3140 global highlight_related
3143 if {$highlight_related ne "None"} {
3148 # prepare for testing whether commits are descendents or ancestors of a
3149 proc rhighlight_sel {a} {
3150 global descendent desc_todo ancestor anc_todo
3151 global highlight_related rhighlights
3153 catch {unset descendent}
3154 set desc_todo [list $a]
3155 catch {unset ancestor}
3156 set anc_todo [list $a]
3157 if {$highlight_related ne "None"} {
3163 proc rhighlight_none {} {
3166 catch {unset rhighlights}
3170 proc is_descendent {a} {
3171 global curview children descendent desc_todo
3174 set la [rowofcommit $a]
3178 for {set i 0} {$i < [llength $todo]} {incr i} {
3179 set do [lindex $todo $i]
3180 if {[rowofcommit $do] < $la} {
3181 lappend leftover $do
3184 foreach nk $children($v,$do) {
3185 if {![info exists descendent($nk)]} {
3186 set descendent($nk) 1
3194 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3198 set descendent($a) 0
3199 set desc_todo $leftover
3202 proc is_ancestor {a} {
3203 global curview parents ancestor anc_todo
3206 set la [rowofcommit $a]
3210 for {set i 0} {$i < [llength $todo]} {incr i} {
3211 set do [lindex $todo $i]
3212 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3213 lappend leftover $do
3216 foreach np $parents($v,$do) {
3217 if {![info exists ancestor($np)]} {
3226 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3231 set anc_todo $leftover
3234 proc askrelhighlight {row id} {
3235 global descendent highlight_related iddrawn rhighlights
3236 global selectedline ancestor
3238 if {![info exists selectedline]} return
3240 if {$highlight_related eq "Descendent" ||
3241 $highlight_related eq "Not descendent"} {
3242 if {![info exists descendent($id)]} {
3245 if {$descendent($id) == ($highlight_related eq "Descendent")} {
3248 } elseif {$highlight_related eq "Ancestor" ||
3249 $highlight_related eq "Not ancestor"} {
3250 if {![info exists ancestor($id)]} {
3253 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
3257 if {[info exists iddrawn($id)]} {
3258 if {$isbold && ![ishighlighted $row]} {
3259 bolden $row mainfontbold
3262 set rhighlights($row) $isbold
3265 # Graph layout functions
3267 proc shortids {ids} {
3270 if {[llength $id] > 1} {
3271 lappend res [shortids $id]
3272 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3273 lappend res [string range $id 0 7]
3284 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3285 if {($n & $mask) != 0} {
3286 set ret [concat $ret $o]
3288 set o [concat $o $o]
3293 proc ordertoken {id} {
3294 global ordertok curview varcid varcstart varctok curview parents children
3295 global nullid nullid2
3297 if {[info exists ordertok($id)]} {
3298 return $ordertok($id)
3303 if {[info exists varcid($curview,$id)]} {
3304 set a $varcid($curview,$id)
3305 set p [lindex $varcstart($curview) $a]
3307 set p [lindex $children($curview,$id) 0]
3309 if {[info exists ordertok($p)]} {
3310 set tok $ordertok($p)
3313 if {[llength $children($curview,$p)] == 0} {
3315 set tok [lindex $varctok($curview) $a]
3318 set id [lindex $children($curview,$p) 0]
3319 if {$id eq $nullid || $id eq $nullid2} {
3320 # XXX treat it as a root
3321 set tok [lindex $varctok($curview) $a]
3324 if {[llength $parents($curview,$id)] == 1} {
3325 lappend todo [list $p {}]
3327 set j [lsearch -exact $parents($curview,$id) $p]
3329 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3331 lappend todo [list $p [strrep $j]]
3334 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3335 set p [lindex $todo $i 0]
3336 append tok [lindex $todo $i 1]
3337 set ordertok($p) $tok
3339 set ordertok($origid) $tok
3343 # Work out where id should go in idlist so that order-token
3344 # values increase from left to right
3345 proc idcol {idlist id {i 0}} {
3346 set t [ordertoken $id]
3347 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3348 if {$i > [llength $idlist]} {
3349 set i [llength $idlist]
3351 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3354 if {$t > [ordertoken [lindex $idlist $i]]} {
3355 while {[incr i] < [llength $idlist] &&
3356 $t >= [ordertoken [lindex $idlist $i]]} {}
3362 proc initlayout {} {
3363 global rowidlist rowisopt rowfinal displayorder parentlist
3364 global numcommits canvxmax canv
3366 global colormap rowtextx
3376 set canvxmax [$canv cget -width]
3377 catch {unset colormap}
3378 catch {unset rowtextx}
3382 proc setcanvscroll {} {
3383 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3385 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3386 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3387 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3388 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3391 proc visiblerows {} {
3392 global canv numcommits linespc
3394 set ymax [lindex [$canv cget -scrollregion] 3]
3395 if {$ymax eq {} || $ymax == 0} return
3397 set y0 [expr {int([lindex $f 0] * $ymax)}]
3398 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3402 set y1 [expr {int([lindex $f 1] * $ymax)}]
3403 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3404 if {$r1 >= $numcommits} {
3405 set r1 [expr {$numcommits - 1}]
3407 return [list $r0 $r1]
3410 proc layoutmore {} {
3411 global commitidx viewcomplete curview
3412 global numcommits pending_select selectedline curview
3413 global selectfirst lastscrollset commitinterest
3415 set canshow $commitidx($curview)
3416 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3417 if {$numcommits == 0} {
3421 set prev $numcommits
3422 set numcommits $canshow
3423 set t [clock clicks -milliseconds]
3424 if {$prev < 100 || $viewcomplete($curview) || $t - $lastscrollset > 500} {
3425 set lastscrollset $t
3428 set rows [visiblerows]
3429 set r1 [lindex $rows 1]
3430 if {$r1 >= $canshow} {
3431 set r1 [expr {$canshow - 1}]
3436 if {[info exists pending_select] &&
3437 [commitinview $pending_select $curview]} {
3438 selectline [rowofcommit $pending_select] 1
3441 if {[info exists selectedline] || [info exists pending_select]} {
3444 set l [first_real_row]
3451 proc doshowlocalchanges {} {
3452 global curview mainheadid
3454 if {[commitinview $mainheadid $curview]} {
3457 lappend commitinterest($mainheadid) {dodiffindex}
3461 proc dohidelocalchanges {} {
3462 global nullid nullid2 lserial curview
3464 if {[commitinview $nullid $curview]} {
3465 removerow $nullid $curview
3467 if {[commitinview $nullid2 $curview]} {
3468 removerow $nullid2 $curview
3473 # spawn off a process to do git diff-index --cached HEAD
3474 proc dodiffindex {} {
3475 global lserial showlocalchanges
3477 if {!$showlocalchanges} return
3479 set fd [open "|git diff-index --cached HEAD" r]
3480 fconfigure $fd -blocking 0
3481 filerun $fd [list readdiffindex $fd $lserial]
3484 proc readdiffindex {fd serial} {
3485 global mainheadid nullid2 curview commitinfo commitdata lserial
3488 if {[gets $fd line] < 0} {
3494 # we only need to see one line and we don't really care what it says...
3497 # now see if there are any local changes not checked in to the index
3498 if {$serial == $lserial} {
3499 set fd [open "|git diff-files" r]
3500 fconfigure $fd -blocking 0
3501 filerun $fd [list readdifffiles $fd $serial]
3504 if {$isdiff && $serial == $lserial && ![commitinview $nullid2 $curview]} {
3505 # add the line for the changes in the index to the graph
3506 set hl "Local changes checked in to index but not committed"
3507 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3508 set commitdata($nullid2) "\n $hl\n"
3509 insertrow $nullid2 $mainheadid $curview
3514 proc readdifffiles {fd serial} {
3515 global mainheadid nullid nullid2 curview
3516 global commitinfo commitdata lserial
3519 if {[gets $fd line] < 0} {
3525 # we only need to see one line and we don't really care what it says...
3528 if {$isdiff && $serial == $lserial && ![commitinview $nullid $curview]} {
3529 # add the line for the local diff to the graph
3530 set hl "Local uncommitted changes, not checked in to index"
3531 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3532 set commitdata($nullid) "\n $hl\n"
3533 if {[commitinview $nullid2 $curview]} {
3538 insertrow $nullid $p $curview
3543 proc nextuse {id row} {
3544 global curview children
3546 if {[info exists children($curview,$id)]} {
3547 foreach kid $children($curview,$id) {
3548 if {![commitinview $kid $curview]} {
3551 if {[rowofcommit $kid] > $row} {
3552 return [rowofcommit $kid]
3556 if {[commitinview $id $curview]} {
3557 return [rowofcommit $id]
3562 proc prevuse {id row} {
3563 global curview children
3566 if {[info exists children($curview,$id)]} {
3567 foreach kid $children($curview,$id) {
3568 if {![commitinview $kid $curview]} break
3569 if {[rowofcommit $kid] < $row} {
3570 set ret [rowofcommit $kid]
3577 proc make_idlist {row} {
3578 global displayorder parentlist uparrowlen downarrowlen mingaplen
3579 global commitidx curview children
3581 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3585 set ra [expr {$row - $downarrowlen}]
3589 set rb [expr {$row + $uparrowlen}]
3590 if {$rb > $commitidx($curview)} {
3591 set rb $commitidx($curview)
3593 make_disporder $r [expr {$rb + 1}]
3595 for {} {$r < $ra} {incr r} {
3596 set nextid [lindex $displayorder [expr {$r + 1}]]
3597 foreach p [lindex $parentlist $r] {
3598 if {$p eq $nextid} continue
3599 set rn [nextuse $p $r]
3601 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3602 lappend ids [list [ordertoken $p] $p]
3606 for {} {$r < $row} {incr r} {
3607 set nextid [lindex $displayorder [expr {$r + 1}]]
3608 foreach p [lindex $parentlist $r] {
3609 if {$p eq $nextid} continue
3610 set rn [nextuse $p $r]
3611 if {$rn < 0 || $rn >= $row} {
3612 lappend ids [list [ordertoken $p] $p]
3616 set id [lindex $displayorder $row]
3617 lappend ids [list [ordertoken $id] $id]
3619 foreach p [lindex $parentlist $r] {
3620 set firstkid [lindex $children($curview,$p) 0]
3621 if {[rowofcommit $firstkid] < $row} {
3622 lappend ids [list [ordertoken $p] $p]
3626 set id [lindex $displayorder $r]
3628 set firstkid [lindex $children($curview,$id) 0]
3629 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3630 lappend ids [list [ordertoken $id] $id]
3635 foreach idx [lsort -unique $ids] {
3636 lappend idlist [lindex $idx 1]
3641 proc rowsequal {a b} {
3642 while {[set i [lsearch -exact $a {}]] >= 0} {
3643 set a [lreplace $a $i $i]
3645 while {[set i [lsearch -exact $b {}]] >= 0} {
3646 set b [lreplace $b $i $i]
3648 return [expr {$a eq $b}]
3651 proc makeupline {id row rend col} {
3652 global rowidlist uparrowlen downarrowlen mingaplen
3654 for {set r $rend} {1} {set r $rstart} {
3655 set rstart [prevuse $id $r]
3656 if {$rstart < 0} return
3657 if {$rstart < $row} break
3659 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3660 set rstart [expr {$rend - $uparrowlen - 1}]
3662 for {set r $rstart} {[incr r] <= $row} {} {
3663 set idlist [lindex $rowidlist $r]
3664 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3665 set col [idcol $idlist $id $col]
3666 lset rowidlist $r [linsert $idlist $col $id]
3672 proc layoutrows {row endrow} {
3673 global rowidlist rowisopt rowfinal displayorder
3674 global uparrowlen downarrowlen maxwidth mingaplen
3675 global children parentlist
3676 global commitidx viewcomplete curview
3678 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3681 set rm1 [expr {$row - 1}]
3682 foreach id [lindex $rowidlist $rm1] {
3687 set final [lindex $rowfinal $rm1]
3689 for {} {$row < $endrow} {incr row} {
3690 set rm1 [expr {$row - 1}]
3691 if {$rm1 < 0 || $idlist eq {}} {
3692 set idlist [make_idlist $row]
3695 set id [lindex $displayorder $rm1]
3696 set col [lsearch -exact $idlist $id]
3697 set idlist [lreplace $idlist $col $col]
3698 foreach p [lindex $parentlist $rm1] {
3699 if {[lsearch -exact $idlist $p] < 0} {
3700 set col [idcol $idlist $p $col]
3701 set idlist [linsert $idlist $col $p]
3702 # if not the first child, we have to insert a line going up
3703 if {$id ne [lindex $children($curview,$p) 0]} {
3704 makeupline $p $rm1 $row $col
3708 set id [lindex $displayorder $row]
3709 if {$row > $downarrowlen} {
3710 set termrow [expr {$row - $downarrowlen - 1}]
3711 foreach p [lindex $parentlist $termrow] {
3712 set i [lsearch -exact $idlist $p]
3713 if {$i < 0} continue
3714 set nr [nextuse $p $termrow]
3715 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3716 set idlist [lreplace $idlist $i $i]
3720 set col [lsearch -exact $idlist $id]
3722 set col [idcol $idlist $id]
3723 set idlist [linsert $idlist $col $id]
3724 if {$children($curview,$id) ne {}} {
3725 makeupline $id $rm1 $row $col
3728 set r [expr {$row + $uparrowlen - 1}]
3729 if {$r < $commitidx($curview)} {
3731 foreach p [lindex $parentlist $r] {
3732 if {[lsearch -exact $idlist $p] >= 0} continue
3733 set fk [lindex $children($curview,$p) 0]
3734 if {[rowofcommit $fk] < $row} {
3735 set x [idcol $idlist $p $x]
3736 set idlist [linsert $idlist $x $p]
3739 if {[incr r] < $commitidx($curview)} {
3740 set p [lindex $displayorder $r]
3741 if {[lsearch -exact $idlist $p] < 0} {
3742 set fk [lindex $children($curview,$p) 0]
3743 if {$fk ne {} && [rowofcommit $fk] < $row} {
3744 set x [idcol $idlist $p $x]
3745 set idlist [linsert $idlist $x $p]
3751 if {$final && !$viewcomplete($curview) &&
3752 $row + $uparrowlen + $mingaplen + $downarrowlen
3753 >= $commitidx($curview)} {
3756 set l [llength $rowidlist]
3758 lappend rowidlist $idlist
3760 lappend rowfinal $final
3761 } elseif {$row < $l} {
3762 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3763 lset rowidlist $row $idlist
3766 lset rowfinal $row $final
3768 set pad [ntimes [expr {$row - $l}] {}]
3769 set rowidlist [concat $rowidlist $pad]
3770 lappend rowidlist $idlist
3771 set rowfinal [concat $rowfinal $pad]
3772 lappend rowfinal $final
3773 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3779 proc changedrow {row} {
3780 global displayorder iddrawn rowisopt need_redisplay
3782 set l [llength $rowisopt]
3784 lset rowisopt $row 0
3785 if {$row + 1 < $l} {
3786 lset rowisopt [expr {$row + 1}] 0
3787 if {$row + 2 < $l} {
3788 lset rowisopt [expr {$row + 2}] 0
3792 set id [lindex $displayorder $row]
3793 if {[info exists iddrawn($id)]} {
3794 set need_redisplay 1
3798 proc insert_pad {row col npad} {
3801 set pad [ntimes $npad {}]
3802 set idlist [lindex $rowidlist $row]
3803 set bef [lrange $idlist 0 [expr {$col - 1}]]
3804 set aft [lrange $idlist $col end]
3805 set i [lsearch -exact $aft {}]
3807 set aft [lreplace $aft $i $i]
3809 lset rowidlist $row [concat $bef $pad $aft]
3813 proc optimize_rows {row col endrow} {
3814 global rowidlist rowisopt displayorder curview children
3819 for {} {$row < $endrow} {incr row; set col 0} {
3820 if {[lindex $rowisopt $row]} continue
3822 set y0 [expr {$row - 1}]
3823 set ym [expr {$row - 2}]
3824 set idlist [lindex $rowidlist $row]
3825 set previdlist [lindex $rowidlist $y0]
3826 if {$idlist eq {} || $previdlist eq {}} continue
3828 set pprevidlist [lindex $rowidlist $ym]
3829 if {$pprevidlist eq {}} continue
3835 for {} {$col < [llength $idlist]} {incr col} {
3836 set id [lindex $idlist $col]
3837 if {[lindex $previdlist $col] eq $id} continue
3842 set x0 [lsearch -exact $previdlist $id]
3843 if {$x0 < 0} continue
3844 set z [expr {$x0 - $col}]
3848 set xm [lsearch -exact $pprevidlist $id]
3850 set z0 [expr {$xm - $x0}]
3854 # if row y0 is the first child of $id then it's not an arrow
3855 if {[lindex $children($curview,$id) 0] ne
3856 [lindex $displayorder $y0]} {
3860 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3861 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3864 # Looking at lines from this row to the previous row,
3865 # make them go straight up if they end in an arrow on
3866 # the previous row; otherwise make them go straight up
3868 if {$z < -1 || ($z < 0 && $isarrow)} {
3869 # Line currently goes left too much;
3870 # insert pads in the previous row, then optimize it
3871 set npad [expr {-1 - $z + $isarrow}]
3872 insert_pad $y0 $x0 $npad
3874 optimize_rows $y0 $x0 $row
3876 set previdlist [lindex $rowidlist $y0]
3877 set x0 [lsearch -exact $previdlist $id]
3878 set z [expr {$x0 - $col}]
3880 set pprevidlist [lindex $rowidlist $ym]
3881 set xm [lsearch -exact $pprevidlist $id]
3882 set z0 [expr {$xm - $x0}]
3884 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3885 # Line currently goes right too much;
3886 # insert pads in this line
3887 set npad [expr {$z - 1 + $isarrow}]
3888 insert_pad $row $col $npad
3889 set idlist [lindex $rowidlist $row]
3891 set z [expr {$x0 - $col}]
3894 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3895 # this line links to its first child on row $row-2
3896 set id [lindex $displayorder $ym]
3897 set xc [lsearch -exact $pprevidlist $id]
3899 set z0 [expr {$xc - $x0}]
3902 # avoid lines jigging left then immediately right
3903 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3904 insert_pad $y0 $x0 1
3906 optimize_rows $y0 $x0 $row
3907 set previdlist [lindex $rowidlist $y0]
3911 # Find the first column that doesn't have a line going right
3912 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3913 set id [lindex $idlist $col]
3914 if {$id eq {}} break
3915 set x0 [lsearch -exact $previdlist $id]
3917 # check if this is the link to the first child
3918 set kid [lindex $displayorder $y0]
3919 if {[lindex $children($curview,$id) 0] eq $kid} {
3920 # it is, work out offset to child
3921 set x0 [lsearch -exact $previdlist $kid]
3924 if {$x0 <= $col} break
3926 # Insert a pad at that column as long as it has a line and
3927 # isn't the last column
3928 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3929 set idlist [linsert $idlist $col {}]
3930 lset rowidlist $row $idlist
3938 global canvx0 linespc
3939 return [expr {$canvx0 + $col * $linespc}]
3943 global canvy0 linespc
3944 return [expr {$canvy0 + $row * $linespc}]
3947 proc linewidth {id} {
3948 global thickerline lthickness
3951 if {[info exists thickerline] && $id eq $thickerline} {
3952 set wid [expr {2 * $lthickness}]
3957 proc rowranges {id} {
3958 global curview children uparrowlen downarrowlen
3961 set kids $children($curview,$id)
3967 foreach child $kids {
3968 if {![commitinview $child $curview]} break
3969 set row [rowofcommit $child]
3970 if {![info exists prev]} {
3971 lappend ret [expr {$row + 1}]
3973 if {$row <= $prevrow} {
3974 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
3976 # see if the line extends the whole way from prevrow to row
3977 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3978 [lsearch -exact [lindex $rowidlist \
3979 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3980 # it doesn't, see where it ends
3981 set r [expr {$prevrow + $downarrowlen}]
3982 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3983 while {[incr r -1] > $prevrow &&
3984 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3986 while {[incr r] <= $row &&
3987 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3991 # see where it starts up again
3992 set r [expr {$row - $uparrowlen}]
3993 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3994 while {[incr r] < $row &&
3995 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3997 while {[incr r -1] >= $prevrow &&
3998 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4004 if {$child eq $id} {
4013 proc drawlineseg {id row endrow arrowlow} {
4014 global rowidlist displayorder iddrawn linesegs
4015 global canv colormap linespc curview maxlinelen parentlist
4017 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4018 set le [expr {$row + 1}]
4021 set c [lsearch -exact [lindex $rowidlist $le] $id]
4027 set x [lindex $displayorder $le]
4032 if {[info exists iddrawn($x)] || $le == $endrow} {
4033 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4049 if {[info exists linesegs($id)]} {
4050 set lines $linesegs($id)
4052 set r0 [lindex $li 0]
4054 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4064 set li [lindex $lines [expr {$i-1}]]
4065 set r1 [lindex $li 1]
4066 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4071 set x [lindex $cols [expr {$le - $row}]]
4072 set xp [lindex $cols [expr {$le - 1 - $row}]]
4073 set dir [expr {$xp - $x}]
4075 set ith [lindex $lines $i 2]
4076 set coords [$canv coords $ith]
4077 set ah [$canv itemcget $ith -arrow]
4078 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4079 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4080 if {$x2 ne {} && $x - $x2 == $dir} {
4081 set coords [lrange $coords 0 end-2]
4084 set coords [list [xc $le $x] [yc $le]]
4087 set itl [lindex $lines [expr {$i-1}] 2]
4088 set al [$canv itemcget $itl -arrow]
4089 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4090 } elseif {$arrowlow} {
4091 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4092 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4096 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4097 for {set y $le} {[incr y -1] > $row} {} {
4099 set xp [lindex $cols [expr {$y - 1 - $row}]]
4100 set ndir [expr {$xp - $x}]
4101 if {$dir != $ndir || $xp < 0} {
4102 lappend coords [xc $y $x] [yc $y]
4108 # join parent line to first child
4109 set ch [lindex $displayorder $row]
4110 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4112 puts "oops: drawlineseg: child $ch not on row $row"
4113 } elseif {$xc != $x} {
4114 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4115 set d [expr {int(0.5 * $linespc)}]
4118 set x2 [expr {$x1 - $d}]
4120 set x2 [expr {$x1 + $d}]
4123 set y1 [expr {$y2 + $d}]
4124 lappend coords $x1 $y1 $x2 $y2
4125 } elseif {$xc < $x - 1} {
4126 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4127 } elseif {$xc > $x + 1} {
4128 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4132 lappend coords [xc $row $x] [yc $row]
4134 set xn [xc $row $xp]
4136 lappend coords $xn $yn
4140 set t [$canv create line $coords -width [linewidth $id] \
4141 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4144 set lines [linsert $lines $i [list $row $le $t]]
4146 $canv coords $ith $coords
4147 if {$arrow ne $ah} {
4148 $canv itemconf $ith -arrow $arrow
4150 lset lines $i 0 $row
4153 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4154 set ndir [expr {$xo - $xp}]
4155 set clow [$canv coords $itl]
4156 if {$dir == $ndir} {
4157 set clow [lrange $clow 2 end]
4159 set coords [concat $coords $clow]
4161 lset lines [expr {$i-1}] 1 $le
4163 # coalesce two pieces
4165 set b [lindex $lines [expr {$i-1}] 0]
4166 set e [lindex $lines $i 1]
4167 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4169 $canv coords $itl $coords
4170 if {$arrow ne $al} {
4171 $canv itemconf $itl -arrow $arrow
4175 set linesegs($id) $lines
4179 proc drawparentlinks {id row} {
4180 global rowidlist canv colormap curview parentlist
4181 global idpos linespc
4183 set rowids [lindex $rowidlist $row]
4184 set col [lsearch -exact $rowids $id]
4185 if {$col < 0} return
4186 set olds [lindex $parentlist $row]
4187 set row2 [expr {$row + 1}]
4188 set x [xc $row $col]
4191 set d [expr {int(0.5 * $linespc)}]
4192 set ymid [expr {$y + $d}]
4193 set ids [lindex $rowidlist $row2]
4194 # rmx = right-most X coord used
4197 set i [lsearch -exact $ids $p]
4199 puts "oops, parent $p of $id not in list"
4202 set x2 [xc $row2 $i]
4206 set j [lsearch -exact $rowids $p]
4208 # drawlineseg will do this one for us
4212 # should handle duplicated parents here...
4213 set coords [list $x $y]
4215 # if attaching to a vertical segment, draw a smaller
4216 # slant for visual distinctness
4219 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4221 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4223 } elseif {$i < $col && $i < $j} {
4224 # segment slants towards us already
4225 lappend coords [xc $row $j] $y
4227 if {$i < $col - 1} {
4228 lappend coords [expr {$x2 + $linespc}] $y
4229 } elseif {$i > $col + 1} {
4230 lappend coords [expr {$x2 - $linespc}] $y
4232 lappend coords $x2 $y2
4235 lappend coords $x2 $y2
4237 set t [$canv create line $coords -width [linewidth $p] \
4238 -fill $colormap($p) -tags lines.$p]
4242 if {$rmx > [lindex $idpos($id) 1]} {
4243 lset idpos($id) 1 $rmx
4248 proc drawlines {id} {
4251 $canv itemconf lines.$id -width [linewidth $id]
4254 proc drawcmittext {id row col} {
4255 global linespc canv canv2 canv3 fgcolor curview
4256 global cmitlisted commitinfo rowidlist parentlist
4257 global rowtextx idpos idtags idheads idotherrefs
4258 global linehtag linentag linedtag selectedline
4259 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4261 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4262 set listed $cmitlisted($curview,$id)
4263 if {$id eq $nullid} {
4265 } elseif {$id eq $nullid2} {
4268 set ofill [expr {$listed != 0? "blue": "white"}]
4270 set x [xc $row $col]
4272 set orad [expr {$linespc / 3}]
4274 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4275 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4276 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4277 } elseif {$listed == 2} {
4278 # triangle pointing left for left-side commits
4279 set t [$canv create polygon \
4280 [expr {$x - $orad}] $y \
4281 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4282 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4283 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4285 # triangle pointing right for right-side commits
4286 set t [$canv create polygon \
4287 [expr {$x + $orad - 1}] $y \
4288 [expr {$x - $orad}] [expr {$y - $orad}] \
4289 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4290 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4293 $canv bind $t <1> {selcanvline {} %x %y}
4294 set rmx [llength [lindex $rowidlist $row]]
4295 set olds [lindex $parentlist $row]
4297 set nextids [lindex $rowidlist [expr {$row + 1}]]
4299 set i [lsearch -exact $nextids $p]
4305 set xt [xc $row $rmx]
4306 set rowtextx($row) $xt
4307 set idpos($id) [list $x $xt $y]
4308 if {[info exists idtags($id)] || [info exists idheads($id)]
4309 || [info exists idotherrefs($id)]} {
4310 set xt [drawtags $id $x $xt $y]
4312 set headline [lindex $commitinfo($id) 0]
4313 set name [lindex $commitinfo($id) 1]
4314 set date [lindex $commitinfo($id) 2]
4315 set date [formatdate $date]
4318 set isbold [ishighlighted $row]
4320 lappend boldrows $row
4321 set font mainfontbold
4323 lappend boldnamerows $row
4324 set nfont mainfontbold
4327 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4328 -text $headline -font $font -tags text]
4329 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4330 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4331 -text $name -font $nfont -tags text]
4332 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4333 -text $date -font mainfont -tags text]
4334 if {[info exists selectedline] && $selectedline == $row} {
4337 set xr [expr {$xt + [font measure $font $headline]}]
4338 if {$xr > $canvxmax} {
4344 proc drawcmitrow {row} {
4345 global displayorder rowidlist nrows_drawn
4346 global iddrawn markingmatches
4347 global commitinfo numcommits
4348 global filehighlight fhighlights findpattern nhighlights
4349 global hlview vhighlights
4350 global highlight_related rhighlights
4352 if {$row >= $numcommits} return
4354 set id [lindex $displayorder $row]
4355 if {[info exists hlview] && ![info exists vhighlights($row)]} {
4356 askvhighlight $row $id
4358 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
4359 askfilehighlight $row $id
4361 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
4362 askfindhighlight $row $id
4364 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
4365 askrelhighlight $row $id
4367 if {![info exists iddrawn($id)]} {
4368 set col [lsearch -exact [lindex $rowidlist $row] $id]
4370 puts "oops, row $row id $id not in list"
4373 if {![info exists commitinfo($id)]} {
4377 drawcmittext $id $row $col
4381 if {$markingmatches} {
4382 markrowmatches $row $id
4386 proc drawcommits {row {endrow {}}} {
4387 global numcommits iddrawn displayorder curview need_redisplay
4388 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4393 if {$endrow eq {}} {
4396 if {$endrow >= $numcommits} {
4397 set endrow [expr {$numcommits - 1}]
4400 set rl1 [expr {$row - $downarrowlen - 3}]
4404 set ro1 [expr {$row - 3}]
4408 set r2 [expr {$endrow + $uparrowlen + 3}]
4409 if {$r2 > $numcommits} {
4412 for {set r $rl1} {$r < $r2} {incr r} {
4413 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4417 set rl1 [expr {$r + 1}]
4423 optimize_rows $ro1 0 $r2
4424 if {$need_redisplay || $nrows_drawn > 2000} {
4429 # make the lines join to already-drawn rows either side
4430 set r [expr {$row - 1}]
4431 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4434 set er [expr {$endrow + 1}]
4435 if {$er >= $numcommits ||
4436 ![info exists iddrawn([lindex $displayorder $er])]} {
4439 for {} {$r <= $er} {incr r} {
4440 set id [lindex $displayorder $r]
4441 set wasdrawn [info exists iddrawn($id)]
4443 if {$r == $er} break
4444 set nextid [lindex $displayorder [expr {$r + 1}]]
4445 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4446 drawparentlinks $id $r
4448 set rowids [lindex $rowidlist $r]
4449 foreach lid $rowids {
4450 if {$lid eq {}} continue
4451 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4453 # see if this is the first child of any of its parents
4454 foreach p [lindex $parentlist $r] {
4455 if {[lsearch -exact $rowids $p] < 0} {
4456 # make this line extend up to the child
4457 set lineend($p) [drawlineseg $p $r $er 0]
4461 set lineend($lid) [drawlineseg $lid $r $er 1]
4467 proc undolayout {row} {
4468 global uparrowlen mingaplen downarrowlen
4469 global rowidlist rowisopt rowfinal need_redisplay
4471 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4475 if {[llength $rowidlist] > $r} {
4477 set rowidlist [lrange $rowidlist 0 $r]
4478 set rowfinal [lrange $rowfinal 0 $r]
4479 set rowisopt [lrange $rowisopt 0 $r]
4480 set need_redisplay 1
4485 proc drawfrac {f0 f1} {
4488 set ymax [lindex [$canv cget -scrollregion] 3]
4489 if {$ymax eq {} || $ymax == 0} return
4490 set y0 [expr {int($f0 * $ymax)}]
4491 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4492 set y1 [expr {int($f1 * $ymax)}]
4493 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4494 drawcommits $row $endrow
4497 proc drawvisible {} {
4499 eval drawfrac [$canv yview]
4502 proc clear_display {} {
4503 global iddrawn linesegs need_redisplay nrows_drawn
4504 global vhighlights fhighlights nhighlights rhighlights
4507 catch {unset iddrawn}
4508 catch {unset linesegs}
4509 catch {unset vhighlights}
4510 catch {unset fhighlights}
4511 catch {unset nhighlights}
4512 catch {unset rhighlights}
4513 set need_redisplay 0
4517 proc findcrossings {id} {
4518 global rowidlist parentlist numcommits displayorder
4522 foreach {s e} [rowranges $id] {
4523 if {$e >= $numcommits} {
4524 set e [expr {$numcommits - 1}]
4526 if {$e <= $s} continue
4527 for {set row $e} {[incr row -1] >= $s} {} {
4528 set x [lsearch -exact [lindex $rowidlist $row] $id]
4530 set olds [lindex $parentlist $row]
4531 set kid [lindex $displayorder $row]
4532 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4533 if {$kidx < 0} continue
4534 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4536 set px [lsearch -exact $nextrow $p]
4537 if {$px < 0} continue
4538 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4539 if {[lsearch -exact $ccross $p] >= 0} continue
4540 if {$x == $px + ($kidx < $px? -1: 1)} {
4542 } elseif {[lsearch -exact $cross $p] < 0} {
4549 return [concat $ccross {{}} $cross]
4552 proc assigncolor {id} {
4553 global colormap colors nextcolor
4554 global parents children children curview
4556 if {[info exists colormap($id)]} return
4557 set ncolors [llength $colors]
4558 if {[info exists children($curview,$id)]} {
4559 set kids $children($curview,$id)
4563 if {[llength $kids] == 1} {
4564 set child [lindex $kids 0]
4565 if {[info exists colormap($child)]
4566 && [llength $parents($curview,$child)] == 1} {
4567 set colormap($id) $colormap($child)
4573 foreach x [findcrossings $id] {
4575 # delimiter between corner crossings and other crossings
4576 if {[llength $badcolors] >= $ncolors - 1} break
4577 set origbad $badcolors
4579 if {[info exists colormap($x)]
4580 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4581 lappend badcolors $colormap($x)
4584 if {[llength $badcolors] >= $ncolors} {
4585 set badcolors $origbad
4587 set origbad $badcolors
4588 if {[llength $badcolors] < $ncolors - 1} {
4589 foreach child $kids {
4590 if {[info exists colormap($child)]
4591 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4592 lappend badcolors $colormap($child)
4594 foreach p $parents($curview,$child) {
4595 if {[info exists colormap($p)]
4596 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4597 lappend badcolors $colormap($p)
4601 if {[llength $badcolors] >= $ncolors} {
4602 set badcolors $origbad
4605 for {set i 0} {$i <= $ncolors} {incr i} {
4606 set c [lindex $colors $nextcolor]
4607 if {[incr nextcolor] >= $ncolors} {
4610 if {[lsearch -exact $badcolors $c]} break
4612 set colormap($id) $c
4615 proc bindline {t id} {
4618 $canv bind $t <Enter> "lineenter %x %y $id"
4619 $canv bind $t <Motion> "linemotion %x %y $id"
4620 $canv bind $t <Leave> "lineleave $id"
4621 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4624 proc drawtags {id x xt y1} {
4625 global idtags idheads idotherrefs mainhead
4626 global linespc lthickness
4627 global canv rowtextx curview fgcolor bgcolor
4632 if {[info exists idtags($id)]} {
4633 set marks $idtags($id)
4634 set ntags [llength $marks]
4636 if {[info exists idheads($id)]} {
4637 set marks [concat $marks $idheads($id)]
4638 set nheads [llength $idheads($id)]
4640 if {[info exists idotherrefs($id)]} {
4641 set marks [concat $marks $idotherrefs($id)]
4647 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4648 set yt [expr {$y1 - 0.5 * $linespc}]
4649 set yb [expr {$yt + $linespc - 1}]
4653 foreach tag $marks {
4655 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4656 set wid [font measure mainfontbold $tag]
4658 set wid [font measure mainfont $tag]
4662 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4664 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4665 -width $lthickness -fill black -tags tag.$id]
4667 foreach tag $marks x $xvals wid $wvals {
4668 set xl [expr {$x + $delta}]
4669 set xr [expr {$x + $delta + $wid + $lthickness}]
4671 if {[incr ntags -1] >= 0} {
4673 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4674 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4675 -width 1 -outline black -fill yellow -tags tag.$id]
4676 $canv bind $t <1> [list showtag $tag 1]
4677 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4679 # draw a head or other ref
4680 if {[incr nheads -1] >= 0} {
4682 if {$tag eq $mainhead} {
4683 set font mainfontbold
4688 set xl [expr {$xl - $delta/2}]
4689 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4690 -width 1 -outline black -fill $col -tags tag.$id
4691 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4692 set rwid [font measure mainfont $remoteprefix]
4693 set xi [expr {$x + 1}]
4694 set yti [expr {$yt + 1}]
4695 set xri [expr {$x + $rwid}]
4696 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4697 -width 0 -fill "#ffddaa" -tags tag.$id
4700 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4701 -font $font -tags [list tag.$id text]]
4703 $canv bind $t <1> [list showtag $tag 1]
4704 } elseif {$nheads >= 0} {
4705 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4711 proc xcoord {i level ln} {
4712 global canvx0 xspc1 xspc2
4714 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4715 if {$i > 0 && $i == $level} {
4716 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4717 } elseif {$i > $level} {
4718 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4723 proc show_status {msg} {
4727 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4728 -tags text -fill $fgcolor
4731 # Don't change the text pane cursor if it is currently the hand cursor,
4732 # showing that we are over a sha1 ID link.
4733 proc settextcursor {c} {
4734 global ctext curtextcursor
4736 if {[$ctext cget -cursor] == $curtextcursor} {
4737 $ctext config -cursor $c
4739 set curtextcursor $c
4742 proc nowbusy {what {name {}}} {
4743 global isbusy busyname statusw
4745 if {[array names isbusy] eq {}} {
4746 . config -cursor watch
4750 set busyname($what) $name
4752 $statusw conf -text $name
4756 proc notbusy {what} {
4757 global isbusy maincursor textcursor busyname statusw
4761 if {$busyname($what) ne {} &&
4762 [$statusw cget -text] eq $busyname($what)} {
4763 $statusw conf -text {}
4766 if {[array names isbusy] eq {}} {
4767 . config -cursor $maincursor
4768 settextcursor $textcursor
4772 proc findmatches {f} {
4773 global findtype findstring
4774 if {$findtype == "Regexp"} {
4775 set matches [regexp -indices -all -inline $findstring $f]
4778 if {$findtype == "IgnCase"} {
4779 set f [string tolower $f]
4780 set fs [string tolower $fs]
4784 set l [string length $fs]
4785 while {[set j [string first $fs $f $i]] >= 0} {
4786 lappend matches [list $j [expr {$j+$l-1}]]
4787 set i [expr {$j + $l}]
4793 proc dofind {{dirn 1} {wrap 1}} {
4794 global findstring findstartline findcurline selectedline numcommits
4795 global gdttype filehighlight fh_serial find_dirn findallowwrap
4797 if {[info exists find_dirn]} {
4798 if {$find_dirn == $dirn} return
4802 if {$findstring eq {} || $numcommits == 0} return
4803 if {![info exists selectedline]} {
4804 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4806 set findstartline $selectedline
4808 set findcurline $findstartline
4809 nowbusy finding "Searching"
4810 if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4811 after cancel do_file_hl $fh_serial
4812 do_file_hl $fh_serial
4815 set findallowwrap $wrap
4819 proc stopfinding {} {
4820 global find_dirn findcurline fprogcoord
4822 if {[info exists find_dirn]} {
4832 global commitdata commitinfo numcommits findpattern findloc
4833 global findstartline findcurline findallowwrap
4834 global find_dirn gdttype fhighlights fprogcoord
4835 global curview varcorder vrownum varccommits
4837 if {![info exists find_dirn]} {
4840 set fldtypes {Headline Author Date Committer CDate Comments}
4843 if {$find_dirn > 0} {
4845 if {$l >= $numcommits} {
4848 if {$l <= $findstartline} {
4849 set lim [expr {$findstartline + 1}]
4852 set moretodo $findallowwrap
4859 if {$l >= $findstartline} {
4860 set lim [expr {$findstartline - 1}]
4863 set moretodo $findallowwrap
4866 set n [expr {($lim - $l) * $find_dirn}]
4873 set ai [bsearch $vrownum($curview) $l]
4874 set a [lindex $varcorder($curview) $ai]
4875 set arow [lindex $vrownum($curview) $ai]
4876 set ids [lindex $varccommits($curview,$a)]
4877 set arowend [expr {$arow + [llength $ids]}]
4878 if {$gdttype eq "containing:"} {
4879 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4880 if {$l < $arow || $l >= $arowend} {
4882 set a [lindex $varcorder($curview) $ai]
4883 set arow [lindex $vrownum($curview) $ai]
4884 set ids [lindex $varccommits($curview,$a)]
4885 set arowend [expr {$arow + [llength $ids]}]
4887 set id [lindex $ids [expr {$l - $arow}]]
4888 # shouldn't happen unless git log doesn't give all the commits...
4889 if {![info exists commitdata($id)] ||
4890 ![doesmatch $commitdata($id)]} {
4893 if {![info exists commitinfo($id)]} {
4896 set info $commitinfo($id)
4897 foreach f $info ty $fldtypes {
4898 if {($findloc eq "All fields" || $findloc eq $ty) &&
4907 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4908 if {$l < $arow || $l >= $arowend} {
4910 set a [lindex $varcorder($curview) $ai]
4911 set arow [lindex $vrownum($curview) $ai]
4912 set ids [lindex $varccommits($curview,$a)]
4913 set arowend [expr {$arow + [llength $ids]}]
4915 set id [lindex $ids [expr {$l - $arow}]]
4916 if {![info exists fhighlights($l)]} {
4917 askfilehighlight $l $id
4920 set findcurline [expr {$l - $find_dirn}]
4922 } elseif {$fhighlights($l)} {
4928 if {$found || ($domore && !$moretodo)} {
4944 set findcurline [expr {$l - $find_dirn}]
4946 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
4950 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4955 proc findselectline {l} {
4956 global findloc commentend ctext findcurline markingmatches gdttype
4958 set markingmatches 1
4961 if {$findloc == "All fields" || $findloc == "Comments"} {
4962 # highlight the matches in the comments
4963 set f [$ctext get 1.0 $commentend]
4964 set matches [findmatches $f]
4965 foreach match $matches {
4966 set start [lindex $match 0]
4967 set end [expr {[lindex $match 1] + 1}]
4968 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4974 # mark the bits of a headline or author that match a find string
4975 proc markmatches {canv l str tag matches font row} {
4978 set bbox [$canv bbox $tag]
4979 set x0 [lindex $bbox 0]
4980 set y0 [lindex $bbox 1]
4981 set y1 [lindex $bbox 3]
4982 foreach match $matches {
4983 set start [lindex $match 0]
4984 set end [lindex $match 1]
4985 if {$start > $end} continue
4986 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4987 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4988 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4989 [expr {$x0+$xlen+2}] $y1 \
4990 -outline {} -tags [list match$l matches] -fill yellow]
4992 if {[info exists selectedline] && $row == $selectedline} {
4993 $canv raise $t secsel
4998 proc unmarkmatches {} {
4999 global markingmatches
5001 allcanvs delete matches
5002 set markingmatches 0
5006 proc selcanvline {w x y} {
5007 global canv canvy0 ctext linespc
5009 set ymax [lindex [$canv cget -scrollregion] 3]
5010 if {$ymax == {}} return
5011 set yfrac [lindex [$canv yview] 0]
5012 set y [expr {$y + $yfrac * $ymax}]
5013 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5018 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
5024 proc commit_descriptor {p} {
5026 if {![info exists commitinfo($p)]} {
5030 if {[llength $commitinfo($p)] > 1} {
5031 set l [lindex $commitinfo($p) 0]
5036 # append some text to the ctext widget, and make any SHA1 ID
5037 # that we know about be a clickable link.
5038 proc appendwithlinks {text tags} {
5039 global ctext linknum curview pendinglinks
5041 set start [$ctext index "end - 1c"]
5042 $ctext insert end $text $tags
5043 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5047 set linkid [string range $text $s $e]
5049 $ctext tag delete link$linknum
5050 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5051 setlink $linkid link$linknum
5056 proc setlink {id lk} {
5057 global curview ctext pendinglinks commitinterest
5059 if {[commitinview $id $curview]} {
5060 $ctext tag conf $lk -foreground blue -underline 1
5061 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5062 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5063 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5065 lappend pendinglinks($id) $lk
5066 lappend commitinterest($id) {makelink %I}
5070 proc makelink {id} {
5073 if {![info exists pendinglinks($id)]} return
5074 foreach lk $pendinglinks($id) {
5077 unset pendinglinks($id)
5080 proc linkcursor {w inc} {
5081 global linkentercount curtextcursor
5083 if {[incr linkentercount $inc] > 0} {
5084 $w configure -cursor hand2
5086 $w configure -cursor $curtextcursor
5087 if {$linkentercount < 0} {
5088 set linkentercount 0
5093 proc viewnextline {dir} {
5097 set ymax [lindex [$canv cget -scrollregion] 3]
5098 set wnow [$canv yview]
5099 set wtop [expr {[lindex $wnow 0] * $ymax}]
5100 set newtop [expr {$wtop + $dir * $linespc}]
5103 } elseif {$newtop > $ymax} {
5106 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5109 # add a list of tag or branch names at position pos
5110 # returns the number of names inserted
5111 proc appendrefs {pos ids var} {
5112 global ctext linknum curview $var maxrefs
5114 if {[catch {$ctext index $pos}]} {
5117 $ctext conf -state normal
5118 $ctext delete $pos "$pos lineend"
5121 foreach tag [set $var\($id\)] {
5122 lappend tags [list $tag $id]
5125 if {[llength $tags] > $maxrefs} {
5126 $ctext insert $pos "many ([llength $tags])"
5128 set tags [lsort -index 0 -decreasing $tags]
5131 set id [lindex $ti 1]
5134 $ctext tag delete $lk
5135 $ctext insert $pos $sep
5136 $ctext insert $pos [lindex $ti 0] $lk
5141 $ctext conf -state disabled
5142 return [llength $tags]
5145 # called when we have finished computing the nearby tags
5146 proc dispneartags {delay} {
5147 global selectedline currentid showneartags tagphase
5149 if {![info exists selectedline] || !$showneartags} return
5150 after cancel dispnexttag
5152 after 200 dispnexttag
5155 after idle dispnexttag
5160 proc dispnexttag {} {
5161 global selectedline currentid showneartags tagphase ctext
5163 if {![info exists selectedline] || !$showneartags} return
5164 switch -- $tagphase {
5166 set dtags [desctags $currentid]
5168 appendrefs precedes $dtags idtags
5172 set atags [anctags $currentid]
5174 appendrefs follows $atags idtags
5178 set dheads [descheads $currentid]
5179 if {$dheads ne {}} {
5180 if {[appendrefs branch $dheads idheads] > 1
5181 && [$ctext get "branch -3c"] eq "h"} {
5182 # turn "Branch" into "Branches"
5183 $ctext conf -state normal
5184 $ctext insert "branch -2c" "es"
5185 $ctext conf -state disabled
5190 if {[incr tagphase] <= 2} {
5191 after idle dispnexttag
5195 proc make_secsel {l} {
5196 global linehtag linentag linedtag canv canv2 canv3
5198 if {![info exists linehtag($l)]} return
5200 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5201 -tags secsel -fill [$canv cget -selectbackground]]
5203 $canv2 delete secsel
5204 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5205 -tags secsel -fill [$canv2 cget -selectbackground]]
5207 $canv3 delete secsel
5208 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5209 -tags secsel -fill [$canv3 cget -selectbackground]]
5213 proc selectline {l isnew} {
5214 global canv ctext commitinfo selectedline
5215 global canvy0 linespc parents children curview
5216 global currentid sha1entry
5217 global commentend idtags linknum
5218 global mergemax numcommits pending_select
5219 global cmitmode showneartags allcommits
5221 catch {unset pending_select}
5226 if {$l < 0 || $l >= $numcommits} return
5227 set y [expr {$canvy0 + $l * $linespc}]
5228 set ymax [lindex [$canv cget -scrollregion] 3]
5229 set ytop [expr {$y - $linespc - 1}]
5230 set ybot [expr {$y + $linespc + 1}]
5231 set wnow [$canv yview]
5232 set wtop [expr {[lindex $wnow 0] * $ymax}]
5233 set wbot [expr {[lindex $wnow 1] * $ymax}]
5234 set wh [expr {$wbot - $wtop}]
5236 if {$ytop < $wtop} {
5237 if {$ybot < $wtop} {
5238 set newtop [expr {$y - $wh / 2.0}]
5241 if {$newtop > $wtop - $linespc} {
5242 set newtop [expr {$wtop - $linespc}]
5245 } elseif {$ybot > $wbot} {
5246 if {$ytop > $wbot} {
5247 set newtop [expr {$y - $wh / 2.0}]
5249 set newtop [expr {$ybot - $wh}]
5250 if {$newtop < $wtop + $linespc} {
5251 set newtop [expr {$wtop + $linespc}]
5255 if {$newtop != $wtop} {
5259 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5266 addtohistory [list selectline $l 0]
5271 set id [commitonrow $l]
5273 $sha1entry delete 0 end
5274 $sha1entry insert 0 $id
5275 $sha1entry selection from 0
5276 $sha1entry selection to end
5279 $ctext conf -state normal
5282 set info $commitinfo($id)
5283 set date [formatdate [lindex $info 2]]
5284 $ctext insert end "Author: [lindex $info 1] $date\n"
5285 set date [formatdate [lindex $info 4]]
5286 $ctext insert end "Committer: [lindex $info 3] $date\n"
5287 if {[info exists idtags($id)]} {
5288 $ctext insert end "Tags:"
5289 foreach tag $idtags($id) {
5290 $ctext insert end " $tag"
5292 $ctext insert end "\n"
5296 set olds $parents($curview,$id)
5297 if {[llength $olds] > 1} {
5300 if {$np >= $mergemax} {
5305 $ctext insert end "Parent: " $tag
5306 appendwithlinks [commit_descriptor $p] {}
5311 append headers "Parent: [commit_descriptor $p]"
5315 foreach c $children($curview,$id) {
5316 append headers "Child: [commit_descriptor $c]"
5319 # make anything that looks like a SHA1 ID be a clickable link
5320 appendwithlinks $headers {}
5321 if {$showneartags} {
5322 if {![info exists allcommits]} {
5325 $ctext insert end "Branch: "
5326 $ctext mark set branch "end -1c"
5327 $ctext mark gravity branch left
5328 $ctext insert end "\nFollows: "
5329 $ctext mark set follows "end -1c"
5330 $ctext mark gravity follows left
5331 $ctext insert end "\nPrecedes: "
5332 $ctext mark set precedes "end -1c"
5333 $ctext mark gravity precedes left
5334 $ctext insert end "\n"
5337 $ctext insert end "\n"
5338 set comment [lindex $info 5]
5339 if {[string first "\r" $comment] >= 0} {
5340 set comment [string map {"\r" "\n "} $comment]
5342 appendwithlinks $comment {comment}
5344 $ctext tag remove found 1.0 end
5345 $ctext conf -state disabled
5346 set commentend [$ctext index "end - 1c"]
5348 init_flist "Comments"
5349 if {$cmitmode eq "tree"} {
5351 } elseif {[llength $olds] <= 1} {
5358 proc selfirstline {} {
5363 proc sellastline {} {
5366 set l [expr {$numcommits - 1}]
5370 proc selnextline {dir} {
5373 if {![info exists selectedline]} return
5374 set l [expr {$selectedline + $dir}]
5379 proc selnextpage {dir} {
5380 global canv linespc selectedline numcommits
5382 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5386 allcanvs yview scroll [expr {$dir * $lpp}] units
5388 if {![info exists selectedline]} return
5389 set l [expr {$selectedline + $dir * $lpp}]
5392 } elseif {$l >= $numcommits} {
5393 set l [expr $numcommits - 1]
5399 proc unselectline {} {
5400 global selectedline currentid
5402 catch {unset selectedline}
5403 catch {unset currentid}
5404 allcanvs delete secsel
5408 proc reselectline {} {
5411 if {[info exists selectedline]} {
5412 selectline $selectedline 0
5416 proc addtohistory {cmd} {
5417 global history historyindex curview
5419 set elt [list $curview $cmd]
5420 if {$historyindex > 0
5421 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5425 if {$historyindex < [llength $history]} {
5426 set history [lreplace $history $historyindex end $elt]
5428 lappend history $elt
5431 if {$historyindex > 1} {
5432 .tf.bar.leftbut conf -state normal
5434 .tf.bar.leftbut conf -state disabled
5436 .tf.bar.rightbut conf -state disabled
5442 set view [lindex $elt 0]
5443 set cmd [lindex $elt 1]
5444 if {$curview != $view} {
5451 global history historyindex
5454 if {$historyindex > 1} {
5455 incr historyindex -1
5456 godo [lindex $history [expr {$historyindex - 1}]]
5457 .tf.bar.rightbut conf -state normal
5459 if {$historyindex <= 1} {
5460 .tf.bar.leftbut conf -state disabled
5465 global history historyindex
5468 if {$historyindex < [llength $history]} {
5469 set cmd [lindex $history $historyindex]
5472 .tf.bar.leftbut conf -state normal
5474 if {$historyindex >= [llength $history]} {
5475 .tf.bar.rightbut conf -state disabled
5480 global treefilelist treeidlist diffids diffmergeid treepending
5481 global nullid nullid2
5484 catch {unset diffmergeid}
5485 if {![info exists treefilelist($id)]} {
5486 if {![info exists treepending]} {
5487 if {$id eq $nullid} {
5488 set cmd [list | git ls-files]
5489 } elseif {$id eq $nullid2} {
5490 set cmd [list | git ls-files --stage -t]
5492 set cmd [list | git ls-tree -r $id]
5494 if {[catch {set gtf [open $cmd r]}]} {
5498 set treefilelist($id) {}
5499 set treeidlist($id) {}
5500 fconfigure $gtf -blocking 0
5501 filerun $gtf [list gettreeline $gtf $id]
5508 proc gettreeline {gtf id} {
5509 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5512 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5513 if {$diffids eq $nullid} {
5516 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5517 set i [string first "\t" $line]
5518 if {$i < 0} continue
5519 set sha1 [lindex $line 2]
5520 set fname [string range $line [expr {$i+1}] end]
5521 if {[string index $fname 0] eq "\""} {
5522 set fname [lindex $fname 0]
5524 lappend treeidlist($id) $sha1
5526 lappend treefilelist($id) $fname
5529 return [expr {$nl >= 1000? 2: 1}]
5533 if {$cmitmode ne "tree"} {
5534 if {![info exists diffmergeid]} {
5535 gettreediffs $diffids
5537 } elseif {$id ne $diffids} {
5546 global treefilelist treeidlist diffids nullid nullid2
5547 global ctext commentend
5549 set i [lsearch -exact $treefilelist($diffids) $f]
5551 puts "oops, $f not in list for id $diffids"
5554 if {$diffids eq $nullid} {
5555 if {[catch {set bf [open $f r]} err]} {
5556 puts "oops, can't read $f: $err"
5560 set blob [lindex $treeidlist($diffids) $i]
5561 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5562 puts "oops, error reading blob $blob: $err"
5566 fconfigure $bf -blocking 0
5567 filerun $bf [list getblobline $bf $diffids]
5568 $ctext config -state normal
5569 clear_ctext $commentend
5570 $ctext insert end "\n"
5571 $ctext insert end "$f\n" filesep
5572 $ctext config -state disabled
5573 $ctext yview $commentend
5577 proc getblobline {bf id} {
5578 global diffids cmitmode ctext
5580 if {$id ne $diffids || $cmitmode ne "tree"} {
5584 $ctext config -state normal
5586 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5587 $ctext insert end "$line\n"
5590 # delete last newline
5591 $ctext delete "end - 2c" "end - 1c"
5595 $ctext config -state disabled
5596 return [expr {$nl >= 1000? 2: 1}]
5599 proc mergediff {id} {
5600 global diffmergeid mdifffd
5603 global limitdiffs viewfiles curview
5607 # this doesn't seem to actually affect anything...
5608 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5609 if {$limitdiffs && $viewfiles($curview) ne {}} {
5610 set cmd [concat $cmd -- $viewfiles($curview)]
5612 if {[catch {set mdf [open $cmd r]} err]} {
5613 error_popup "Error getting merge diffs: $err"
5616 fconfigure $mdf -blocking 0
5617 set mdifffd($id) $mdf
5618 set np [llength $parents($curview,$id)]
5620 filerun $mdf [list getmergediffline $mdf $id $np]
5623 proc getmergediffline {mdf id np} {
5624 global diffmergeid ctext cflist mergemax
5625 global difffilestart mdifffd
5627 $ctext conf -state normal
5629 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5630 if {![info exists diffmergeid] || $id != $diffmergeid
5631 || $mdf != $mdifffd($id)} {
5635 if {[regexp {^diff --cc (.*)} $line match fname]} {
5636 # start of a new file
5637 $ctext insert end "\n"
5638 set here [$ctext index "end - 1c"]
5639 lappend difffilestart $here
5640 add_flist [list $fname]
5641 set l [expr {(78 - [string length $fname]) / 2}]
5642 set pad [string range "----------------------------------------" 1 $l]
5643 $ctext insert end "$pad $fname $pad\n" filesep
5644 } elseif {[regexp {^@@} $line]} {
5645 $ctext insert end "$line\n" hunksep
5646 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5649 # parse the prefix - one ' ', '-' or '+' for each parent
5654 for {set j 0} {$j < $np} {incr j} {
5655 set c [string range $line $j $j]
5658 } elseif {$c == "-"} {
5660 } elseif {$c == "+"} {
5669 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5670 # line doesn't appear in result, parents in $minuses have the line
5671 set num [lindex $minuses 0]
5672 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5673 # line appears in result, parents in $pluses don't have the line
5674 lappend tags mresult
5675 set num [lindex $spaces 0]
5678 if {$num >= $mergemax} {
5683 $ctext insert end "$line\n" $tags
5686 $ctext conf -state disabled
5691 return [expr {$nr >= 1000? 2: 1}]
5694 proc startdiff {ids} {
5695 global treediffs diffids treepending diffmergeid nullid nullid2
5699 catch {unset diffmergeid}
5700 if {![info exists treediffs($ids)] ||
5701 [lsearch -exact $ids $nullid] >= 0 ||
5702 [lsearch -exact $ids $nullid2] >= 0} {
5703 if {![info exists treepending]} {
5711 proc path_filter {filter name} {
5713 set l [string length $p]
5714 if {[string index $p end] eq "/"} {
5715 if {[string compare -length $l $p $name] == 0} {
5719 if {[string compare -length $l $p $name] == 0 &&
5720 ([string length $name] == $l ||
5721 [string index $name $l] eq "/")} {
5729 proc addtocflist {ids} {
5732 add_flist $treediffs($ids)
5736 proc diffcmd {ids flags} {
5737 global nullid nullid2
5739 set i [lsearch -exact $ids $nullid]
5740 set j [lsearch -exact $ids $nullid2]
5742 if {[llength $ids] > 1 && $j < 0} {
5743 # comparing working directory with some specific revision
5744 set cmd [concat | git diff-index $flags]
5746 lappend cmd -R [lindex $ids 1]
5748 lappend cmd [lindex $ids 0]
5751 # comparing working directory with index
5752 set cmd [concat | git diff-files $flags]
5757 } elseif {$j >= 0} {
5758 set cmd [concat | git diff-index --cached $flags]
5759 if {[llength $ids] > 1} {
5760 # comparing index with specific revision
5762 lappend cmd -R [lindex $ids 1]
5764 lappend cmd [lindex $ids 0]
5767 # comparing index with HEAD
5771 set cmd [concat | git diff-tree -r $flags $ids]
5776 proc gettreediffs {ids} {
5777 global treediff treepending
5779 set treepending $ids
5781 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5782 fconfigure $gdtf -blocking 0
5783 filerun $gdtf [list gettreediffline $gdtf $ids]
5786 proc gettreediffline {gdtf ids} {
5787 global treediff treediffs treepending diffids diffmergeid
5788 global cmitmode viewfiles curview limitdiffs
5791 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5792 set i [string first "\t" $line]
5794 set file [string range $line [expr {$i+1}] end]
5795 if {[string index $file 0] eq "\""} {
5796 set file [lindex $file 0]
5798 lappend treediff $file
5802 return [expr {$nr >= 1000? 2: 1}]
5805 if {$limitdiffs && $viewfiles($curview) ne {}} {
5807 foreach f $treediff {
5808 if {[path_filter $viewfiles($curview) $f]} {
5812 set treediffs($ids) $flist
5814 set treediffs($ids) $treediff
5817 if {$cmitmode eq "tree"} {
5819 } elseif {$ids != $diffids} {
5820 if {![info exists diffmergeid]} {
5821 gettreediffs $diffids
5829 # empty string or positive integer
5830 proc diffcontextvalidate {v} {
5831 return [regexp {^(|[1-9][0-9]*)$} $v]
5834 proc diffcontextchange {n1 n2 op} {
5835 global diffcontextstring diffcontext
5837 if {[string is integer -strict $diffcontextstring]} {
5838 if {$diffcontextstring > 0} {
5839 set diffcontext $diffcontextstring
5845 proc getblobdiffs {ids} {
5846 global blobdifffd diffids env
5847 global diffinhdr treediffs
5849 global limitdiffs viewfiles curview
5851 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5852 if {$limitdiffs && $viewfiles($curview) ne {}} {
5853 set cmd [concat $cmd -- $viewfiles($curview)]
5855 if {[catch {set bdf [open $cmd r]} err]} {
5856 puts "error getting diffs: $err"
5860 fconfigure $bdf -blocking 0
5861 set blobdifffd($ids) $bdf
5862 filerun $bdf [list getblobdiffline $bdf $diffids]
5865 proc setinlist {var i val} {
5868 while {[llength [set $var]] < $i} {
5871 if {[llength [set $var]] == $i} {
5878 proc makediffhdr {fname ids} {
5879 global ctext curdiffstart treediffs
5881 set i [lsearch -exact $treediffs($ids) $fname]
5883 setinlist difffilestart $i $curdiffstart
5885 set l [expr {(78 - [string length $fname]) / 2}]
5886 set pad [string range "----------------------------------------" 1 $l]
5887 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5890 proc getblobdiffline {bdf ids} {
5891 global diffids blobdifffd ctext curdiffstart
5892 global diffnexthead diffnextnote difffilestart
5893 global diffinhdr treediffs
5896 $ctext conf -state normal
5897 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5898 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5902 if {![string compare -length 11 "diff --git " $line]} {
5903 # trim off "diff --git "
5904 set line [string range $line 11 end]
5906 # start of a new file
5907 $ctext insert end "\n"
5908 set curdiffstart [$ctext index "end - 1c"]
5909 $ctext insert end "\n" filesep
5910 # If the name hasn't changed the length will be odd,
5911 # the middle char will be a space, and the two bits either
5912 # side will be a/name and b/name, or "a/name" and "b/name".
5913 # If the name has changed we'll get "rename from" and
5914 # "rename to" or "copy from" and "copy to" lines following this,
5915 # and we'll use them to get the filenames.
5916 # This complexity is necessary because spaces in the filename(s)
5917 # don't get escaped.
5918 set l [string length $line]
5919 set i [expr {$l / 2}]
5920 if {!(($l & 1) && [string index $line $i] eq " " &&
5921 [string range $line 2 [expr {$i - 1}]] eq \
5922 [string range $line [expr {$i + 3}] end])} {
5925 # unescape if quoted and chop off the a/ from the front
5926 if {[string index $line 0] eq "\""} {
5927 set fname [string range [lindex $line 0] 2 end]
5929 set fname [string range $line 2 [expr {$i - 1}]]
5931 makediffhdr $fname $ids
5933 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5934 $line match f1l f1c f2l f2c rest]} {
5935 $ctext insert end "$line\n" hunksep
5938 } elseif {$diffinhdr} {
5939 if {![string compare -length 12 "rename from " $line]} {
5940 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5941 if {[string index $fname 0] eq "\""} {
5942 set fname [lindex $fname 0]
5944 set i [lsearch -exact $treediffs($ids) $fname]
5946 setinlist difffilestart $i $curdiffstart
5948 } elseif {![string compare -length 10 $line "rename to "] ||
5949 ![string compare -length 8 $line "copy to "]} {
5950 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5951 if {[string index $fname 0] eq "\""} {
5952 set fname [lindex $fname 0]
5954 makediffhdr $fname $ids
5955 } elseif {[string compare -length 3 $line "---"] == 0} {
5958 } elseif {[string compare -length 3 $line "+++"] == 0} {
5962 $ctext insert end "$line\n" filesep
5965 set x [string range $line 0 0]
5966 if {$x == "-" || $x == "+"} {
5967 set tag [expr {$x == "+"}]
5968 $ctext insert end "$line\n" d$tag
5969 } elseif {$x == " "} {
5970 $ctext insert end "$line\n"
5972 # "\ No newline at end of file",
5973 # or something else we don't recognize
5974 $ctext insert end "$line\n" hunksep
5978 $ctext conf -state disabled
5983 return [expr {$nr >= 1000? 2: 1}]
5986 proc changediffdisp {} {
5987 global ctext diffelide
5989 $ctext tag conf d0 -elide [lindex $diffelide 0]
5990 $ctext tag conf d1 -elide [lindex $diffelide 1]
5994 global difffilestart ctext
5995 set prev [lindex $difffilestart 0]
5996 set here [$ctext index @0,0]
5997 foreach loc $difffilestart {
5998 if {[$ctext compare $loc >= $here]} {
6008 global difffilestart ctext
6009 set here [$ctext index @0,0]
6010 foreach loc $difffilestart {
6011 if {[$ctext compare $loc > $here]} {
6018 proc clear_ctext {{first 1.0}} {
6019 global ctext smarktop smarkbot
6022 set l [lindex [split $first .] 0]
6023 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6026 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6029 $ctext delete $first end
6030 if {$first eq "1.0"} {
6031 catch {unset pendinglinks}
6035 proc settabs {{firstab {}}} {
6036 global firsttabstop tabstop ctext have_tk85
6038 if {$firstab ne {} && $have_tk85} {
6039 set firsttabstop $firstab
6041 set w [font measure textfont "0"]
6042 if {$firsttabstop != 0} {
6043 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6044 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6045 } elseif {$have_tk85 || $tabstop != 8} {
6046 $ctext conf -tabs [expr {$tabstop * $w}]
6048 $ctext conf -tabs {}
6052 proc incrsearch {name ix op} {
6053 global ctext searchstring searchdirn
6055 $ctext tag remove found 1.0 end
6056 if {[catch {$ctext index anchor}]} {
6057 # no anchor set, use start of selection, or of visible area
6058 set sel [$ctext tag ranges sel]
6060 $ctext mark set anchor [lindex $sel 0]
6061 } elseif {$searchdirn eq "-forwards"} {
6062 $ctext mark set anchor @0,0
6064 $ctext mark set anchor @0,[winfo height $ctext]
6067 if {$searchstring ne {}} {
6068 set here [$ctext search $searchdirn -- $searchstring anchor]
6077 global sstring ctext searchstring searchdirn
6080 $sstring icursor end
6081 set searchdirn -forwards
6082 if {$searchstring ne {}} {
6083 set sel [$ctext tag ranges sel]
6085 set start "[lindex $sel 0] + 1c"
6086 } elseif {[catch {set start [$ctext index anchor]}]} {
6089 set match [$ctext search -count mlen -- $searchstring $start]
6090 $ctext tag remove sel 1.0 end
6096 set mend "$match + $mlen c"
6097 $ctext tag add sel $match $mend
6098 $ctext mark unset anchor
6102 proc dosearchback {} {
6103 global sstring ctext searchstring searchdirn
6106 $sstring icursor end
6107 set searchdirn -backwards
6108 if {$searchstring ne {}} {
6109 set sel [$ctext tag ranges sel]
6111 set start [lindex $sel 0]
6112 } elseif {[catch {set start [$ctext index anchor]}]} {
6113 set start @0,[winfo height $ctext]
6115 set match [$ctext search -backwards -count ml -- $searchstring $start]
6116 $ctext tag remove sel 1.0 end
6122 set mend "$match + $ml c"
6123 $ctext tag add sel $match $mend
6124 $ctext mark unset anchor
6128 proc searchmark {first last} {
6129 global ctext searchstring
6133 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6134 if {$match eq {}} break
6135 set mend "$match + $mlen c"
6136 $ctext tag add found $match $mend
6140 proc searchmarkvisible {doall} {
6141 global ctext smarktop smarkbot
6143 set topline [lindex [split [$ctext index @0,0] .] 0]
6144 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6145 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6146 # no overlap with previous
6147 searchmark $topline $botline
6148 set smarktop $topline
6149 set smarkbot $botline
6151 if {$topline < $smarktop} {
6152 searchmark $topline [expr {$smarktop-1}]
6153 set smarktop $topline
6155 if {$botline > $smarkbot} {
6156 searchmark [expr {$smarkbot+1}] $botline
6157 set smarkbot $botline
6162 proc scrolltext {f0 f1} {
6165 .bleft.sb set $f0 $f1
6166 if {$searchstring ne {}} {
6172 global linespc charspc canvx0 canvy0
6173 global xspc1 xspc2 lthickness
6175 set linespc [font metrics mainfont -linespace]
6176 set charspc [font measure mainfont "m"]
6177 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6178 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6179 set lthickness [expr {int($linespc / 9) + 1}]
6180 set xspc1(0) $linespc
6188 set ymax [lindex [$canv cget -scrollregion] 3]
6189 if {$ymax eq {} || $ymax == 0} return
6190 set span [$canv yview]
6193 allcanvs yview moveto [lindex $span 0]
6195 if {[info exists selectedline]} {
6196 selectline $selectedline 0
6197 allcanvs yview moveto [lindex $span 0]
6201 proc parsefont {f n} {
6204 set fontattr($f,family) [lindex $n 0]
6206 if {$s eq {} || $s == 0} {
6209 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6211 set fontattr($f,size) $s
6212 set fontattr($f,weight) normal
6213 set fontattr($f,slant) roman
6214 foreach style [lrange $n 2 end] {
6217 "bold" {set fontattr($f,weight) $style}
6219 "italic" {set fontattr($f,slant) $style}
6224 proc fontflags {f {isbold 0}} {
6227 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6228 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6229 -slant $fontattr($f,slant)]
6235 set n [list $fontattr($f,family) $fontattr($f,size)]
6236 if {$fontattr($f,weight) eq "bold"} {
6239 if {$fontattr($f,slant) eq "italic"} {
6245 proc incrfont {inc} {
6246 global mainfont textfont ctext canv cflist showrefstop
6247 global stopped entries fontattr
6250 set s $fontattr(mainfont,size)
6255 set fontattr(mainfont,size) $s
6256 font config mainfont -size $s
6257 font config mainfontbold -size $s
6258 set mainfont [fontname mainfont]
6259 set s $fontattr(textfont,size)
6264 set fontattr(textfont,size) $s
6265 font config textfont -size $s
6266 font config textfontbold -size $s
6267 set textfont [fontname textfont]
6274 global sha1entry sha1string
6275 if {[string length $sha1string] == 40} {
6276 $sha1entry delete 0 end
6280 proc sha1change {n1 n2 op} {
6281 global sha1string currentid sha1but
6282 if {$sha1string == {}
6283 || ([info exists currentid] && $sha1string == $currentid)} {
6288 if {[$sha1but cget -state] == $state} return
6289 if {$state == "normal"} {
6290 $sha1but conf -state normal -relief raised -text "Goto: "
6292 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
6296 proc gotocommit {} {
6297 global sha1string tagids headids curview varcid
6299 if {$sha1string == {}
6300 || ([info exists currentid] && $sha1string == $currentid)} return
6301 if {[info exists tagids($sha1string)]} {
6302 set id $tagids($sha1string)
6303 } elseif {[info exists headids($sha1string)]} {
6304 set id $headids($sha1string)
6306 set id [string tolower $sha1string]
6307 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6308 set matches [array names varcid "$curview,$id*"]
6309 if {$matches ne {}} {
6310 if {[llength $matches] > 1} {
6311 error_popup "Short SHA1 id $id is ambiguous"
6314 set id [lindex [split [lindex $matches 0] ","] 1]
6318 if {[commitinview $id $curview]} {
6319 selectline [rowofcommit $id] 1
6322 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6327 error_popup "$type $sha1string is not known"
6330 proc lineenter {x y id} {
6331 global hoverx hovery hoverid hovertimer
6332 global commitinfo canv
6334 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6338 if {[info exists hovertimer]} {
6339 after cancel $hovertimer
6341 set hovertimer [after 500 linehover]
6345 proc linemotion {x y id} {
6346 global hoverx hovery hoverid hovertimer
6348 if {[info exists hoverid] && $id == $hoverid} {
6351 if {[info exists hovertimer]} {
6352 after cancel $hovertimer
6354 set hovertimer [after 500 linehover]
6358 proc lineleave {id} {
6359 global hoverid hovertimer canv
6361 if {[info exists hoverid] && $id == $hoverid} {
6363 if {[info exists hovertimer]} {
6364 after cancel $hovertimer
6372 global hoverx hovery hoverid hovertimer
6373 global canv linespc lthickness
6376 set text [lindex $commitinfo($hoverid) 0]
6377 set ymax [lindex [$canv cget -scrollregion] 3]
6378 if {$ymax == {}} return
6379 set yfrac [lindex [$canv yview] 0]
6380 set x [expr {$hoverx + 2 * $linespc}]
6381 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6382 set x0 [expr {$x - 2 * $lthickness}]
6383 set y0 [expr {$y - 2 * $lthickness}]
6384 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6385 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6386 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6387 -fill \#ffff80 -outline black -width 1 -tags hover]
6389 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6394 proc clickisonarrow {id y} {
6397 set ranges [rowranges $id]
6398 set thresh [expr {2 * $lthickness + 6}]
6399 set n [expr {[llength $ranges] - 1}]
6400 for {set i 1} {$i < $n} {incr i} {
6401 set row [lindex $ranges $i]
6402 if {abs([yc $row] - $y) < $thresh} {
6409 proc arrowjump {id n y} {
6412 # 1 <-> 2, 3 <-> 4, etc...
6413 set n [expr {(($n - 1) ^ 1) + 1}]
6414 set row [lindex [rowranges $id] $n]
6416 set ymax [lindex [$canv cget -scrollregion] 3]
6417 if {$ymax eq {} || $ymax <= 0} return
6418 set view [$canv yview]
6419 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6420 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6424 allcanvs yview moveto $yfrac
6427 proc lineclick {x y id isnew} {
6428 global ctext commitinfo children canv thickerline curview
6430 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6435 # draw this line thicker than normal
6439 set ymax [lindex [$canv cget -scrollregion] 3]
6440 if {$ymax eq {}} return
6441 set yfrac [lindex [$canv yview] 0]
6442 set y [expr {$y + $yfrac * $ymax}]
6444 set dirn [clickisonarrow $id $y]
6446 arrowjump $id $dirn $y
6451 addtohistory [list lineclick $x $y $id 0]
6453 # fill the details pane with info about this line
6454 $ctext conf -state normal
6457 $ctext insert end "Parent:\t"
6458 $ctext insert end $id link0
6460 set info $commitinfo($id)
6461 $ctext insert end "\n\t[lindex $info 0]\n"
6462 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
6463 set date [formatdate [lindex $info 2]]
6464 $ctext insert end "\tDate:\t$date\n"
6465 set kids $children($curview,$id)
6467 $ctext insert end "\nChildren:"
6469 foreach child $kids {
6471 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6472 set info $commitinfo($child)
6473 $ctext insert end "\n\t"
6474 $ctext insert end $child link$i
6475 setlink $child link$i
6476 $ctext insert end "\n\t[lindex $info 0]"
6477 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
6478 set date [formatdate [lindex $info 2]]
6479 $ctext insert end "\n\tDate:\t$date\n"
6482 $ctext conf -state disabled
6486 proc normalline {} {
6488 if {[info exists thickerline]} {
6497 if {[commitinview $id $curview]} {
6498 selectline [rowofcommit $id] 1
6504 if {![info exists startmstime]} {
6505 set startmstime [clock clicks -milliseconds]
6507 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6510 proc rowmenu {x y id} {
6511 global rowctxmenu selectedline rowmenuid curview
6512 global nullid nullid2 fakerowmenu mainhead
6516 if {![info exists selectedline]
6517 || [rowofcommit $id] eq $selectedline} {
6522 if {$id ne $nullid && $id ne $nullid2} {
6523 set menu $rowctxmenu
6524 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6526 set menu $fakerowmenu
6528 $menu entryconfigure "Diff this*" -state $state
6529 $menu entryconfigure "Diff selected*" -state $state
6530 $menu entryconfigure "Make patch" -state $state
6531 tk_popup $menu $x $y
6534 proc diffvssel {dirn} {
6535 global rowmenuid selectedline
6537 if {![info exists selectedline]} return
6539 set oldid [commitonrow $selectedline]
6540 set newid $rowmenuid
6542 set oldid $rowmenuid
6543 set newid [commitonrow $selectedline]
6545 addtohistory [list doseldiff $oldid $newid]
6546 doseldiff $oldid $newid
6549 proc doseldiff {oldid newid} {
6553 $ctext conf -state normal
6556 $ctext insert end "From "
6557 $ctext insert end $oldid link0
6558 setlink $oldid link0
6559 $ctext insert end "\n "
6560 $ctext insert end [lindex $commitinfo($oldid) 0]
6561 $ctext insert end "\n\nTo "
6562 $ctext insert end $newid link1
6563 setlink $newid link1
6564 $ctext insert end "\n "
6565 $ctext insert end [lindex $commitinfo($newid) 0]
6566 $ctext insert end "\n"
6567 $ctext conf -state disabled
6568 $ctext tag remove found 1.0 end
6569 startdiff [list $oldid $newid]
6573 global rowmenuid currentid commitinfo patchtop patchnum
6575 if {![info exists currentid]} return
6576 set oldid $currentid
6577 set oldhead [lindex $commitinfo($oldid) 0]
6578 set newid $rowmenuid
6579 set newhead [lindex $commitinfo($newid) 0]
6582 catch {destroy $top}
6584 label $top.title -text "Generate patch"
6585 grid $top.title - -pady 10
6586 label $top.from -text "From:"
6587 entry $top.fromsha1 -width 40 -relief flat
6588 $top.fromsha1 insert 0 $oldid
6589 $top.fromsha1 conf -state readonly
6590 grid $top.from $top.fromsha1 -sticky w
6591 entry $top.fromhead -width 60 -relief flat
6592 $top.fromhead insert 0 $oldhead
6593 $top.fromhead conf -state readonly
6594 grid x $top.fromhead -sticky w
6595 label $top.to -text "To:"
6596 entry $top.tosha1 -width 40 -relief flat
6597 $top.tosha1 insert 0 $newid
6598 $top.tosha1 conf -state readonly
6599 grid $top.to $top.tosha1 -sticky w
6600 entry $top.tohead -width 60 -relief flat
6601 $top.tohead insert 0 $newhead
6602 $top.tohead conf -state readonly
6603 grid x $top.tohead -sticky w
6604 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6605 grid $top.rev x -pady 10
6606 label $top.flab -text "Output file:"
6607 entry $top.fname -width 60
6608 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6610 grid $top.flab $top.fname -sticky w
6612 button $top.buts.gen -text "Generate" -command mkpatchgo
6613 button $top.buts.can -text "Cancel" -command mkpatchcan
6614 grid $top.buts.gen $top.buts.can
6615 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6616 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6617 grid $top.buts - -pady 10 -sticky ew
6621 proc mkpatchrev {} {
6624 set oldid [$patchtop.fromsha1 get]
6625 set oldhead [$patchtop.fromhead get]
6626 set newid [$patchtop.tosha1 get]
6627 set newhead [$patchtop.tohead get]
6628 foreach e [list fromsha1 fromhead tosha1 tohead] \
6629 v [list $newid $newhead $oldid $oldhead] {
6630 $patchtop.$e conf -state normal
6631 $patchtop.$e delete 0 end
6632 $patchtop.$e insert 0 $v
6633 $patchtop.$e conf -state readonly
6638 global patchtop nullid nullid2
6640 set oldid [$patchtop.fromsha1 get]
6641 set newid [$patchtop.tosha1 get]
6642 set fname [$patchtop.fname get]
6643 set cmd [diffcmd [list $oldid $newid] -p]
6644 # trim off the initial "|"
6645 set cmd [lrange $cmd 1 end]
6646 lappend cmd >$fname &
6647 if {[catch {eval exec $cmd} err]} {
6648 error_popup "Error creating patch: $err"
6650 catch {destroy $patchtop}
6654 proc mkpatchcan {} {
6657 catch {destroy $patchtop}
6662 global rowmenuid mktagtop commitinfo
6666 catch {destroy $top}
6668 label $top.title -text "Create tag"
6669 grid $top.title - -pady 10
6670 label $top.id -text "ID:"
6671 entry $top.sha1 -width 40 -relief flat
6672 $top.sha1 insert 0 $rowmenuid
6673 $top.sha1 conf -state readonly
6674 grid $top.id $top.sha1 -sticky w
6675 entry $top.head -width 60 -relief flat
6676 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6677 $top.head conf -state readonly
6678 grid x $top.head -sticky w
6679 label $top.tlab -text "Tag name:"
6680 entry $top.tag -width 60
6681 grid $top.tlab $top.tag -sticky w
6683 button $top.buts.gen -text "Create" -command mktaggo
6684 button $top.buts.can -text "Cancel" -command mktagcan
6685 grid $top.buts.gen $top.buts.can
6686 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6687 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6688 grid $top.buts - -pady 10 -sticky ew
6693 global mktagtop env tagids idtags
6695 set id [$mktagtop.sha1 get]
6696 set tag [$mktagtop.tag get]
6698 error_popup "No tag name specified"
6701 if {[info exists tagids($tag)]} {
6702 error_popup "Tag \"$tag\" already exists"
6707 set fname [file join $dir "refs/tags" $tag]
6708 set f [open $fname w]
6712 error_popup "Error creating tag: $err"
6716 set tagids($tag) $id
6717 lappend idtags($id) $tag
6724 proc redrawtags {id} {
6725 global canv linehtag idpos selectedline curview
6726 global canvxmax iddrawn
6728 if {![commitinview $id $curview]} return
6729 if {![info exists iddrawn($id)]} return
6730 drawcommits [rowofcommit $id]
6731 $canv delete tag.$id
6732 set xt [eval drawtags $id $idpos($id)]
6733 $canv coords $linehtag([rowofcommit $id]) $xt [lindex $idpos($id) 2]
6734 set text [$canv itemcget $linehtag([rowofcommit $id]) -text]
6735 set xr [expr {$xt + [font measure mainfont $text]}]
6736 if {$xr > $canvxmax} {
6740 if {[info exists selectedline]
6741 && $selectedline == [rowofcommit $id]} {
6742 selectline $selectedline 0
6749 catch {destroy $mktagtop}
6758 proc writecommit {} {
6759 global rowmenuid wrcomtop commitinfo wrcomcmd
6761 set top .writecommit
6763 catch {destroy $top}
6765 label $top.title -text "Write commit to file"
6766 grid $top.title - -pady 10
6767 label $top.id -text "ID:"
6768 entry $top.sha1 -width 40 -relief flat
6769 $top.sha1 insert 0 $rowmenuid
6770 $top.sha1 conf -state readonly
6771 grid $top.id $top.sha1 -sticky w
6772 entry $top.head -width 60 -relief flat
6773 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6774 $top.head conf -state readonly
6775 grid x $top.head -sticky w
6776 label $top.clab -text "Command:"
6777 entry $top.cmd -width 60 -textvariable wrcomcmd
6778 grid $top.clab $top.cmd -sticky w -pady 10
6779 label $top.flab -text "Output file:"
6780 entry $top.fname -width 60
6781 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6782 grid $top.flab $top.fname -sticky w
6784 button $top.buts.gen -text "Write" -command wrcomgo
6785 button $top.buts.can -text "Cancel" -command wrcomcan
6786 grid $top.buts.gen $top.buts.can
6787 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6788 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6789 grid $top.buts - -pady 10 -sticky ew
6796 set id [$wrcomtop.sha1 get]
6797 set cmd "echo $id | [$wrcomtop.cmd get]"
6798 set fname [$wrcomtop.fname get]
6799 if {[catch {exec sh -c $cmd >$fname &} err]} {
6800 error_popup "Error writing commit: $err"
6802 catch {destroy $wrcomtop}
6809 catch {destroy $wrcomtop}
6814 global rowmenuid mkbrtop
6817 catch {destroy $top}
6819 label $top.title -text "Create new branch"
6820 grid $top.title - -pady 10
6821 label $top.id -text "ID:"
6822 entry $top.sha1 -width 40 -relief flat
6823 $top.sha1 insert 0 $rowmenuid
6824 $top.sha1 conf -state readonly
6825 grid $top.id $top.sha1 -sticky w
6826 label $top.nlab -text "Name:"
6827 entry $top.name -width 40
6828 grid $top.nlab $top.name -sticky w
6830 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6831 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6832 grid $top.buts.go $top.buts.can
6833 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6834 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6835 grid $top.buts - -pady 10 -sticky ew
6840 global headids idheads
6842 set name [$top.name get]
6843 set id [$top.sha1 get]
6845 error_popup "Please specify a name for the new branch"
6848 catch {destroy $top}
6852 exec git branch $name $id
6857 set headids($name) $id
6858 lappend idheads($id) $name
6867 proc cherrypick {} {
6868 global rowmenuid curview
6871 set oldhead [exec git rev-parse HEAD]
6872 set dheads [descheads $rowmenuid]
6873 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6874 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6875 included in branch $mainhead -- really re-apply it?"]
6878 nowbusy cherrypick "Cherry-picking"
6880 # Unfortunately git-cherry-pick writes stuff to stderr even when
6881 # no error occurs, and exec takes that as an indication of error...
6882 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6887 set newhead [exec git rev-parse HEAD]
6888 if {$newhead eq $oldhead} {
6890 error_popup "No changes committed"
6893 addnewchild $newhead $oldhead
6894 if {[commitinview $oldhead $curview]} {
6895 insertrow $newhead $oldhead $curview
6896 if {$mainhead ne {}} {
6897 movehead $newhead $mainhead
6898 movedhead $newhead $mainhead
6907 global mainheadid mainhead rowmenuid confirm_ok resettype
6910 set w ".confirmreset"
6913 wm title $w "Confirm reset"
6914 message $w.m -text \
6915 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6916 -justify center -aspect 1000
6917 pack $w.m -side top -fill x -padx 20 -pady 20
6918 frame $w.f -relief sunken -border 2
6919 message $w.f.rt -text "Reset type:" -aspect 1000
6920 grid $w.f.rt -sticky w
6922 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6923 -text "Soft: Leave working tree and index untouched"
6924 grid $w.f.soft -sticky w
6925 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6926 -text "Mixed: Leave working tree untouched, reset index"
6927 grid $w.f.mixed -sticky w
6928 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6929 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6930 grid $w.f.hard -sticky w
6931 pack $w.f -side top -fill x
6932 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6933 pack $w.ok -side left -fill x -padx 20 -pady 20
6934 button $w.cancel -text Cancel -command "destroy $w"
6935 pack $w.cancel -side right -fill x -padx 20 -pady 20
6936 bind $w <Visibility> "grab $w; focus $w"
6938 if {!$confirm_ok} return
6939 if {[catch {set fd [open \
6940 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6944 filerun $fd [list readresetstat $fd]
6945 nowbusy reset "Resetting"
6949 proc readresetstat {fd} {
6950 global mainhead mainheadid showlocalchanges rprogcoord
6952 if {[gets $fd line] >= 0} {
6953 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6954 set rprogcoord [expr {1.0 * $m / $n}]
6962 if {[catch {close $fd} err]} {
6965 set oldhead $mainheadid
6966 set newhead [exec git rev-parse HEAD]
6967 if {$newhead ne $oldhead} {
6968 movehead $newhead $mainhead
6969 movedhead $newhead $mainhead
6970 set mainheadid $newhead
6974 if {$showlocalchanges} {
6980 # context menu for a head
6981 proc headmenu {x y id head} {
6982 global headmenuid headmenuhead headctxmenu mainhead
6986 set headmenuhead $head
6988 if {$head eq $mainhead} {
6991 $headctxmenu entryconfigure 0 -state $state
6992 $headctxmenu entryconfigure 1 -state $state
6993 tk_popup $headctxmenu $x $y
6997 global headmenuid headmenuhead mainhead headids
6998 global showlocalchanges mainheadid
7000 # check the tree is clean first??
7001 set oldmainhead $mainhead
7002 nowbusy checkout "Checking out"
7006 exec git checkout -q $headmenuhead
7012 set mainhead $headmenuhead
7013 set mainheadid $headmenuid
7014 if {[info exists headids($oldmainhead)]} {
7015 redrawtags $headids($oldmainhead)
7017 redrawtags $headmenuid
7019 if {$showlocalchanges} {
7025 global headmenuid headmenuhead mainhead
7028 set head $headmenuhead
7030 # this check shouldn't be needed any more...
7031 if {$head eq $mainhead} {
7032 error_popup "Cannot delete the currently checked-out branch"
7035 set dheads [descheads $id]
7036 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7037 # the stuff on this branch isn't on any other branch
7038 if {![confirm_popup "The commits on branch $head aren't on any other\
7039 branch.\nReally delete branch $head?"]} return
7043 if {[catch {exec git branch -D $head} err]} {
7048 removehead $id $head
7049 removedhead $id $head
7056 # Display a list of tags and heads
7058 global showrefstop bgcolor fgcolor selectbgcolor
7059 global bglist fglist reflistfilter reflist maincursor
7062 set showrefstop $top
7063 if {[winfo exists $top]} {
7069 wm title $top "Tags and heads: [file tail [pwd]]"
7070 text $top.list -background $bgcolor -foreground $fgcolor \
7071 -selectbackground $selectbgcolor -font mainfont \
7072 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7073 -width 30 -height 20 -cursor $maincursor \
7074 -spacing1 1 -spacing3 1 -state disabled
7075 $top.list tag configure highlight -background $selectbgcolor
7076 lappend bglist $top.list
7077 lappend fglist $top.list
7078 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7079 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7080 grid $top.list $top.ysb -sticky nsew
7081 grid $top.xsb x -sticky ew
7083 label $top.f.l -text "Filter: " -font uifont
7084 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
7085 set reflistfilter "*"
7086 trace add variable reflistfilter write reflistfilter_change
7087 pack $top.f.e -side right -fill x -expand 1
7088 pack $top.f.l -side left
7089 grid $top.f - -sticky ew -pady 2
7090 button $top.close -command [list destroy $top] -text "Close" \
7093 grid columnconfigure $top 0 -weight 1
7094 grid rowconfigure $top 0 -weight 1
7095 bind $top.list <1> {break}
7096 bind $top.list <B1-Motion> {break}
7097 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7102 proc sel_reflist {w x y} {
7103 global showrefstop reflist headids tagids otherrefids
7105 if {![winfo exists $showrefstop]} return
7106 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7107 set ref [lindex $reflist [expr {$l-1}]]
7108 set n [lindex $ref 0]
7109 switch -- [lindex $ref 1] {
7110 "H" {selbyid $headids($n)}
7111 "T" {selbyid $tagids($n)}
7112 "o" {selbyid $otherrefids($n)}
7114 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7117 proc unsel_reflist {} {
7120 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7121 $showrefstop.list tag remove highlight 0.0 end
7124 proc reflistfilter_change {n1 n2 op} {
7125 global reflistfilter
7127 after cancel refill_reflist
7128 after 200 refill_reflist
7131 proc refill_reflist {} {
7132 global reflist reflistfilter showrefstop headids tagids otherrefids
7133 global curview commitinterest
7135 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7137 foreach n [array names headids] {
7138 if {[string match $reflistfilter $n]} {
7139 if {[commitinview $headids($n) $curview]} {
7140 lappend refs [list $n H]
7142 set commitinterest($headids($n)) {run refill_reflist}
7146 foreach n [array names tagids] {
7147 if {[string match $reflistfilter $n]} {
7148 if {[commitinview $tagids($n) $curview]} {
7149 lappend refs [list $n T]
7151 set commitinterest($tagids($n)) {run refill_reflist}
7155 foreach n [array names otherrefids] {
7156 if {[string match $reflistfilter $n]} {
7157 if {[commitinview $otherrefids($n) $curview]} {
7158 lappend refs [list $n o]
7160 set commitinterest($otherrefids($n)) {run refill_reflist}
7164 set refs [lsort -index 0 $refs]
7165 if {$refs eq $reflist} return
7167 # Update the contents of $showrefstop.list according to the
7168 # differences between $reflist (old) and $refs (new)
7169 $showrefstop.list conf -state normal
7170 $showrefstop.list insert end "\n"
7173 while {$i < [llength $reflist] || $j < [llength $refs]} {
7174 if {$i < [llength $reflist]} {
7175 if {$j < [llength $refs]} {
7176 set cmp [string compare [lindex $reflist $i 0] \
7177 [lindex $refs $j 0]]
7179 set cmp [string compare [lindex $reflist $i 1] \
7180 [lindex $refs $j 1]]
7190 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7198 set l [expr {$j + 1}]
7199 $showrefstop.list image create $l.0 -align baseline \
7200 -image reficon-[lindex $refs $j 1] -padx 2
7201 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7207 # delete last newline
7208 $showrefstop.list delete end-2c end-1c
7209 $showrefstop.list conf -state disabled
7212 # Stuff for finding nearby tags
7213 proc getallcommits {} {
7214 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7215 global idheads idtags idotherrefs allparents tagobjid
7217 if {![info exists allcommits]} {
7223 set allccache [file join [gitdir] "gitk.cache"]
7225 set f [open $allccache r]
7234 set cmd [list | git rev-list --parents]
7235 set allcupdate [expr {$seeds ne {}}]
7239 set refs [concat [array names idheads] [array names idtags] \
7240 [array names idotherrefs]]
7243 foreach name [array names tagobjid] {
7244 lappend tagobjs $tagobjid($name)
7246 foreach id [lsort -unique $refs] {
7247 if {![info exists allparents($id)] &&
7248 [lsearch -exact $tagobjs $id] < 0} {
7259 set fd [open [concat $cmd $ids] r]
7260 fconfigure $fd -blocking 0
7263 filerun $fd [list getallclines $fd]
7269 # Since most commits have 1 parent and 1 child, we group strings of
7270 # such commits into "arcs" joining branch/merge points (BMPs), which
7271 # are commits that either don't have 1 parent or don't have 1 child.
7273 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7274 # arcout(id) - outgoing arcs for BMP
7275 # arcids(a) - list of IDs on arc including end but not start
7276 # arcstart(a) - BMP ID at start of arc
7277 # arcend(a) - BMP ID at end of arc
7278 # growing(a) - arc a is still growing
7279 # arctags(a) - IDs out of arcids (excluding end) that have tags
7280 # archeads(a) - IDs out of arcids (excluding end) that have heads
7281 # The start of an arc is at the descendent end, so "incoming" means
7282 # coming from descendents, and "outgoing" means going towards ancestors.
7284 proc getallclines {fd} {
7285 global allparents allchildren idtags idheads nextarc
7286 global arcnos arcids arctags arcout arcend arcstart archeads growing
7287 global seeds allcommits cachedarcs allcupdate
7290 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7291 set id [lindex $line 0]
7292 if {[info exists allparents($id)]} {
7297 set olds [lrange $line 1 end]
7298 set allparents($id) $olds
7299 if {![info exists allchildren($id)]} {
7300 set allchildren($id) {}
7305 if {[llength $olds] == 1 && [llength $a] == 1} {
7306 lappend arcids($a) $id
7307 if {[info exists idtags($id)]} {
7308 lappend arctags($a) $id
7310 if {[info exists idheads($id)]} {
7311 lappend archeads($a) $id
7313 if {[info exists allparents($olds)]} {
7314 # seen parent already
7315 if {![info exists arcout($olds)]} {
7318 lappend arcids($a) $olds
7319 set arcend($a) $olds
7322 lappend allchildren($olds) $id
7323 lappend arcnos($olds) $a
7327 foreach a $arcnos($id) {
7328 lappend arcids($a) $id
7335 lappend allchildren($p) $id
7336 set a [incr nextarc]
7337 set arcstart($a) $id
7344 if {[info exists allparents($p)]} {
7345 # seen it already, may need to make a new branch
7346 if {![info exists arcout($p)]} {
7349 lappend arcids($a) $p
7353 lappend arcnos($p) $a
7358 global cached_dheads cached_dtags cached_atags
7359 catch {unset cached_dheads}
7360 catch {unset cached_dtags}
7361 catch {unset cached_atags}
7364 return [expr {$nid >= 1000? 2: 1}]
7368 fconfigure $fd -blocking 1
7371 # got an error reading the list of commits
7372 # if we were updating, try rereading the whole thing again
7378 error_popup "Error reading commit topology information;\
7379 branch and preceding/following tag information\
7380 will be incomplete.\n($err)"
7383 if {[incr allcommits -1] == 0} {
7393 proc recalcarc {a} {
7394 global arctags archeads arcids idtags idheads
7398 foreach id [lrange $arcids($a) 0 end-1] {
7399 if {[info exists idtags($id)]} {
7402 if {[info exists idheads($id)]} {
7407 set archeads($a) $ah
7411 global arcnos arcids nextarc arctags archeads idtags idheads
7412 global arcstart arcend arcout allparents growing
7415 if {[llength $a] != 1} {
7416 puts "oops splitarc called but [llength $a] arcs already"
7420 set i [lsearch -exact $arcids($a) $p]
7422 puts "oops splitarc $p not in arc $a"
7425 set na [incr nextarc]
7426 if {[info exists arcend($a)]} {
7427 set arcend($na) $arcend($a)
7429 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7430 set j [lsearch -exact $arcnos($l) $a]
7431 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7433 set tail [lrange $arcids($a) [expr {$i+1}] end]
7434 set arcids($a) [lrange $arcids($a) 0 $i]
7436 set arcstart($na) $p
7438 set arcids($na) $tail
7439 if {[info exists growing($a)]} {
7445 if {[llength $arcnos($id)] == 1} {
7448 set j [lsearch -exact $arcnos($id) $a]
7449 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7453 # reconstruct tags and heads lists
7454 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7459 set archeads($na) {}
7463 # Update things for a new commit added that is a child of one
7464 # existing commit. Used when cherry-picking.
7465 proc addnewchild {id p} {
7466 global allparents allchildren idtags nextarc
7467 global arcnos arcids arctags arcout arcend arcstart archeads growing
7468 global seeds allcommits
7470 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7471 set allparents($id) [list $p]
7472 set allchildren($id) {}
7475 lappend allchildren($p) $id
7476 set a [incr nextarc]
7477 set arcstart($a) $id
7480 set arcids($a) [list $p]
7482 if {![info exists arcout($p)]} {
7485 lappend arcnos($p) $a
7486 set arcout($id) [list $a]
7489 # This implements a cache for the topology information.
7490 # The cache saves, for each arc, the start and end of the arc,
7491 # the ids on the arc, and the outgoing arcs from the end.
7492 proc readcache {f} {
7493 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7494 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7499 if {$lim - $a > 500} {
7500 set lim [expr {$a + 500}]
7504 # finish reading the cache and setting up arctags, etc.
7506 if {$line ne "1"} {error "bad final version"}
7508 foreach id [array names idtags] {
7509 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7510 [llength $allparents($id)] == 1} {
7511 set a [lindex $arcnos($id) 0]
7512 if {$arctags($a) eq {}} {
7517 foreach id [array names idheads] {
7518 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7519 [llength $allparents($id)] == 1} {
7520 set a [lindex $arcnos($id) 0]
7521 if {$archeads($a) eq {}} {
7526 foreach id [lsort -unique $possible_seeds] {
7527 if {$arcnos($id) eq {}} {
7533 while {[incr a] <= $lim} {
7535 if {[llength $line] != 3} {error "bad line"}
7536 set s [lindex $line 0]
7538 lappend arcout($s) $a
7539 if {![info exists arcnos($s)]} {
7540 lappend possible_seeds $s
7543 set e [lindex $line 1]
7548 if {![info exists arcout($e)]} {
7552 set arcids($a) [lindex $line 2]
7553 foreach id $arcids($a) {
7554 lappend allparents($s) $id
7556 lappend arcnos($id) $a
7558 if {![info exists allparents($s)]} {
7559 set allparents($s) {}
7564 set nextarc [expr {$a - 1}]
7577 global nextarc cachedarcs possible_seeds
7581 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7582 # make sure it's an integer
7583 set cachedarcs [expr {int([lindex $line 1])}]
7584 if {$cachedarcs < 0} {error "bad number of arcs"}
7586 set possible_seeds {}
7594 proc dropcache {err} {
7595 global allcwait nextarc cachedarcs seeds
7597 #puts "dropping cache ($err)"
7598 foreach v {arcnos arcout arcids arcstart arcend growing \
7599 arctags archeads allparents allchildren} {
7610 proc writecache {f} {
7611 global cachearc cachedarcs allccache
7612 global arcstart arcend arcnos arcids arcout
7616 if {$lim - $a > 1000} {
7617 set lim [expr {$a + 1000}]
7620 while {[incr a] <= $lim} {
7621 if {[info exists arcend($a)]} {
7622 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7624 puts $f [list $arcstart($a) {} $arcids($a)]
7629 catch {file delete $allccache}
7630 #puts "writing cache failed ($err)"
7633 set cachearc [expr {$a - 1}]
7634 if {$a > $cachedarcs} {
7643 global nextarc cachedarcs cachearc allccache
7645 if {$nextarc == $cachedarcs} return
7647 set cachedarcs $nextarc
7649 set f [open $allccache w]
7650 puts $f [list 1 $cachedarcs]
7655 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7656 # or 0 if neither is true.
7657 proc anc_or_desc {a b} {
7658 global arcout arcstart arcend arcnos cached_isanc
7660 if {$arcnos($a) eq $arcnos($b)} {
7661 # Both are on the same arc(s); either both are the same BMP,
7662 # or if one is not a BMP, the other is also not a BMP or is
7663 # the BMP at end of the arc (and it only has 1 incoming arc).
7664 # Or both can be BMPs with no incoming arcs.
7665 if {$a eq $b || $arcnos($a) eq {}} {
7668 # assert {[llength $arcnos($a)] == 1}
7669 set arc [lindex $arcnos($a) 0]
7670 set i [lsearch -exact $arcids($arc) $a]
7671 set j [lsearch -exact $arcids($arc) $b]
7672 if {$i < 0 || $i > $j} {
7679 if {![info exists arcout($a)]} {
7680 set arc [lindex $arcnos($a) 0]
7681 if {[info exists arcend($arc)]} {
7682 set aend $arcend($arc)
7686 set a $arcstart($arc)
7690 if {![info exists arcout($b)]} {
7691 set arc [lindex $arcnos($b) 0]
7692 if {[info exists arcend($arc)]} {
7693 set bend $arcend($arc)
7697 set b $arcstart($arc)
7707 if {[info exists cached_isanc($a,$bend)]} {
7708 if {$cached_isanc($a,$bend)} {
7712 if {[info exists cached_isanc($b,$aend)]} {
7713 if {$cached_isanc($b,$aend)} {
7716 if {[info exists cached_isanc($a,$bend)]} {
7721 set todo [list $a $b]
7724 for {set i 0} {$i < [llength $todo]} {incr i} {
7725 set x [lindex $todo $i]
7726 if {$anc($x) eq {}} {
7729 foreach arc $arcnos($x) {
7730 set xd $arcstart($arc)
7732 set cached_isanc($a,$bend) 1
7733 set cached_isanc($b,$aend) 0
7735 } elseif {$xd eq $aend} {
7736 set cached_isanc($b,$aend) 1
7737 set cached_isanc($a,$bend) 0
7740 if {![info exists anc($xd)]} {
7741 set anc($xd) $anc($x)
7743 } elseif {$anc($xd) ne $anc($x)} {
7748 set cached_isanc($a,$bend) 0
7749 set cached_isanc($b,$aend) 0
7753 # This identifies whether $desc has an ancestor that is
7754 # a growing tip of the graph and which is not an ancestor of $anc
7755 # and returns 0 if so and 1 if not.
7756 # If we subsequently discover a tag on such a growing tip, and that
7757 # turns out to be a descendent of $anc (which it could, since we
7758 # don't necessarily see children before parents), then $desc
7759 # isn't a good choice to display as a descendent tag of
7760 # $anc (since it is the descendent of another tag which is
7761 # a descendent of $anc). Similarly, $anc isn't a good choice to
7762 # display as a ancestor tag of $desc.
7764 proc is_certain {desc anc} {
7765 global arcnos arcout arcstart arcend growing problems
7768 if {[llength $arcnos($anc)] == 1} {
7769 # tags on the same arc are certain
7770 if {$arcnos($desc) eq $arcnos($anc)} {
7773 if {![info exists arcout($anc)]} {
7774 # if $anc is partway along an arc, use the start of the arc instead
7775 set a [lindex $arcnos($anc) 0]
7776 set anc $arcstart($a)
7779 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7782 set a [lindex $arcnos($desc) 0]
7788 set anclist [list $x]
7792 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7793 set x [lindex $anclist $i]
7798 foreach a $arcout($x) {
7799 if {[info exists growing($a)]} {
7800 if {![info exists growanc($x)] && $dl($x)} {
7806 if {[info exists dl($y)]} {
7810 if {![info exists done($y)]} {
7813 if {[info exists growanc($x)]} {
7817 for {set k 0} {$k < [llength $xl]} {incr k} {
7818 set z [lindex $xl $k]
7819 foreach c $arcout($z) {
7820 if {[info exists arcend($c)]} {
7822 if {[info exists dl($v)] && $dl($v)} {
7824 if {![info exists done($v)]} {
7827 if {[info exists growanc($v)]} {
7837 } elseif {$y eq $anc || !$dl($x)} {
7848 foreach x [array names growanc] {
7857 proc validate_arctags {a} {
7858 global arctags idtags
7862 foreach id $arctags($a) {
7864 if {![info exists idtags($id)]} {
7865 set na [lreplace $na $i $i]
7872 proc validate_archeads {a} {
7873 global archeads idheads
7876 set na $archeads($a)
7877 foreach id $archeads($a) {
7879 if {![info exists idheads($id)]} {
7880 set na [lreplace $na $i $i]
7884 set archeads($a) $na
7887 # Return the list of IDs that have tags that are descendents of id,
7888 # ignoring IDs that are descendents of IDs already reported.
7889 proc desctags {id} {
7890 global arcnos arcstart arcids arctags idtags allparents
7891 global growing cached_dtags
7893 if {![info exists allparents($id)]} {
7896 set t1 [clock clicks -milliseconds]
7898 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7899 # part-way along an arc; check that arc first
7900 set a [lindex $arcnos($id) 0]
7901 if {$arctags($a) ne {}} {
7903 set i [lsearch -exact $arcids($a) $id]
7905 foreach t $arctags($a) {
7906 set j [lsearch -exact $arcids($a) $t]
7914 set id $arcstart($a)
7915 if {[info exists idtags($id)]} {
7919 if {[info exists cached_dtags($id)]} {
7920 return $cached_dtags($id)
7927 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7928 set id [lindex $todo $i]
7930 set ta [info exists hastaggedancestor($id)]
7934 # ignore tags on starting node
7935 if {!$ta && $i > 0} {
7936 if {[info exists idtags($id)]} {
7939 } elseif {[info exists cached_dtags($id)]} {
7940 set tagloc($id) $cached_dtags($id)
7944 foreach a $arcnos($id) {
7946 if {!$ta && $arctags($a) ne {}} {
7948 if {$arctags($a) ne {}} {
7949 lappend tagloc($id) [lindex $arctags($a) end]
7952 if {$ta || $arctags($a) ne {}} {
7953 set tomark [list $d]
7954 for {set j 0} {$j < [llength $tomark]} {incr j} {
7955 set dd [lindex $tomark $j]
7956 if {![info exists hastaggedancestor($dd)]} {
7957 if {[info exists done($dd)]} {
7958 foreach b $arcnos($dd) {
7959 lappend tomark $arcstart($b)
7961 if {[info exists tagloc($dd)]} {
7964 } elseif {[info exists queued($dd)]} {
7967 set hastaggedancestor($dd) 1
7971 if {![info exists queued($d)]} {
7974 if {![info exists hastaggedancestor($d)]} {
7981 foreach id [array names tagloc] {
7982 if {![info exists hastaggedancestor($id)]} {
7983 foreach t $tagloc($id) {
7984 if {[lsearch -exact $tags $t] < 0} {
7990 set t2 [clock clicks -milliseconds]
7993 # remove tags that are descendents of other tags
7994 for {set i 0} {$i < [llength $tags]} {incr i} {
7995 set a [lindex $tags $i]
7996 for {set j 0} {$j < $i} {incr j} {
7997 set b [lindex $tags $j]
7998 set r [anc_or_desc $a $b]
8000 set tags [lreplace $tags $j $j]
8003 } elseif {$r == -1} {
8004 set tags [lreplace $tags $i $i]
8011 if {[array names growing] ne {}} {
8012 # graph isn't finished, need to check if any tag could get
8013 # eclipsed by another tag coming later. Simply ignore any
8014 # tags that could later get eclipsed.
8017 if {[is_certain $t $origid]} {
8021 if {$tags eq $ctags} {
8022 set cached_dtags($origid) $tags
8027 set cached_dtags($origid) $tags
8029 set t3 [clock clicks -milliseconds]
8030 if {0 && $t3 - $t1 >= 100} {
8031 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8032 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8038 global arcnos arcids arcout arcend arctags idtags allparents
8039 global growing cached_atags
8041 if {![info exists allparents($id)]} {
8044 set t1 [clock clicks -milliseconds]
8046 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8047 # part-way along an arc; check that arc first
8048 set a [lindex $arcnos($id) 0]
8049 if {$arctags($a) ne {}} {
8051 set i [lsearch -exact $arcids($a) $id]
8052 foreach t $arctags($a) {
8053 set j [lsearch -exact $arcids($a) $t]
8059 if {![info exists arcend($a)]} {
8063 if {[info exists idtags($id)]} {
8067 if {[info exists cached_atags($id)]} {
8068 return $cached_atags($id)
8076 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8077 set id [lindex $todo $i]
8079 set td [info exists hastaggeddescendent($id)]
8083 # ignore tags on starting node
8084 if {!$td && $i > 0} {
8085 if {[info exists idtags($id)]} {
8088 } elseif {[info exists cached_atags($id)]} {
8089 set tagloc($id) $cached_atags($id)
8093 foreach a $arcout($id) {
8094 if {!$td && $arctags($a) ne {}} {
8096 if {$arctags($a) ne {}} {
8097 lappend tagloc($id) [lindex $arctags($a) 0]
8100 if {![info exists arcend($a)]} continue
8102 if {$td || $arctags($a) ne {}} {
8103 set tomark [list $d]
8104 for {set j 0} {$j < [llength $tomark]} {incr j} {
8105 set dd [lindex $tomark $j]
8106 if {![info exists hastaggeddescendent($dd)]} {
8107 if {[info exists done($dd)]} {
8108 foreach b $arcout($dd) {
8109 if {[info exists arcend($b)]} {
8110 lappend tomark $arcend($b)
8113 if {[info exists tagloc($dd)]} {
8116 } elseif {[info exists queued($dd)]} {
8119 set hastaggeddescendent($dd) 1
8123 if {![info exists queued($d)]} {
8126 if {![info exists hastaggeddescendent($d)]} {
8132 set t2 [clock clicks -milliseconds]
8135 foreach id [array names tagloc] {
8136 if {![info exists hastaggeddescendent($id)]} {
8137 foreach t $tagloc($id) {
8138 if {[lsearch -exact $tags $t] < 0} {
8145 # remove tags that are ancestors of other tags
8146 for {set i 0} {$i < [llength $tags]} {incr i} {
8147 set a [lindex $tags $i]
8148 for {set j 0} {$j < $i} {incr j} {
8149 set b [lindex $tags $j]
8150 set r [anc_or_desc $a $b]
8152 set tags [lreplace $tags $j $j]
8155 } elseif {$r == 1} {
8156 set tags [lreplace $tags $i $i]
8163 if {[array names growing] ne {}} {
8164 # graph isn't finished, need to check if any tag could get
8165 # eclipsed by another tag coming later. Simply ignore any
8166 # tags that could later get eclipsed.
8169 if {[is_certain $origid $t]} {
8173 if {$tags eq $ctags} {
8174 set cached_atags($origid) $tags
8179 set cached_atags($origid) $tags
8181 set t3 [clock clicks -milliseconds]
8182 if {0 && $t3 - $t1 >= 100} {
8183 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8184 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8189 # Return the list of IDs that have heads that are descendents of id,
8190 # including id itself if it has a head.
8191 proc descheads {id} {
8192 global arcnos arcstart arcids archeads idheads cached_dheads
8195 if {![info exists allparents($id)]} {
8199 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8200 # part-way along an arc; check it first
8201 set a [lindex $arcnos($id) 0]
8202 if {$archeads($a) ne {}} {
8203 validate_archeads $a
8204 set i [lsearch -exact $arcids($a) $id]
8205 foreach t $archeads($a) {
8206 set j [lsearch -exact $arcids($a) $t]
8211 set id $arcstart($a)
8217 for {set i 0} {$i < [llength $todo]} {incr i} {
8218 set id [lindex $todo $i]
8219 if {[info exists cached_dheads($id)]} {
8220 set ret [concat $ret $cached_dheads($id)]
8222 if {[info exists idheads($id)]} {
8225 foreach a $arcnos($id) {
8226 if {$archeads($a) ne {}} {
8227 validate_archeads $a
8228 if {$archeads($a) ne {}} {
8229 set ret [concat $ret $archeads($a)]
8233 if {![info exists seen($d)]} {
8240 set ret [lsort -unique $ret]
8241 set cached_dheads($origid) $ret
8242 return [concat $ret $aret]
8245 proc addedtag {id} {
8246 global arcnos arcout cached_dtags cached_atags
8248 if {![info exists arcnos($id)]} return
8249 if {![info exists arcout($id)]} {
8250 recalcarc [lindex $arcnos($id) 0]
8252 catch {unset cached_dtags}
8253 catch {unset cached_atags}
8256 proc addedhead {hid head} {
8257 global arcnos arcout cached_dheads
8259 if {![info exists arcnos($hid)]} return
8260 if {![info exists arcout($hid)]} {
8261 recalcarc [lindex $arcnos($hid) 0]
8263 catch {unset cached_dheads}
8266 proc removedhead {hid head} {
8267 global cached_dheads
8269 catch {unset cached_dheads}
8272 proc movedhead {hid head} {
8273 global arcnos arcout cached_dheads
8275 if {![info exists arcnos($hid)]} return
8276 if {![info exists arcout($hid)]} {
8277 recalcarc [lindex $arcnos($hid) 0]
8279 catch {unset cached_dheads}
8282 proc changedrefs {} {
8283 global cached_dheads cached_dtags cached_atags
8284 global arctags archeads arcnos arcout idheads idtags
8286 foreach id [concat [array names idheads] [array names idtags]] {
8287 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8288 set a [lindex $arcnos($id) 0]
8289 if {![info exists donearc($a)]} {
8295 catch {unset cached_dtags}
8296 catch {unset cached_atags}
8297 catch {unset cached_dheads}
8300 proc rereadrefs {} {
8301 global idtags idheads idotherrefs mainhead
8303 set refids [concat [array names idtags] \
8304 [array names idheads] [array names idotherrefs]]
8305 foreach id $refids {
8306 if {![info exists ref($id)]} {
8307 set ref($id) [listrefs $id]
8310 set oldmainhead $mainhead
8313 set refids [lsort -unique [concat $refids [array names idtags] \
8314 [array names idheads] [array names idotherrefs]]]
8315 foreach id $refids {
8316 set v [listrefs $id]
8317 if {![info exists ref($id)] || $ref($id) != $v ||
8318 ($id eq $oldmainhead && $id ne $mainhead) ||
8319 ($id eq $mainhead && $id ne $oldmainhead)} {
8326 proc listrefs {id} {
8327 global idtags idheads idotherrefs
8330 if {[info exists idtags($id)]} {
8334 if {[info exists idheads($id)]} {
8338 if {[info exists idotherrefs($id)]} {
8339 set z $idotherrefs($id)
8341 return [list $x $y $z]
8344 proc showtag {tag isnew} {
8345 global ctext tagcontents tagids linknum tagobjid
8348 addtohistory [list showtag $tag 0]
8350 $ctext conf -state normal
8354 if {![info exists tagcontents($tag)]} {
8356 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8359 if {[info exists tagcontents($tag)]} {
8360 set text $tagcontents($tag)
8362 set text "Tag: $tag\nId: $tagids($tag)"
8364 appendwithlinks $text {}
8365 $ctext conf -state disabled
8376 proc mkfontdisp {font top which} {
8377 global fontattr fontpref $font
8379 set fontpref($font) [set $font]
8380 button $top.${font}but -text $which -font optionfont \
8381 -command [list choosefont $font $which]
8382 label $top.$font -relief flat -font $font \
8383 -text $fontattr($font,family) -justify left
8384 grid x $top.${font}but $top.$font -sticky w
8387 proc choosefont {font which} {
8388 global fontparam fontlist fonttop fontattr
8390 set fontparam(which) $which
8391 set fontparam(font) $font
8392 set fontparam(family) [font actual $font -family]
8393 set fontparam(size) $fontattr($font,size)
8394 set fontparam(weight) $fontattr($font,weight)
8395 set fontparam(slant) $fontattr($font,slant)
8398 if {![winfo exists $top]} {
8400 eval font config sample [font actual $font]
8402 wm title $top "Gitk font chooser"
8403 label $top.l -textvariable fontparam(which) -font uifont
8404 pack $top.l -side top
8405 set fontlist [lsort [font families]]
8407 listbox $top.f.fam -listvariable fontlist \
8408 -yscrollcommand [list $top.f.sb set]
8409 bind $top.f.fam <<ListboxSelect>> selfontfam
8410 scrollbar $top.f.sb -command [list $top.f.fam yview]
8411 pack $top.f.sb -side right -fill y
8412 pack $top.f.fam -side left -fill both -expand 1
8413 pack $top.f -side top -fill both -expand 1
8415 spinbox $top.g.size -from 4 -to 40 -width 4 \
8416 -textvariable fontparam(size) \
8417 -validatecommand {string is integer -strict %s}
8418 checkbutton $top.g.bold -padx 5 \
8419 -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
8420 -variable fontparam(weight) -onvalue bold -offvalue normal
8421 checkbutton $top.g.ital -padx 5 \
8422 -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0 \
8423 -variable fontparam(slant) -onvalue italic -offvalue roman
8424 pack $top.g.size $top.g.bold $top.g.ital -side left
8425 pack $top.g -side top
8426 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8428 $top.c create text 100 25 -anchor center -text $which -font sample \
8429 -fill black -tags text
8430 bind $top.c <Configure> [list centertext $top.c]
8431 pack $top.c -side top -fill x
8433 button $top.buts.ok -text "OK" -command fontok -default active \
8435 button $top.buts.can -text "Cancel" -command fontcan -default normal \
8437 grid $top.buts.ok $top.buts.can
8438 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8439 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8440 pack $top.buts -side bottom -fill x
8441 trace add variable fontparam write chg_fontparam
8444 $top.c itemconf text -text $which
8446 set i [lsearch -exact $fontlist $fontparam(family)]
8448 $top.f.fam selection set $i
8453 proc centertext {w} {
8454 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8458 global fontparam fontpref prefstop
8460 set f $fontparam(font)
8461 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8462 if {$fontparam(weight) eq "bold"} {
8463 lappend fontpref($f) "bold"
8465 if {$fontparam(slant) eq "italic"} {
8466 lappend fontpref($f) "italic"
8469 $w conf -text $fontparam(family) -font $fontpref($f)
8475 global fonttop fontparam
8477 if {[info exists fonttop]} {
8478 catch {destroy $fonttop}
8479 catch {font delete sample}
8485 proc selfontfam {} {
8486 global fonttop fontparam
8488 set i [$fonttop.f.fam curselection]
8490 set fontparam(family) [$fonttop.f.fam get $i]
8494 proc chg_fontparam {v sub op} {
8497 font config sample -$sub $fontparam($sub)
8501 global maxwidth maxgraphpct
8502 global oldprefs prefstop showneartags showlocalchanges
8503 global bgcolor fgcolor ctext diffcolors selectbgcolor
8504 global uifont tabstop limitdiffs
8508 if {[winfo exists $top]} {
8512 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8513 limitdiffs tabstop} {
8514 set oldprefs($v) [set $v]
8517 wm title $top "Gitk preferences"
8518 label $top.ldisp -text "Commit list display options"
8519 $top.ldisp configure -font uifont
8520 grid $top.ldisp - -sticky w -pady 10
8521 label $top.spacer -text " "
8522 label $top.maxwidthl -text "Maximum graph width (lines)" \
8524 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8525 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8526 label $top.maxpctl -text "Maximum graph width (% of pane)" \
8528 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8529 grid x $top.maxpctl $top.maxpct -sticky w
8530 frame $top.showlocal
8531 label $top.showlocal.l -text "Show local changes" -font optionfont
8532 checkbutton $top.showlocal.b -variable showlocalchanges
8533 pack $top.showlocal.b $top.showlocal.l -side left
8534 grid x $top.showlocal -sticky w
8536 label $top.ddisp -text "Diff display options"
8537 $top.ddisp configure -font uifont
8538 grid $top.ddisp - -sticky w -pady 10
8539 label $top.tabstopl -text "Tab spacing" -font optionfont
8540 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8541 grid x $top.tabstopl $top.tabstop -sticky w
8543 label $top.ntag.l -text "Display nearby tags" -font optionfont
8544 checkbutton $top.ntag.b -variable showneartags
8545 pack $top.ntag.b $top.ntag.l -side left
8546 grid x $top.ntag -sticky w
8548 label $top.ldiff.l -text "Limit diffs to listed paths" -font optionfont
8549 checkbutton $top.ldiff.b -variable limitdiffs
8550 pack $top.ldiff.b $top.ldiff.l -side left
8551 grid x $top.ldiff -sticky w
8553 label $top.cdisp -text "Colors: press to choose"
8554 $top.cdisp configure -font uifont
8555 grid $top.cdisp - -sticky w -pady 10
8556 label $top.bg -padx 40 -relief sunk -background $bgcolor
8557 button $top.bgbut -text "Background" -font optionfont \
8558 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8559 grid x $top.bgbut $top.bg -sticky w
8560 label $top.fg -padx 40 -relief sunk -background $fgcolor
8561 button $top.fgbut -text "Foreground" -font optionfont \
8562 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8563 grid x $top.fgbut $top.fg -sticky w
8564 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8565 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8566 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8567 [list $ctext tag conf d0 -foreground]]
8568 grid x $top.diffoldbut $top.diffold -sticky w
8569 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8570 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8571 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8572 [list $ctext tag conf d1 -foreground]]
8573 grid x $top.diffnewbut $top.diffnew -sticky w
8574 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8575 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8576 -command [list choosecolor diffcolors 2 $top.hunksep \
8577 "diff hunk header" \
8578 [list $ctext tag conf hunksep -foreground]]
8579 grid x $top.hunksepbut $top.hunksep -sticky w
8580 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8581 button $top.selbgbut -text "Select bg" -font optionfont \
8582 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8583 grid x $top.selbgbut $top.selbgsep -sticky w
8585 label $top.cfont -text "Fonts: press to choose"
8586 $top.cfont configure -font uifont
8587 grid $top.cfont - -sticky w -pady 10
8588 mkfontdisp mainfont $top "Main font"
8589 mkfontdisp textfont $top "Diff display font"
8590 mkfontdisp uifont $top "User interface font"
8593 button $top.buts.ok -text "OK" -command prefsok -default active
8594 $top.buts.ok configure -font uifont
8595 button $top.buts.can -text "Cancel" -command prefscan -default normal
8596 $top.buts.can configure -font uifont
8597 grid $top.buts.ok $top.buts.can
8598 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8599 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8600 grid $top.buts - - -pady 10 -sticky ew
8601 bind $top <Visibility> "focus $top.buts.ok"
8604 proc choosecolor {v vi w x cmd} {
8607 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8608 -title "Gitk: choose color for $x"]
8609 if {$c eq {}} return
8610 $w conf -background $c
8616 global bglist cflist
8618 $w configure -selectbackground $c
8620 $cflist tag configure highlight \
8621 -background [$cflist cget -selectbackground]
8622 allcanvs itemconf secsel -fill $c
8629 $w conf -background $c
8637 $w conf -foreground $c
8639 allcanvs itemconf text -fill $c
8640 $canv itemconf circle -outline $c
8644 global oldprefs prefstop
8646 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8647 limitdiffs tabstop} {
8649 set $v $oldprefs($v)
8651 catch {destroy $prefstop}
8657 global maxwidth maxgraphpct
8658 global oldprefs prefstop showneartags showlocalchanges
8659 global fontpref mainfont textfont uifont
8660 global limitdiffs treediffs
8662 catch {destroy $prefstop}
8666 if {$mainfont ne $fontpref(mainfont)} {
8667 set mainfont $fontpref(mainfont)
8668 parsefont mainfont $mainfont
8669 eval font configure mainfont [fontflags mainfont]
8670 eval font configure mainfontbold [fontflags mainfont 1]
8674 if {$textfont ne $fontpref(textfont)} {
8675 set textfont $fontpref(textfont)
8676 parsefont textfont $textfont
8677 eval font configure textfont [fontflags textfont]
8678 eval font configure textfontbold [fontflags textfont 1]
8680 if {$uifont ne $fontpref(uifont)} {
8681 set uifont $fontpref(uifont)
8682 parsefont uifont $uifont
8683 eval font configure uifont [fontflags uifont]
8686 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8687 if {$showlocalchanges} {
8693 if {$limitdiffs != $oldprefs(limitdiffs)} {
8694 # treediffs elements are limited by path
8695 catch {unset treediffs}
8697 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8698 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8700 } elseif {$showneartags != $oldprefs(showneartags) ||
8701 $limitdiffs != $oldprefs(limitdiffs)} {
8706 proc formatdate {d} {
8707 global datetimeformat
8709 set d [clock format $d -format $datetimeformat]
8714 # This list of encoding names and aliases is distilled from
8715 # http://www.iana.org/assignments/character-sets.
8716 # Not all of them are supported by Tcl.
8717 set encoding_aliases {
8718 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8719 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8720 { ISO-10646-UTF-1 csISO10646UTF1 }
8721 { ISO_646.basic:1983 ref csISO646basic1983 }
8722 { INVARIANT csINVARIANT }
8723 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8724 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8725 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8726 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8727 { NATS-DANO iso-ir-9-1 csNATSDANO }
8728 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8729 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8730 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8731 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8732 { ISO-2022-KR csISO2022KR }
8734 { ISO-2022-JP csISO2022JP }
8735 { ISO-2022-JP-2 csISO2022JP2 }
8736 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8738 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8739 { IT iso-ir-15 ISO646-IT csISO15Italian }
8740 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8741 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8742 { greek7-old iso-ir-18 csISO18Greek7Old }
8743 { latin-greek iso-ir-19 csISO19LatinGreek }
8744 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8745 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8746 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8747 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8748 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8749 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8750 { INIS iso-ir-49 csISO49INIS }
8751 { INIS-8 iso-ir-50 csISO50INIS8 }
8752 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8753 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8754 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8755 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8756 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8757 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8759 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8760 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8761 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8762 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8763 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8764 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8765 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8766 { greek7 iso-ir-88 csISO88Greek7 }
8767 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8768 { iso-ir-90 csISO90 }
8769 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8770 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8771 csISO92JISC62991984b }
8772 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8773 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8774 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8775 csISO95JIS62291984handadd }
8776 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8777 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8778 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8779 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8781 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8782 { T.61-7bit iso-ir-102 csISO102T617bit }
8783 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8784 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8785 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8786 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8787 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8788 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8789 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8790 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8791 arabic csISOLatinArabic }
8792 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8793 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8794 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8795 greek greek8 csISOLatinGreek }
8796 { T.101-G2 iso-ir-128 csISO128T101G2 }
8797 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8799 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8800 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8801 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8802 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8803 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8804 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8805 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8806 csISOLatinCyrillic }
8807 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8808 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8809 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8810 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8811 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8812 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8813 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8814 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8815 { ISO_10367-box iso-ir-155 csISO10367Box }
8816 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8817 { latin-lap lap iso-ir-158 csISO158Lap }
8818 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8819 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8822 { JIS_X0201 X0201 csHalfWidthKatakana }
8823 { KSC5636 ISO646-KR csKSC5636 }
8824 { ISO-10646-UCS-2 csUnicode }
8825 { ISO-10646-UCS-4 csUCS4 }
8826 { DEC-MCS dec csDECMCS }
8827 { hp-roman8 roman8 r8 csHPRoman8 }
8828 { macintosh mac csMacintosh }
8829 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8831 { IBM038 EBCDIC-INT cp038 csIBM038 }
8832 { IBM273 CP273 csIBM273 }
8833 { IBM274 EBCDIC-BE CP274 csIBM274 }
8834 { IBM275 EBCDIC-BR cp275 csIBM275 }
8835 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8836 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8837 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8838 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8839 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8840 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8841 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8842 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8843 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8844 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8845 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8846 { IBM437 cp437 437 csPC8CodePage437 }
8847 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8848 { IBM775 cp775 csPC775Baltic }
8849 { IBM850 cp850 850 csPC850Multilingual }
8850 { IBM851 cp851 851 csIBM851 }
8851 { IBM852 cp852 852 csPCp852 }
8852 { IBM855 cp855 855 csIBM855 }
8853 { IBM857 cp857 857 csIBM857 }
8854 { IBM860 cp860 860 csIBM860 }
8855 { IBM861 cp861 861 cp-is csIBM861 }
8856 { IBM862 cp862 862 csPC862LatinHebrew }
8857 { IBM863 cp863 863 csIBM863 }
8858 { IBM864 cp864 csIBM864 }
8859 { IBM865 cp865 865 csIBM865 }
8860 { IBM866 cp866 866 csIBM866 }
8861 { IBM868 CP868 cp-ar csIBM868 }
8862 { IBM869 cp869 869 cp-gr csIBM869 }
8863 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8864 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8865 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8866 { IBM891 cp891 csIBM891 }
8867 { IBM903 cp903 csIBM903 }
8868 { IBM904 cp904 904 csIBBM904 }
8869 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8870 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8871 { IBM1026 CP1026 csIBM1026 }
8872 { EBCDIC-AT-DE csIBMEBCDICATDE }
8873 { EBCDIC-AT-DE-A csEBCDICATDEA }
8874 { EBCDIC-CA-FR csEBCDICCAFR }
8875 { EBCDIC-DK-NO csEBCDICDKNO }
8876 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8877 { EBCDIC-FI-SE csEBCDICFISE }
8878 { EBCDIC-FI-SE-A csEBCDICFISEA }
8879 { EBCDIC-FR csEBCDICFR }
8880 { EBCDIC-IT csEBCDICIT }
8881 { EBCDIC-PT csEBCDICPT }
8882 { EBCDIC-ES csEBCDICES }
8883 { EBCDIC-ES-A csEBCDICESA }
8884 { EBCDIC-ES-S csEBCDICESS }
8885 { EBCDIC-UK csEBCDICUK }
8886 { EBCDIC-US csEBCDICUS }
8887 { UNKNOWN-8BIT csUnknown8BiT }
8888 { MNEMONIC csMnemonic }
8893 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8894 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8895 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8896 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8897 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8898 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8899 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8900 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8901 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8902 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8903 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8904 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8905 { IBM1047 IBM-1047 }
8906 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8907 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8908 { UNICODE-1-1 csUnicode11 }
8911 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8912 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8914 { ISO-8859-15 ISO_8859-15 Latin-9 }
8915 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8916 { GBK CP936 MS936 windows-936 }
8917 { JIS_Encoding csJISEncoding }
8918 { Shift_JIS MS_Kanji csShiftJIS }
8919 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8921 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8922 { ISO-10646-UCS-Basic csUnicodeASCII }
8923 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8924 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8925 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8926 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8927 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8928 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8929 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8930 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8931 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8932 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8933 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8934 { Ventura-US csVenturaUS }
8935 { Ventura-International csVenturaInternational }
8936 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8937 { PC8-Turkish csPC8Turkish }
8938 { IBM-Symbols csIBMSymbols }
8939 { IBM-Thai csIBMThai }
8940 { HP-Legal csHPLegal }
8941 { HP-Pi-font csHPPiFont }
8942 { HP-Math8 csHPMath8 }
8943 { Adobe-Symbol-Encoding csHPPSMath }
8944 { HP-DeskTop csHPDesktop }
8945 { Ventura-Math csVenturaMath }
8946 { Microsoft-Publishing csMicrosoftPublishing }
8947 { Windows-31J csWindows31J }
8952 proc tcl_encoding {enc} {
8953 global encoding_aliases
8954 set names [encoding names]
8955 set lcnames [string tolower $names]
8956 set enc [string tolower $enc]
8957 set i [lsearch -exact $lcnames $enc]
8959 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8960 if {[regsub {^iso[-_]} $enc iso encx]} {
8961 set i [lsearch -exact $lcnames $encx]
8965 foreach l $encoding_aliases {
8966 set ll [string tolower $l]
8967 if {[lsearch -exact $ll $enc] < 0} continue
8968 # look through the aliases for one that tcl knows about
8970 set i [lsearch -exact $lcnames $e]
8972 if {[regsub {^iso[-_]} $e iso ex]} {
8973 set i [lsearch -exact $lcnames $ex]
8982 return [lindex $names $i]
8987 # First check that Tcl/Tk is recent enough
8988 if {[catch {package require Tk 8.4} err]} {
8989 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8990 Gitk requires at least Tcl/Tk 8.4."
8996 set wrcomcmd "git diff-tree --stdin -p --pretty"
9000 set gitencoding [exec git config --get i18n.commitencoding]
9002 if {$gitencoding == ""} {
9003 set gitencoding "utf-8"
9005 set tclencoding [tcl_encoding $gitencoding]
9006 if {$tclencoding == {}} {
9007 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9010 set mainfont {Helvetica 9}
9011 set textfont {Courier 9}
9012 set uifont {Helvetica 9 bold}
9014 set findmergefiles 0
9022 set cmitmode "patch"
9023 set wrapcomment "none"
9027 set showlocalchanges 1
9029 set datetimeformat "%Y-%m-%d %H:%M:%S"
9031 set colors {green red blue magenta darkgrey brown orange}
9034 set diffcolors {red "#00a000" blue}
9036 set selectbgcolor gray85
9038 catch {source ~/.gitk}
9040 font create optionfont -family sans-serif -size -12
9042 parsefont mainfont $mainfont
9043 eval font create mainfont [fontflags mainfont]
9044 eval font create mainfontbold [fontflags mainfont 1]
9046 parsefont textfont $textfont
9047 eval font create textfont [fontflags textfont]
9048 eval font create textfontbold [fontflags textfont 1]
9050 parsefont uifont $uifont
9051 eval font create uifont [fontflags uifont]
9053 # check that we can find a .git directory somewhere...
9054 if {[catch {set gitdir [gitdir]}]} {
9055 show_error {} . "Cannot find a git repository here."
9058 if {![file isdirectory $gitdir]} {
9059 show_error {} . "Cannot find the git directory \"$gitdir\"."
9065 set cmdline_files {}
9070 "-d" { set datemode 1 }
9073 lappend revtreeargs $arg
9076 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9080 lappend revtreeargs $arg
9086 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9087 # no -- on command line, but some arguments (other than -d)
9089 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9090 set cmdline_files [split $f "\n"]
9091 set n [llength $cmdline_files]
9092 set revtreeargs [lrange $revtreeargs 0 end-$n]
9093 # Unfortunately git rev-parse doesn't produce an error when
9094 # something is both a revision and a filename. To be consistent
9095 # with git log and git rev-list, check revtreeargs for filenames.
9096 foreach arg $revtreeargs {
9097 if {[file exists $arg]} {
9098 show_error {} . "Ambiguous argument '$arg': both revision\
9104 # unfortunately we get both stdout and stderr in $err,
9105 # so look for "fatal:".
9106 set i [string first "fatal:" $err]
9108 set err [string range $err [expr {$i + 6}] end]
9110 show_error {} . "Bad arguments to gitk:\n$err"
9116 # find the list of unmerged files
9120 set fd [open "| git ls-files -u" r]
9122 show_error {} . "Couldn't get list of unmerged files: $err"
9125 while {[gets $fd line] >= 0} {
9126 set i [string first "\t" $line]
9127 if {$i < 0} continue
9128 set fname [string range $line [expr {$i+1}] end]
9129 if {[lsearch -exact $mlist $fname] >= 0} continue
9131 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9132 lappend mlist $fname
9137 if {$nr_unmerged == 0} {
9138 show_error {} . "No files selected: --merge specified but\
9139 no files are unmerged."
9141 show_error {} . "No files selected: --merge specified but\
9142 no unmerged files are within file limit."
9146 set cmdline_files $mlist
9149 set nullid "0000000000000000000000000000000000000000"
9150 set nullid2 "0000000000000000000000000000000000000001"
9152 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9159 set highlight_paths {}
9161 set searchdirn -forwards
9165 set markingmatches 0
9166 set linkentercount 0
9167 set need_redisplay 0
9174 set selectedhlview None
9175 set highlight_related None
9176 set highlight_files {}
9190 # wait for the window to become visible
9192 wm title . "[file tail $argv0]: [file tail [pwd]]"
9195 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9196 # create a view for the files/dirs specified on the command line
9200 set viewname(1) "Command line"
9201 set viewfiles(1) $cmdline_files
9202 set viewargs(1) $revtreeargs
9205 .bar.view entryconf Edit* -state normal
9206 .bar.view entryconf Delete* -state normal
9209 if {[info exists permviews]} {
9210 foreach v $permviews {
9213 set viewname($n) [lindex $v 0]
9214 set viewfiles($n) [lindex $v 1]
9215 set viewargs($n) [lindex $v 2]