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 vrowmod 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) {}
283 set varcix
($view) {{}}
287 proc resetvarcs
{view
} {
288 global varcid varccommits parents children vseedcount ordertok
290 foreach vid
[array names varcid
$view,*] {
295 # some commits might have children but haven't been seen yet
296 foreach vid
[array names children
$view,*] {
299 foreach va
[array names varccommits
$view,*] {
300 unset varccommits
($va)
302 foreach vd
[array names vseedcount
$view,*] {
303 unset vseedcount
($vd)
305 catch
{unset ordertok
}
308 proc newvarc
{view id
} {
309 global varcid varctok parents children vseeds
310 global vupptr vdownptr vleftptr varcrow varcix varcstart
311 global commitdata commitinfo vseedcount varccommits
313 set a
[llength
$varctok($view)]
315 if {[llength
$children($vid)] == 0} {
316 if {![info exists commitinfo
($id)]} {
317 parsecommit
$id $commitdata($id) 1
319 set cdate
[lindex
$commitinfo($id) 4]
320 if {![string is integer
-strict $cdate]} {
323 if {![info exists vseedcount
($view,$cdate)]} {
324 set vseedcount
($view,$cdate) -1
326 set c
[incr vseedcount
($view,$cdate)]
327 set cdate
[expr {$cdate ^
0xffffffff}]
328 set tok
"s[strrep $cdate][strrep $c]"
329 lappend vseeds
($view) $id
330 lappend vupptr
($view) 0
331 set ka
[lindex
$vdownptr($view) 0]
333 [string compare
$tok [lindex
$varctok($view) $ka]] < 0} {
334 lset vdownptr
($view) 0 $a
335 lappend vleftptr
($view) $ka
337 while {[set b
[lindex
$vleftptr($view) $ka]] != 0 &&
338 [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
341 lset vleftptr
($view) $ka $a
342 lappend vleftptr
($view) $b
346 foreach k
$children($vid) {
347 set ka
$varcid($view,$k)
348 if {[string compare
[lindex
$varctok($view) $ka] $tok] > 0} {
350 set tok
[lindex
$varctok($view) $ka]
353 set ka
$varcid($view,$ki)
354 lappend vupptr
($view) $ka
355 set i
[lsearch
-exact $parents($view,$ki) $id]
356 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
358 while {[incr i
] < [llength
$parents($view,$ki)]} {
359 set bi
[lindex
$parents($view,$ki) $i]
360 if {[info exists varcid
($view,$bi)]} {
361 set b
$varcid($view,$bi)
362 if {[lindex
$vupptr($view) $b] == $ka} {
364 lappend vleftptr
($view) [lindex
$vleftptr($view) $b]
365 lset vleftptr
($view) $b $a
371 lappend vleftptr
($view) [lindex
$vdownptr($view) $ka]
372 lset vdownptr
($view) $ka $a
374 append tok
[strrep
$j]
376 lappend varctok
($view) $tok
377 lappend varcstart
($view) $id
378 lappend vdownptr
($view) 0
379 lappend varcrow
($view) {}
380 lappend varcix
($view) {}
381 set varccommits
($view,$a) {}
385 proc splitvarc
{p v
} {
386 global varcid varcstart varccommits varctok
387 global vupptr vdownptr vleftptr varcix varcrow
389 set oa
$varcid($v,$p)
390 set ac
$varccommits($v,$oa)
391 set i
[lsearch
-exact $varccommits($v,$oa) $p]
393 set na
[llength
$varctok($v)]
394 # "%" sorts before "0"...
395 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
396 lappend varctok
($v) $tok
397 lappend varcrow
($v) {}
398 lappend varcix
($v) {}
399 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
400 set varccommits
($v,$na) [lrange
$ac $i end
]
401 lappend varcstart
($v) $p
402 foreach id
$varccommits($v,$na) {
403 set varcid
($v,$id) $na
405 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
406 lset vdownptr
($v) $oa $na
407 lappend vupptr
($v) $oa
408 lappend vleftptr
($v) 0
409 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
410 lset vupptr
($v) $b $na
414 proc renumbervarc
{a v
} {
415 global parents children varctok varcstart varccommits
416 global vupptr vdownptr vleftptr varcid vtokmod
418 set t1
[clock clicks
-milliseconds]
423 if {[info exists isrelated
($a)]} {
425 set id
[lindex
$varccommits($v,$a) end
]
426 foreach p
$parents($v,$id) {
427 if {[info exists varcid
($v,$p)]} {
428 set isrelated
($varcid($v,$p)) 1
433 set b
[lindex
$vdownptr($v) $a]
436 set b
[lindex
$vleftptr($v) $a]
438 set a
[lindex
$vupptr($v) $a]
444 set id
[lindex
$varcstart($v) $a]
446 foreach k
$children($v,$id) {
447 set ka
$varcid($v,$k)
448 if {[string compare
[lindex
$varctok($v) $ka] $tok] > 0} {
450 set tok
[lindex
$varctok($v) $ka]
454 set ka
$varcid($v,$ki)
455 set i
[lsearch
-exact $parents($v,$ki) $id]
456 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
457 append tok
[strrep
$j]
458 set oldtok
[lindex
$varctok($v) $a]
459 if {$tok eq
$oldtok} continue
460 lset varctok
($v) $a $tok
464 set b
[lindex
$vupptr($v) $a]
466 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
469 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
472 set c
[lindex
$vdownptr($v) $b]
474 lset vdownptr
($v) $b [lindex
$vleftptr($v) $a]
477 while {$b != 0 && [lindex
$vleftptr($v) $b] != $a} {
478 set b
[lindex
$vleftptr($v) $b]
481 lset vleftptr
($v) $b [lindex
$vleftptr($v) $a]
483 puts
"oops couldn't find $a in chain for [lindex $vupptr($v) $a]"
486 lset vupptr
($v) $a $ka
488 while {[incr i
] < [llength
$parents($v,$ki)]} {
489 set bi
[lindex
$parents($v,$ki) $i]
490 if {[info exists varcid
($v,$bi)]} {
491 set b
$varcid($v,$bi)
492 if {[lindex
$vupptr($v) $b] == $ka} {
494 lset vleftptr
($v) $a [lindex
$vleftptr($v) $b]
495 lset vleftptr
($v) $b $a
501 lset vleftptr
($v) $a [lindex
$vdownptr($v) $ka]
502 lset vdownptr
($v) $ka $a
506 set t2
[clock clicks
-milliseconds]
507 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
510 proc fix_reversal
{p a v
} {
511 global varcid varcstart varctok vupptr vseeds
513 set pa
$varcid($v,$p)
514 if {$p ne
[lindex
$varcstart($v) $pa]} {
516 set pa
$varcid($v,$p)
518 # seeds always need to be renumbered (and taken out of the seeds list)
519 if {[lindex
$vupptr($v) $pa] == 0} {
520 set i
[lsearch
-exact $vseeds($v) $p]
522 set vseeds
($v) [lreplace
$vseeds($v) $i $i]
524 puts
"oops couldn't find [shortids $p] in seeds"
527 } elseif
{[string compare
[lindex
$varctok($v) $a] \
528 [lindex
$varctok($v) $pa]] > 0} {
533 proc insertrow
{id p v
} {
534 global varcid varccommits parents children cmitlisted
535 global commitidx varctok vtokmod
538 set i
[lsearch
-exact $varccommits($v,$a) $p]
540 puts
"oops: insertrow can't find [shortids $p] on arc $a"
543 set children
($v,$id) {}
544 set parents
($v,$id) [list
$p]
545 set varcid
($v,$id) $a
546 lappend children
($v,$p) $id
547 set cmitlisted
($v,$id) 1
549 # note we deliberately don't update varcstart($v) even if $i == 0
550 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
551 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
557 proc removerow
{id v
} {
558 global varcid varccommits parents children commitidx
559 global varctok vtokmod
561 if {[llength
$parents($v,$id)] != 1} {
562 puts
"oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
565 set p
[lindex
$parents($v,$id) 0]
566 set a
$varcid($v,$id)
567 set i
[lsearch
-exact $varccommits($v,$a) $id]
569 puts
"oops: removerow can't find [shortids $id] on arc $a"
573 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
574 unset parents
($v,$id)
575 unset children
($v,$id)
576 unset cmitlisted
($v,$id)
577 incr commitidx
($v) -1
578 set j
[lsearch
-exact $children($v,$p) $id]
580 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
582 set tok
[lindex
$varctok($v) $a]
583 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
589 proc vtokcmp
{v a b
} {
590 global varctok varcid
592 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
593 [lindex
$varctok($v) $varcid($v,$b)]]
596 proc modify_arc
{v a
{lim
{}}} {
597 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
599 set vtokmod
($v) [lindex
$varctok($v) $a]
601 if {$v == $curview} {
602 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
603 set a
[lindex
$vupptr($v) $a]
609 set lim
[llength
$varccommits($v,$a)]
611 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
618 proc update_arcrows
{v
} {
619 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
620 global varcid vseeds vrownum varcorder varcix varccommits
621 global vupptr vdownptr vleftptr varctok
622 global uat displayorder parentlist curview cached_commitrow
624 set t1
[clock clicks
-milliseconds]
625 set narctot
[expr {[llength
$varctok($v)] - 1}]
627 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
628 # go up the tree until we find something that has a row number,
629 # or we get to a seed
630 set a
[lindex
$vupptr($v) $a]
633 set a
[lindex
$vdownptr($v) 0]
636 set varcorder
($v) [list
$a]
638 lset varcrow
($v) $a 0
642 set arcn
[lindex
$varcix($v) $a]
643 # see if a is the last arc; if so, nothing to do
644 if {$arcn == $narctot - 1} {
647 if {[llength
$vrownum($v)] > $arcn + 1} {
648 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
649 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
651 set row
[lindex
$varcrow($v) $a]
653 if {$v == $curview} {
654 if {[llength
$displayorder] > $vrowmod($v)} {
655 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
656 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
658 catch
{unset cached_commitrow
}
662 incr row
[llength
$varccommits($v,$a)]
663 # go down if possible
664 set b
[lindex
$vdownptr($v) $a]
666 # if not, go left, or go up until we can go left
668 set b
[lindex
$vleftptr($v) $a]
670 set a
[lindex
$vupptr($v) $a]
676 lappend vrownum
($v) $row
677 lappend varcorder
($v) $a
678 lset varcix
($v) $a $arcn
679 lset varcrow
($v) $a $row
681 set vtokmod
($v) [lindex
$varctok($v) $p]
684 if {[info exists currentid
]} {
685 set selectedline
[rowofcommit
$currentid]
687 set t2
[clock clicks
-milliseconds]
688 incr uat
[expr {$t2-$t1}]
691 # Test whether view $v contains commit $id
692 proc commitinview
{id v
} {
695 return [info exists varcid
($v,$id)]
698 # Return the row number for commit $id in the current view
699 proc rowofcommit
{id
} {
700 global varcid varccommits varcrow curview cached_commitrow
701 global varctok vtokmod
703 if {[info exists cached_commitrow
($id)]} {
704 return $cached_commitrow($id)
707 if {![info exists varcid
($v,$id)]} {
708 puts
"oops rowofcommit no arc for [shortids $id]"
711 set a
$varcid($v,$id)
712 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] > 0} {
715 set i
[lsearch
-exact $varccommits($v,$a) $id]
717 puts
"oops didn't find commit [shortids $id] in arc $a"
720 incr i
[lindex
$varcrow($v) $a]
721 set cached_commitrow
($id) $i
725 proc bsearch
{l elt
} {
726 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
731 while {$hi - $lo > 1} {
732 set mid
[expr {int
(($lo + $hi) / 2)}]
733 set t
[lindex
$l $mid]
736 } elseif
{$elt > $t} {
745 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
746 proc make_disporder
{start end
} {
747 global vrownum curview commitidx displayorder parentlist
748 global varccommits varcorder parents vrowmod varcrow
749 global d_valid_start d_valid_end
751 if {$end > $vrowmod($curview)} {
752 update_arcrows
$curview
754 set ai
[bsearch
$vrownum($curview) $start]
755 set start
[lindex
$vrownum($curview) $ai]
756 set narc
[llength
$vrownum($curview)]
757 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
758 set a
[lindex
$varcorder($curview) $ai]
759 set l
[llength
$displayorder]
760 set al
[llength
$varccommits($curview,$a)]
763 set pad
[ntimes
[expr {$r - $l}] {}]
764 set displayorder
[concat
$displayorder $pad]
765 set parentlist
[concat
$parentlist $pad]
767 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
768 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
770 foreach id
$varccommits($curview,$a) {
771 lappend displayorder
$id
772 lappend parentlist
$parents($curview,$id)
774 } elseif
{[lindex
$displayorder $r] eq
{}} {
776 foreach id
$varccommits($curview,$a) {
777 lset displayorder
$i $id
778 lset parentlist
$i $parents($curview,$id)
786 proc commitonrow
{row
} {
789 set id
[lindex
$displayorder $row]
791 make_disporder
$row [expr {$row + 1}]
792 set id
[lindex
$displayorder $row]
797 proc closevarcs
{v
} {
798 global varctok varccommits varcid parents children
799 global cmitlisted commitidx commitinterest vtokmod
801 set missing_parents
0
803 set narcs
[llength
$varctok($v)]
804 for {set a
1} {$a < $narcs} {incr a
} {
805 set id
[lindex
$varccommits($v,$a) end
]
806 foreach p
$parents($v,$id) {
807 if {[info exists varcid
($v,$p)]} continue
808 # add p as a new commit
810 set cmitlisted
($v,$p) 0
811 set parents
($v,$p) {}
812 if {[llength
$children($v,$p)] == 1 &&
813 [llength
$parents($v,$id)] == 1} {
816 set b
[newvarc
$v $p]
819 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
822 lappend varccommits
($v,$b) $p
824 if {[info exists commitinterest
($p)]} {
825 foreach
script $commitinterest($p) {
826 lappend scripts
[string map
[list
"%I" $p] $script]
828 unset commitinterest
($id)
832 if {$missing_parents > 0} {
839 proc getcommitlines
{fd inst view
} {
840 global cmitlisted commitinterest leftover getdbg
841 global commitidx commitdata
842 global parents children curview hlview
843 global vnextroot idpending ordertok
844 global varccommits varcid varctok vtokmod
846 set stuff
[read $fd 500000]
847 # git log doesn't terminate the last commit with a null...
848 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
855 global commfd viewcomplete viewactive viewname progresscoords
858 set i
[lsearch
-exact $viewinstances($view) $inst]
860 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
862 # set it blocking so we wait for the process to terminate
863 fconfigure
$fd -blocking 1
864 if {[catch
{close
$fd} err
]} {
866 if {$view != $curview} {
867 set fv
" for the \"$viewname($view)\" view"
869 if {[string range
$err 0 4] == "usage"} {
870 set err
"Gitk: error reading commits$fv:\
871 bad arguments to git rev-list."
872 if {$viewname($view) eq
"Command line"} {
874 " (Note: arguments to gitk are passed to git rev-list\
875 to allow selection of commits to be displayed.)"
878 set err
"Error reading commits$fv: $err"
882 if {[incr viewactive
($view) -1] <= 0} {
883 set viewcomplete
($view) 1
884 # Check if we have seen any ids listed as parents that haven't
885 # appeared in the list
888 set progresscoords
{0 0}
891 if {$view == $curview} {
892 run chewcommits
$view
900 set i
[string first
"\0" $stuff $start]
902 append leftover
($inst) [string range
$stuff $start end
]
906 set cmit
$leftover($inst)
907 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
908 set leftover
($inst) {}
910 set cmit
[string range
$stuff $start [expr {$i - 1}]]
912 set start
[expr {$i + 1}]
913 set j
[string first
"\n" $cmit]
916 if {$j >= 0 && [string match
"commit *" $cmit]} {
917 set ids
[string range
$cmit 7 [expr {$j - 1}]]
918 if {[string match
{[-<>]*} $ids]} {
919 switch
-- [string index
$ids 0] {
924 set ids
[string range
$ids 1 end
]
928 if {[string length
$id] != 40} {
936 if {[string length
$shortcmit] > 80} {
937 set shortcmit
"[string range $shortcmit 0 80]..."
939 error_popup
"Can't parse git log output: {$shortcmit}"
942 set id
[lindex
$ids 0]
944 if {!$listed && [info exists parents
($vid)]} continue
946 set olds
[lrange
$ids 1 end
]
950 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
951 set cmitlisted
($vid) $listed
952 set parents
($vid) $olds
954 if {![info exists children
($vid)]} {
955 set children
($vid) {}
957 if {[llength
$children($vid)] == 1} {
958 set k
[lindex
$children($vid) 0]
959 if {[llength
$parents($view,$k)] == 1} {
960 set a
$varcid($view,$k)
966 set a
[newvarc
$view $id]
969 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
972 lappend varccommits
($view,$a) $id
976 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
978 if {[llength
[lappend children
($vp) $id]] > 1 &&
979 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
980 set children
($vp) [lsort
-command [list vtokcmp
$view] \
982 catch
{unset ordertok
}
985 if {[info exists varcid
($view,$p)]} {
986 fix_reversal
$p $a $view
991 incr commitidx
($view)
992 if {[info exists commitinterest
($id)]} {
993 foreach
script $commitinterest($id) {
994 lappend scripts
[string map
[list
"%I" $id] $script]
996 unset commitinterest
($id)
1001 run chewcommits
$view
1002 foreach s
$scripts {
1005 if {$view == $curview} {
1006 # update progress bar
1007 global progressdirn progresscoords proglastnc
1008 set inc
[expr {($commitidx($view) - $proglastnc) * 0.0002}]
1009 set proglastnc
$commitidx($view)
1010 set l
[lindex
$progresscoords 0]
1011 set r
[lindex
$progresscoords 1]
1012 if {$progressdirn} {
1013 set r
[expr {$r + $inc}]
1019 set l
[expr {$r - 0.2}]
1022 set l
[expr {$l - $inc}]
1027 set r
[expr {$l + 0.2}]
1029 set progresscoords
[list
$l $r]
1036 proc chewcommits
{view
} {
1037 global curview hlview viewcomplete
1038 global pending_select
1040 if {$view == $curview} {
1042 if {$viewcomplete($view)} {
1044 global numcommits startmsecs
1045 global mainheadid commitinfo nullid
1047 if {[info exists pending_select
]} {
1048 set row
[first_real_row
]
1051 if {$commitidx($curview) > 0} {
1052 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1053 #puts "overall $ms ms for $numcommits commits"
1055 #puts "${uat}ms in update_arcrows"
1057 show_status
"No commits selected"
1062 if {[info exists hlview
] && $view == $hlview} {
1068 proc readcommit
{id
} {
1069 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1070 parsecommit
$id $contents 0
1073 proc parsecommit
{id contents listed
} {
1074 global commitinfo cdate
1083 set hdrend
[string first
"\n\n" $contents]
1085 # should never happen...
1086 set hdrend
[string length
$contents]
1088 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1089 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1090 foreach line
[split $header "\n"] {
1091 set tag
[lindex
$line 0]
1092 if {$tag == "author"} {
1093 set audate
[lindex
$line end-1
]
1094 set auname
[lrange
$line 1 end-2
]
1095 } elseif
{$tag == "committer"} {
1096 set comdate
[lindex
$line end-1
]
1097 set comname
[lrange
$line 1 end-2
]
1101 # take the first non-blank line of the comment as the headline
1102 set headline
[string trimleft
$comment]
1103 set i
[string first
"\n" $headline]
1105 set headline
[string range
$headline 0 $i]
1107 set headline
[string trimright
$headline]
1108 set i
[string first
"\r" $headline]
1110 set headline
[string trimright
[string range
$headline 0 $i]]
1113 # git rev-list indents the comment by 4 spaces;
1114 # if we got this via git cat-file, add the indentation
1116 foreach line
[split $comment "\n"] {
1117 append newcomment
" "
1118 append newcomment
$line
1119 append newcomment
"\n"
1121 set comment
$newcomment
1123 if {$comdate != {}} {
1124 set cdate
($id) $comdate
1126 set commitinfo
($id) [list
$headline $auname $audate \
1127 $comname $comdate $comment]
1130 proc getcommit
{id
} {
1131 global commitdata commitinfo
1133 if {[info exists commitdata
($id)]} {
1134 parsecommit
$id $commitdata($id) 1
1137 if {![info exists commitinfo
($id)]} {
1138 set commitinfo
($id) {"No commit information available"}
1145 global tagids idtags headids idheads tagobjid
1146 global otherrefids idotherrefs mainhead mainheadid
1148 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1151 set refd
[open
[list | git show-ref
-d] r
]
1152 while {[gets
$refd line
] >= 0} {
1153 if {[string index
$line 40] ne
" "} continue
1154 set id
[string range
$line 0 39]
1155 set ref
[string range
$line 41 end
]
1156 if {![string match
"refs/*" $ref]} continue
1157 set name
[string range
$ref 5 end
]
1158 if {[string match
"remotes/*" $name]} {
1159 if {![string match
"*/HEAD" $name]} {
1160 set headids
($name) $id
1161 lappend idheads
($id) $name
1163 } elseif
{[string match
"heads/*" $name]} {
1164 set name
[string range
$name 6 end
]
1165 set headids
($name) $id
1166 lappend idheads
($id) $name
1167 } elseif
{[string match
"tags/*" $name]} {
1168 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1169 # which is what we want since the former is the commit ID
1170 set name
[string range
$name 5 end
]
1171 if {[string match
"*^{}" $name]} {
1172 set name
[string range
$name 0 end-3
]
1174 set tagobjid
($name) $id
1176 set tagids
($name) $id
1177 lappend idtags
($id) $name
1179 set otherrefids
($name) $id
1180 lappend idotherrefs
($id) $name
1187 set thehead
[exec git symbolic-ref HEAD
]
1188 if {[string match
"refs/heads/*" $thehead]} {
1189 set mainhead
[string range
$thehead 11 end
]
1190 if {[info exists headids
($mainhead)]} {
1191 set mainheadid
$headids($mainhead)
1197 # skip over fake commits
1198 proc first_real_row
{} {
1199 global nullid nullid2 numcommits
1201 for {set row
0} {$row < $numcommits} {incr row
} {
1202 set id
[commitonrow
$row]
1203 if {$id ne
$nullid && $id ne
$nullid2} {
1210 # update things for a head moved to a child of its previous location
1211 proc movehead
{id name
} {
1212 global headids idheads
1214 removehead
$headids($name) $name
1215 set headids
($name) $id
1216 lappend idheads
($id) $name
1219 # update things when a head has been removed
1220 proc removehead
{id name
} {
1221 global headids idheads
1223 if {$idheads($id) eq
$name} {
1226 set i
[lsearch
-exact $idheads($id) $name]
1228 set idheads
($id) [lreplace
$idheads($id) $i $i]
1231 unset headids
($name)
1234 proc show_error
{w top msg
} {
1235 message
$w.m
-text $msg -justify center
-aspect 400
1236 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1237 button
$w.ok
-text OK
-command "destroy $top"
1238 pack
$w.ok
-side bottom
-fill x
1239 bind $top <Visibility
> "grab $top; focus $top"
1240 bind $top <Key-Return
> "destroy $top"
1244 proc error_popup msg
{
1248 show_error
$w $w $msg
1251 proc confirm_popup msg
{
1257 message
$w.m
-text $msg -justify center
-aspect 400
1258 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1259 button
$w.ok
-text OK
-command "set confirm_ok 1; destroy $w"
1260 pack
$w.ok
-side left
-fill x
1261 button
$w.cancel
-text Cancel
-command "destroy $w"
1262 pack
$w.cancel
-side right
-fill x
1263 bind $w <Visibility
> "grab $w; focus $w"
1268 proc makewindow
{} {
1269 global canv canv2 canv3 linespc charspc ctext cflist
1271 global findtype findtypemenu findloc findstring fstring geometry
1272 global entries sha1entry sha1string sha1but
1273 global diffcontextstring diffcontext
1274 global maincursor textcursor curtextcursor
1275 global rowctxmenu fakerowmenu mergemax wrapcomment
1276 global highlight_files gdttype
1277 global searchstring sstring
1278 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1279 global headctxmenu progresscanv progressitem progresscoords statusw
1280 global fprogitem fprogcoord lastprogupdate progupdatepending
1281 global rprogitem rprogcoord
1285 .bar add cascade
-label "File" -menu .bar.
file
1286 .bar configure
-font uifont
1288 .bar.
file add
command -label "Update" -command updatecommits
1289 .bar.
file add
command -label "Reload" -command reloadcommits
1290 .bar.
file add
command -label "Reread references" -command rereadrefs
1291 .bar.
file add
command -label "List references" -command showrefs
1292 .bar.
file add
command -label "Quit" -command doquit
1293 .bar.
file configure
-font uifont
1295 .bar add cascade
-label "Edit" -menu .bar.edit
1296 .bar.edit add
command -label "Preferences" -command doprefs
1297 .bar.edit configure
-font uifont
1299 menu .bar.view
-font uifont
1300 .bar add cascade
-label "View" -menu .bar.view
1301 .bar.view add
command -label "New view..." -command {newview
0}
1302 .bar.view add
command -label "Edit view..." -command editview \
1304 .bar.view add
command -label "Delete view" -command delview
-state disabled
1305 .bar.view add separator
1306 .bar.view add radiobutton
-label "All files" -command {showview
0} \
1307 -variable selectedview
-value 0
1310 .bar add cascade
-label "Help" -menu .bar.
help
1311 .bar.
help add
command -label "About gitk" -command about
1312 .bar.
help add
command -label "Key bindings" -command keys
1313 .bar.
help configure
-font uifont
1314 . configure
-menu .bar
1316 # the gui has upper and lower half, parts of a paned window.
1317 panedwindow .ctop
-orient vertical
1319 # possibly use assumed geometry
1320 if {![info exists geometry
(pwsash0
)]} {
1321 set geometry
(topheight
) [expr {15 * $linespc}]
1322 set geometry
(topwidth
) [expr {80 * $charspc}]
1323 set geometry
(botheight
) [expr {15 * $linespc}]
1324 set geometry
(botwidth
) [expr {50 * $charspc}]
1325 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1326 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1329 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1330 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1332 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1334 # create three canvases
1335 set cscroll .tf.histframe.csb
1336 set canv .tf.histframe.pwclist.canv
1338 -selectbackground $selectbgcolor \
1339 -background $bgcolor -bd 0 \
1340 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1341 .tf.histframe.pwclist add
$canv
1342 set canv2 .tf.histframe.pwclist.canv2
1344 -selectbackground $selectbgcolor \
1345 -background $bgcolor -bd 0 -yscrollincr $linespc
1346 .tf.histframe.pwclist add
$canv2
1347 set canv3 .tf.histframe.pwclist.canv3
1349 -selectbackground $selectbgcolor \
1350 -background $bgcolor -bd 0 -yscrollincr $linespc
1351 .tf.histframe.pwclist add
$canv3
1352 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1353 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1355 # a scroll bar to rule them
1356 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1357 pack
$cscroll -side right
-fill y
1358 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1359 lappend bglist
$canv $canv2 $canv3
1360 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1362 # we have two button bars at bottom of top frame. Bar 1
1364 frame .tf.lbar
-height 15
1366 set sha1entry .tf.bar.sha1
1367 set entries
$sha1entry
1368 set sha1but .tf.bar.sha1label
1369 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
1370 -command gotocommit
-width 8 -font uifont
1371 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1372 pack .tf.bar.sha1label
-side left
1373 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1374 trace add variable sha1string
write sha1change
1375 pack
$sha1entry -side left
-pady 2
1377 image create bitmap bm-left
-data {
1378 #define left_width 16
1379 #define left_height 16
1380 static unsigned char left_bits
[] = {
1381 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1382 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1383 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1385 image create bitmap bm-right
-data {
1386 #define right_width 16
1387 #define right_height 16
1388 static unsigned char right_bits
[] = {
1389 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1390 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1391 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1393 button .tf.bar.leftbut
-image bm-left
-command goback \
1394 -state disabled
-width 26
1395 pack .tf.bar.leftbut
-side left
-fill y
1396 button .tf.bar.rightbut
-image bm-right
-command goforw \
1397 -state disabled
-width 26
1398 pack .tf.bar.rightbut
-side left
-fill y
1400 # Status label and progress bar
1401 set statusw .tf.bar.status
1402 label
$statusw -width 15 -relief sunken
-font uifont
1403 pack
$statusw -side left
-padx 5
1404 set h
[expr {[font metrics uifont
-linespace] + 2}]
1405 set progresscanv .tf.bar.progress
1406 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1407 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1408 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1409 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1410 pack
$progresscanv -side right
-expand 1 -fill x
1411 set progresscoords
{0 0}
1414 bind $progresscanv <Configure
> adjustprogress
1415 set lastprogupdate
[clock clicks
-milliseconds]
1416 set progupdatepending
0
1418 # build up the bottom bar of upper window
1419 label .tf.lbar.flabel
-text "Find " -font uifont
1420 button .tf.lbar.fnext
-text "next" -command {dofind
1 1} -font uifont
1421 button .tf.lbar.fprev
-text "prev" -command {dofind
-1 1} -font uifont
1422 label .tf.lbar.flab2
-text " commit " -font uifont
1423 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1425 set gdttype
"containing:"
1426 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1429 "adding/removing string:"]
1430 trace add variable gdttype
write gdttype_change
1431 $gm conf
-font uifont
1432 .tf.lbar.gdttype conf
-font uifont
1433 pack .tf.lbar.gdttype
-side left
-fill y
1436 set fstring .tf.lbar.findstring
1437 lappend entries
$fstring
1438 entry
$fstring -width 30 -font textfont
-textvariable findstring
1439 trace add variable findstring
write find_change
1441 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1442 findtype Exact IgnCase Regexp
]
1443 trace add variable findtype
write findcom_change
1444 .tf.lbar.findtype configure
-font uifont
1445 .tf.lbar.findtype.menu configure
-font uifont
1446 set findloc
"All fields"
1447 tk_optionMenu .tf.lbar.findloc findloc
"All fields" Headline \
1448 Comments Author Committer
1449 trace add variable findloc
write find_change
1450 .tf.lbar.findloc configure
-font uifont
1451 .tf.lbar.findloc.menu configure
-font uifont
1452 pack .tf.lbar.findloc
-side right
1453 pack .tf.lbar.findtype
-side right
1454 pack
$fstring -side left
-expand 1 -fill x
1456 # Finish putting the upper half of the viewer together
1457 pack .tf.lbar
-in .tf
-side bottom
-fill x
1458 pack .tf.bar
-in .tf
-side bottom
-fill x
1459 pack .tf.histframe
-fill both
-side top
-expand 1
1461 .ctop paneconfigure .tf
-height $geometry(topheight
)
1462 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1464 # now build up the bottom
1465 panedwindow .pwbottom
-orient horizontal
1467 # lower left, a text box over search bar, scroll bar to the right
1468 # if we know window height, then that will set the lower text height, otherwise
1469 # we set lower text height which will drive window height
1470 if {[info exists geometry
(main
)]} {
1471 frame .bleft
-width $geometry(botwidth
)
1473 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
1478 button .bleft.top.search
-text "Search" -command dosearch \
1480 pack .bleft.top.search
-side left
-padx 5
1481 set sstring .bleft.top.sstring
1482 entry
$sstring -width 20 -font textfont
-textvariable searchstring
1483 lappend entries
$sstring
1484 trace add variable searchstring
write incrsearch
1485 pack
$sstring -side left
-expand 1 -fill x
1486 radiobutton .bleft.mid.
diff -text "Diff" -font uifont \
1487 -command changediffdisp
-variable diffelide
-value {0 0}
1488 radiobutton .bleft.mid.old
-text "Old version" -font uifont \
1489 -command changediffdisp
-variable diffelide
-value {0 1}
1490 radiobutton .bleft.mid.new
-text "New version" -font uifont \
1491 -command changediffdisp
-variable diffelide
-value {1 0}
1492 label .bleft.mid.labeldiffcontext
-text " Lines of context: " \
1494 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
1495 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
1496 -from 1 -increment 1 -to 10000000 \
1497 -validate all
-validatecommand "diffcontextvalidate %P" \
1498 -textvariable diffcontextstring
1499 .bleft.mid.diffcontext
set $diffcontext
1500 trace add variable diffcontextstring
write diffcontextchange
1501 lappend entries .bleft.mid.diffcontext
1502 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
1503 set ctext .bleft.ctext
1504 text
$ctext -background $bgcolor -foreground $fgcolor \
1505 -state disabled
-font textfont \
1506 -yscrollcommand scrolltext
-wrap none
1508 $ctext conf
-tabstyle wordprocessor
1510 scrollbar .bleft.sb
-command "$ctext yview"
1511 pack .bleft.top
-side top
-fill x
1512 pack .bleft.mid
-side top
-fill x
1513 pack .bleft.sb
-side right
-fill y
1514 pack
$ctext -side left
-fill both
-expand 1
1515 lappend bglist
$ctext
1516 lappend fglist
$ctext
1518 $ctext tag conf comment
-wrap $wrapcomment
1519 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
1520 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
1521 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
1522 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
1523 $ctext tag conf m0
-fore red
1524 $ctext tag conf m1
-fore blue
1525 $ctext tag conf m2
-fore green
1526 $ctext tag conf m3
-fore purple
1527 $ctext tag conf
m4 -fore brown
1528 $ctext tag conf m5
-fore "#009090"
1529 $ctext tag conf m6
-fore magenta
1530 $ctext tag conf m7
-fore "#808000"
1531 $ctext tag conf m8
-fore "#009000"
1532 $ctext tag conf m9
-fore "#ff0080"
1533 $ctext tag conf m10
-fore cyan
1534 $ctext tag conf m11
-fore "#b07070"
1535 $ctext tag conf m12
-fore "#70b0f0"
1536 $ctext tag conf m13
-fore "#70f0b0"
1537 $ctext tag conf m14
-fore "#f0b070"
1538 $ctext tag conf m15
-fore "#ff70b0"
1539 $ctext tag conf mmax
-fore darkgrey
1541 $ctext tag conf mresult
-font textfontbold
1542 $ctext tag conf msep
-font textfontbold
1543 $ctext tag conf found
-back yellow
1545 .pwbottom add .bleft
1546 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
1551 radiobutton .bright.mode.
patch -text "Patch" \
1552 -command reselectline
-variable cmitmode
-value "patch"
1553 .bright.mode.
patch configure
-font uifont
1554 radiobutton .bright.mode.tree
-text "Tree" \
1555 -command reselectline
-variable cmitmode
-value "tree"
1556 .bright.mode.tree configure
-font uifont
1557 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
1558 pack .bright.mode
-side top
-fill x
1559 set cflist .bright.cfiles
1560 set indent
[font measure mainfont
"nn"]
1562 -selectbackground $selectbgcolor \
1563 -background $bgcolor -foreground $fgcolor \
1565 -tabs [list
$indent [expr {2 * $indent}]] \
1566 -yscrollcommand ".bright.sb set" \
1567 -cursor [. cget
-cursor] \
1568 -spacing1 1 -spacing3 1
1569 lappend bglist
$cflist
1570 lappend fglist
$cflist
1571 scrollbar .bright.sb
-command "$cflist yview"
1572 pack .bright.sb
-side right
-fill y
1573 pack
$cflist -side left
-fill both
-expand 1
1574 $cflist tag configure highlight \
1575 -background [$cflist cget
-selectbackground]
1576 $cflist tag configure bold
-font mainfontbold
1578 .pwbottom add .bright
1581 # restore window position if known
1582 if {[info exists geometry
(main
)]} {
1583 wm geometry .
"$geometry(main)"
1586 if {[tk windowingsystem
] eq
{aqua
}} {
1592 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
1593 pack .ctop
-fill both
-expand 1
1594 bindall
<1> {selcanvline
%W
%x
%y
}
1595 #bindall <B1-Motion> {selcanvline %W %x %y}
1596 if {[tk windowingsystem
] == "win32"} {
1597 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
1598 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
1600 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
1601 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
1602 if {[tk windowingsystem
] eq
"aqua"} {
1603 bindall
<MouseWheel
> {
1604 set delta
[expr {- (%D
)}]
1605 allcanvs yview scroll
$delta units
1609 bindall
<2> "canvscan mark %W %x %y"
1610 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
1611 bindkey
<Home
> selfirstline
1612 bindkey
<End
> sellastline
1613 bind .
<Key-Up
> "selnextline -1"
1614 bind .
<Key-Down
> "selnextline 1"
1615 bind .
<Shift-Key-Up
> "dofind -1 0"
1616 bind .
<Shift-Key-Down
> "dofind 1 0"
1617 bindkey
<Key-Right
> "goforw"
1618 bindkey
<Key-Left
> "goback"
1619 bind .
<Key-Prior
> "selnextpage -1"
1620 bind .
<Key-Next
> "selnextpage 1"
1621 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
1622 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
1623 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
1624 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
1625 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1626 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1627 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
1628 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
1629 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
1630 bindkey p
"selnextline -1"
1631 bindkey n
"selnextline 1"
1634 bindkey i
"selnextline -1"
1635 bindkey k
"selnextline 1"
1638 bindkey b
"$ctext yview scroll -1 pages"
1639 bindkey d
"$ctext yview scroll 18 units"
1640 bindkey u
"$ctext yview scroll -18 units"
1641 bindkey
/ {dofind
1 1}
1642 bindkey
<Key-Return
> {dofind
1 1}
1643 bindkey ?
{dofind
-1 1}
1645 bindkey
<F5
> updatecommits
1646 bind .
<$M1B-q> doquit
1647 bind .
<$M1B-f> {dofind
1 1}
1648 bind .
<$M1B-g> {dofind
1 0}
1649 bind .
<$M1B-r> dosearchback
1650 bind .
<$M1B-s> dosearch
1651 bind .
<$M1B-equal> {incrfont
1}
1652 bind .
<$M1B-KP_Add> {incrfont
1}
1653 bind .
<$M1B-minus> {incrfont
-1}
1654 bind .
<$M1B-KP_Subtract> {incrfont
-1}
1655 wm protocol . WM_DELETE_WINDOW doquit
1656 bind .
<Button-1
> "click %W"
1657 bind $fstring <Key-Return
> {dofind
1 1}
1658 bind $sha1entry <Key-Return
> gotocommit
1659 bind $sha1entry <<PasteSelection>> clearsha1
1660 bind $cflist <1> {sel_flist %W %x %y; break}
1661 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1662 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1663 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1665 set maincursor [. cget -cursor]
1666 set textcursor [$ctext cget -cursor]
1667 set curtextcursor $textcursor
1669 set rowctxmenu .rowctxmenu
1670 menu $rowctxmenu -tearoff 0
1671 $rowctxmenu add command -label "Diff this -> selected" \
1672 -command {diffvssel 0}
1673 $rowctxmenu add command -label "Diff selected -> this" \
1674 -command {diffvssel 1}
1675 $rowctxmenu add command -label "Make patch" -command mkpatch
1676 $rowctxmenu add command -label "Create tag" -command mktag
1677 $rowctxmenu add command -label "Write commit to file" -command writecommit
1678 $rowctxmenu add command -label "Create new branch" -command mkbranch
1679 $rowctxmenu add command -label "Cherry-pick this commit" \
1681 $rowctxmenu add command -label "Reset HEAD branch to here" \
1684 set fakerowmenu .fakerowmenu
1685 menu $fakerowmenu -tearoff 0
1686 $fakerowmenu add command -label "Diff this -> selected" \
1687 -command {diffvssel 0}
1688 $fakerowmenu add command -label "Diff selected -> this" \
1689 -command {diffvssel 1}
1690 $fakerowmenu add command -label "Make patch" -command mkpatch
1691 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1692 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1693 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
1695 set headctxmenu .headctxmenu
1696 menu $headctxmenu -tearoff 0
1697 $headctxmenu add command -label "Check out this branch" \
1699 $headctxmenu add command -label "Remove this branch" \
1703 set flist_menu .flistctxmenu
1704 menu $flist_menu -tearoff 0
1705 $flist_menu add command -label "Highlight this too" \
1706 -command {flist_hl 0}
1707 $flist_menu add command -label "Highlight this only" \
1708 -command {flist_hl 1}
1711 # Windows sends all mouse wheel events to the current focused window, not
1712 # the one where the mouse hovers, so bind those events here and redirect
1713 # to the correct window
1714 proc windows_mousewheel_redirector {W X Y D} {
1715 global canv canv2 canv3
1716 set w [winfo containing -displayof $W $X $Y]
1718 set u [expr {$D < 0 ? 5 : -5}]
1719 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1720 allcanvs yview scroll $u units
1723 $w yview scroll $u units
1729 # mouse-2 makes all windows scan vertically, but only the one
1730 # the cursor is in scans horizontally
1731 proc canvscan {op w x y} {
1732 global canv canv2 canv3
1733 foreach c [list $canv $canv2 $canv3] {
1742 proc scrollcanv {cscroll f0 f1} {
1743 $cscroll set $f0 $f1
1748 # when we make a key binding for the toplevel, make sure
1749 # it doesn't get triggered when that key is pressed in the
1750 # find string entry widget.
1751 proc bindkey {ev script} {
1754 set escript [bind Entry $ev]
1755 if {$escript == {}} {
1756 set escript [bind Entry <Key>]
1758 foreach e $entries {
1759 bind $e $ev "$escript; break"
1763 # set the focus back to the toplevel for any click outside
1766 global ctext entries
1767 foreach e [concat $entries $ctext] {
1768 if {$w == $e} return
1773 # Adjust the progress bar for a change in requested extent or canvas size
1774 proc adjustprogress {} {
1775 global progresscanv progressitem progresscoords
1776 global fprogitem fprogcoord lastprogupdate progupdatepending
1777 global rprogitem rprogcoord
1779 set w [expr {[winfo width $progresscanv] - 4}]
1780 set x0 [expr {$w * [lindex $progresscoords 0]}]
1781 set x1 [expr {$w * [lindex $progresscoords 1]}]
1782 set h [winfo height $progresscanv]
1783 $progresscanv coords $progressitem $x0 0 $x1 $h
1784 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1785 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1786 set now [clock clicks -milliseconds]
1787 if {$now >= $lastprogupdate + 100} {
1788 set progupdatepending 0
1790 } elseif {!$progupdatepending} {
1791 set progupdatepending 1
1792 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1796 proc doprogupdate {} {
1797 global lastprogupdate progupdatepending
1799 if {$progupdatepending} {
1800 set progupdatepending 0
1801 set lastprogupdate [clock clicks -milliseconds]
1806 proc savestuff {w} {
1807 global canv canv2 canv3 mainfont textfont uifont tabstop
1808 global stuffsaved findmergefiles maxgraphpct
1809 global maxwidth showneartags showlocalchanges
1810 global viewname viewfiles viewargs viewperm nextviewnum
1811 global cmitmode wrapcomment datetimeformat limitdiffs
1812 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1814 if {$stuffsaved} return
1815 if {![winfo viewable .]} return
1817 set f [open "~/.gitk-new" w]
1818 puts $f [list set mainfont $mainfont]
1819 puts $f [list set textfont $textfont]
1820 puts $f [list set uifont $uifont]
1821 puts $f [list set tabstop $tabstop]
1822 puts $f [list set findmergefiles $findmergefiles]
1823 puts $f [list set maxgraphpct $maxgraphpct]
1824 puts $f [list set maxwidth $maxwidth]
1825 puts $f [list set cmitmode $cmitmode]
1826 puts $f [list set wrapcomment $wrapcomment]
1827 puts $f [list set showneartags $showneartags]
1828 puts $f [list set showlocalchanges $showlocalchanges]
1829 puts $f [list set datetimeformat $datetimeformat]
1830 puts $f [list set limitdiffs $limitdiffs]
1831 puts $f [list set bgcolor $bgcolor]
1832 puts $f [list set fgcolor $fgcolor]
1833 puts $f [list set colors $colors]
1834 puts $f [list set diffcolors $diffcolors]
1835 puts $f [list set diffcontext $diffcontext]
1836 puts $f [list set selectbgcolor $selectbgcolor]
1838 puts $f "set geometry(main) [wm geometry .]"
1839 puts $f "set geometry(topwidth) [winfo width .tf]"
1840 puts $f "set geometry(topheight) [winfo height .tf]"
1841 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1842 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1843 puts $f "set geometry(botwidth) [winfo width .bleft]"
1844 puts $f "set geometry(botheight) [winfo height .bleft]"
1846 puts -nonewline $f "set permviews {"
1847 for {set v 0} {$v < $nextviewnum} {incr v} {
1848 if {$viewperm($v)} {
1849 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1854 file rename -force "~/.gitk-new" "~/.gitk"
1859 proc resizeclistpanes {win w} {
1861 if {[info exists oldwidth($win)]} {
1862 set s0 [$win sash coord 0]
1863 set s1 [$win sash coord 1]
1865 set sash0 [expr {int($w/2 - 2)}]
1866 set sash1 [expr {int($w*5/6 - 2)}]
1868 set factor [expr {1.0 * $w / $oldwidth($win)}]
1869 set sash0 [expr {int($factor * [lindex $s0 0])}]
1870 set sash1 [expr {int($factor * [lindex $s1 0])}]
1874 if {$sash1 < $sash0 + 20} {
1875 set sash1 [expr {$sash0 + 20}]
1877 if {$sash1 > $w - 10} {
1878 set sash1 [expr {$w - 10}]
1879 if {$sash0 > $sash1 - 20} {
1880 set sash0 [expr {$sash1 - 20}]
1884 $win sash place 0 $sash0 [lindex $s0 1]
1885 $win sash place 1 $sash1 [lindex $s1 1]
1887 set oldwidth($win) $w
1890 proc resizecdetpanes {win w} {
1892 if {[info exists oldwidth($win)]} {
1893 set s0 [$win sash coord 0]
1895 set sash0 [expr {int($w*3/4 - 2)}]
1897 set factor [expr {1.0 * $w / $oldwidth($win)}]
1898 set sash0 [expr {int($factor * [lindex $s0 0])}]
1902 if {$sash0 > $w - 15} {
1903 set sash0 [expr {$w - 15}]
1906 $win sash place 0 $sash0 [lindex $s0 1]
1908 set oldwidth($win) $w
1911 proc allcanvs args {
1912 global canv canv2 canv3
1918 proc bindall {event action} {
1919 global canv canv2 canv3
1920 bind $canv $event $action
1921 bind $canv2 $event $action
1922 bind $canv3 $event $action
1928 if {[winfo exists $w]} {
1933 wm title $w "About gitk"
1934 message $w.m -text {
1935 Gitk - a commit viewer for git
1937 Copyright © 2005-2007 Paul Mackerras
1939 Use and redistribute under the terms of the GNU General Public License} \
1940 -justify center -aspect 400 -border 2 -bg white -relief groove
1941 pack $w.m -side top -fill x -padx 2 -pady 2
1942 $w.m configure -font uifont
1943 button $w.ok -text Close -command "destroy $w" -default active
1944 pack $w.ok -side bottom
1945 $w.ok configure -font uifont
1946 bind $w <Visibility> "focus $w.ok"
1947 bind $w <Key-Escape> "destroy $w"
1948 bind $w <Key-Return> "destroy $w"
1954 if {[winfo exists $w]} {
1958 if {[tk windowingsystem] eq {aqua}} {
1964 wm title $w "Gitk key bindings"
1965 message $w.m -text "
1969 <Home> Move to first commit
1970 <End> Move to last commit
1971 <Up>, p, i Move up one commit
1972 <Down>, n, k Move down one commit
1973 <Left>, z, j Go back in history list
1974 <Right>, x, l Go forward in history list
1975 <PageUp> Move up one page in commit list
1976 <PageDown> Move down one page in commit list
1977 <$M1T-Home> Scroll to top of commit list
1978 <$M1T-End> Scroll to bottom of commit list
1979 <$M1T-Up> Scroll commit list up one line
1980 <$M1T-Down> Scroll commit list down one line
1981 <$M1T-PageUp> Scroll commit list up one page
1982 <$M1T-PageDown> Scroll commit list down one page
1983 <Shift-Up> Find backwards (upwards, later commits)
1984 <Shift-Down> Find forwards (downwards, earlier commits)
1985 <Delete>, b Scroll diff view up one page
1986 <Backspace> Scroll diff view up one page
1987 <Space> Scroll diff view down one page
1988 u Scroll diff view up 18 lines
1989 d Scroll diff view down 18 lines
1991 <$M1T-G> Move to next find hit
1992 <Return> Move to next find hit
1993 / Move to next find hit, or redo find
1994 ? Move to previous find hit
1995 f Scroll diff view to next file
1996 <$M1T-S> Search for next hit in diff view
1997 <$M1T-R> Search for previous hit in diff view
1998 <$M1T-KP+> Increase font size
1999 <$M1T-plus> Increase font size
2000 <$M1T-KP-> Decrease font size
2001 <$M1T-minus> Decrease font size
2004 -justify left -bg white -border 2 -relief groove
2005 pack $w.m -side top -fill both -padx 2 -pady 2
2006 $w.m configure -font uifont
2007 button $w.ok -text Close -command "destroy $w" -default active
2008 pack $w.ok -side bottom
2009 $w.ok configure -font uifont
2010 bind $w <Visibility> "focus $w.ok"
2011 bind $w <Key-Escape> "destroy $w"
2012 bind $w <Key-Return> "destroy $w"
2015 # Procedures for manipulating the file list window at the
2016 # bottom right of the overall window.
2018 proc treeview {w l openlevs} {
2019 global treecontents treediropen treeheight treeparent treeindex
2029 set treecontents() {}
2030 $w conf -state normal
2032 while {[string range $f 0 $prefixend] ne $prefix} {
2033 if {$lev <= $openlevs} {
2034 $w mark set e:$treeindex($prefix) "end -1c"
2035 $w mark gravity e:$treeindex($prefix) left
2037 set treeheight($prefix) $ht
2038 incr ht [lindex $htstack end]
2039 set htstack [lreplace $htstack end end]
2040 set prefixend [lindex $prefendstack end]
2041 set prefendstack [lreplace $prefendstack end end]
2042 set prefix [string range $prefix 0 $prefixend]
2045 set tail [string range $f [expr {$prefixend+1}] end]
2046 while {[set slash [string first "/" $tail]] >= 0} {
2049 lappend prefendstack $prefixend
2050 incr prefixend [expr {$slash + 1}]
2051 set d [string range $tail 0 $slash]
2052 lappend treecontents($prefix) $d
2053 set oldprefix $prefix
2055 set treecontents($prefix) {}
2056 set treeindex($prefix) [incr ix]
2057 set treeparent($prefix) $oldprefix
2058 set tail [string range $tail [expr {$slash+1}] end]
2059 if {$lev <= $openlevs} {
2061 set treediropen($prefix) [expr {$lev < $openlevs}]
2062 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2063 $w mark set d:$ix "end -1c"
2064 $w mark gravity d:$ix left
2066 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2068 $w image create end -align center -image $bm -padx 1 \
2070 $w insert end $d [highlight_tag $prefix]
2071 $w mark set s:$ix "end -1c"
2072 $w mark gravity s:$ix left
2077 if {$lev <= $openlevs} {
2080 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2082 $w insert end $tail [highlight_tag $f]
2084 lappend treecontents($prefix) $tail
2087 while {$htstack ne {}} {
2088 set treeheight($prefix) $ht
2089 incr ht [lindex $htstack end]
2090 set htstack [lreplace $htstack end end]
2091 set prefixend [lindex $prefendstack end]
2092 set prefendstack [lreplace $prefendstack end end]
2093 set prefix [string range $prefix 0 $prefixend]
2095 $w conf -state disabled
2098 proc linetoelt {l} {
2099 global treeheight treecontents
2104 foreach e $treecontents($prefix) {
2109 if {[string index $e end] eq "/"} {
2110 set n $treeheight($prefix$e)
2122 proc highlight_tree {y prefix} {
2123 global treeheight treecontents cflist
2125 foreach e $treecontents($prefix) {
2127 if {[highlight_tag $path] ne {}} {
2128 $cflist tag add bold $y.0 "$y.0 lineend"
2131 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2132 set y [highlight_tree $y $path]
2138 proc treeclosedir {w dir} {
2139 global treediropen treeheight treeparent treeindex
2141 set ix $treeindex($dir)
2142 $w conf -state normal
2143 $w delete s:$ix e:$ix
2144 set treediropen($dir) 0
2145 $w image configure a:$ix -image tri-rt
2146 $w conf -state disabled
2147 set n [expr {1 - $treeheight($dir)}]
2148 while {$dir ne {}} {
2149 incr treeheight($dir) $n
2150 set dir $treeparent($dir)
2154 proc treeopendir {w dir} {
2155 global treediropen treeheight treeparent treecontents treeindex
2157 set ix $treeindex($dir)
2158 $w conf -state normal
2159 $w image configure a:$ix -image tri-dn
2160 $w mark set e:$ix s:$ix
2161 $w mark gravity e:$ix right
2164 set n [llength $treecontents($dir)]
2165 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2168 incr treeheight($x) $n
2170 foreach e $treecontents($dir) {
2172 if {[string index $e end] eq "/"} {
2173 set iy $treeindex($de)
2174 $w mark set d:$iy e:$ix
2175 $w mark gravity d:$iy left
2176 $w insert e:$ix $str
2177 set treediropen($de) 0
2178 $w image create e:$ix -align center -image tri-rt -padx 1 \
2180 $w insert e:$ix $e [highlight_tag $de]
2181 $w mark set s:$iy e:$ix
2182 $w mark gravity s:$iy left
2183 set treeheight($de) 1
2185 $w insert e:$ix $str
2186 $w insert e:$ix $e [highlight_tag $de]
2189 $w mark gravity e:$ix left
2190 $w conf -state disabled
2191 set treediropen($dir) 1
2192 set top [lindex [split [$w index @0,0] .] 0]
2193 set ht [$w cget -height]
2194 set l [lindex [split [$w index s:$ix] .] 0]
2197 } elseif {$l + $n + 1 > $top + $ht} {
2198 set top [expr {$l + $n + 2 - $ht}]
2206 proc treeclick {w x y} {
2207 global treediropen cmitmode ctext cflist cflist_top
2209 if {$cmitmode ne "tree"} return
2210 if {![info exists cflist_top]} return
2211 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2212 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2213 $cflist tag add highlight $l.0 "$l.0 lineend"
2219 set e [linetoelt $l]
2220 if {[string index $e end] ne "/"} {
2222 } elseif {$treediropen($e)} {
2229 proc setfilelist {id} {
2230 global treefilelist cflist
2232 treeview $cflist $treefilelist($id) 0
2235 image create bitmap tri-rt -background black -foreground blue -data {
2236 #define tri-rt_width 13
2237 #define tri-rt_height 13
2238 static unsigned char tri-rt_bits[] = {
2239 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2240 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2243 #define tri-rt-mask_width 13
2244 #define tri-rt-mask_height 13
2245 static unsigned char tri-rt-mask_bits[] = {
2246 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2247 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2250 image create bitmap tri-dn -background black -foreground blue -data {
2251 #define tri-dn_width 13
2252 #define tri-dn_height 13
2253 static unsigned char tri-dn_bits[] = {
2254 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2255 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2258 #define tri-dn-mask_width 13
2259 #define tri-dn-mask_height 13
2260 static unsigned char tri-dn-mask_bits[] = {
2261 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2262 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2266 image create bitmap reficon-T -background black -foreground yellow -data {
2267 #define tagicon_width 13
2268 #define tagicon_height 9
2269 static unsigned char tagicon_bits[] = {
2270 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2271 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2273 #define tagicon-mask_width 13
2274 #define tagicon-mask_height 9
2275 static unsigned char tagicon-mask_bits[] = {
2276 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2277 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2280 #define headicon_width 13
2281 #define headicon_height 9
2282 static unsigned char headicon_bits[] = {
2283 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2284 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2287 #define headicon-mask_width 13
2288 #define headicon-mask_height 9
2289 static unsigned char headicon-mask_bits[] = {
2290 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2291 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2293 image create bitmap reficon-H -background black -foreground green \
2294 -data $rectdata -maskdata $rectmask
2295 image create bitmap reficon-o -background black -foreground "#ddddff" \
2296 -data $rectdata -maskdata $rectmask
2298 proc init_flist {first} {
2299 global cflist cflist_top difffilestart
2301 $cflist conf -state normal
2302 $cflist delete 0.0 end
2304 $cflist insert end $first
2306 $cflist tag add highlight 1.0 "1.0 lineend"
2308 catch {unset cflist_top}
2310 $cflist conf -state disabled
2311 set difffilestart {}
2314 proc highlight_tag {f} {
2315 global highlight_paths
2317 foreach p $highlight_paths {
2318 if {[string match $p $f]} {
2325 proc highlight_filelist {} {
2326 global cmitmode cflist
2328 $cflist conf -state normal
2329 if {$cmitmode ne "tree"} {
2330 set end [lindex [split [$cflist index end] .] 0]
2331 for {set l 2} {$l < $end} {incr l} {
2332 set line [$cflist get $l.0 "$l.0 lineend"]
2333 if {[highlight_tag $line] ne {}} {
2334 $cflist tag add bold $l.0 "$l.0 lineend"
2340 $cflist conf -state disabled
2343 proc unhighlight_filelist {} {
2346 $cflist conf -state normal
2347 $cflist tag remove bold 1.0 end
2348 $cflist conf -state disabled
2351 proc add_flist {fl} {
2354 $cflist conf -state normal
2356 $cflist insert end "\n"
2357 $cflist insert end $f [highlight_tag $f]
2359 $cflist conf -state disabled
2362 proc sel_flist {w x y} {
2363 global ctext difffilestart cflist cflist_top cmitmode
2365 if {$cmitmode eq "tree"} return
2366 if {![info exists cflist_top]} return
2367 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2368 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2369 $cflist tag add highlight $l.0 "$l.0 lineend"
2374 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2378 proc pop_flist_menu {w X Y x y} {
2379 global ctext cflist cmitmode flist_menu flist_menu_file
2380 global treediffs diffids
2383 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2385 if {$cmitmode eq "tree"} {
2386 set e [linetoelt $l]
2387 if {[string index $e end] eq "/"} return
2389 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2391 set flist_menu_file $e
2392 tk_popup $flist_menu $X $Y
2395 proc flist_hl {only} {
2396 global flist_menu_file findstring gdttype
2398 set x [shellquote $flist_menu_file]
2399 if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
2402 append findstring " " $x
2404 set gdttype "touching paths:"
2407 # Functions for adding and removing shell-type quoting
2409 proc shellquote {str} {
2410 if {![string match "*\['\"\\ \t]*" $str]} {
2413 if {![string match "*\['\"\\]*" $str]} {
2416 if {![string match "*'*" $str]} {
2419 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2422 proc shellarglist {l} {
2428 append str [shellquote $a]
2433 proc shelldequote {str} {
2438 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2439 append ret [string range $str $used end]
2440 set used [string length $str]
2443 set first [lindex $first 0]
2444 set ch [string index $str $first]
2445 if {$first > $used} {
2446 append ret [string range $str $used [expr {$first - 1}]]
2449 if {$ch eq " " || $ch eq "\t"} break
2452 set first [string first "'" $str $used]
2454 error "unmatched single-quote"
2456 append ret [string range $str $used [expr {$first - 1}]]
2461 if {$used >= [string length $str]} {
2462 error "trailing backslash"
2464 append ret [string index $str $used]
2469 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2470 error "unmatched double-quote"
2472 set first [lindex $first 0]
2473 set ch [string index $str $first]
2474 if {$first > $used} {
2475 append ret [string range $str $used [expr {$first - 1}]]
2478 if {$ch eq "\""} break
2480 append ret [string index $str $used]
2484 return [list $used $ret]
2487 proc shellsplit {str} {
2490 set str [string trimleft $str]
2491 if {$str eq {}} break
2492 set dq [shelldequote $str]
2493 set n [lindex $dq 0]
2494 set word [lindex $dq 1]
2495 set str [string range $str $n end]
2501 # Code to implement multiple views
2503 proc newview {ishighlight} {
2504 global nextviewnum newviewname newviewperm uifont newishighlight
2505 global newviewargs revtreeargs
2507 set newishighlight $ishighlight
2509 if {[winfo exists $top]} {
2513 set newviewname($nextviewnum) "View $nextviewnum"
2514 set newviewperm($nextviewnum) 0
2515 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2516 vieweditor $top $nextviewnum "Gitk view definition"
2521 global viewname viewperm newviewname newviewperm
2522 global viewargs newviewargs
2524 set top .gitkvedit-$curview
2525 if {[winfo exists $top]} {
2529 set newviewname($curview) $viewname($curview)
2530 set newviewperm($curview) $viewperm($curview)
2531 set newviewargs($curview) [shellarglist $viewargs($curview)]
2532 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2535 proc vieweditor {top n title} {
2536 global newviewname newviewperm viewfiles
2540 wm title $top $title
2541 label $top.nl -text "Name" -font uifont
2542 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
2543 grid $top.nl $top.name -sticky w -pady 5
2544 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
2546 grid $top.perm - -pady 5 -sticky w
2547 message $top.al -aspect 1000 -font uifont \
2548 -text "Commits to include (arguments to git rev-list):"
2549 grid $top.al - -sticky w -pady 5
2550 entry $top.args -width 50 -textvariable newviewargs($n) \
2551 -background white -font uifont
2552 grid $top.args - -sticky ew -padx 5
2553 message $top.l -aspect 1000 -font uifont \
2554 -text "Enter files and directories to include, one per line:"
2555 grid $top.l - -sticky w
2556 text $top.t -width 40 -height 10 -background white -font uifont
2557 if {[info exists viewfiles($n)]} {
2558 foreach f $viewfiles($n) {
2559 $top.t insert end $f
2560 $top.t insert end "\n"
2562 $top.t delete {end - 1c} end
2563 $top.t mark set insert 0.0
2565 grid $top.t - -sticky ew -padx 5
2567 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
2569 button $top.buts.can -text "Cancel" -command [list destroy $top] \
2571 grid $top.buts.ok $top.buts.can
2572 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2573 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2574 grid $top.buts - -pady 10 -sticky ew
2578 proc doviewmenu {m first cmd op argv} {
2579 set nmenu [$m index end]
2580 for {set i $first} {$i <= $nmenu} {incr i} {
2581 if {[$m entrycget $i -command] eq $cmd} {
2582 eval $m $op $i $argv
2588 proc allviewmenus {n op args} {
2591 doviewmenu .bar.view 5 [list showview $n] $op $args
2592 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2595 proc newviewok {top n} {
2596 global nextviewnum newviewperm newviewname newishighlight
2597 global viewname viewfiles viewperm selectedview curview
2598 global viewargs newviewargs viewhlmenu
2601 set newargs [shellsplit $newviewargs($n)]
2603 error_popup "Error in commit selection arguments: $err"
2609 foreach f [split [$top.t get 0.0 end] "\n"] {
2610 set ft [string trim $f]
2615 if {![info exists viewfiles($n)]} {
2616 # creating a new view
2618 set viewname($n) $newviewname($n)
2619 set viewperm($n) $newviewperm($n)
2620 set viewfiles($n) $files
2621 set viewargs($n) $newargs
2623 if {!$newishighlight} {
2626 run addvhighlight $n
2629 # editing an existing view
2630 set viewperm($n) $newviewperm($n)
2631 if {$newviewname($n) ne $viewname($n)} {
2632 set viewname($n) $newviewname($n)
2633 doviewmenu .bar.view 5 [list showview $n] \
2634 entryconf [list -label $viewname($n)]
2635 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2636 # entryconf [list -label $viewname($n) -value $viewname($n)]
2638 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2639 set viewfiles($n) $files
2640 set viewargs($n) $newargs
2641 if {$curview == $n} {
2646 catch {destroy $top}
2650 global curview viewperm hlview selectedhlview
2652 if {$curview == 0} return
2653 if {[info exists hlview] && $hlview == $curview} {
2654 set selectedhlview None
2657 allviewmenus $curview delete
2658 set viewperm($curview) 0
2662 proc addviewmenu {n} {
2663 global viewname viewhlmenu
2665 .bar.view add radiobutton -label $viewname($n) \
2666 -command [list showview $n] -variable selectedview -value $n
2667 #$viewhlmenu add radiobutton -label $viewname($n) \
2668 # -command [list addvhighlight $n] -variable selectedhlview
2672 global curview viewfiles cached_commitrow ordertok
2673 global displayorder parentlist rowidlist rowisopt rowfinal
2674 global colormap rowtextx nextcolor canvxmax
2675 global numcommits viewcomplete
2676 global selectedline currentid canv canvy0
2678 global pending_select
2680 global selectedview selectfirst
2681 global hlview selectedhlview commitinterest
2683 if {$n == $curview} return
2685 set ymax [lindex [$canv cget -scrollregion] 3]
2686 set span [$canv yview]
2687 set ytop [expr {[lindex $span 0] * $ymax}]
2688 set ybot [expr {[lindex $span 1] * $ymax}]
2689 set yscreen [expr {($ybot - $ytop) / 2}]
2690 if {[info exists selectedline]} {
2691 set selid $currentid
2692 set y [yc $selectedline]
2693 if {$ytop < $y && $y < $ybot} {
2694 set yscreen [expr {$y - $ytop}]
2696 } elseif {[info exists pending_select]} {
2697 set selid $pending_select
2698 unset pending_select
2702 catch {unset treediffs}
2704 if {[info exists hlview] && $hlview == $n} {
2706 set selectedhlview None
2708 catch {unset commitinterest}
2709 catch {unset cached_commitrow}
2710 catch {unset ordertok}
2714 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2715 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2718 if {![info exists viewcomplete($n)]} {
2720 set pending_select $selid
2731 set numcommits $commitidx($n)
2733 catch {unset colormap}
2734 catch {unset rowtextx}
2736 set canvxmax [$canv cget -width]
2743 if {$selid ne {} && [commitinview $selid $n]} {
2744 set row [rowofcommit $selid]
2745 # try to get the selected row in the same position on the screen
2746 set ymax [lindex [$canv cget -scrollregion] 3]
2747 set ytop [expr {[yc $row] - $yscreen}]
2751 set yf [expr {$ytop * 1.0 / $ymax}]
2753 allcanvs yview moveto $yf
2757 } elseif {$selid ne {}} {
2758 set pending_select $selid
2760 set row [first_real_row]
2761 if {$row < $numcommits} {
2767 if {!$viewcomplete($n)} {
2768 if {$numcommits == 0} {
2769 show_status "Reading commits..."
2773 } elseif {$numcommits == 0} {
2774 show_status "No commits selected"
2778 # Stuff relating to the highlighting facility
2780 proc ishighlighted {row} {
2781 global vhighlights fhighlights nhighlights rhighlights
2783 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2784 return $nhighlights($row)
2786 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2787 return $vhighlights($row)
2789 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2790 return $fhighlights($row)
2792 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2793 return $rhighlights($row)
2798 proc bolden {row font} {
2799 global canv linehtag selectedline boldrows
2801 lappend boldrows $row
2802 $canv itemconf $linehtag($row) -font $font
2803 if {[info exists selectedline] && $row == $selectedline} {
2805 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2806 -outline {{}} -tags secsel \
2807 -fill [$canv cget -selectbackground]]
2812 proc bolden_name {row font} {
2813 global canv2 linentag selectedline boldnamerows
2815 lappend boldnamerows $row
2816 $canv2 itemconf $linentag($row) -font $font
2817 if {[info exists selectedline] && $row == $selectedline} {
2818 $canv2 delete secsel
2819 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2820 -outline {{}} -tags secsel \
2821 -fill [$canv2 cget -selectbackground]]
2830 foreach row $boldrows {
2831 if {![ishighlighted $row]} {
2832 bolden $row mainfont
2834 lappend stillbold $row
2837 set boldrows $stillbold
2840 proc addvhighlight {n} {
2841 global hlview viewcomplete curview vhl_done vhighlights commitidx
2843 if {[info exists hlview]} {
2847 if {$n != $curview && ![info exists viewcomplete($n)]} {
2850 set vhl_done $commitidx($hlview)
2851 if {$vhl_done > 0} {
2856 proc delvhighlight {} {
2857 global hlview vhighlights
2859 if {![info exists hlview]} return
2861 catch {unset vhighlights}
2865 proc vhighlightmore {} {
2866 global hlview vhl_done commitidx vhighlights curview
2868 set max $commitidx($hlview)
2869 set vr [visiblerows]
2870 set r0 [lindex $vr 0]
2871 set r1 [lindex $vr 1]
2872 for {set i $vhl_done} {$i < $max} {incr i} {
2873 set id [commitonrow $i $hlview]
2874 if {[commitinview $id $curview]} {
2875 set row [rowofcommit $id]
2876 if {$r0 <= $row && $row <= $r1} {
2877 if {![highlighted $row]} {
2878 bolden $row mainfontbold
2880 set vhighlights($row) 1
2887 proc askvhighlight {row id} {
2888 global hlview vhighlights iddrawn
2890 if {[commitinview $id $hlview]} {
2891 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2892 bolden $row mainfontbold
2894 set vhighlights($row) 1
2896 set vhighlights($row) 0
2900 proc hfiles_change {} {
2901 global highlight_files filehighlight fhighlights fh_serial
2902 global highlight_paths gdttype
2904 if {[info exists filehighlight]} {
2905 # delete previous highlights
2906 catch {close $filehighlight}
2908 catch {unset fhighlights}
2910 unhighlight_filelist
2912 set highlight_paths {}
2913 after cancel do_file_hl $fh_serial
2915 if {$highlight_files ne {}} {
2916 after 300 do_file_hl $fh_serial
2920 proc gdttype_change {name ix op} {
2921 global gdttype highlight_files findstring findpattern
2924 if {$findstring ne {}} {
2925 if {$gdttype eq "containing:"} {
2926 if {$highlight_files ne {}} {
2927 set highlight_files {}
2932 if {$findpattern ne {}} {
2936 set highlight_files $findstring
2941 # enable/disable findtype/findloc menus too
2944 proc find_change {name ix op} {
2945 global gdttype findstring highlight_files
2948 if {$gdttype eq "containing:"} {
2951 if {$highlight_files ne $findstring} {
2952 set highlight_files $findstring
2959 proc findcom_change args {
2960 global nhighlights boldnamerows
2961 global findpattern findtype findstring gdttype
2964 # delete previous highlights, if any
2965 foreach row $boldnamerows {
2966 bolden_name $row mainfont
2969 catch {unset nhighlights}
2972 if {$gdttype ne "containing:" || $findstring eq {}} {
2974 } elseif {$findtype eq "Regexp"} {
2975 set findpattern $findstring
2977 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2979 set findpattern "*$e*"
2983 proc makepatterns {l} {
2986 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2987 if {[string index $ee end] eq "/"} {
2997 proc do_file_hl {serial} {
2998 global highlight_files filehighlight highlight_paths gdttype fhl_list
3000 if {$gdttype eq "touching paths:"} {
3001 if {[catch {set paths [shellsplit $highlight_files]}]} return
3002 set highlight_paths [makepatterns $paths]
3004 set gdtargs [concat -- $paths]
3005 } elseif {$gdttype eq "adding/removing string:"} {
3006 set gdtargs [list "-S$highlight_files"]
3008 # must be "containing:", i.e. we're searching commit info
3011 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3012 set filehighlight [open $cmd r+]
3013 fconfigure $filehighlight -blocking 0
3014 filerun $filehighlight readfhighlight
3020 proc flushhighlights {} {
3021 global filehighlight fhl_list
3023 if {[info exists filehighlight]} {
3025 puts $filehighlight ""
3026 flush $filehighlight
3030 proc askfilehighlight {row id} {
3031 global filehighlight fhighlights fhl_list
3033 lappend fhl_list $id
3034 set fhighlights($row) -1
3035 puts $filehighlight $id
3038 proc readfhighlight {} {
3039 global filehighlight fhighlights curview iddrawn
3040 global fhl_list find_dirn
3042 if {![info exists filehighlight]} {
3046 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3047 set line [string trim $line]
3048 set i [lsearch -exact $fhl_list $line]
3049 if {$i < 0} continue
3050 for {set j 0} {$j < $i} {incr j} {
3051 set id [lindex $fhl_list $j]
3052 if {[commitinview $id $curview]} {
3053 set fhighlights([rowofcommit $id]) 0
3056 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3057 if {$line eq {}} continue
3058 if {![commitinview $line $curview]} continue
3059 set row [rowofcommit $line]
3060 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
3061 bolden $row mainfontbold
3063 set fhighlights($row) 1
3065 if {[eof $filehighlight]} {
3067 puts "oops, git diff-tree died"
3068 catch {close $filehighlight}
3072 if {[info exists find_dirn]} {
3078 proc doesmatch {f} {
3079 global findtype findpattern
3081 if {$findtype eq "Regexp"} {
3082 return [regexp $findpattern $f]
3083 } elseif {$findtype eq "IgnCase"} {
3084 return [string match -nocase $findpattern $f]
3086 return [string match $findpattern $f]
3090 proc askfindhighlight {row id} {
3091 global nhighlights commitinfo iddrawn
3093 global markingmatches
3095 if {![info exists commitinfo($id)]} {
3098 set info $commitinfo($id)
3100 set fldtypes {Headline Author Date Committer CDate Comments}
3101 foreach f $info ty $fldtypes {
3102 if {($findloc eq "All fields" || $findloc eq $ty) &&
3104 if {$ty eq "Author"} {
3111 if {$isbold && [info exists iddrawn($id)]} {
3112 if {![ishighlighted $row]} {
3113 bolden $row mainfontbold
3115 bolden_name $row mainfontbold
3118 if {$markingmatches} {
3119 markrowmatches $row $id
3122 set nhighlights($row) $isbold
3125 proc markrowmatches {row id} {
3126 global canv canv2 linehtag linentag commitinfo findloc
3128 set headline [lindex $commitinfo($id) 0]
3129 set author [lindex $commitinfo($id) 1]
3130 $canv delete match$row
3131 $canv2 delete match$row
3132 if {$findloc eq "All fields" || $findloc eq "Headline"} {
3133 set m [findmatches $headline]
3135 markmatches $canv $row $headline $linehtag($row) $m \
3136 [$canv itemcget $linehtag($row) -font] $row
3139 if {$findloc eq "All fields" || $findloc eq "Author"} {
3140 set m [findmatches $author]
3142 markmatches $canv2 $row $author $linentag($row) $m \
3143 [$canv2 itemcget $linentag($row) -font] $row
3148 proc vrel_change {name ix op} {
3149 global highlight_related
3152 if {$highlight_related ne "None"} {
3157 # prepare for testing whether commits are descendents or ancestors of a
3158 proc rhighlight_sel {a} {
3159 global descendent desc_todo ancestor anc_todo
3160 global highlight_related rhighlights
3162 catch {unset descendent}
3163 set desc_todo [list $a]
3164 catch {unset ancestor}
3165 set anc_todo [list $a]
3166 if {$highlight_related ne "None"} {
3172 proc rhighlight_none {} {
3175 catch {unset rhighlights}
3179 proc is_descendent {a} {
3180 global curview children descendent desc_todo
3183 set la [rowofcommit $a]
3187 for {set i 0} {$i < [llength $todo]} {incr i} {
3188 set do [lindex $todo $i]
3189 if {[rowofcommit $do] < $la} {
3190 lappend leftover $do
3193 foreach nk $children($v,$do) {
3194 if {![info exists descendent($nk)]} {
3195 set descendent($nk) 1
3203 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3207 set descendent($a) 0
3208 set desc_todo $leftover
3211 proc is_ancestor {a} {
3212 global curview parents ancestor anc_todo
3215 set la [rowofcommit $a]
3219 for {set i 0} {$i < [llength $todo]} {incr i} {
3220 set do [lindex $todo $i]
3221 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3222 lappend leftover $do
3225 foreach np $parents($v,$do) {
3226 if {![info exists ancestor($np)]} {
3235 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3240 set anc_todo $leftover
3243 proc askrelhighlight {row id} {
3244 global descendent highlight_related iddrawn rhighlights
3245 global selectedline ancestor
3247 if {![info exists selectedline]} return
3249 if {$highlight_related eq "Descendent" ||
3250 $highlight_related eq "Not descendent"} {
3251 if {![info exists descendent($id)]} {
3254 if {$descendent($id) == ($highlight_related eq "Descendent")} {
3257 } elseif {$highlight_related eq "Ancestor" ||
3258 $highlight_related eq "Not ancestor"} {
3259 if {![info exists ancestor($id)]} {
3262 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
3266 if {[info exists iddrawn($id)]} {
3267 if {$isbold && ![ishighlighted $row]} {
3268 bolden $row mainfontbold
3271 set rhighlights($row) $isbold
3274 # Graph layout functions
3276 proc shortids {ids} {
3279 if {[llength $id] > 1} {
3280 lappend res [shortids $id]
3281 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3282 lappend res [string range $id 0 7]
3293 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3294 if {($n & $mask) != 0} {
3295 set ret [concat $ret $o]
3297 set o [concat $o $o]
3302 proc ordertoken {id} {
3303 global ordertok curview varcid varcstart varctok curview parents children
3304 global nullid nullid2
3306 if {[info exists ordertok($id)]} {
3307 return $ordertok($id)
3312 if {[info exists varcid($curview,$id)]} {
3313 set a $varcid($curview,$id)
3314 set p [lindex $varcstart($curview) $a]
3316 set p [lindex $children($curview,$id) 0]
3318 if {[info exists ordertok($p)]} {
3319 set tok $ordertok($p)
3322 if {[llength $children($curview,$p)] == 0} {
3324 set tok [lindex $varctok($curview) $a]
3327 set id [lindex $children($curview,$p) 0]
3328 if {$id eq $nullid || $id eq $nullid2} {
3329 # XXX treat it as a root
3330 set tok [lindex $varctok($curview) $a]
3333 if {[llength $parents($curview,$id)] == 1} {
3334 lappend todo [list $p {}]
3336 set j [lsearch -exact $parents($curview,$id) $p]
3338 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3340 lappend todo [list $p [strrep $j]]
3343 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3344 set p [lindex $todo $i 0]
3345 append tok [lindex $todo $i 1]
3346 set ordertok($p) $tok
3348 set ordertok($origid) $tok
3352 # Work out where id should go in idlist so that order-token
3353 # values increase from left to right
3354 proc idcol {idlist id {i 0}} {
3355 set t [ordertoken $id]
3359 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3360 if {$i > [llength $idlist]} {
3361 set i [llength $idlist]
3363 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3366 if {$t > [ordertoken [lindex $idlist $i]]} {
3367 while {[incr i] < [llength $idlist] &&
3368 $t >= [ordertoken [lindex $idlist $i]]} {}
3374 proc initlayout {} {
3375 global rowidlist rowisopt rowfinal displayorder parentlist
3376 global numcommits canvxmax canv
3378 global colormap rowtextx
3388 set canvxmax [$canv cget -width]
3389 catch {unset colormap}
3390 catch {unset rowtextx}
3394 proc setcanvscroll {} {
3395 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3397 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3398 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3399 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3400 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3403 proc visiblerows {} {
3404 global canv numcommits linespc
3406 set ymax [lindex [$canv cget -scrollregion] 3]
3407 if {$ymax eq {} || $ymax == 0} return
3409 set y0 [expr {int([lindex $f 0] * $ymax)}]
3410 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3414 set y1 [expr {int([lindex $f 1] * $ymax)}]
3415 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3416 if {$r1 >= $numcommits} {
3417 set r1 [expr {$numcommits - 1}]
3419 return [list $r0 $r1]
3422 proc layoutmore {} {
3423 global commitidx viewcomplete curview
3424 global numcommits pending_select selectedline curview
3425 global selectfirst lastscrollset commitinterest
3427 set canshow $commitidx($curview)
3428 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3429 if {$numcommits == 0} {
3433 set prev $numcommits
3434 set numcommits $canshow
3435 set t [clock clicks -milliseconds]
3436 if {$prev < 100 || $viewcomplete($curview) || $t - $lastscrollset > 500} {
3437 set lastscrollset $t
3440 set rows [visiblerows]
3441 set r1 [lindex $rows 1]
3442 if {$r1 >= $canshow} {
3443 set r1 [expr {$canshow - 1}]
3448 if {[info exists pending_select] &&
3449 [commitinview $pending_select $curview]} {
3450 selectline [rowofcommit $pending_select] 1
3453 if {[info exists selectedline] || [info exists pending_select]} {
3456 set l [first_real_row]
3463 proc doshowlocalchanges {} {
3464 global curview mainheadid
3466 if {[commitinview $mainheadid $curview]} {
3469 lappend commitinterest($mainheadid) {dodiffindex}
3473 proc dohidelocalchanges {} {
3474 global nullid nullid2 lserial curview
3476 if {[commitinview $nullid $curview]} {
3477 removerow $nullid $curview
3479 if {[commitinview $nullid2 $curview]} {
3480 removerow $nullid2 $curview
3485 # spawn off a process to do git diff-index --cached HEAD
3486 proc dodiffindex {} {
3487 global lserial showlocalchanges
3489 if {!$showlocalchanges} return
3491 set fd [open "|git diff-index --cached HEAD" r]
3492 fconfigure $fd -blocking 0
3493 filerun $fd [list readdiffindex $fd $lserial]
3496 proc readdiffindex {fd serial} {
3497 global mainheadid nullid2 curview commitinfo commitdata lserial
3500 if {[gets $fd line] < 0} {
3506 # we only need to see one line and we don't really care what it says...
3509 # now see if there are any local changes not checked in to the index
3510 if {$serial == $lserial} {
3511 set fd [open "|git diff-files" r]
3512 fconfigure $fd -blocking 0
3513 filerun $fd [list readdifffiles $fd $serial]
3516 if {$isdiff && $serial == $lserial && ![commitinview $nullid2 $curview]} {
3517 # add the line for the changes in the index to the graph
3518 set hl "Local changes checked in to index but not committed"
3519 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3520 set commitdata($nullid2) "\n $hl\n"
3521 insertrow $nullid2 $mainheadid $curview
3526 proc readdifffiles {fd serial} {
3527 global mainheadid nullid nullid2 curview
3528 global commitinfo commitdata lserial
3531 if {[gets $fd line] < 0} {
3537 # we only need to see one line and we don't really care what it says...
3540 if {$isdiff && $serial == $lserial && ![commitinview $nullid $curview]} {
3541 # add the line for the local diff to the graph
3542 set hl "Local uncommitted changes, not checked in to index"
3543 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3544 set commitdata($nullid) "\n $hl\n"
3545 if {[commitinview $nullid2 $curview]} {
3550 insertrow $nullid $p $curview
3555 proc nextuse {id row} {
3556 global curview children
3558 if {[info exists children($curview,$id)]} {
3559 foreach kid $children($curview,$id) {
3560 if {![commitinview $kid $curview]} {
3563 if {[rowofcommit $kid] > $row} {
3564 return [rowofcommit $kid]
3568 if {[commitinview $id $curview]} {
3569 return [rowofcommit $id]
3574 proc prevuse {id row} {
3575 global curview children
3578 if {[info exists children($curview,$id)]} {
3579 foreach kid $children($curview,$id) {
3580 if {![commitinview $kid $curview]} break
3581 if {[rowofcommit $kid] < $row} {
3582 set ret [rowofcommit $kid]
3589 proc make_idlist {row} {
3590 global displayorder parentlist uparrowlen downarrowlen mingaplen
3591 global commitidx curview children
3593 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3597 set ra [expr {$row - $downarrowlen}]
3601 set rb [expr {$row + $uparrowlen}]
3602 if {$rb > $commitidx($curview)} {
3603 set rb $commitidx($curview)
3605 make_disporder $r [expr {$rb + 1}]
3607 for {} {$r < $ra} {incr r} {
3608 set nextid [lindex $displayorder [expr {$r + 1}]]
3609 foreach p [lindex $parentlist $r] {
3610 if {$p eq $nextid} continue
3611 set rn [nextuse $p $r]
3613 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3614 lappend ids [list [ordertoken $p] $p]
3618 for {} {$r < $row} {incr r} {
3619 set nextid [lindex $displayorder [expr {$r + 1}]]
3620 foreach p [lindex $parentlist $r] {
3621 if {$p eq $nextid} continue
3622 set rn [nextuse $p $r]
3623 if {$rn < 0 || $rn >= $row} {
3624 lappend ids [list [ordertoken $p] $p]
3628 set id [lindex $displayorder $row]
3629 lappend ids [list [ordertoken $id] $id]
3631 foreach p [lindex $parentlist $r] {
3632 set firstkid [lindex $children($curview,$p) 0]
3633 if {[rowofcommit $firstkid] < $row} {
3634 lappend ids [list [ordertoken $p] $p]
3638 set id [lindex $displayorder $r]
3640 set firstkid [lindex $children($curview,$id) 0]
3641 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3642 lappend ids [list [ordertoken $id] $id]
3647 foreach idx [lsort -unique $ids] {
3648 lappend idlist [lindex $idx 1]
3653 proc rowsequal {a b} {
3654 while {[set i [lsearch -exact $a {}]] >= 0} {
3655 set a [lreplace $a $i $i]
3657 while {[set i [lsearch -exact $b {}]] >= 0} {
3658 set b [lreplace $b $i $i]
3660 return [expr {$a eq $b}]
3663 proc makeupline {id row rend col} {
3664 global rowidlist uparrowlen downarrowlen mingaplen
3666 for {set r $rend} {1} {set r $rstart} {
3667 set rstart [prevuse $id $r]
3668 if {$rstart < 0} return
3669 if {$rstart < $row} break
3671 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3672 set rstart [expr {$rend - $uparrowlen - 1}]
3674 for {set r $rstart} {[incr r] <= $row} {} {
3675 set idlist [lindex $rowidlist $r]
3676 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3677 set col [idcol $idlist $id $col]
3678 lset rowidlist $r [linsert $idlist $col $id]
3684 proc layoutrows {row endrow} {
3685 global rowidlist rowisopt rowfinal displayorder
3686 global uparrowlen downarrowlen maxwidth mingaplen
3687 global children parentlist
3688 global commitidx viewcomplete curview
3690 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3693 set rm1 [expr {$row - 1}]
3694 foreach id [lindex $rowidlist $rm1] {
3699 set final [lindex $rowfinal $rm1]
3701 for {} {$row < $endrow} {incr row} {
3702 set rm1 [expr {$row - 1}]
3703 if {$rm1 < 0 || $idlist eq {}} {
3704 set idlist [make_idlist $row]
3707 set id [lindex $displayorder $rm1]
3708 set col [lsearch -exact $idlist $id]
3709 set idlist [lreplace $idlist $col $col]
3710 foreach p [lindex $parentlist $rm1] {
3711 if {[lsearch -exact $idlist $p] < 0} {
3712 set col [idcol $idlist $p $col]
3713 set idlist [linsert $idlist $col $p]
3714 # if not the first child, we have to insert a line going up
3715 if {$id ne [lindex $children($curview,$p) 0]} {
3716 makeupline $p $rm1 $row $col
3720 set id [lindex $displayorder $row]
3721 if {$row > $downarrowlen} {
3722 set termrow [expr {$row - $downarrowlen - 1}]
3723 foreach p [lindex $parentlist $termrow] {
3724 set i [lsearch -exact $idlist $p]
3725 if {$i < 0} continue
3726 set nr [nextuse $p $termrow]
3727 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3728 set idlist [lreplace $idlist $i $i]
3732 set col [lsearch -exact $idlist $id]
3734 set col [idcol $idlist $id]
3735 set idlist [linsert $idlist $col $id]
3736 if {$children($curview,$id) ne {}} {
3737 makeupline $id $rm1 $row $col
3740 set r [expr {$row + $uparrowlen - 1}]
3741 if {$r < $commitidx($curview)} {
3743 foreach p [lindex $parentlist $r] {
3744 if {[lsearch -exact $idlist $p] >= 0} continue
3745 set fk [lindex $children($curview,$p) 0]
3746 if {[rowofcommit $fk] < $row} {
3747 set x [idcol $idlist $p $x]
3748 set idlist [linsert $idlist $x $p]
3751 if {[incr r] < $commitidx($curview)} {
3752 set p [lindex $displayorder $r]
3753 if {[lsearch -exact $idlist $p] < 0} {
3754 set fk [lindex $children($curview,$p) 0]
3755 if {$fk ne {} && [rowofcommit $fk] < $row} {
3756 set x [idcol $idlist $p $x]
3757 set idlist [linsert $idlist $x $p]
3763 if {$final && !$viewcomplete($curview) &&
3764 $row + $uparrowlen + $mingaplen + $downarrowlen
3765 >= $commitidx($curview)} {
3768 set l [llength $rowidlist]
3770 lappend rowidlist $idlist
3772 lappend rowfinal $final
3773 } elseif {$row < $l} {
3774 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3775 lset rowidlist $row $idlist
3778 lset rowfinal $row $final
3780 set pad [ntimes [expr {$row - $l}] {}]
3781 set rowidlist [concat $rowidlist $pad]
3782 lappend rowidlist $idlist
3783 set rowfinal [concat $rowfinal $pad]
3784 lappend rowfinal $final
3785 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3791 proc changedrow {row} {
3792 global displayorder iddrawn rowisopt need_redisplay
3794 set l [llength $rowisopt]
3796 lset rowisopt $row 0
3797 if {$row + 1 < $l} {
3798 lset rowisopt [expr {$row + 1}] 0
3799 if {$row + 2 < $l} {
3800 lset rowisopt [expr {$row + 2}] 0
3804 set id [lindex $displayorder $row]
3805 if {[info exists iddrawn($id)]} {
3806 set need_redisplay 1
3810 proc insert_pad {row col npad} {
3813 set pad [ntimes $npad {}]
3814 set idlist [lindex $rowidlist $row]
3815 set bef [lrange $idlist 0 [expr {$col - 1}]]
3816 set aft [lrange $idlist $col end]
3817 set i [lsearch -exact $aft {}]
3819 set aft [lreplace $aft $i $i]
3821 lset rowidlist $row [concat $bef $pad $aft]
3825 proc optimize_rows {row col endrow} {
3826 global rowidlist rowisopt displayorder curview children
3831 for {} {$row < $endrow} {incr row; set col 0} {
3832 if {[lindex $rowisopt $row]} continue
3834 set y0 [expr {$row - 1}]
3835 set ym [expr {$row - 2}]
3836 set idlist [lindex $rowidlist $row]
3837 set previdlist [lindex $rowidlist $y0]
3838 if {$idlist eq {} || $previdlist eq {}} continue
3840 set pprevidlist [lindex $rowidlist $ym]
3841 if {$pprevidlist eq {}} continue
3847 for {} {$col < [llength $idlist]} {incr col} {
3848 set id [lindex $idlist $col]
3849 if {[lindex $previdlist $col] eq $id} continue
3854 set x0 [lsearch -exact $previdlist $id]
3855 if {$x0 < 0} continue
3856 set z [expr {$x0 - $col}]
3860 set xm [lsearch -exact $pprevidlist $id]
3862 set z0 [expr {$xm - $x0}]
3866 # if row y0 is the first child of $id then it's not an arrow
3867 if {[lindex $children($curview,$id) 0] ne
3868 [lindex $displayorder $y0]} {
3872 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3873 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3876 # Looking at lines from this row to the previous row,
3877 # make them go straight up if they end in an arrow on
3878 # the previous row; otherwise make them go straight up
3880 if {$z < -1 || ($z < 0 && $isarrow)} {
3881 # Line currently goes left too much;
3882 # insert pads in the previous row, then optimize it
3883 set npad [expr {-1 - $z + $isarrow}]
3884 insert_pad $y0 $x0 $npad
3886 optimize_rows $y0 $x0 $row
3888 set previdlist [lindex $rowidlist $y0]
3889 set x0 [lsearch -exact $previdlist $id]
3890 set z [expr {$x0 - $col}]
3892 set pprevidlist [lindex $rowidlist $ym]
3893 set xm [lsearch -exact $pprevidlist $id]
3894 set z0 [expr {$xm - $x0}]
3896 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3897 # Line currently goes right too much;
3898 # insert pads in this line
3899 set npad [expr {$z - 1 + $isarrow}]
3900 insert_pad $row $col $npad
3901 set idlist [lindex $rowidlist $row]
3903 set z [expr {$x0 - $col}]
3906 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3907 # this line links to its first child on row $row-2
3908 set id [lindex $displayorder $ym]
3909 set xc [lsearch -exact $pprevidlist $id]
3911 set z0 [expr {$xc - $x0}]
3914 # avoid lines jigging left then immediately right
3915 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3916 insert_pad $y0 $x0 1
3918 optimize_rows $y0 $x0 $row
3919 set previdlist [lindex $rowidlist $y0]
3923 # Find the first column that doesn't have a line going right
3924 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3925 set id [lindex $idlist $col]
3926 if {$id eq {}} break
3927 set x0 [lsearch -exact $previdlist $id]
3929 # check if this is the link to the first child
3930 set kid [lindex $displayorder $y0]
3931 if {[lindex $children($curview,$id) 0] eq $kid} {
3932 # it is, work out offset to child
3933 set x0 [lsearch -exact $previdlist $kid]
3936 if {$x0 <= $col} break
3938 # Insert a pad at that column as long as it has a line and
3939 # isn't the last column
3940 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3941 set idlist [linsert $idlist $col {}]
3942 lset rowidlist $row $idlist
3950 global canvx0 linespc
3951 return [expr {$canvx0 + $col * $linespc}]
3955 global canvy0 linespc
3956 return [expr {$canvy0 + $row * $linespc}]
3959 proc linewidth {id} {
3960 global thickerline lthickness
3963 if {[info exists thickerline] && $id eq $thickerline} {
3964 set wid [expr {2 * $lthickness}]
3969 proc rowranges {id} {
3970 global curview children uparrowlen downarrowlen
3973 set kids $children($curview,$id)
3979 foreach child $kids {
3980 if {![commitinview $child $curview]} break
3981 set row [rowofcommit $child]
3982 if {![info exists prev]} {
3983 lappend ret [expr {$row + 1}]
3985 if {$row <= $prevrow} {
3986 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
3988 # see if the line extends the whole way from prevrow to row
3989 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3990 [lsearch -exact [lindex $rowidlist \
3991 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3992 # it doesn't, see where it ends
3993 set r [expr {$prevrow + $downarrowlen}]
3994 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3995 while {[incr r -1] > $prevrow &&
3996 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3998 while {[incr r] <= $row &&
3999 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4003 # see where it starts up again
4004 set r [expr {$row - $uparrowlen}]
4005 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4006 while {[incr r] < $row &&
4007 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4009 while {[incr r -1] >= $prevrow &&
4010 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4016 if {$child eq $id} {
4025 proc drawlineseg {id row endrow arrowlow} {
4026 global rowidlist displayorder iddrawn linesegs
4027 global canv colormap linespc curview maxlinelen parentlist
4029 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4030 set le [expr {$row + 1}]
4033 set c [lsearch -exact [lindex $rowidlist $le] $id]
4039 set x [lindex $displayorder $le]
4044 if {[info exists iddrawn($x)] || $le == $endrow} {
4045 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4061 if {[info exists linesegs($id)]} {
4062 set lines $linesegs($id)
4064 set r0 [lindex $li 0]
4066 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4076 set li [lindex $lines [expr {$i-1}]]
4077 set r1 [lindex $li 1]
4078 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4083 set x [lindex $cols [expr {$le - $row}]]
4084 set xp [lindex $cols [expr {$le - 1 - $row}]]
4085 set dir [expr {$xp - $x}]
4087 set ith [lindex $lines $i 2]
4088 set coords [$canv coords $ith]
4089 set ah [$canv itemcget $ith -arrow]
4090 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4091 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4092 if {$x2 ne {} && $x - $x2 == $dir} {
4093 set coords [lrange $coords 0 end-2]
4096 set coords [list [xc $le $x] [yc $le]]
4099 set itl [lindex $lines [expr {$i-1}] 2]
4100 set al [$canv itemcget $itl -arrow]
4101 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4102 } elseif {$arrowlow} {
4103 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4104 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4108 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4109 for {set y $le} {[incr y -1] > $row} {} {
4111 set xp [lindex $cols [expr {$y - 1 - $row}]]
4112 set ndir [expr {$xp - $x}]
4113 if {$dir != $ndir || $xp < 0} {
4114 lappend coords [xc $y $x] [yc $y]
4120 # join parent line to first child
4121 set ch [lindex $displayorder $row]
4122 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4124 puts "oops: drawlineseg: child $ch not on row $row"
4125 } elseif {$xc != $x} {
4126 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4127 set d [expr {int(0.5 * $linespc)}]
4130 set x2 [expr {$x1 - $d}]
4132 set x2 [expr {$x1 + $d}]
4135 set y1 [expr {$y2 + $d}]
4136 lappend coords $x1 $y1 $x2 $y2
4137 } elseif {$xc < $x - 1} {
4138 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4139 } elseif {$xc > $x + 1} {
4140 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4144 lappend coords [xc $row $x] [yc $row]
4146 set xn [xc $row $xp]
4148 lappend coords $xn $yn
4152 set t [$canv create line $coords -width [linewidth $id] \
4153 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4156 set lines [linsert $lines $i [list $row $le $t]]
4158 $canv coords $ith $coords
4159 if {$arrow ne $ah} {
4160 $canv itemconf $ith -arrow $arrow
4162 lset lines $i 0 $row
4165 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4166 set ndir [expr {$xo - $xp}]
4167 set clow [$canv coords $itl]
4168 if {$dir == $ndir} {
4169 set clow [lrange $clow 2 end]
4171 set coords [concat $coords $clow]
4173 lset lines [expr {$i-1}] 1 $le
4175 # coalesce two pieces
4177 set b [lindex $lines [expr {$i-1}] 0]
4178 set e [lindex $lines $i 1]
4179 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4181 $canv coords $itl $coords
4182 if {$arrow ne $al} {
4183 $canv itemconf $itl -arrow $arrow
4187 set linesegs($id) $lines
4191 proc drawparentlinks {id row} {
4192 global rowidlist canv colormap curview parentlist
4193 global idpos linespc
4195 set rowids [lindex $rowidlist $row]
4196 set col [lsearch -exact $rowids $id]
4197 if {$col < 0} return
4198 set olds [lindex $parentlist $row]
4199 set row2 [expr {$row + 1}]
4200 set x [xc $row $col]
4203 set d [expr {int(0.5 * $linespc)}]
4204 set ymid [expr {$y + $d}]
4205 set ids [lindex $rowidlist $row2]
4206 # rmx = right-most X coord used
4209 set i [lsearch -exact $ids $p]
4211 puts "oops, parent $p of $id not in list"
4214 set x2 [xc $row2 $i]
4218 set j [lsearch -exact $rowids $p]
4220 # drawlineseg will do this one for us
4224 # should handle duplicated parents here...
4225 set coords [list $x $y]
4227 # if attaching to a vertical segment, draw a smaller
4228 # slant for visual distinctness
4231 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4233 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4235 } elseif {$i < $col && $i < $j} {
4236 # segment slants towards us already
4237 lappend coords [xc $row $j] $y
4239 if {$i < $col - 1} {
4240 lappend coords [expr {$x2 + $linespc}] $y
4241 } elseif {$i > $col + 1} {
4242 lappend coords [expr {$x2 - $linespc}] $y
4244 lappend coords $x2 $y2
4247 lappend coords $x2 $y2
4249 set t [$canv create line $coords -width [linewidth $p] \
4250 -fill $colormap($p) -tags lines.$p]
4254 if {$rmx > [lindex $idpos($id) 1]} {
4255 lset idpos($id) 1 $rmx
4260 proc drawlines {id} {
4263 $canv itemconf lines.$id -width [linewidth $id]
4266 proc drawcmittext {id row col} {
4267 global linespc canv canv2 canv3 fgcolor curview
4268 global cmitlisted commitinfo rowidlist parentlist
4269 global rowtextx idpos idtags idheads idotherrefs
4270 global linehtag linentag linedtag selectedline
4271 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4273 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4274 set listed $cmitlisted($curview,$id)
4275 if {$id eq $nullid} {
4277 } elseif {$id eq $nullid2} {
4280 set ofill [expr {$listed != 0? "blue": "white"}]
4282 set x [xc $row $col]
4284 set orad [expr {$linespc / 3}]
4286 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4287 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4288 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4289 } elseif {$listed == 2} {
4290 # triangle pointing left for left-side commits
4291 set t [$canv create polygon \
4292 [expr {$x - $orad}] $y \
4293 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4294 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4295 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4297 # triangle pointing right for right-side commits
4298 set t [$canv create polygon \
4299 [expr {$x + $orad - 1}] $y \
4300 [expr {$x - $orad}] [expr {$y - $orad}] \
4301 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4302 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4305 $canv bind $t <1> {selcanvline {} %x %y}
4306 set rmx [llength [lindex $rowidlist $row]]
4307 set olds [lindex $parentlist $row]
4309 set nextids [lindex $rowidlist [expr {$row + 1}]]
4311 set i [lsearch -exact $nextids $p]
4317 set xt [xc $row $rmx]
4318 set rowtextx($row) $xt
4319 set idpos($id) [list $x $xt $y]
4320 if {[info exists idtags($id)] || [info exists idheads($id)]
4321 || [info exists idotherrefs($id)]} {
4322 set xt [drawtags $id $x $xt $y]
4324 set headline [lindex $commitinfo($id) 0]
4325 set name [lindex $commitinfo($id) 1]
4326 set date [lindex $commitinfo($id) 2]
4327 set date [formatdate $date]
4330 set isbold [ishighlighted $row]
4332 lappend boldrows $row
4333 set font mainfontbold
4335 lappend boldnamerows $row
4336 set nfont mainfontbold
4339 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4340 -text $headline -font $font -tags text]
4341 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4342 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4343 -text $name -font $nfont -tags text]
4344 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4345 -text $date -font mainfont -tags text]
4346 if {[info exists selectedline] && $selectedline == $row} {
4349 set xr [expr {$xt + [font measure $font $headline]}]
4350 if {$xr > $canvxmax} {
4356 proc drawcmitrow {row} {
4357 global displayorder rowidlist nrows_drawn
4358 global iddrawn markingmatches
4359 global commitinfo numcommits
4360 global filehighlight fhighlights findpattern nhighlights
4361 global hlview vhighlights
4362 global highlight_related rhighlights
4364 if {$row >= $numcommits} return
4366 set id [lindex $displayorder $row]
4367 if {[info exists hlview] && ![info exists vhighlights($row)]} {
4368 askvhighlight $row $id
4370 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
4371 askfilehighlight $row $id
4373 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
4374 askfindhighlight $row $id
4376 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
4377 askrelhighlight $row $id
4379 if {![info exists iddrawn($id)]} {
4380 set col [lsearch -exact [lindex $rowidlist $row] $id]
4382 puts "oops, row $row id $id not in list"
4385 if {![info exists commitinfo($id)]} {
4389 drawcmittext $id $row $col
4393 if {$markingmatches} {
4394 markrowmatches $row $id
4398 proc drawcommits {row {endrow {}}} {
4399 global numcommits iddrawn displayorder curview need_redisplay
4400 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4405 if {$endrow eq {}} {
4408 if {$endrow >= $numcommits} {
4409 set endrow [expr {$numcommits - 1}]
4412 set rl1 [expr {$row - $downarrowlen - 3}]
4416 set ro1 [expr {$row - 3}]
4420 set r2 [expr {$endrow + $uparrowlen + 3}]
4421 if {$r2 > $numcommits} {
4424 for {set r $rl1} {$r < $r2} {incr r} {
4425 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4429 set rl1 [expr {$r + 1}]
4435 optimize_rows $ro1 0 $r2
4436 if {$need_redisplay || $nrows_drawn > 2000} {
4441 # make the lines join to already-drawn rows either side
4442 set r [expr {$row - 1}]
4443 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4446 set er [expr {$endrow + 1}]
4447 if {$er >= $numcommits ||
4448 ![info exists iddrawn([lindex $displayorder $er])]} {
4451 for {} {$r <= $er} {incr r} {
4452 set id [lindex $displayorder $r]
4453 set wasdrawn [info exists iddrawn($id)]
4455 if {$r == $er} break
4456 set nextid [lindex $displayorder [expr {$r + 1}]]
4457 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4458 drawparentlinks $id $r
4460 set rowids [lindex $rowidlist $r]
4461 foreach lid $rowids {
4462 if {$lid eq {}} continue
4463 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4465 # see if this is the first child of any of its parents
4466 foreach p [lindex $parentlist $r] {
4467 if {[lsearch -exact $rowids $p] < 0} {
4468 # make this line extend up to the child
4469 set lineend($p) [drawlineseg $p $r $er 0]
4473 set lineend($lid) [drawlineseg $lid $r $er 1]
4479 proc undolayout {row} {
4480 global uparrowlen mingaplen downarrowlen
4481 global rowidlist rowisopt rowfinal need_redisplay
4483 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4487 if {[llength $rowidlist] > $r} {
4489 set rowidlist [lrange $rowidlist 0 $r]
4490 set rowfinal [lrange $rowfinal 0 $r]
4491 set rowisopt [lrange $rowisopt 0 $r]
4492 set need_redisplay 1
4497 proc drawfrac {f0 f1} {
4500 set ymax [lindex [$canv cget -scrollregion] 3]
4501 if {$ymax eq {} || $ymax == 0} return
4502 set y0 [expr {int($f0 * $ymax)}]
4503 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4504 set y1 [expr {int($f1 * $ymax)}]
4505 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4506 drawcommits $row $endrow
4509 proc drawvisible {} {
4511 eval drawfrac [$canv yview]
4514 proc clear_display {} {
4515 global iddrawn linesegs need_redisplay nrows_drawn
4516 global vhighlights fhighlights nhighlights rhighlights
4519 catch {unset iddrawn}
4520 catch {unset linesegs}
4521 catch {unset vhighlights}
4522 catch {unset fhighlights}
4523 catch {unset nhighlights}
4524 catch {unset rhighlights}
4525 set need_redisplay 0
4529 proc findcrossings {id} {
4530 global rowidlist parentlist numcommits displayorder
4534 foreach {s e} [rowranges $id] {
4535 if {$e >= $numcommits} {
4536 set e [expr {$numcommits - 1}]
4538 if {$e <= $s} continue
4539 for {set row $e} {[incr row -1] >= $s} {} {
4540 set x [lsearch -exact [lindex $rowidlist $row] $id]
4542 set olds [lindex $parentlist $row]
4543 set kid [lindex $displayorder $row]
4544 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4545 if {$kidx < 0} continue
4546 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4548 set px [lsearch -exact $nextrow $p]
4549 if {$px < 0} continue
4550 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4551 if {[lsearch -exact $ccross $p] >= 0} continue
4552 if {$x == $px + ($kidx < $px? -1: 1)} {
4554 } elseif {[lsearch -exact $cross $p] < 0} {
4561 return [concat $ccross {{}} $cross]
4564 proc assigncolor {id} {
4565 global colormap colors nextcolor
4566 global parents children children curview
4568 if {[info exists colormap($id)]} return
4569 set ncolors [llength $colors]
4570 if {[info exists children($curview,$id)]} {
4571 set kids $children($curview,$id)
4575 if {[llength $kids] == 1} {
4576 set child [lindex $kids 0]
4577 if {[info exists colormap($child)]
4578 && [llength $parents($curview,$child)] == 1} {
4579 set colormap($id) $colormap($child)
4585 foreach x [findcrossings $id] {
4587 # delimiter between corner crossings and other crossings
4588 if {[llength $badcolors] >= $ncolors - 1} break
4589 set origbad $badcolors
4591 if {[info exists colormap($x)]
4592 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4593 lappend badcolors $colormap($x)
4596 if {[llength $badcolors] >= $ncolors} {
4597 set badcolors $origbad
4599 set origbad $badcolors
4600 if {[llength $badcolors] < $ncolors - 1} {
4601 foreach child $kids {
4602 if {[info exists colormap($child)]
4603 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4604 lappend badcolors $colormap($child)
4606 foreach p $parents($curview,$child) {
4607 if {[info exists colormap($p)]
4608 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4609 lappend badcolors $colormap($p)
4613 if {[llength $badcolors] >= $ncolors} {
4614 set badcolors $origbad
4617 for {set i 0} {$i <= $ncolors} {incr i} {
4618 set c [lindex $colors $nextcolor]
4619 if {[incr nextcolor] >= $ncolors} {
4622 if {[lsearch -exact $badcolors $c]} break
4624 set colormap($id) $c
4627 proc bindline {t id} {
4630 $canv bind $t <Enter> "lineenter %x %y $id"
4631 $canv bind $t <Motion> "linemotion %x %y $id"
4632 $canv bind $t <Leave> "lineleave $id"
4633 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4636 proc drawtags {id x xt y1} {
4637 global idtags idheads idotherrefs mainhead
4638 global linespc lthickness
4639 global canv rowtextx curview fgcolor bgcolor
4644 if {[info exists idtags($id)]} {
4645 set marks $idtags($id)
4646 set ntags [llength $marks]
4648 if {[info exists idheads($id)]} {
4649 set marks [concat $marks $idheads($id)]
4650 set nheads [llength $idheads($id)]
4652 if {[info exists idotherrefs($id)]} {
4653 set marks [concat $marks $idotherrefs($id)]
4659 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4660 set yt [expr {$y1 - 0.5 * $linespc}]
4661 set yb [expr {$yt + $linespc - 1}]
4665 foreach tag $marks {
4667 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4668 set wid [font measure mainfontbold $tag]
4670 set wid [font measure mainfont $tag]
4674 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4676 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4677 -width $lthickness -fill black -tags tag.$id]
4679 foreach tag $marks x $xvals wid $wvals {
4680 set xl [expr {$x + $delta}]
4681 set xr [expr {$x + $delta + $wid + $lthickness}]
4683 if {[incr ntags -1] >= 0} {
4685 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4686 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4687 -width 1 -outline black -fill yellow -tags tag.$id]
4688 $canv bind $t <1> [list showtag $tag 1]
4689 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4691 # draw a head or other ref
4692 if {[incr nheads -1] >= 0} {
4694 if {$tag eq $mainhead} {
4695 set font mainfontbold
4700 set xl [expr {$xl - $delta/2}]
4701 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4702 -width 1 -outline black -fill $col -tags tag.$id
4703 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4704 set rwid [font measure mainfont $remoteprefix]
4705 set xi [expr {$x + 1}]
4706 set yti [expr {$yt + 1}]
4707 set xri [expr {$x + $rwid}]
4708 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4709 -width 0 -fill "#ffddaa" -tags tag.$id
4712 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4713 -font $font -tags [list tag.$id text]]
4715 $canv bind $t <1> [list showtag $tag 1]
4716 } elseif {$nheads >= 0} {
4717 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4723 proc xcoord {i level ln} {
4724 global canvx0 xspc1 xspc2
4726 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4727 if {$i > 0 && $i == $level} {
4728 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4729 } elseif {$i > $level} {
4730 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4735 proc show_status {msg} {
4739 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4740 -tags text -fill $fgcolor
4743 # Don't change the text pane cursor if it is currently the hand cursor,
4744 # showing that we are over a sha1 ID link.
4745 proc settextcursor {c} {
4746 global ctext curtextcursor
4748 if {[$ctext cget -cursor] == $curtextcursor} {
4749 $ctext config -cursor $c
4751 set curtextcursor $c
4754 proc nowbusy {what {name {}}} {
4755 global isbusy busyname statusw
4757 if {[array names isbusy] eq {}} {
4758 . config -cursor watch
4762 set busyname($what) $name
4764 $statusw conf -text $name
4768 proc notbusy {what} {
4769 global isbusy maincursor textcursor busyname statusw
4773 if {$busyname($what) ne {} &&
4774 [$statusw cget -text] eq $busyname($what)} {
4775 $statusw conf -text {}
4778 if {[array names isbusy] eq {}} {
4779 . config -cursor $maincursor
4780 settextcursor $textcursor
4784 proc findmatches {f} {
4785 global findtype findstring
4786 if {$findtype == "Regexp"} {
4787 set matches [regexp -indices -all -inline $findstring $f]
4790 if {$findtype == "IgnCase"} {
4791 set f [string tolower $f]
4792 set fs [string tolower $fs]
4796 set l [string length $fs]
4797 while {[set j [string first $fs $f $i]] >= 0} {
4798 lappend matches [list $j [expr {$j+$l-1}]]
4799 set i [expr {$j + $l}]
4805 proc dofind {{dirn 1} {wrap 1}} {
4806 global findstring findstartline findcurline selectedline numcommits
4807 global gdttype filehighlight fh_serial find_dirn findallowwrap
4809 if {[info exists find_dirn]} {
4810 if {$find_dirn == $dirn} return
4814 if {$findstring eq {} || $numcommits == 0} return
4815 if {![info exists selectedline]} {
4816 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4818 set findstartline $selectedline
4820 set findcurline $findstartline
4821 nowbusy finding "Searching"
4822 if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4823 after cancel do_file_hl $fh_serial
4824 do_file_hl $fh_serial
4827 set findallowwrap $wrap
4831 proc stopfinding {} {
4832 global find_dirn findcurline fprogcoord
4834 if {[info exists find_dirn]} {
4844 global commitdata commitinfo numcommits findpattern findloc
4845 global findstartline findcurline findallowwrap
4846 global find_dirn gdttype fhighlights fprogcoord
4847 global curview varcorder vrownum varccommits
4849 if {![info exists find_dirn]} {
4852 set fldtypes {Headline Author Date Committer CDate Comments}
4855 if {$find_dirn > 0} {
4857 if {$l >= $numcommits} {
4860 if {$l <= $findstartline} {
4861 set lim [expr {$findstartline + 1}]
4864 set moretodo $findallowwrap
4871 if {$l >= $findstartline} {
4872 set lim [expr {$findstartline - 1}]
4875 set moretodo $findallowwrap
4878 set n [expr {($lim - $l) * $find_dirn}]
4885 set ai [bsearch $vrownum($curview) $l]
4886 set a [lindex $varcorder($curview) $ai]
4887 set arow [lindex $vrownum($curview) $ai]
4888 set ids [lindex $varccommits($curview,$a)]
4889 set arowend [expr {$arow + [llength $ids]}]
4890 if {$gdttype eq "containing:"} {
4891 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4892 if {$l < $arow || $l >= $arowend} {
4894 set a [lindex $varcorder($curview) $ai]
4895 set arow [lindex $vrownum($curview) $ai]
4896 set ids [lindex $varccommits($curview,$a)]
4897 set arowend [expr {$arow + [llength $ids]}]
4899 set id [lindex $ids [expr {$l - $arow}]]
4900 # shouldn't happen unless git log doesn't give all the commits...
4901 if {![info exists commitdata($id)] ||
4902 ![doesmatch $commitdata($id)]} {
4905 if {![info exists commitinfo($id)]} {
4908 set info $commitinfo($id)
4909 foreach f $info ty $fldtypes {
4910 if {($findloc eq "All fields" || $findloc eq $ty) &&
4919 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4920 if {$l < $arow || $l >= $arowend} {
4922 set a [lindex $varcorder($curview) $ai]
4923 set arow [lindex $vrownum($curview) $ai]
4924 set ids [lindex $varccommits($curview,$a)]
4925 set arowend [expr {$arow + [llength $ids]}]
4927 set id [lindex $ids [expr {$l - $arow}]]
4928 if {![info exists fhighlights($l)]} {
4929 askfilehighlight $l $id
4932 set findcurline [expr {$l - $find_dirn}]
4934 } elseif {$fhighlights($l)} {
4940 if {$found || ($domore && !$moretodo)} {
4956 set findcurline [expr {$l - $find_dirn}]
4958 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
4962 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4967 proc findselectline {l} {
4968 global findloc commentend ctext findcurline markingmatches gdttype
4970 set markingmatches 1
4973 if {$findloc == "All fields" || $findloc == "Comments"} {
4974 # highlight the matches in the comments
4975 set f [$ctext get 1.0 $commentend]
4976 set matches [findmatches $f]
4977 foreach match $matches {
4978 set start [lindex $match 0]
4979 set end [expr {[lindex $match 1] + 1}]
4980 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4986 # mark the bits of a headline or author that match a find string
4987 proc markmatches {canv l str tag matches font row} {
4990 set bbox [$canv bbox $tag]
4991 set x0 [lindex $bbox 0]
4992 set y0 [lindex $bbox 1]
4993 set y1 [lindex $bbox 3]
4994 foreach match $matches {
4995 set start [lindex $match 0]
4996 set end [lindex $match 1]
4997 if {$start > $end} continue
4998 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4999 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5000 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5001 [expr {$x0+$xlen+2}] $y1 \
5002 -outline {} -tags [list match$l matches] -fill yellow]
5004 if {[info exists selectedline] && $row == $selectedline} {
5005 $canv raise $t secsel
5010 proc unmarkmatches {} {
5011 global markingmatches
5013 allcanvs delete matches
5014 set markingmatches 0
5018 proc selcanvline {w x y} {
5019 global canv canvy0 ctext linespc
5021 set ymax [lindex [$canv cget -scrollregion] 3]
5022 if {$ymax == {}} return
5023 set yfrac [lindex [$canv yview] 0]
5024 set y [expr {$y + $yfrac * $ymax}]
5025 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5030 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
5036 proc commit_descriptor {p} {
5038 if {![info exists commitinfo($p)]} {
5042 if {[llength $commitinfo($p)] > 1} {
5043 set l [lindex $commitinfo($p) 0]
5048 # append some text to the ctext widget, and make any SHA1 ID
5049 # that we know about be a clickable link.
5050 proc appendwithlinks {text tags} {
5051 global ctext linknum curview pendinglinks
5053 set start [$ctext index "end - 1c"]
5054 $ctext insert end $text $tags
5055 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5059 set linkid [string range $text $s $e]
5061 $ctext tag delete link$linknum
5062 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5063 setlink $linkid link$linknum
5068 proc setlink {id lk} {
5069 global curview ctext pendinglinks commitinterest
5071 if {[commitinview $id $curview]} {
5072 $ctext tag conf $lk -foreground blue -underline 1
5073 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5074 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5075 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5077 lappend pendinglinks($id) $lk
5078 lappend commitinterest($id) {makelink %I}
5082 proc makelink {id} {
5085 if {![info exists pendinglinks($id)]} return
5086 foreach lk $pendinglinks($id) {
5089 unset pendinglinks($id)
5092 proc linkcursor {w inc} {
5093 global linkentercount curtextcursor
5095 if {[incr linkentercount $inc] > 0} {
5096 $w configure -cursor hand2
5098 $w configure -cursor $curtextcursor
5099 if {$linkentercount < 0} {
5100 set linkentercount 0
5105 proc viewnextline {dir} {
5109 set ymax [lindex [$canv cget -scrollregion] 3]
5110 set wnow [$canv yview]
5111 set wtop [expr {[lindex $wnow 0] * $ymax}]
5112 set newtop [expr {$wtop + $dir * $linespc}]
5115 } elseif {$newtop > $ymax} {
5118 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5121 # add a list of tag or branch names at position pos
5122 # returns the number of names inserted
5123 proc appendrefs {pos ids var} {
5124 global ctext linknum curview $var maxrefs
5126 if {[catch {$ctext index $pos}]} {
5129 $ctext conf -state normal
5130 $ctext delete $pos "$pos lineend"
5133 foreach tag [set $var\($id\)] {
5134 lappend tags [list $tag $id]
5137 if {[llength $tags] > $maxrefs} {
5138 $ctext insert $pos "many ([llength $tags])"
5140 set tags [lsort -index 0 -decreasing $tags]
5143 set id [lindex $ti 1]
5146 $ctext tag delete $lk
5147 $ctext insert $pos $sep
5148 $ctext insert $pos [lindex $ti 0] $lk
5153 $ctext conf -state disabled
5154 return [llength $tags]
5157 # called when we have finished computing the nearby tags
5158 proc dispneartags {delay} {
5159 global selectedline currentid showneartags tagphase
5161 if {![info exists selectedline] || !$showneartags} return
5162 after cancel dispnexttag
5164 after 200 dispnexttag
5167 after idle dispnexttag
5172 proc dispnexttag {} {
5173 global selectedline currentid showneartags tagphase ctext
5175 if {![info exists selectedline] || !$showneartags} return
5176 switch -- $tagphase {
5178 set dtags [desctags $currentid]
5180 appendrefs precedes $dtags idtags
5184 set atags [anctags $currentid]
5186 appendrefs follows $atags idtags
5190 set dheads [descheads $currentid]
5191 if {$dheads ne {}} {
5192 if {[appendrefs branch $dheads idheads] > 1
5193 && [$ctext get "branch -3c"] eq "h"} {
5194 # turn "Branch" into "Branches"
5195 $ctext conf -state normal
5196 $ctext insert "branch -2c" "es"
5197 $ctext conf -state disabled
5202 if {[incr tagphase] <= 2} {
5203 after idle dispnexttag
5207 proc make_secsel {l} {
5208 global linehtag linentag linedtag canv canv2 canv3
5210 if {![info exists linehtag($l)]} return
5212 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5213 -tags secsel -fill [$canv cget -selectbackground]]
5215 $canv2 delete secsel
5216 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5217 -tags secsel -fill [$canv2 cget -selectbackground]]
5219 $canv3 delete secsel
5220 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5221 -tags secsel -fill [$canv3 cget -selectbackground]]
5225 proc selectline {l isnew} {
5226 global canv ctext commitinfo selectedline
5227 global canvy0 linespc parents children curview
5228 global currentid sha1entry
5229 global commentend idtags linknum
5230 global mergemax numcommits pending_select
5231 global cmitmode showneartags allcommits
5233 catch {unset pending_select}
5238 if {$l < 0 || $l >= $numcommits} return
5239 set y [expr {$canvy0 + $l * $linespc}]
5240 set ymax [lindex [$canv cget -scrollregion] 3]
5241 set ytop [expr {$y - $linespc - 1}]
5242 set ybot [expr {$y + $linespc + 1}]
5243 set wnow [$canv yview]
5244 set wtop [expr {[lindex $wnow 0] * $ymax}]
5245 set wbot [expr {[lindex $wnow 1] * $ymax}]
5246 set wh [expr {$wbot - $wtop}]
5248 if {$ytop < $wtop} {
5249 if {$ybot < $wtop} {
5250 set newtop [expr {$y - $wh / 2.0}]
5253 if {$newtop > $wtop - $linespc} {
5254 set newtop [expr {$wtop - $linespc}]
5257 } elseif {$ybot > $wbot} {
5258 if {$ytop > $wbot} {
5259 set newtop [expr {$y - $wh / 2.0}]
5261 set newtop [expr {$ybot - $wh}]
5262 if {$newtop < $wtop + $linespc} {
5263 set newtop [expr {$wtop + $linespc}]
5267 if {$newtop != $wtop} {
5271 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5278 addtohistory [list selectline $l 0]
5283 set id [commitonrow $l]
5285 $sha1entry delete 0 end
5286 $sha1entry insert 0 $id
5287 $sha1entry selection from 0
5288 $sha1entry selection to end
5291 $ctext conf -state normal
5294 set info $commitinfo($id)
5295 set date [formatdate [lindex $info 2]]
5296 $ctext insert end "Author: [lindex $info 1] $date\n"
5297 set date [formatdate [lindex $info 4]]
5298 $ctext insert end "Committer: [lindex $info 3] $date\n"
5299 if {[info exists idtags($id)]} {
5300 $ctext insert end "Tags:"
5301 foreach tag $idtags($id) {
5302 $ctext insert end " $tag"
5304 $ctext insert end "\n"
5308 set olds $parents($curview,$id)
5309 if {[llength $olds] > 1} {
5312 if {$np >= $mergemax} {
5317 $ctext insert end "Parent: " $tag
5318 appendwithlinks [commit_descriptor $p] {}
5323 append headers "Parent: [commit_descriptor $p]"
5327 foreach c $children($curview,$id) {
5328 append headers "Child: [commit_descriptor $c]"
5331 # make anything that looks like a SHA1 ID be a clickable link
5332 appendwithlinks $headers {}
5333 if {$showneartags} {
5334 if {![info exists allcommits]} {
5337 $ctext insert end "Branch: "
5338 $ctext mark set branch "end -1c"
5339 $ctext mark gravity branch left
5340 $ctext insert end "\nFollows: "
5341 $ctext mark set follows "end -1c"
5342 $ctext mark gravity follows left
5343 $ctext insert end "\nPrecedes: "
5344 $ctext mark set precedes "end -1c"
5345 $ctext mark gravity precedes left
5346 $ctext insert end "\n"
5349 $ctext insert end "\n"
5350 set comment [lindex $info 5]
5351 if {[string first "\r" $comment] >= 0} {
5352 set comment [string map {"\r" "\n "} $comment]
5354 appendwithlinks $comment {comment}
5356 $ctext tag remove found 1.0 end
5357 $ctext conf -state disabled
5358 set commentend [$ctext index "end - 1c"]
5360 init_flist "Comments"
5361 if {$cmitmode eq "tree"} {
5363 } elseif {[llength $olds] <= 1} {
5370 proc selfirstline {} {
5375 proc sellastline {} {
5378 set l [expr {$numcommits - 1}]
5382 proc selnextline {dir} {
5385 if {![info exists selectedline]} return
5386 set l [expr {$selectedline + $dir}]
5391 proc selnextpage {dir} {
5392 global canv linespc selectedline numcommits
5394 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5398 allcanvs yview scroll [expr {$dir * $lpp}] units
5400 if {![info exists selectedline]} return
5401 set l [expr {$selectedline + $dir * $lpp}]
5404 } elseif {$l >= $numcommits} {
5405 set l [expr $numcommits - 1]
5411 proc unselectline {} {
5412 global selectedline currentid
5414 catch {unset selectedline}
5415 catch {unset currentid}
5416 allcanvs delete secsel
5420 proc reselectline {} {
5423 if {[info exists selectedline]} {
5424 selectline $selectedline 0
5428 proc addtohistory {cmd} {
5429 global history historyindex curview
5431 set elt [list $curview $cmd]
5432 if {$historyindex > 0
5433 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5437 if {$historyindex < [llength $history]} {
5438 set history [lreplace $history $historyindex end $elt]
5440 lappend history $elt
5443 if {$historyindex > 1} {
5444 .tf.bar.leftbut conf -state normal
5446 .tf.bar.leftbut conf -state disabled
5448 .tf.bar.rightbut conf -state disabled
5454 set view [lindex $elt 0]
5455 set cmd [lindex $elt 1]
5456 if {$curview != $view} {
5463 global history historyindex
5466 if {$historyindex > 1} {
5467 incr historyindex -1
5468 godo [lindex $history [expr {$historyindex - 1}]]
5469 .tf.bar.rightbut conf -state normal
5471 if {$historyindex <= 1} {
5472 .tf.bar.leftbut conf -state disabled
5477 global history historyindex
5480 if {$historyindex < [llength $history]} {
5481 set cmd [lindex $history $historyindex]
5484 .tf.bar.leftbut conf -state normal
5486 if {$historyindex >= [llength $history]} {
5487 .tf.bar.rightbut conf -state disabled
5492 global treefilelist treeidlist diffids diffmergeid treepending
5493 global nullid nullid2
5496 catch {unset diffmergeid}
5497 if {![info exists treefilelist($id)]} {
5498 if {![info exists treepending]} {
5499 if {$id eq $nullid} {
5500 set cmd [list | git ls-files]
5501 } elseif {$id eq $nullid2} {
5502 set cmd [list | git ls-files --stage -t]
5504 set cmd [list | git ls-tree -r $id]
5506 if {[catch {set gtf [open $cmd r]}]} {
5510 set treefilelist($id) {}
5511 set treeidlist($id) {}
5512 fconfigure $gtf -blocking 0
5513 filerun $gtf [list gettreeline $gtf $id]
5520 proc gettreeline {gtf id} {
5521 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5524 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5525 if {$diffids eq $nullid} {
5528 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5529 set i [string first "\t" $line]
5530 if {$i < 0} continue
5531 set sha1 [lindex $line 2]
5532 set fname [string range $line [expr {$i+1}] end]
5533 if {[string index $fname 0] eq "\""} {
5534 set fname [lindex $fname 0]
5536 lappend treeidlist($id) $sha1
5538 lappend treefilelist($id) $fname
5541 return [expr {$nl >= 1000? 2: 1}]
5545 if {$cmitmode ne "tree"} {
5546 if {![info exists diffmergeid]} {
5547 gettreediffs $diffids
5549 } elseif {$id ne $diffids} {
5558 global treefilelist treeidlist diffids nullid nullid2
5559 global ctext commentend
5561 set i [lsearch -exact $treefilelist($diffids) $f]
5563 puts "oops, $f not in list for id $diffids"
5566 if {$diffids eq $nullid} {
5567 if {[catch {set bf [open $f r]} err]} {
5568 puts "oops, can't read $f: $err"
5572 set blob [lindex $treeidlist($diffids) $i]
5573 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5574 puts "oops, error reading blob $blob: $err"
5578 fconfigure $bf -blocking 0
5579 filerun $bf [list getblobline $bf $diffids]
5580 $ctext config -state normal
5581 clear_ctext $commentend
5582 $ctext insert end "\n"
5583 $ctext insert end "$f\n" filesep
5584 $ctext config -state disabled
5585 $ctext yview $commentend
5589 proc getblobline {bf id} {
5590 global diffids cmitmode ctext
5592 if {$id ne $diffids || $cmitmode ne "tree"} {
5596 $ctext config -state normal
5598 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5599 $ctext insert end "$line\n"
5602 # delete last newline
5603 $ctext delete "end - 2c" "end - 1c"
5607 $ctext config -state disabled
5608 return [expr {$nl >= 1000? 2: 1}]
5611 proc mergediff {id} {
5612 global diffmergeid mdifffd
5615 global limitdiffs viewfiles curview
5619 # this doesn't seem to actually affect anything...
5620 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5621 if {$limitdiffs && $viewfiles($curview) ne {}} {
5622 set cmd [concat $cmd -- $viewfiles($curview)]
5624 if {[catch {set mdf [open $cmd r]} err]} {
5625 error_popup "Error getting merge diffs: $err"
5628 fconfigure $mdf -blocking 0
5629 set mdifffd($id) $mdf
5630 set np [llength $parents($curview,$id)]
5632 filerun $mdf [list getmergediffline $mdf $id $np]
5635 proc getmergediffline {mdf id np} {
5636 global diffmergeid ctext cflist mergemax
5637 global difffilestart mdifffd
5639 $ctext conf -state normal
5641 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5642 if {![info exists diffmergeid] || $id != $diffmergeid
5643 || $mdf != $mdifffd($id)} {
5647 if {[regexp {^diff --cc (.*)} $line match fname]} {
5648 # start of a new file
5649 $ctext insert end "\n"
5650 set here [$ctext index "end - 1c"]
5651 lappend difffilestart $here
5652 add_flist [list $fname]
5653 set l [expr {(78 - [string length $fname]) / 2}]
5654 set pad [string range "----------------------------------------" 1 $l]
5655 $ctext insert end "$pad $fname $pad\n" filesep
5656 } elseif {[regexp {^@@} $line]} {
5657 $ctext insert end "$line\n" hunksep
5658 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5661 # parse the prefix - one ' ', '-' or '+' for each parent
5666 for {set j 0} {$j < $np} {incr j} {
5667 set c [string range $line $j $j]
5670 } elseif {$c == "-"} {
5672 } elseif {$c == "+"} {
5681 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5682 # line doesn't appear in result, parents in $minuses have the line
5683 set num [lindex $minuses 0]
5684 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5685 # line appears in result, parents in $pluses don't have the line
5686 lappend tags mresult
5687 set num [lindex $spaces 0]
5690 if {$num >= $mergemax} {
5695 $ctext insert end "$line\n" $tags
5698 $ctext conf -state disabled
5703 return [expr {$nr >= 1000? 2: 1}]
5706 proc startdiff {ids} {
5707 global treediffs diffids treepending diffmergeid nullid nullid2
5711 catch {unset diffmergeid}
5712 if {![info exists treediffs($ids)] ||
5713 [lsearch -exact $ids $nullid] >= 0 ||
5714 [lsearch -exact $ids $nullid2] >= 0} {
5715 if {![info exists treepending]} {
5723 proc path_filter {filter name} {
5725 set l [string length $p]
5726 if {[string index $p end] eq "/"} {
5727 if {[string compare -length $l $p $name] == 0} {
5731 if {[string compare -length $l $p $name] == 0 &&
5732 ([string length $name] == $l ||
5733 [string index $name $l] eq "/")} {
5741 proc addtocflist {ids} {
5744 add_flist $treediffs($ids)
5748 proc diffcmd {ids flags} {
5749 global nullid nullid2
5751 set i [lsearch -exact $ids $nullid]
5752 set j [lsearch -exact $ids $nullid2]
5754 if {[llength $ids] > 1 && $j < 0} {
5755 # comparing working directory with some specific revision
5756 set cmd [concat | git diff-index $flags]
5758 lappend cmd -R [lindex $ids 1]
5760 lappend cmd [lindex $ids 0]
5763 # comparing working directory with index
5764 set cmd [concat | git diff-files $flags]
5769 } elseif {$j >= 0} {
5770 set cmd [concat | git diff-index --cached $flags]
5771 if {[llength $ids] > 1} {
5772 # comparing index with specific revision
5774 lappend cmd -R [lindex $ids 1]
5776 lappend cmd [lindex $ids 0]
5779 # comparing index with HEAD
5783 set cmd [concat | git diff-tree -r $flags $ids]
5788 proc gettreediffs {ids} {
5789 global treediff treepending
5791 set treepending $ids
5793 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5794 fconfigure $gdtf -blocking 0
5795 filerun $gdtf [list gettreediffline $gdtf $ids]
5798 proc gettreediffline {gdtf ids} {
5799 global treediff treediffs treepending diffids diffmergeid
5800 global cmitmode viewfiles curview limitdiffs
5803 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5804 set i [string first "\t" $line]
5806 set file [string range $line [expr {$i+1}] end]
5807 if {[string index $file 0] eq "\""} {
5808 set file [lindex $file 0]
5810 lappend treediff $file
5814 return [expr {$nr >= 1000? 2: 1}]
5817 if {$limitdiffs && $viewfiles($curview) ne {}} {
5819 foreach f $treediff {
5820 if {[path_filter $viewfiles($curview) $f]} {
5824 set treediffs($ids) $flist
5826 set treediffs($ids) $treediff
5829 if {$cmitmode eq "tree"} {
5831 } elseif {$ids != $diffids} {
5832 if {![info exists diffmergeid]} {
5833 gettreediffs $diffids
5841 # empty string or positive integer
5842 proc diffcontextvalidate {v} {
5843 return [regexp {^(|[1-9][0-9]*)$} $v]
5846 proc diffcontextchange {n1 n2 op} {
5847 global diffcontextstring diffcontext
5849 if {[string is integer -strict $diffcontextstring]} {
5850 if {$diffcontextstring > 0} {
5851 set diffcontext $diffcontextstring
5857 proc getblobdiffs {ids} {
5858 global blobdifffd diffids env
5859 global diffinhdr treediffs
5861 global limitdiffs viewfiles curview
5863 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5864 if {$limitdiffs && $viewfiles($curview) ne {}} {
5865 set cmd [concat $cmd -- $viewfiles($curview)]
5867 if {[catch {set bdf [open $cmd r]} err]} {
5868 puts "error getting diffs: $err"
5872 fconfigure $bdf -blocking 0
5873 set blobdifffd($ids) $bdf
5874 filerun $bdf [list getblobdiffline $bdf $diffids]
5877 proc setinlist {var i val} {
5880 while {[llength [set $var]] < $i} {
5883 if {[llength [set $var]] == $i} {
5890 proc makediffhdr {fname ids} {
5891 global ctext curdiffstart treediffs
5893 set i [lsearch -exact $treediffs($ids) $fname]
5895 setinlist difffilestart $i $curdiffstart
5897 set l [expr {(78 - [string length $fname]) / 2}]
5898 set pad [string range "----------------------------------------" 1 $l]
5899 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5902 proc getblobdiffline {bdf ids} {
5903 global diffids blobdifffd ctext curdiffstart
5904 global diffnexthead diffnextnote difffilestart
5905 global diffinhdr treediffs
5908 $ctext conf -state normal
5909 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5910 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5914 if {![string compare -length 11 "diff --git " $line]} {
5915 # trim off "diff --git "
5916 set line [string range $line 11 end]
5918 # start of a new file
5919 $ctext insert end "\n"
5920 set curdiffstart [$ctext index "end - 1c"]
5921 $ctext insert end "\n" filesep
5922 # If the name hasn't changed the length will be odd,
5923 # the middle char will be a space, and the two bits either
5924 # side will be a/name and b/name, or "a/name" and "b/name".
5925 # If the name has changed we'll get "rename from" and
5926 # "rename to" or "copy from" and "copy to" lines following this,
5927 # and we'll use them to get the filenames.
5928 # This complexity is necessary because spaces in the filename(s)
5929 # don't get escaped.
5930 set l [string length $line]
5931 set i [expr {$l / 2}]
5932 if {!(($l & 1) && [string index $line $i] eq " " &&
5933 [string range $line 2 [expr {$i - 1}]] eq \
5934 [string range $line [expr {$i + 3}] end])} {
5937 # unescape if quoted and chop off the a/ from the front
5938 if {[string index $line 0] eq "\""} {
5939 set fname [string range [lindex $line 0] 2 end]
5941 set fname [string range $line 2 [expr {$i - 1}]]
5943 makediffhdr $fname $ids
5945 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5946 $line match f1l f1c f2l f2c rest]} {
5947 $ctext insert end "$line\n" hunksep
5950 } elseif {$diffinhdr} {
5951 if {![string compare -length 12 "rename from " $line]} {
5952 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5953 if {[string index $fname 0] eq "\""} {
5954 set fname [lindex $fname 0]
5956 set i [lsearch -exact $treediffs($ids) $fname]
5958 setinlist difffilestart $i $curdiffstart
5960 } elseif {![string compare -length 10 $line "rename to "] ||
5961 ![string compare -length 8 $line "copy to "]} {
5962 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5963 if {[string index $fname 0] eq "\""} {
5964 set fname [lindex $fname 0]
5966 makediffhdr $fname $ids
5967 } elseif {[string compare -length 3 $line "---"] == 0} {
5970 } elseif {[string compare -length 3 $line "+++"] == 0} {
5974 $ctext insert end "$line\n" filesep
5977 set x [string range $line 0 0]
5978 if {$x == "-" || $x == "+"} {
5979 set tag [expr {$x == "+"}]
5980 $ctext insert end "$line\n" d$tag
5981 } elseif {$x == " "} {
5982 $ctext insert end "$line\n"
5984 # "\ No newline at end of file",
5985 # or something else we don't recognize
5986 $ctext insert end "$line\n" hunksep
5990 $ctext conf -state disabled
5995 return [expr {$nr >= 1000? 2: 1}]
5998 proc changediffdisp {} {
5999 global ctext diffelide
6001 $ctext tag conf d0 -elide [lindex $diffelide 0]
6002 $ctext tag conf d1 -elide [lindex $diffelide 1]
6006 global difffilestart ctext
6007 set prev [lindex $difffilestart 0]
6008 set here [$ctext index @0,0]
6009 foreach loc $difffilestart {
6010 if {[$ctext compare $loc >= $here]} {
6020 global difffilestart ctext
6021 set here [$ctext index @0,0]
6022 foreach loc $difffilestart {
6023 if {[$ctext compare $loc > $here]} {
6030 proc clear_ctext {{first 1.0}} {
6031 global ctext smarktop smarkbot
6034 set l [lindex [split $first .] 0]
6035 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6038 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6041 $ctext delete $first end
6042 if {$first eq "1.0"} {
6043 catch {unset pendinglinks}
6047 proc settabs {{firstab {}}} {
6048 global firsttabstop tabstop ctext have_tk85
6050 if {$firstab ne {} && $have_tk85} {
6051 set firsttabstop $firstab
6053 set w [font measure textfont "0"]
6054 if {$firsttabstop != 0} {
6055 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6056 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6057 } elseif {$have_tk85 || $tabstop != 8} {
6058 $ctext conf -tabs [expr {$tabstop * $w}]
6060 $ctext conf -tabs {}
6064 proc incrsearch {name ix op} {
6065 global ctext searchstring searchdirn
6067 $ctext tag remove found 1.0 end
6068 if {[catch {$ctext index anchor}]} {
6069 # no anchor set, use start of selection, or of visible area
6070 set sel [$ctext tag ranges sel]
6072 $ctext mark set anchor [lindex $sel 0]
6073 } elseif {$searchdirn eq "-forwards"} {
6074 $ctext mark set anchor @0,0
6076 $ctext mark set anchor @0,[winfo height $ctext]
6079 if {$searchstring ne {}} {
6080 set here [$ctext search $searchdirn -- $searchstring anchor]
6089 global sstring ctext searchstring searchdirn
6092 $sstring icursor end
6093 set searchdirn -forwards
6094 if {$searchstring ne {}} {
6095 set sel [$ctext tag ranges sel]
6097 set start "[lindex $sel 0] + 1c"
6098 } elseif {[catch {set start [$ctext index anchor]}]} {
6101 set match [$ctext search -count mlen -- $searchstring $start]
6102 $ctext tag remove sel 1.0 end
6108 set mend "$match + $mlen c"
6109 $ctext tag add sel $match $mend
6110 $ctext mark unset anchor
6114 proc dosearchback {} {
6115 global sstring ctext searchstring searchdirn
6118 $sstring icursor end
6119 set searchdirn -backwards
6120 if {$searchstring ne {}} {
6121 set sel [$ctext tag ranges sel]
6123 set start [lindex $sel 0]
6124 } elseif {[catch {set start [$ctext index anchor]}]} {
6125 set start @0,[winfo height $ctext]
6127 set match [$ctext search -backwards -count ml -- $searchstring $start]
6128 $ctext tag remove sel 1.0 end
6134 set mend "$match + $ml c"
6135 $ctext tag add sel $match $mend
6136 $ctext mark unset anchor
6140 proc searchmark {first last} {
6141 global ctext searchstring
6145 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6146 if {$match eq {}} break
6147 set mend "$match + $mlen c"
6148 $ctext tag add found $match $mend
6152 proc searchmarkvisible {doall} {
6153 global ctext smarktop smarkbot
6155 set topline [lindex [split [$ctext index @0,0] .] 0]
6156 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6157 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6158 # no overlap with previous
6159 searchmark $topline $botline
6160 set smarktop $topline
6161 set smarkbot $botline
6163 if {$topline < $smarktop} {
6164 searchmark $topline [expr {$smarktop-1}]
6165 set smarktop $topline
6167 if {$botline > $smarkbot} {
6168 searchmark [expr {$smarkbot+1}] $botline
6169 set smarkbot $botline
6174 proc scrolltext {f0 f1} {
6177 .bleft.sb set $f0 $f1
6178 if {$searchstring ne {}} {
6184 global linespc charspc canvx0 canvy0
6185 global xspc1 xspc2 lthickness
6187 set linespc [font metrics mainfont -linespace]
6188 set charspc [font measure mainfont "m"]
6189 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6190 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6191 set lthickness [expr {int($linespc / 9) + 1}]
6192 set xspc1(0) $linespc
6200 set ymax [lindex [$canv cget -scrollregion] 3]
6201 if {$ymax eq {} || $ymax == 0} return
6202 set span [$canv yview]
6205 allcanvs yview moveto [lindex $span 0]
6207 if {[info exists selectedline]} {
6208 selectline $selectedline 0
6209 allcanvs yview moveto [lindex $span 0]
6213 proc parsefont {f n} {
6216 set fontattr($f,family) [lindex $n 0]
6218 if {$s eq {} || $s == 0} {
6221 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6223 set fontattr($f,size) $s
6224 set fontattr($f,weight) normal
6225 set fontattr($f,slant) roman
6226 foreach style [lrange $n 2 end] {
6229 "bold" {set fontattr($f,weight) $style}
6231 "italic" {set fontattr($f,slant) $style}
6236 proc fontflags {f {isbold 0}} {
6239 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6240 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6241 -slant $fontattr($f,slant)]
6247 set n [list $fontattr($f,family) $fontattr($f,size)]
6248 if {$fontattr($f,weight) eq "bold"} {
6251 if {$fontattr($f,slant) eq "italic"} {
6257 proc incrfont {inc} {
6258 global mainfont textfont ctext canv cflist showrefstop
6259 global stopped entries fontattr
6262 set s $fontattr(mainfont,size)
6267 set fontattr(mainfont,size) $s
6268 font config mainfont -size $s
6269 font config mainfontbold -size $s
6270 set mainfont [fontname mainfont]
6271 set s $fontattr(textfont,size)
6276 set fontattr(textfont,size) $s
6277 font config textfont -size $s
6278 font config textfontbold -size $s
6279 set textfont [fontname textfont]
6286 global sha1entry sha1string
6287 if {[string length $sha1string] == 40} {
6288 $sha1entry delete 0 end
6292 proc sha1change {n1 n2 op} {
6293 global sha1string currentid sha1but
6294 if {$sha1string == {}
6295 || ([info exists currentid] && $sha1string == $currentid)} {
6300 if {[$sha1but cget -state] == $state} return
6301 if {$state == "normal"} {
6302 $sha1but conf -state normal -relief raised -text "Goto: "
6304 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
6308 proc gotocommit {} {
6309 global sha1string tagids headids curview varcid
6311 if {$sha1string == {}
6312 || ([info exists currentid] && $sha1string == $currentid)} return
6313 if {[info exists tagids($sha1string)]} {
6314 set id $tagids($sha1string)
6315 } elseif {[info exists headids($sha1string)]} {
6316 set id $headids($sha1string)
6318 set id [string tolower $sha1string]
6319 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6320 set matches [array names varcid "$curview,$id*"]
6321 if {$matches ne {}} {
6322 if {[llength $matches] > 1} {
6323 error_popup "Short SHA1 id $id is ambiguous"
6326 set id [lindex [split [lindex $matches 0] ","] 1]
6330 if {[commitinview $id $curview]} {
6331 selectline [rowofcommit $id] 1
6334 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6339 error_popup "$type $sha1string is not known"
6342 proc lineenter {x y id} {
6343 global hoverx hovery hoverid hovertimer
6344 global commitinfo canv
6346 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6350 if {[info exists hovertimer]} {
6351 after cancel $hovertimer
6353 set hovertimer [after 500 linehover]
6357 proc linemotion {x y id} {
6358 global hoverx hovery hoverid hovertimer
6360 if {[info exists hoverid] && $id == $hoverid} {
6363 if {[info exists hovertimer]} {
6364 after cancel $hovertimer
6366 set hovertimer [after 500 linehover]
6370 proc lineleave {id} {
6371 global hoverid hovertimer canv
6373 if {[info exists hoverid] && $id == $hoverid} {
6375 if {[info exists hovertimer]} {
6376 after cancel $hovertimer
6384 global hoverx hovery hoverid hovertimer
6385 global canv linespc lthickness
6388 set text [lindex $commitinfo($hoverid) 0]
6389 set ymax [lindex [$canv cget -scrollregion] 3]
6390 if {$ymax == {}} return
6391 set yfrac [lindex [$canv yview] 0]
6392 set x [expr {$hoverx + 2 * $linespc}]
6393 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6394 set x0 [expr {$x - 2 * $lthickness}]
6395 set y0 [expr {$y - 2 * $lthickness}]
6396 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6397 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6398 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6399 -fill \#ffff80 -outline black -width 1 -tags hover]
6401 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6406 proc clickisonarrow {id y} {
6409 set ranges [rowranges $id]
6410 set thresh [expr {2 * $lthickness + 6}]
6411 set n [expr {[llength $ranges] - 1}]
6412 for {set i 1} {$i < $n} {incr i} {
6413 set row [lindex $ranges $i]
6414 if {abs([yc $row] - $y) < $thresh} {
6421 proc arrowjump {id n y} {
6424 # 1 <-> 2, 3 <-> 4, etc...
6425 set n [expr {(($n - 1) ^ 1) + 1}]
6426 set row [lindex [rowranges $id] $n]
6428 set ymax [lindex [$canv cget -scrollregion] 3]
6429 if {$ymax eq {} || $ymax <= 0} return
6430 set view [$canv yview]
6431 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6432 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6436 allcanvs yview moveto $yfrac
6439 proc lineclick {x y id isnew} {
6440 global ctext commitinfo children canv thickerline curview
6442 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6447 # draw this line thicker than normal
6451 set ymax [lindex [$canv cget -scrollregion] 3]
6452 if {$ymax eq {}} return
6453 set yfrac [lindex [$canv yview] 0]
6454 set y [expr {$y + $yfrac * $ymax}]
6456 set dirn [clickisonarrow $id $y]
6458 arrowjump $id $dirn $y
6463 addtohistory [list lineclick $x $y $id 0]
6465 # fill the details pane with info about this line
6466 $ctext conf -state normal
6469 $ctext insert end "Parent:\t"
6470 $ctext insert end $id link0
6472 set info $commitinfo($id)
6473 $ctext insert end "\n\t[lindex $info 0]\n"
6474 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
6475 set date [formatdate [lindex $info 2]]
6476 $ctext insert end "\tDate:\t$date\n"
6477 set kids $children($curview,$id)
6479 $ctext insert end "\nChildren:"
6481 foreach child $kids {
6483 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6484 set info $commitinfo($child)
6485 $ctext insert end "\n\t"
6486 $ctext insert end $child link$i
6487 setlink $child link$i
6488 $ctext insert end "\n\t[lindex $info 0]"
6489 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
6490 set date [formatdate [lindex $info 2]]
6491 $ctext insert end "\n\tDate:\t$date\n"
6494 $ctext conf -state disabled
6498 proc normalline {} {
6500 if {[info exists thickerline]} {
6509 if {[commitinview $id $curview]} {
6510 selectline [rowofcommit $id] 1
6516 if {![info exists startmstime]} {
6517 set startmstime [clock clicks -milliseconds]
6519 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6522 proc rowmenu {x y id} {
6523 global rowctxmenu selectedline rowmenuid curview
6524 global nullid nullid2 fakerowmenu mainhead
6528 if {![info exists selectedline]
6529 || [rowofcommit $id] eq $selectedline} {
6534 if {$id ne $nullid && $id ne $nullid2} {
6535 set menu $rowctxmenu
6536 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6538 set menu $fakerowmenu
6540 $menu entryconfigure "Diff this*" -state $state
6541 $menu entryconfigure "Diff selected*" -state $state
6542 $menu entryconfigure "Make patch" -state $state
6543 tk_popup $menu $x $y
6546 proc diffvssel {dirn} {
6547 global rowmenuid selectedline
6549 if {![info exists selectedline]} return
6551 set oldid [commitonrow $selectedline]
6552 set newid $rowmenuid
6554 set oldid $rowmenuid
6555 set newid [commitonrow $selectedline]
6557 addtohistory [list doseldiff $oldid $newid]
6558 doseldiff $oldid $newid
6561 proc doseldiff {oldid newid} {
6565 $ctext conf -state normal
6568 $ctext insert end "From "
6569 $ctext insert end $oldid link0
6570 setlink $oldid link0
6571 $ctext insert end "\n "
6572 $ctext insert end [lindex $commitinfo($oldid) 0]
6573 $ctext insert end "\n\nTo "
6574 $ctext insert end $newid link1
6575 setlink $newid link1
6576 $ctext insert end "\n "
6577 $ctext insert end [lindex $commitinfo($newid) 0]
6578 $ctext insert end "\n"
6579 $ctext conf -state disabled
6580 $ctext tag remove found 1.0 end
6581 startdiff [list $oldid $newid]
6585 global rowmenuid currentid commitinfo patchtop patchnum
6587 if {![info exists currentid]} return
6588 set oldid $currentid
6589 set oldhead [lindex $commitinfo($oldid) 0]
6590 set newid $rowmenuid
6591 set newhead [lindex $commitinfo($newid) 0]
6594 catch {destroy $top}
6596 label $top.title -text "Generate patch"
6597 grid $top.title - -pady 10
6598 label $top.from -text "From:"
6599 entry $top.fromsha1 -width 40 -relief flat
6600 $top.fromsha1 insert 0 $oldid
6601 $top.fromsha1 conf -state readonly
6602 grid $top.from $top.fromsha1 -sticky w
6603 entry $top.fromhead -width 60 -relief flat
6604 $top.fromhead insert 0 $oldhead
6605 $top.fromhead conf -state readonly
6606 grid x $top.fromhead -sticky w
6607 label $top.to -text "To:"
6608 entry $top.tosha1 -width 40 -relief flat
6609 $top.tosha1 insert 0 $newid
6610 $top.tosha1 conf -state readonly
6611 grid $top.to $top.tosha1 -sticky w
6612 entry $top.tohead -width 60 -relief flat
6613 $top.tohead insert 0 $newhead
6614 $top.tohead conf -state readonly
6615 grid x $top.tohead -sticky w
6616 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6617 grid $top.rev x -pady 10
6618 label $top.flab -text "Output file:"
6619 entry $top.fname -width 60
6620 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6622 grid $top.flab $top.fname -sticky w
6624 button $top.buts.gen -text "Generate" -command mkpatchgo
6625 button $top.buts.can -text "Cancel" -command mkpatchcan
6626 grid $top.buts.gen $top.buts.can
6627 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6628 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6629 grid $top.buts - -pady 10 -sticky ew
6633 proc mkpatchrev {} {
6636 set oldid [$patchtop.fromsha1 get]
6637 set oldhead [$patchtop.fromhead get]
6638 set newid [$patchtop.tosha1 get]
6639 set newhead [$patchtop.tohead get]
6640 foreach e [list fromsha1 fromhead tosha1 tohead] \
6641 v [list $newid $newhead $oldid $oldhead] {
6642 $patchtop.$e conf -state normal
6643 $patchtop.$e delete 0 end
6644 $patchtop.$e insert 0 $v
6645 $patchtop.$e conf -state readonly
6650 global patchtop nullid nullid2
6652 set oldid [$patchtop.fromsha1 get]
6653 set newid [$patchtop.tosha1 get]
6654 set fname [$patchtop.fname get]
6655 set cmd [diffcmd [list $oldid $newid] -p]
6656 # trim off the initial "|"
6657 set cmd [lrange $cmd 1 end]
6658 lappend cmd >$fname &
6659 if {[catch {eval exec $cmd} err]} {
6660 error_popup "Error creating patch: $err"
6662 catch {destroy $patchtop}
6666 proc mkpatchcan {} {
6669 catch {destroy $patchtop}
6674 global rowmenuid mktagtop commitinfo
6678 catch {destroy $top}
6680 label $top.title -text "Create tag"
6681 grid $top.title - -pady 10
6682 label $top.id -text "ID:"
6683 entry $top.sha1 -width 40 -relief flat
6684 $top.sha1 insert 0 $rowmenuid
6685 $top.sha1 conf -state readonly
6686 grid $top.id $top.sha1 -sticky w
6687 entry $top.head -width 60 -relief flat
6688 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6689 $top.head conf -state readonly
6690 grid x $top.head -sticky w
6691 label $top.tlab -text "Tag name:"
6692 entry $top.tag -width 60
6693 grid $top.tlab $top.tag -sticky w
6695 button $top.buts.gen -text "Create" -command mktaggo
6696 button $top.buts.can -text "Cancel" -command mktagcan
6697 grid $top.buts.gen $top.buts.can
6698 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6699 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6700 grid $top.buts - -pady 10 -sticky ew
6705 global mktagtop env tagids idtags
6707 set id [$mktagtop.sha1 get]
6708 set tag [$mktagtop.tag get]
6710 error_popup "No tag name specified"
6713 if {[info exists tagids($tag)]} {
6714 error_popup "Tag \"$tag\" already exists"
6719 set fname [file join $dir "refs/tags" $tag]
6720 set f [open $fname w]
6724 error_popup "Error creating tag: $err"
6728 set tagids($tag) $id
6729 lappend idtags($id) $tag
6736 proc redrawtags {id} {
6737 global canv linehtag idpos selectedline curview
6738 global canvxmax iddrawn
6740 if {![commitinview $id $curview]} return
6741 if {![info exists iddrawn($id)]} return
6742 drawcommits [rowofcommit $id]
6743 $canv delete tag.$id
6744 set xt [eval drawtags $id $idpos($id)]
6745 $canv coords $linehtag([rowofcommit $id]) $xt [lindex $idpos($id) 2]
6746 set text [$canv itemcget $linehtag([rowofcommit $id]) -text]
6747 set xr [expr {$xt + [font measure mainfont $text]}]
6748 if {$xr > $canvxmax} {
6752 if {[info exists selectedline]
6753 && $selectedline == [rowofcommit $id]} {
6754 selectline $selectedline 0
6761 catch {destroy $mktagtop}
6770 proc writecommit {} {
6771 global rowmenuid wrcomtop commitinfo wrcomcmd
6773 set top .writecommit
6775 catch {destroy $top}
6777 label $top.title -text "Write commit to file"
6778 grid $top.title - -pady 10
6779 label $top.id -text "ID:"
6780 entry $top.sha1 -width 40 -relief flat
6781 $top.sha1 insert 0 $rowmenuid
6782 $top.sha1 conf -state readonly
6783 grid $top.id $top.sha1 -sticky w
6784 entry $top.head -width 60 -relief flat
6785 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6786 $top.head conf -state readonly
6787 grid x $top.head -sticky w
6788 label $top.clab -text "Command:"
6789 entry $top.cmd -width 60 -textvariable wrcomcmd
6790 grid $top.clab $top.cmd -sticky w -pady 10
6791 label $top.flab -text "Output file:"
6792 entry $top.fname -width 60
6793 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6794 grid $top.flab $top.fname -sticky w
6796 button $top.buts.gen -text "Write" -command wrcomgo
6797 button $top.buts.can -text "Cancel" -command wrcomcan
6798 grid $top.buts.gen $top.buts.can
6799 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6800 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6801 grid $top.buts - -pady 10 -sticky ew
6808 set id [$wrcomtop.sha1 get]
6809 set cmd "echo $id | [$wrcomtop.cmd get]"
6810 set fname [$wrcomtop.fname get]
6811 if {[catch {exec sh -c $cmd >$fname &} err]} {
6812 error_popup "Error writing commit: $err"
6814 catch {destroy $wrcomtop}
6821 catch {destroy $wrcomtop}
6826 global rowmenuid mkbrtop
6829 catch {destroy $top}
6831 label $top.title -text "Create new branch"
6832 grid $top.title - -pady 10
6833 label $top.id -text "ID:"
6834 entry $top.sha1 -width 40 -relief flat
6835 $top.sha1 insert 0 $rowmenuid
6836 $top.sha1 conf -state readonly
6837 grid $top.id $top.sha1 -sticky w
6838 label $top.nlab -text "Name:"
6839 entry $top.name -width 40
6840 grid $top.nlab $top.name -sticky w
6842 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6843 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6844 grid $top.buts.go $top.buts.can
6845 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6846 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6847 grid $top.buts - -pady 10 -sticky ew
6852 global headids idheads
6854 set name [$top.name get]
6855 set id [$top.sha1 get]
6857 error_popup "Please specify a name for the new branch"
6860 catch {destroy $top}
6864 exec git branch $name $id
6869 set headids($name) $id
6870 lappend idheads($id) $name
6879 proc cherrypick {} {
6880 global rowmenuid curview
6883 set oldhead [exec git rev-parse HEAD]
6884 set dheads [descheads $rowmenuid]
6885 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6886 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6887 included in branch $mainhead -- really re-apply it?"]
6890 nowbusy cherrypick "Cherry-picking"
6892 # Unfortunately git-cherry-pick writes stuff to stderr even when
6893 # no error occurs, and exec takes that as an indication of error...
6894 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6899 set newhead [exec git rev-parse HEAD]
6900 if {$newhead eq $oldhead} {
6902 error_popup "No changes committed"
6905 addnewchild $newhead $oldhead
6906 if {[commitinview $oldhead $curview]} {
6907 insertrow $newhead $oldhead $curview
6908 if {$mainhead ne {}} {
6909 movehead $newhead $mainhead
6910 movedhead $newhead $mainhead
6919 global mainheadid mainhead rowmenuid confirm_ok resettype
6922 set w ".confirmreset"
6925 wm title $w "Confirm reset"
6926 message $w.m -text \
6927 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6928 -justify center -aspect 1000
6929 pack $w.m -side top -fill x -padx 20 -pady 20
6930 frame $w.f -relief sunken -border 2
6931 message $w.f.rt -text "Reset type:" -aspect 1000
6932 grid $w.f.rt -sticky w
6934 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6935 -text "Soft: Leave working tree and index untouched"
6936 grid $w.f.soft -sticky w
6937 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6938 -text "Mixed: Leave working tree untouched, reset index"
6939 grid $w.f.mixed -sticky w
6940 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6941 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6942 grid $w.f.hard -sticky w
6943 pack $w.f -side top -fill x
6944 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6945 pack $w.ok -side left -fill x -padx 20 -pady 20
6946 button $w.cancel -text Cancel -command "destroy $w"
6947 pack $w.cancel -side right -fill x -padx 20 -pady 20
6948 bind $w <Visibility> "grab $w; focus $w"
6950 if {!$confirm_ok} return
6951 if {[catch {set fd [open \
6952 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6956 filerun $fd [list readresetstat $fd]
6957 nowbusy reset "Resetting"
6961 proc readresetstat {fd} {
6962 global mainhead mainheadid showlocalchanges rprogcoord
6964 if {[gets $fd line] >= 0} {
6965 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6966 set rprogcoord [expr {1.0 * $m / $n}]
6974 if {[catch {close $fd} err]} {
6977 set oldhead $mainheadid
6978 set newhead [exec git rev-parse HEAD]
6979 if {$newhead ne $oldhead} {
6980 movehead $newhead $mainhead
6981 movedhead $newhead $mainhead
6982 set mainheadid $newhead
6986 if {$showlocalchanges} {
6992 # context menu for a head
6993 proc headmenu {x y id head} {
6994 global headmenuid headmenuhead headctxmenu mainhead
6998 set headmenuhead $head
7000 if {$head eq $mainhead} {
7003 $headctxmenu entryconfigure 0 -state $state
7004 $headctxmenu entryconfigure 1 -state $state
7005 tk_popup $headctxmenu $x $y
7009 global headmenuid headmenuhead mainhead headids
7010 global showlocalchanges mainheadid
7012 # check the tree is clean first??
7013 set oldmainhead $mainhead
7014 nowbusy checkout "Checking out"
7018 exec git checkout -q $headmenuhead
7024 set mainhead $headmenuhead
7025 set mainheadid $headmenuid
7026 if {[info exists headids($oldmainhead)]} {
7027 redrawtags $headids($oldmainhead)
7029 redrawtags $headmenuid
7031 if {$showlocalchanges} {
7037 global headmenuid headmenuhead mainhead
7040 set head $headmenuhead
7042 # this check shouldn't be needed any more...
7043 if {$head eq $mainhead} {
7044 error_popup "Cannot delete the currently checked-out branch"
7047 set dheads [descheads $id]
7048 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7049 # the stuff on this branch isn't on any other branch
7050 if {![confirm_popup "The commits on branch $head aren't on any other\
7051 branch.\nReally delete branch $head?"]} return
7055 if {[catch {exec git branch -D $head} err]} {
7060 removehead $id $head
7061 removedhead $id $head
7068 # Display a list of tags and heads
7070 global showrefstop bgcolor fgcolor selectbgcolor
7071 global bglist fglist reflistfilter reflist maincursor
7074 set showrefstop $top
7075 if {[winfo exists $top]} {
7081 wm title $top "Tags and heads: [file tail [pwd]]"
7082 text $top.list -background $bgcolor -foreground $fgcolor \
7083 -selectbackground $selectbgcolor -font mainfont \
7084 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7085 -width 30 -height 20 -cursor $maincursor \
7086 -spacing1 1 -spacing3 1 -state disabled
7087 $top.list tag configure highlight -background $selectbgcolor
7088 lappend bglist $top.list
7089 lappend fglist $top.list
7090 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7091 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7092 grid $top.list $top.ysb -sticky nsew
7093 grid $top.xsb x -sticky ew
7095 label $top.f.l -text "Filter: " -font uifont
7096 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
7097 set reflistfilter "*"
7098 trace add variable reflistfilter write reflistfilter_change
7099 pack $top.f.e -side right -fill x -expand 1
7100 pack $top.f.l -side left
7101 grid $top.f - -sticky ew -pady 2
7102 button $top.close -command [list destroy $top] -text "Close" \
7105 grid columnconfigure $top 0 -weight 1
7106 grid rowconfigure $top 0 -weight 1
7107 bind $top.list <1> {break}
7108 bind $top.list <B1-Motion> {break}
7109 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7114 proc sel_reflist {w x y} {
7115 global showrefstop reflist headids tagids otherrefids
7117 if {![winfo exists $showrefstop]} return
7118 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7119 set ref [lindex $reflist [expr {$l-1}]]
7120 set n [lindex $ref 0]
7121 switch -- [lindex $ref 1] {
7122 "H" {selbyid $headids($n)}
7123 "T" {selbyid $tagids($n)}
7124 "o" {selbyid $otherrefids($n)}
7126 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7129 proc unsel_reflist {} {
7132 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7133 $showrefstop.list tag remove highlight 0.0 end
7136 proc reflistfilter_change {n1 n2 op} {
7137 global reflistfilter
7139 after cancel refill_reflist
7140 after 200 refill_reflist
7143 proc refill_reflist {} {
7144 global reflist reflistfilter showrefstop headids tagids otherrefids
7145 global curview commitinterest
7147 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7149 foreach n [array names headids] {
7150 if {[string match $reflistfilter $n]} {
7151 if {[commitinview $headids($n) $curview]} {
7152 lappend refs [list $n H]
7154 set commitinterest($headids($n)) {run refill_reflist}
7158 foreach n [array names tagids] {
7159 if {[string match $reflistfilter $n]} {
7160 if {[commitinview $tagids($n) $curview]} {
7161 lappend refs [list $n T]
7163 set commitinterest($tagids($n)) {run refill_reflist}
7167 foreach n [array names otherrefids] {
7168 if {[string match $reflistfilter $n]} {
7169 if {[commitinview $otherrefids($n) $curview]} {
7170 lappend refs [list $n o]
7172 set commitinterest($otherrefids($n)) {run refill_reflist}
7176 set refs [lsort -index 0 $refs]
7177 if {$refs eq $reflist} return
7179 # Update the contents of $showrefstop.list according to the
7180 # differences between $reflist (old) and $refs (new)
7181 $showrefstop.list conf -state normal
7182 $showrefstop.list insert end "\n"
7185 while {$i < [llength $reflist] || $j < [llength $refs]} {
7186 if {$i < [llength $reflist]} {
7187 if {$j < [llength $refs]} {
7188 set cmp [string compare [lindex $reflist $i 0] \
7189 [lindex $refs $j 0]]
7191 set cmp [string compare [lindex $reflist $i 1] \
7192 [lindex $refs $j 1]]
7202 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7210 set l [expr {$j + 1}]
7211 $showrefstop.list image create $l.0 -align baseline \
7212 -image reficon-[lindex $refs $j 1] -padx 2
7213 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7219 # delete last newline
7220 $showrefstop.list delete end-2c end-1c
7221 $showrefstop.list conf -state disabled
7224 # Stuff for finding nearby tags
7225 proc getallcommits {} {
7226 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7227 global idheads idtags idotherrefs allparents tagobjid
7229 if {![info exists allcommits]} {
7235 set allccache [file join [gitdir] "gitk.cache"]
7237 set f [open $allccache r]
7246 set cmd [list | git rev-list --parents]
7247 set allcupdate [expr {$seeds ne {}}]
7251 set refs [concat [array names idheads] [array names idtags] \
7252 [array names idotherrefs]]
7255 foreach name [array names tagobjid] {
7256 lappend tagobjs $tagobjid($name)
7258 foreach id [lsort -unique $refs] {
7259 if {![info exists allparents($id)] &&
7260 [lsearch -exact $tagobjs $id] < 0} {
7271 set fd [open [concat $cmd $ids] r]
7272 fconfigure $fd -blocking 0
7275 filerun $fd [list getallclines $fd]
7281 # Since most commits have 1 parent and 1 child, we group strings of
7282 # such commits into "arcs" joining branch/merge points (BMPs), which
7283 # are commits that either don't have 1 parent or don't have 1 child.
7285 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7286 # arcout(id) - outgoing arcs for BMP
7287 # arcids(a) - list of IDs on arc including end but not start
7288 # arcstart(a) - BMP ID at start of arc
7289 # arcend(a) - BMP ID at end of arc
7290 # growing(a) - arc a is still growing
7291 # arctags(a) - IDs out of arcids (excluding end) that have tags
7292 # archeads(a) - IDs out of arcids (excluding end) that have heads
7293 # The start of an arc is at the descendent end, so "incoming" means
7294 # coming from descendents, and "outgoing" means going towards ancestors.
7296 proc getallclines {fd} {
7297 global allparents allchildren idtags idheads nextarc
7298 global arcnos arcids arctags arcout arcend arcstart archeads growing
7299 global seeds allcommits cachedarcs allcupdate
7302 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7303 set id [lindex $line 0]
7304 if {[info exists allparents($id)]} {
7309 set olds [lrange $line 1 end]
7310 set allparents($id) $olds
7311 if {![info exists allchildren($id)]} {
7312 set allchildren($id) {}
7317 if {[llength $olds] == 1 && [llength $a] == 1} {
7318 lappend arcids($a) $id
7319 if {[info exists idtags($id)]} {
7320 lappend arctags($a) $id
7322 if {[info exists idheads($id)]} {
7323 lappend archeads($a) $id
7325 if {[info exists allparents($olds)]} {
7326 # seen parent already
7327 if {![info exists arcout($olds)]} {
7330 lappend arcids($a) $olds
7331 set arcend($a) $olds
7334 lappend allchildren($olds) $id
7335 lappend arcnos($olds) $a
7339 foreach a $arcnos($id) {
7340 lappend arcids($a) $id
7347 lappend allchildren($p) $id
7348 set a [incr nextarc]
7349 set arcstart($a) $id
7356 if {[info exists allparents($p)]} {
7357 # seen it already, may need to make a new branch
7358 if {![info exists arcout($p)]} {
7361 lappend arcids($a) $p
7365 lappend arcnos($p) $a
7370 global cached_dheads cached_dtags cached_atags
7371 catch {unset cached_dheads}
7372 catch {unset cached_dtags}
7373 catch {unset cached_atags}
7376 return [expr {$nid >= 1000? 2: 1}]
7380 fconfigure $fd -blocking 1
7383 # got an error reading the list of commits
7384 # if we were updating, try rereading the whole thing again
7390 error_popup "Error reading commit topology information;\
7391 branch and preceding/following tag information\
7392 will be incomplete.\n($err)"
7395 if {[incr allcommits -1] == 0} {
7405 proc recalcarc {a} {
7406 global arctags archeads arcids idtags idheads
7410 foreach id [lrange $arcids($a) 0 end-1] {
7411 if {[info exists idtags($id)]} {
7414 if {[info exists idheads($id)]} {
7419 set archeads($a) $ah
7423 global arcnos arcids nextarc arctags archeads idtags idheads
7424 global arcstart arcend arcout allparents growing
7427 if {[llength $a] != 1} {
7428 puts "oops splitarc called but [llength $a] arcs already"
7432 set i [lsearch -exact $arcids($a) $p]
7434 puts "oops splitarc $p not in arc $a"
7437 set na [incr nextarc]
7438 if {[info exists arcend($a)]} {
7439 set arcend($na) $arcend($a)
7441 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7442 set j [lsearch -exact $arcnos($l) $a]
7443 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7445 set tail [lrange $arcids($a) [expr {$i+1}] end]
7446 set arcids($a) [lrange $arcids($a) 0 $i]
7448 set arcstart($na) $p
7450 set arcids($na) $tail
7451 if {[info exists growing($a)]} {
7457 if {[llength $arcnos($id)] == 1} {
7460 set j [lsearch -exact $arcnos($id) $a]
7461 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7465 # reconstruct tags and heads lists
7466 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7471 set archeads($na) {}
7475 # Update things for a new commit added that is a child of one
7476 # existing commit. Used when cherry-picking.
7477 proc addnewchild {id p} {
7478 global allparents allchildren idtags nextarc
7479 global arcnos arcids arctags arcout arcend arcstart archeads growing
7480 global seeds allcommits
7482 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7483 set allparents($id) [list $p]
7484 set allchildren($id) {}
7487 lappend allchildren($p) $id
7488 set a [incr nextarc]
7489 set arcstart($a) $id
7492 set arcids($a) [list $p]
7494 if {![info exists arcout($p)]} {
7497 lappend arcnos($p) $a
7498 set arcout($id) [list $a]
7501 # This implements a cache for the topology information.
7502 # The cache saves, for each arc, the start and end of the arc,
7503 # the ids on the arc, and the outgoing arcs from the end.
7504 proc readcache {f} {
7505 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7506 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7511 if {$lim - $a > 500} {
7512 set lim [expr {$a + 500}]
7516 # finish reading the cache and setting up arctags, etc.
7518 if {$line ne "1"} {error "bad final version"}
7520 foreach id [array names idtags] {
7521 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7522 [llength $allparents($id)] == 1} {
7523 set a [lindex $arcnos($id) 0]
7524 if {$arctags($a) eq {}} {
7529 foreach id [array names idheads] {
7530 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7531 [llength $allparents($id)] == 1} {
7532 set a [lindex $arcnos($id) 0]
7533 if {$archeads($a) eq {}} {
7538 foreach id [lsort -unique $possible_seeds] {
7539 if {$arcnos($id) eq {}} {
7545 while {[incr a] <= $lim} {
7547 if {[llength $line] != 3} {error "bad line"}
7548 set s [lindex $line 0]
7550 lappend arcout($s) $a
7551 if {![info exists arcnos($s)]} {
7552 lappend possible_seeds $s
7555 set e [lindex $line 1]
7560 if {![info exists arcout($e)]} {
7564 set arcids($a) [lindex $line 2]
7565 foreach id $arcids($a) {
7566 lappend allparents($s) $id
7568 lappend arcnos($id) $a
7570 if {![info exists allparents($s)]} {
7571 set allparents($s) {}
7576 set nextarc [expr {$a - 1}]
7589 global nextarc cachedarcs possible_seeds
7593 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7594 # make sure it's an integer
7595 set cachedarcs [expr {int([lindex $line 1])}]
7596 if {$cachedarcs < 0} {error "bad number of arcs"}
7598 set possible_seeds {}
7606 proc dropcache {err} {
7607 global allcwait nextarc cachedarcs seeds
7609 #puts "dropping cache ($err)"
7610 foreach v {arcnos arcout arcids arcstart arcend growing \
7611 arctags archeads allparents allchildren} {
7622 proc writecache {f} {
7623 global cachearc cachedarcs allccache
7624 global arcstart arcend arcnos arcids arcout
7628 if {$lim - $a > 1000} {
7629 set lim [expr {$a + 1000}]
7632 while {[incr a] <= $lim} {
7633 if {[info exists arcend($a)]} {
7634 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7636 puts $f [list $arcstart($a) {} $arcids($a)]
7641 catch {file delete $allccache}
7642 #puts "writing cache failed ($err)"
7645 set cachearc [expr {$a - 1}]
7646 if {$a > $cachedarcs} {
7655 global nextarc cachedarcs cachearc allccache
7657 if {$nextarc == $cachedarcs} return
7659 set cachedarcs $nextarc
7661 set f [open $allccache w]
7662 puts $f [list 1 $cachedarcs]
7667 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7668 # or 0 if neither is true.
7669 proc anc_or_desc {a b} {
7670 global arcout arcstart arcend arcnos cached_isanc
7672 if {$arcnos($a) eq $arcnos($b)} {
7673 # Both are on the same arc(s); either both are the same BMP,
7674 # or if one is not a BMP, the other is also not a BMP or is
7675 # the BMP at end of the arc (and it only has 1 incoming arc).
7676 # Or both can be BMPs with no incoming arcs.
7677 if {$a eq $b || $arcnos($a) eq {}} {
7680 # assert {[llength $arcnos($a)] == 1}
7681 set arc [lindex $arcnos($a) 0]
7682 set i [lsearch -exact $arcids($arc) $a]
7683 set j [lsearch -exact $arcids($arc) $b]
7684 if {$i < 0 || $i > $j} {
7691 if {![info exists arcout($a)]} {
7692 set arc [lindex $arcnos($a) 0]
7693 if {[info exists arcend($arc)]} {
7694 set aend $arcend($arc)
7698 set a $arcstart($arc)
7702 if {![info exists arcout($b)]} {
7703 set arc [lindex $arcnos($b) 0]
7704 if {[info exists arcend($arc)]} {
7705 set bend $arcend($arc)
7709 set b $arcstart($arc)
7719 if {[info exists cached_isanc($a,$bend)]} {
7720 if {$cached_isanc($a,$bend)} {
7724 if {[info exists cached_isanc($b,$aend)]} {
7725 if {$cached_isanc($b,$aend)} {
7728 if {[info exists cached_isanc($a,$bend)]} {
7733 set todo [list $a $b]
7736 for {set i 0} {$i < [llength $todo]} {incr i} {
7737 set x [lindex $todo $i]
7738 if {$anc($x) eq {}} {
7741 foreach arc $arcnos($x) {
7742 set xd $arcstart($arc)
7744 set cached_isanc($a,$bend) 1
7745 set cached_isanc($b,$aend) 0
7747 } elseif {$xd eq $aend} {
7748 set cached_isanc($b,$aend) 1
7749 set cached_isanc($a,$bend) 0
7752 if {![info exists anc($xd)]} {
7753 set anc($xd) $anc($x)
7755 } elseif {$anc($xd) ne $anc($x)} {
7760 set cached_isanc($a,$bend) 0
7761 set cached_isanc($b,$aend) 0
7765 # This identifies whether $desc has an ancestor that is
7766 # a growing tip of the graph and which is not an ancestor of $anc
7767 # and returns 0 if so and 1 if not.
7768 # If we subsequently discover a tag on such a growing tip, and that
7769 # turns out to be a descendent of $anc (which it could, since we
7770 # don't necessarily see children before parents), then $desc
7771 # isn't a good choice to display as a descendent tag of
7772 # $anc (since it is the descendent of another tag which is
7773 # a descendent of $anc). Similarly, $anc isn't a good choice to
7774 # display as a ancestor tag of $desc.
7776 proc is_certain {desc anc} {
7777 global arcnos arcout arcstart arcend growing problems
7780 if {[llength $arcnos($anc)] == 1} {
7781 # tags on the same arc are certain
7782 if {$arcnos($desc) eq $arcnos($anc)} {
7785 if {![info exists arcout($anc)]} {
7786 # if $anc is partway along an arc, use the start of the arc instead
7787 set a [lindex $arcnos($anc) 0]
7788 set anc $arcstart($a)
7791 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7794 set a [lindex $arcnos($desc) 0]
7800 set anclist [list $x]
7804 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7805 set x [lindex $anclist $i]
7810 foreach a $arcout($x) {
7811 if {[info exists growing($a)]} {
7812 if {![info exists growanc($x)] && $dl($x)} {
7818 if {[info exists dl($y)]} {
7822 if {![info exists done($y)]} {
7825 if {[info exists growanc($x)]} {
7829 for {set k 0} {$k < [llength $xl]} {incr k} {
7830 set z [lindex $xl $k]
7831 foreach c $arcout($z) {
7832 if {[info exists arcend($c)]} {
7834 if {[info exists dl($v)] && $dl($v)} {
7836 if {![info exists done($v)]} {
7839 if {[info exists growanc($v)]} {
7849 } elseif {$y eq $anc || !$dl($x)} {
7860 foreach x [array names growanc] {
7869 proc validate_arctags {a} {
7870 global arctags idtags
7874 foreach id $arctags($a) {
7876 if {![info exists idtags($id)]} {
7877 set na [lreplace $na $i $i]
7884 proc validate_archeads {a} {
7885 global archeads idheads
7888 set na $archeads($a)
7889 foreach id $archeads($a) {
7891 if {![info exists idheads($id)]} {
7892 set na [lreplace $na $i $i]
7896 set archeads($a) $na
7899 # Return the list of IDs that have tags that are descendents of id,
7900 # ignoring IDs that are descendents of IDs already reported.
7901 proc desctags {id} {
7902 global arcnos arcstart arcids arctags idtags allparents
7903 global growing cached_dtags
7905 if {![info exists allparents($id)]} {
7908 set t1 [clock clicks -milliseconds]
7910 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7911 # part-way along an arc; check that arc first
7912 set a [lindex $arcnos($id) 0]
7913 if {$arctags($a) ne {}} {
7915 set i [lsearch -exact $arcids($a) $id]
7917 foreach t $arctags($a) {
7918 set j [lsearch -exact $arcids($a) $t]
7926 set id $arcstart($a)
7927 if {[info exists idtags($id)]} {
7931 if {[info exists cached_dtags($id)]} {
7932 return $cached_dtags($id)
7939 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7940 set id [lindex $todo $i]
7942 set ta [info exists hastaggedancestor($id)]
7946 # ignore tags on starting node
7947 if {!$ta && $i > 0} {
7948 if {[info exists idtags($id)]} {
7951 } elseif {[info exists cached_dtags($id)]} {
7952 set tagloc($id) $cached_dtags($id)
7956 foreach a $arcnos($id) {
7958 if {!$ta && $arctags($a) ne {}} {
7960 if {$arctags($a) ne {}} {
7961 lappend tagloc($id) [lindex $arctags($a) end]
7964 if {$ta || $arctags($a) ne {}} {
7965 set tomark [list $d]
7966 for {set j 0} {$j < [llength $tomark]} {incr j} {
7967 set dd [lindex $tomark $j]
7968 if {![info exists hastaggedancestor($dd)]} {
7969 if {[info exists done($dd)]} {
7970 foreach b $arcnos($dd) {
7971 lappend tomark $arcstart($b)
7973 if {[info exists tagloc($dd)]} {
7976 } elseif {[info exists queued($dd)]} {
7979 set hastaggedancestor($dd) 1
7983 if {![info exists queued($d)]} {
7986 if {![info exists hastaggedancestor($d)]} {
7993 foreach id [array names tagloc] {
7994 if {![info exists hastaggedancestor($id)]} {
7995 foreach t $tagloc($id) {
7996 if {[lsearch -exact $tags $t] < 0} {
8002 set t2 [clock clicks -milliseconds]
8005 # remove tags that are descendents of other tags
8006 for {set i 0} {$i < [llength $tags]} {incr i} {
8007 set a [lindex $tags $i]
8008 for {set j 0} {$j < $i} {incr j} {
8009 set b [lindex $tags $j]
8010 set r [anc_or_desc $a $b]
8012 set tags [lreplace $tags $j $j]
8015 } elseif {$r == -1} {
8016 set tags [lreplace $tags $i $i]
8023 if {[array names growing] ne {}} {
8024 # graph isn't finished, need to check if any tag could get
8025 # eclipsed by another tag coming later. Simply ignore any
8026 # tags that could later get eclipsed.
8029 if {[is_certain $t $origid]} {
8033 if {$tags eq $ctags} {
8034 set cached_dtags($origid) $tags
8039 set cached_dtags($origid) $tags
8041 set t3 [clock clicks -milliseconds]
8042 if {0 && $t3 - $t1 >= 100} {
8043 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8044 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8050 global arcnos arcids arcout arcend arctags idtags allparents
8051 global growing cached_atags
8053 if {![info exists allparents($id)]} {
8056 set t1 [clock clicks -milliseconds]
8058 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8059 # part-way along an arc; check that arc first
8060 set a [lindex $arcnos($id) 0]
8061 if {$arctags($a) ne {}} {
8063 set i [lsearch -exact $arcids($a) $id]
8064 foreach t $arctags($a) {
8065 set j [lsearch -exact $arcids($a) $t]
8071 if {![info exists arcend($a)]} {
8075 if {[info exists idtags($id)]} {
8079 if {[info exists cached_atags($id)]} {
8080 return $cached_atags($id)
8088 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8089 set id [lindex $todo $i]
8091 set td [info exists hastaggeddescendent($id)]
8095 # ignore tags on starting node
8096 if {!$td && $i > 0} {
8097 if {[info exists idtags($id)]} {
8100 } elseif {[info exists cached_atags($id)]} {
8101 set tagloc($id) $cached_atags($id)
8105 foreach a $arcout($id) {
8106 if {!$td && $arctags($a) ne {}} {
8108 if {$arctags($a) ne {}} {
8109 lappend tagloc($id) [lindex $arctags($a) 0]
8112 if {![info exists arcend($a)]} continue
8114 if {$td || $arctags($a) ne {}} {
8115 set tomark [list $d]
8116 for {set j 0} {$j < [llength $tomark]} {incr j} {
8117 set dd [lindex $tomark $j]
8118 if {![info exists hastaggeddescendent($dd)]} {
8119 if {[info exists done($dd)]} {
8120 foreach b $arcout($dd) {
8121 if {[info exists arcend($b)]} {
8122 lappend tomark $arcend($b)
8125 if {[info exists tagloc($dd)]} {
8128 } elseif {[info exists queued($dd)]} {
8131 set hastaggeddescendent($dd) 1
8135 if {![info exists queued($d)]} {
8138 if {![info exists hastaggeddescendent($d)]} {
8144 set t2 [clock clicks -milliseconds]
8147 foreach id [array names tagloc] {
8148 if {![info exists hastaggeddescendent($id)]} {
8149 foreach t $tagloc($id) {
8150 if {[lsearch -exact $tags $t] < 0} {
8157 # remove tags that are ancestors of other tags
8158 for {set i 0} {$i < [llength $tags]} {incr i} {
8159 set a [lindex $tags $i]
8160 for {set j 0} {$j < $i} {incr j} {
8161 set b [lindex $tags $j]
8162 set r [anc_or_desc $a $b]
8164 set tags [lreplace $tags $j $j]
8167 } elseif {$r == 1} {
8168 set tags [lreplace $tags $i $i]
8175 if {[array names growing] ne {}} {
8176 # graph isn't finished, need to check if any tag could get
8177 # eclipsed by another tag coming later. Simply ignore any
8178 # tags that could later get eclipsed.
8181 if {[is_certain $origid $t]} {
8185 if {$tags eq $ctags} {
8186 set cached_atags($origid) $tags
8191 set cached_atags($origid) $tags
8193 set t3 [clock clicks -milliseconds]
8194 if {0 && $t3 - $t1 >= 100} {
8195 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8196 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8201 # Return the list of IDs that have heads that are descendents of id,
8202 # including id itself if it has a head.
8203 proc descheads {id} {
8204 global arcnos arcstart arcids archeads idheads cached_dheads
8207 if {![info exists allparents($id)]} {
8211 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8212 # part-way along an arc; check it first
8213 set a [lindex $arcnos($id) 0]
8214 if {$archeads($a) ne {}} {
8215 validate_archeads $a
8216 set i [lsearch -exact $arcids($a) $id]
8217 foreach t $archeads($a) {
8218 set j [lsearch -exact $arcids($a) $t]
8223 set id $arcstart($a)
8229 for {set i 0} {$i < [llength $todo]} {incr i} {
8230 set id [lindex $todo $i]
8231 if {[info exists cached_dheads($id)]} {
8232 set ret [concat $ret $cached_dheads($id)]
8234 if {[info exists idheads($id)]} {
8237 foreach a $arcnos($id) {
8238 if {$archeads($a) ne {}} {
8239 validate_archeads $a
8240 if {$archeads($a) ne {}} {
8241 set ret [concat $ret $archeads($a)]
8245 if {![info exists seen($d)]} {
8252 set ret [lsort -unique $ret]
8253 set cached_dheads($origid) $ret
8254 return [concat $ret $aret]
8257 proc addedtag {id} {
8258 global arcnos arcout cached_dtags cached_atags
8260 if {![info exists arcnos($id)]} return
8261 if {![info exists arcout($id)]} {
8262 recalcarc [lindex $arcnos($id) 0]
8264 catch {unset cached_dtags}
8265 catch {unset cached_atags}
8268 proc addedhead {hid head} {
8269 global arcnos arcout cached_dheads
8271 if {![info exists arcnos($hid)]} return
8272 if {![info exists arcout($hid)]} {
8273 recalcarc [lindex $arcnos($hid) 0]
8275 catch {unset cached_dheads}
8278 proc removedhead {hid head} {
8279 global cached_dheads
8281 catch {unset cached_dheads}
8284 proc movedhead {hid head} {
8285 global arcnos arcout cached_dheads
8287 if {![info exists arcnos($hid)]} return
8288 if {![info exists arcout($hid)]} {
8289 recalcarc [lindex $arcnos($hid) 0]
8291 catch {unset cached_dheads}
8294 proc changedrefs {} {
8295 global cached_dheads cached_dtags cached_atags
8296 global arctags archeads arcnos arcout idheads idtags
8298 foreach id [concat [array names idheads] [array names idtags]] {
8299 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8300 set a [lindex $arcnos($id) 0]
8301 if {![info exists donearc($a)]} {
8307 catch {unset cached_dtags}
8308 catch {unset cached_atags}
8309 catch {unset cached_dheads}
8312 proc rereadrefs {} {
8313 global idtags idheads idotherrefs mainhead
8315 set refids [concat [array names idtags] \
8316 [array names idheads] [array names idotherrefs]]
8317 foreach id $refids {
8318 if {![info exists ref($id)]} {
8319 set ref($id) [listrefs $id]
8322 set oldmainhead $mainhead
8325 set refids [lsort -unique [concat $refids [array names idtags] \
8326 [array names idheads] [array names idotherrefs]]]
8327 foreach id $refids {
8328 set v [listrefs $id]
8329 if {![info exists ref($id)] || $ref($id) != $v ||
8330 ($id eq $oldmainhead && $id ne $mainhead) ||
8331 ($id eq $mainhead && $id ne $oldmainhead)} {
8338 proc listrefs {id} {
8339 global idtags idheads idotherrefs
8342 if {[info exists idtags($id)]} {
8346 if {[info exists idheads($id)]} {
8350 if {[info exists idotherrefs($id)]} {
8351 set z $idotherrefs($id)
8353 return [list $x $y $z]
8356 proc showtag {tag isnew} {
8357 global ctext tagcontents tagids linknum tagobjid
8360 addtohistory [list showtag $tag 0]
8362 $ctext conf -state normal
8366 if {![info exists tagcontents($tag)]} {
8368 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8371 if {[info exists tagcontents($tag)]} {
8372 set text $tagcontents($tag)
8374 set text "Tag: $tag\nId: $tagids($tag)"
8376 appendwithlinks $text {}
8377 $ctext conf -state disabled
8388 proc mkfontdisp {font top which} {
8389 global fontattr fontpref $font
8391 set fontpref($font) [set $font]
8392 button $top.${font}but -text $which -font optionfont \
8393 -command [list choosefont $font $which]
8394 label $top.$font -relief flat -font $font \
8395 -text $fontattr($font,family) -justify left
8396 grid x $top.${font}but $top.$font -sticky w
8399 proc choosefont {font which} {
8400 global fontparam fontlist fonttop fontattr
8402 set fontparam(which) $which
8403 set fontparam(font) $font
8404 set fontparam(family) [font actual $font -family]
8405 set fontparam(size) $fontattr($font,size)
8406 set fontparam(weight) $fontattr($font,weight)
8407 set fontparam(slant) $fontattr($font,slant)
8410 if {![winfo exists $top]} {
8412 eval font config sample [font actual $font]
8414 wm title $top "Gitk font chooser"
8415 label $top.l -textvariable fontparam(which) -font uifont
8416 pack $top.l -side top
8417 set fontlist [lsort [font families]]
8419 listbox $top.f.fam -listvariable fontlist \
8420 -yscrollcommand [list $top.f.sb set]
8421 bind $top.f.fam <<ListboxSelect>> selfontfam
8422 scrollbar $top.f.sb -command [list $top.f.fam yview]
8423 pack $top.f.sb -side right -fill y
8424 pack $top.f.fam -side left -fill both -expand 1
8425 pack $top.f -side top -fill both -expand 1
8427 spinbox $top.g.size -from 4 -to 40 -width 4 \
8428 -textvariable fontparam(size) \
8429 -validatecommand {string is integer -strict %s}
8430 checkbutton $top.g.bold -padx 5 \
8431 -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
8432 -variable fontparam(weight) -onvalue bold -offvalue normal
8433 checkbutton $top.g.ital -padx 5 \
8434 -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0 \
8435 -variable fontparam(slant) -onvalue italic -offvalue roman
8436 pack $top.g.size $top.g.bold $top.g.ital -side left
8437 pack $top.g -side top
8438 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8440 $top.c create text 100 25 -anchor center -text $which -font sample \
8441 -fill black -tags text
8442 bind $top.c <Configure> [list centertext $top.c]
8443 pack $top.c -side top -fill x
8445 button $top.buts.ok -text "OK" -command fontok -default active \
8447 button $top.buts.can -text "Cancel" -command fontcan -default normal \
8449 grid $top.buts.ok $top.buts.can
8450 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8451 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8452 pack $top.buts -side bottom -fill x
8453 trace add variable fontparam write chg_fontparam
8456 $top.c itemconf text -text $which
8458 set i [lsearch -exact $fontlist $fontparam(family)]
8460 $top.f.fam selection set $i
8465 proc centertext {w} {
8466 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8470 global fontparam fontpref prefstop
8472 set f $fontparam(font)
8473 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8474 if {$fontparam(weight) eq "bold"} {
8475 lappend fontpref($f) "bold"
8477 if {$fontparam(slant) eq "italic"} {
8478 lappend fontpref($f) "italic"
8481 $w conf -text $fontparam(family) -font $fontpref($f)
8487 global fonttop fontparam
8489 if {[info exists fonttop]} {
8490 catch {destroy $fonttop}
8491 catch {font delete sample}
8497 proc selfontfam {} {
8498 global fonttop fontparam
8500 set i [$fonttop.f.fam curselection]
8502 set fontparam(family) [$fonttop.f.fam get $i]
8506 proc chg_fontparam {v sub op} {
8509 font config sample -$sub $fontparam($sub)
8513 global maxwidth maxgraphpct
8514 global oldprefs prefstop showneartags showlocalchanges
8515 global bgcolor fgcolor ctext diffcolors selectbgcolor
8516 global uifont tabstop limitdiffs
8520 if {[winfo exists $top]} {
8524 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8525 limitdiffs tabstop} {
8526 set oldprefs($v) [set $v]
8529 wm title $top "Gitk preferences"
8530 label $top.ldisp -text "Commit list display options"
8531 $top.ldisp configure -font uifont
8532 grid $top.ldisp - -sticky w -pady 10
8533 label $top.spacer -text " "
8534 label $top.maxwidthl -text "Maximum graph width (lines)" \
8536 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8537 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8538 label $top.maxpctl -text "Maximum graph width (% of pane)" \
8540 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8541 grid x $top.maxpctl $top.maxpct -sticky w
8542 frame $top.showlocal
8543 label $top.showlocal.l -text "Show local changes" -font optionfont
8544 checkbutton $top.showlocal.b -variable showlocalchanges
8545 pack $top.showlocal.b $top.showlocal.l -side left
8546 grid x $top.showlocal -sticky w
8548 label $top.ddisp -text "Diff display options"
8549 $top.ddisp configure -font uifont
8550 grid $top.ddisp - -sticky w -pady 10
8551 label $top.tabstopl -text "Tab spacing" -font optionfont
8552 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8553 grid x $top.tabstopl $top.tabstop -sticky w
8555 label $top.ntag.l -text "Display nearby tags" -font optionfont
8556 checkbutton $top.ntag.b -variable showneartags
8557 pack $top.ntag.b $top.ntag.l -side left
8558 grid x $top.ntag -sticky w
8560 label $top.ldiff.l -text "Limit diffs to listed paths" -font optionfont
8561 checkbutton $top.ldiff.b -variable limitdiffs
8562 pack $top.ldiff.b $top.ldiff.l -side left
8563 grid x $top.ldiff -sticky w
8565 label $top.cdisp -text "Colors: press to choose"
8566 $top.cdisp configure -font uifont
8567 grid $top.cdisp - -sticky w -pady 10
8568 label $top.bg -padx 40 -relief sunk -background $bgcolor
8569 button $top.bgbut -text "Background" -font optionfont \
8570 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8571 grid x $top.bgbut $top.bg -sticky w
8572 label $top.fg -padx 40 -relief sunk -background $fgcolor
8573 button $top.fgbut -text "Foreground" -font optionfont \
8574 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8575 grid x $top.fgbut $top.fg -sticky w
8576 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8577 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8578 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8579 [list $ctext tag conf d0 -foreground]]
8580 grid x $top.diffoldbut $top.diffold -sticky w
8581 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8582 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8583 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8584 [list $ctext tag conf d1 -foreground]]
8585 grid x $top.diffnewbut $top.diffnew -sticky w
8586 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8587 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8588 -command [list choosecolor diffcolors 2 $top.hunksep \
8589 "diff hunk header" \
8590 [list $ctext tag conf hunksep -foreground]]
8591 grid x $top.hunksepbut $top.hunksep -sticky w
8592 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8593 button $top.selbgbut -text "Select bg" -font optionfont \
8594 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8595 grid x $top.selbgbut $top.selbgsep -sticky w
8597 label $top.cfont -text "Fonts: press to choose"
8598 $top.cfont configure -font uifont
8599 grid $top.cfont - -sticky w -pady 10
8600 mkfontdisp mainfont $top "Main font"
8601 mkfontdisp textfont $top "Diff display font"
8602 mkfontdisp uifont $top "User interface font"
8605 button $top.buts.ok -text "OK" -command prefsok -default active
8606 $top.buts.ok configure -font uifont
8607 button $top.buts.can -text "Cancel" -command prefscan -default normal
8608 $top.buts.can configure -font uifont
8609 grid $top.buts.ok $top.buts.can
8610 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8611 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8612 grid $top.buts - - -pady 10 -sticky ew
8613 bind $top <Visibility> "focus $top.buts.ok"
8616 proc choosecolor {v vi w x cmd} {
8619 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8620 -title "Gitk: choose color for $x"]
8621 if {$c eq {}} return
8622 $w conf -background $c
8628 global bglist cflist
8630 $w configure -selectbackground $c
8632 $cflist tag configure highlight \
8633 -background [$cflist cget -selectbackground]
8634 allcanvs itemconf secsel -fill $c
8641 $w conf -background $c
8649 $w conf -foreground $c
8651 allcanvs itemconf text -fill $c
8652 $canv itemconf circle -outline $c
8656 global oldprefs prefstop
8658 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8659 limitdiffs tabstop} {
8661 set $v $oldprefs($v)
8663 catch {destroy $prefstop}
8669 global maxwidth maxgraphpct
8670 global oldprefs prefstop showneartags showlocalchanges
8671 global fontpref mainfont textfont uifont
8672 global limitdiffs treediffs
8674 catch {destroy $prefstop}
8678 if {$mainfont ne $fontpref(mainfont)} {
8679 set mainfont $fontpref(mainfont)
8680 parsefont mainfont $mainfont
8681 eval font configure mainfont [fontflags mainfont]
8682 eval font configure mainfontbold [fontflags mainfont 1]
8686 if {$textfont ne $fontpref(textfont)} {
8687 set textfont $fontpref(textfont)
8688 parsefont textfont $textfont
8689 eval font configure textfont [fontflags textfont]
8690 eval font configure textfontbold [fontflags textfont 1]
8692 if {$uifont ne $fontpref(uifont)} {
8693 set uifont $fontpref(uifont)
8694 parsefont uifont $uifont
8695 eval font configure uifont [fontflags uifont]
8698 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8699 if {$showlocalchanges} {
8705 if {$limitdiffs != $oldprefs(limitdiffs)} {
8706 # treediffs elements are limited by path
8707 catch {unset treediffs}
8709 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8710 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8712 } elseif {$showneartags != $oldprefs(showneartags) ||
8713 $limitdiffs != $oldprefs(limitdiffs)} {
8718 proc formatdate {d} {
8719 global datetimeformat
8721 set d [clock format $d -format $datetimeformat]
8726 # This list of encoding names and aliases is distilled from
8727 # http://www.iana.org/assignments/character-sets.
8728 # Not all of them are supported by Tcl.
8729 set encoding_aliases {
8730 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8731 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8732 { ISO-10646-UTF-1 csISO10646UTF1 }
8733 { ISO_646.basic:1983 ref csISO646basic1983 }
8734 { INVARIANT csINVARIANT }
8735 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8736 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8737 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8738 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8739 { NATS-DANO iso-ir-9-1 csNATSDANO }
8740 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8741 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8742 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8743 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8744 { ISO-2022-KR csISO2022KR }
8746 { ISO-2022-JP csISO2022JP }
8747 { ISO-2022-JP-2 csISO2022JP2 }
8748 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8750 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8751 { IT iso-ir-15 ISO646-IT csISO15Italian }
8752 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8753 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8754 { greek7-old iso-ir-18 csISO18Greek7Old }
8755 { latin-greek iso-ir-19 csISO19LatinGreek }
8756 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8757 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8758 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8759 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8760 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8761 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8762 { INIS iso-ir-49 csISO49INIS }
8763 { INIS-8 iso-ir-50 csISO50INIS8 }
8764 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8765 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8766 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8767 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8768 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8769 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8771 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8772 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8773 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8774 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8775 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8776 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8777 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8778 { greek7 iso-ir-88 csISO88Greek7 }
8779 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8780 { iso-ir-90 csISO90 }
8781 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8782 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8783 csISO92JISC62991984b }
8784 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8785 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8786 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8787 csISO95JIS62291984handadd }
8788 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8789 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8790 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8791 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8793 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8794 { T.61-7bit iso-ir-102 csISO102T617bit }
8795 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8796 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8797 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8798 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8799 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8800 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8801 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8802 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8803 arabic csISOLatinArabic }
8804 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8805 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8806 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8807 greek greek8 csISOLatinGreek }
8808 { T.101-G2 iso-ir-128 csISO128T101G2 }
8809 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8811 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8812 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8813 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8814 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8815 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8816 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8817 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8818 csISOLatinCyrillic }
8819 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8820 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8821 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8822 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8823 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8824 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8825 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8826 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8827 { ISO_10367-box iso-ir-155 csISO10367Box }
8828 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8829 { latin-lap lap iso-ir-158 csISO158Lap }
8830 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8831 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8834 { JIS_X0201 X0201 csHalfWidthKatakana }
8835 { KSC5636 ISO646-KR csKSC5636 }
8836 { ISO-10646-UCS-2 csUnicode }
8837 { ISO-10646-UCS-4 csUCS4 }
8838 { DEC-MCS dec csDECMCS }
8839 { hp-roman8 roman8 r8 csHPRoman8 }
8840 { macintosh mac csMacintosh }
8841 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8843 { IBM038 EBCDIC-INT cp038 csIBM038 }
8844 { IBM273 CP273 csIBM273 }
8845 { IBM274 EBCDIC-BE CP274 csIBM274 }
8846 { IBM275 EBCDIC-BR cp275 csIBM275 }
8847 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8848 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8849 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8850 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8851 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8852 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8853 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8854 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8855 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8856 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8857 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8858 { IBM437 cp437 437 csPC8CodePage437 }
8859 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8860 { IBM775 cp775 csPC775Baltic }
8861 { IBM850 cp850 850 csPC850Multilingual }
8862 { IBM851 cp851 851 csIBM851 }
8863 { IBM852 cp852 852 csPCp852 }
8864 { IBM855 cp855 855 csIBM855 }
8865 { IBM857 cp857 857 csIBM857 }
8866 { IBM860 cp860 860 csIBM860 }
8867 { IBM861 cp861 861 cp-is csIBM861 }
8868 { IBM862 cp862 862 csPC862LatinHebrew }
8869 { IBM863 cp863 863 csIBM863 }
8870 { IBM864 cp864 csIBM864 }
8871 { IBM865 cp865 865 csIBM865 }
8872 { IBM866 cp866 866 csIBM866 }
8873 { IBM868 CP868 cp-ar csIBM868 }
8874 { IBM869 cp869 869 cp-gr csIBM869 }
8875 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8876 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8877 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8878 { IBM891 cp891 csIBM891 }
8879 { IBM903 cp903 csIBM903 }
8880 { IBM904 cp904 904 csIBBM904 }
8881 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8882 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8883 { IBM1026 CP1026 csIBM1026 }
8884 { EBCDIC-AT-DE csIBMEBCDICATDE }
8885 { EBCDIC-AT-DE-A csEBCDICATDEA }
8886 { EBCDIC-CA-FR csEBCDICCAFR }
8887 { EBCDIC-DK-NO csEBCDICDKNO }
8888 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8889 { EBCDIC-FI-SE csEBCDICFISE }
8890 { EBCDIC-FI-SE-A csEBCDICFISEA }
8891 { EBCDIC-FR csEBCDICFR }
8892 { EBCDIC-IT csEBCDICIT }
8893 { EBCDIC-PT csEBCDICPT }
8894 { EBCDIC-ES csEBCDICES }
8895 { EBCDIC-ES-A csEBCDICESA }
8896 { EBCDIC-ES-S csEBCDICESS }
8897 { EBCDIC-UK csEBCDICUK }
8898 { EBCDIC-US csEBCDICUS }
8899 { UNKNOWN-8BIT csUnknown8BiT }
8900 { MNEMONIC csMnemonic }
8905 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8906 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8907 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8908 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8909 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8910 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8911 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8912 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8913 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8914 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8915 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8916 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8917 { IBM1047 IBM-1047 }
8918 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8919 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8920 { UNICODE-1-1 csUnicode11 }
8923 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8924 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8926 { ISO-8859-15 ISO_8859-15 Latin-9 }
8927 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8928 { GBK CP936 MS936 windows-936 }
8929 { JIS_Encoding csJISEncoding }
8930 { Shift_JIS MS_Kanji csShiftJIS }
8931 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8933 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8934 { ISO-10646-UCS-Basic csUnicodeASCII }
8935 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8936 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8937 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8938 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8939 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8940 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8941 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8942 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8943 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8944 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8945 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8946 { Ventura-US csVenturaUS }
8947 { Ventura-International csVenturaInternational }
8948 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8949 { PC8-Turkish csPC8Turkish }
8950 { IBM-Symbols csIBMSymbols }
8951 { IBM-Thai csIBMThai }
8952 { HP-Legal csHPLegal }
8953 { HP-Pi-font csHPPiFont }
8954 { HP-Math8 csHPMath8 }
8955 { Adobe-Symbol-Encoding csHPPSMath }
8956 { HP-DeskTop csHPDesktop }
8957 { Ventura-Math csVenturaMath }
8958 { Microsoft-Publishing csMicrosoftPublishing }
8959 { Windows-31J csWindows31J }
8964 proc tcl_encoding {enc} {
8965 global encoding_aliases
8966 set names [encoding names]
8967 set lcnames [string tolower $names]
8968 set enc [string tolower $enc]
8969 set i [lsearch -exact $lcnames $enc]
8971 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8972 if {[regsub {^iso[-_]} $enc iso encx]} {
8973 set i [lsearch -exact $lcnames $encx]
8977 foreach l $encoding_aliases {
8978 set ll [string tolower $l]
8979 if {[lsearch -exact $ll $enc] < 0} continue
8980 # look through the aliases for one that tcl knows about
8982 set i [lsearch -exact $lcnames $e]
8984 if {[regsub {^iso[-_]} $e iso ex]} {
8985 set i [lsearch -exact $lcnames $ex]
8994 return [lindex $names $i]
8999 # First check that Tcl/Tk is recent enough
9000 if {[catch {package require Tk 8.4} err]} {
9001 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9002 Gitk requires at least Tcl/Tk 8.4."
9008 set wrcomcmd "git diff-tree --stdin -p --pretty"
9012 set gitencoding [exec git config --get i18n.commitencoding]
9014 if {$gitencoding == ""} {
9015 set gitencoding "utf-8"
9017 set tclencoding [tcl_encoding $gitencoding]
9018 if {$tclencoding == {}} {
9019 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9022 set mainfont {Helvetica 9}
9023 set textfont {Courier 9}
9024 set uifont {Helvetica 9 bold}
9026 set findmergefiles 0
9034 set cmitmode "patch"
9035 set wrapcomment "none"
9039 set showlocalchanges 1
9041 set datetimeformat "%Y-%m-%d %H:%M:%S"
9043 set colors {green red blue magenta darkgrey brown orange}
9046 set diffcolors {red "#00a000" blue}
9048 set selectbgcolor gray85
9050 catch {source ~/.gitk}
9052 font create optionfont -family sans-serif -size -12
9054 parsefont mainfont $mainfont
9055 eval font create mainfont [fontflags mainfont]
9056 eval font create mainfontbold [fontflags mainfont 1]
9058 parsefont textfont $textfont
9059 eval font create textfont [fontflags textfont]
9060 eval font create textfontbold [fontflags textfont 1]
9062 parsefont uifont $uifont
9063 eval font create uifont [fontflags uifont]
9065 # check that we can find a .git directory somewhere...
9066 if {[catch {set gitdir [gitdir]}]} {
9067 show_error {} . "Cannot find a git repository here."
9070 if {![file isdirectory $gitdir]} {
9071 show_error {} . "Cannot find the git directory \"$gitdir\"."
9077 set cmdline_files {}
9082 "-d" { set datemode 1 }
9085 lappend revtreeargs $arg
9088 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9092 lappend revtreeargs $arg
9098 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9099 # no -- on command line, but some arguments (other than -d)
9101 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9102 set cmdline_files [split $f "\n"]
9103 set n [llength $cmdline_files]
9104 set revtreeargs [lrange $revtreeargs 0 end-$n]
9105 # Unfortunately git rev-parse doesn't produce an error when
9106 # something is both a revision and a filename. To be consistent
9107 # with git log and git rev-list, check revtreeargs for filenames.
9108 foreach arg $revtreeargs {
9109 if {[file exists $arg]} {
9110 show_error {} . "Ambiguous argument '$arg': both revision\
9116 # unfortunately we get both stdout and stderr in $err,
9117 # so look for "fatal:".
9118 set i [string first "fatal:" $err]
9120 set err [string range $err [expr {$i + 6}] end]
9122 show_error {} . "Bad arguments to gitk:\n$err"
9128 # find the list of unmerged files
9132 set fd [open "| git ls-files -u" r]
9134 show_error {} . "Couldn't get list of unmerged files: $err"
9137 while {[gets $fd line] >= 0} {
9138 set i [string first "\t" $line]
9139 if {$i < 0} continue
9140 set fname [string range $line [expr {$i+1}] end]
9141 if {[lsearch -exact $mlist $fname] >= 0} continue
9143 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9144 lappend mlist $fname
9149 if {$nr_unmerged == 0} {
9150 show_error {} . "No files selected: --merge specified but\
9151 no files are unmerged."
9153 show_error {} . "No files selected: --merge specified but\
9154 no unmerged files are within file limit."
9158 set cmdline_files $mlist
9161 set nullid "0000000000000000000000000000000000000000"
9162 set nullid2 "0000000000000000000000000000000000000001"
9164 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9171 set highlight_paths {}
9173 set searchdirn -forwards
9177 set markingmatches 0
9178 set linkentercount 0
9179 set need_redisplay 0
9186 set selectedhlview None
9187 set highlight_related None
9188 set highlight_files {}
9202 # wait for the window to become visible
9204 wm title . "[file tail $argv0]: [file tail [pwd]]"
9207 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9208 # create a view for the files/dirs specified on the command line
9212 set viewname(1) "Command line"
9213 set viewfiles(1) $cmdline_files
9214 set viewargs(1) $revtreeargs
9217 .bar.view entryconf Edit* -state normal
9218 .bar.view entryconf Delete* -state normal
9221 if {[info exists permviews]} {
9222 foreach v $permviews {
9225 set viewname($n) [lindex $v 0]
9226 set viewfiles($n) [lindex $v 1]
9227 set viewargs($n) [lindex $v 2]