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 mainheadid
172 global varcid startmsecs commfd showneartags showlocalchanges leftover
174 if {$showlocalchanges && [commitinview
$mainheadid $curview]} {
178 set commits
[exec git rev-parse
--default HEAD
--revs-only \
183 if {[string match
"^*" $c]} {
186 if {!([info exists varcid
($view,$c)] ||
187 [lsearch
-exact $viewincl($view) $c] >= 0)} {
195 foreach id
$viewincl($view) {
198 set viewincl
($view) [concat
$viewincl($view) $pos]
200 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
201 --boundary $pos $neg "--" $viewfiles($view)] r
]
203 error_popup
"Error executing git log: $err"
206 if {$viewactive($view) == 0} {
207 set startmsecs
[clock clicks
-milliseconds]
209 set i
[incr loginstance
]
210 lappend viewinstances
($view) $i
213 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
214 if {$tclencoding != {}} {
215 fconfigure
$fd -encoding $tclencoding
217 filerun
$fd [list getcommitlines
$fd $i $view]
218 incr viewactive
($view)
219 set viewcomplete
($view) 0
220 nowbusy
$view "Reading"
228 proc reloadcommits
{} {
229 global curview viewcomplete selectedline currentid thickerline
230 global showneartags treediffs commitinterest cached_commitrow
231 global progresscoords
233 if {!$viewcomplete($curview)} {
234 stop_rev_list
$curview
235 set progresscoords
{0 0}
239 catch
{unset selectedline
}
240 catch
{unset currentid
}
241 catch
{unset thickerline
}
242 catch
{unset treediffs
}
249 catch
{unset commitinterest
}
250 catch
{unset cached_commitrow
}
255 # This makes a string representation of a positive integer which
256 # sorts as a string in numerical order
259 return [format
"%x" $n]
260 } elseif
{$n < 256} {
261 return [format
"x%.2x" $n]
262 } elseif
{$n < 65536} {
263 return [format
"y%.4x" $n]
265 return [format
"z%.8x" $n]
268 # Procedures used in reordering commits from git log (without
269 # --topo-order) into the order for display.
271 proc varcinit
{view
} {
272 global varcstart vupptr vdownptr vleftptr varctok varcrow
273 global vtokmod varcmod vrowmod varcix
275 set varcstart
($view) {{}}
276 set vupptr
($view) {0}
277 set vdownptr
($view) {0}
278 set vleftptr
($view) {0}
279 set varctok
($view) {{}}
280 set varcrow
($view) {{}}
281 set vtokmod
($view) {}
284 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
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 vupptr
($view) 0
330 set ka
[lindex
$vdownptr($view) 0]
332 [string compare
$tok [lindex
$varctok($view) $ka]] < 0} {
333 lset vdownptr
($view) 0 $a
334 lappend vleftptr
($view) $ka
336 while {[set b
[lindex
$vleftptr($view) $ka]] != 0 &&
337 [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
340 lset vleftptr
($view) $ka $a
341 lappend vleftptr
($view) $b
345 foreach k
$children($vid) {
346 set ka
$varcid($view,$k)
347 if {[string compare
[lindex
$varctok($view) $ka] $tok] > 0} {
349 set tok
[lindex
$varctok($view) $ka]
352 set ka
$varcid($view,$ki)
353 lappend vupptr
($view) $ka
354 set i
[lsearch
-exact $parents($view,$ki) $id]
355 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
357 while {[incr i
] < [llength
$parents($view,$ki)]} {
358 set bi
[lindex
$parents($view,$ki) $i]
359 if {[info exists varcid
($view,$bi)]} {
360 set b
$varcid($view,$bi)
361 if {[lindex
$vupptr($view) $b] == $ka} {
363 lappend vleftptr
($view) [lindex
$vleftptr($view) $b]
364 lset vleftptr
($view) $b $a
370 lappend vleftptr
($view) [lindex
$vdownptr($view) $ka]
371 lset vdownptr
($view) $ka $a
373 append tok
[strrep
$j]
375 lappend varctok
($view) $tok
376 lappend varcstart
($view) $id
377 lappend vdownptr
($view) 0
378 lappend varcrow
($view) {}
379 lappend varcix
($view) {}
380 set varccommits
($view,$a) {}
384 proc splitvarc
{p v
} {
385 global varcid varcstart varccommits varctok
386 global vupptr vdownptr vleftptr varcix varcrow
388 set oa
$varcid($v,$p)
389 set ac
$varccommits($v,$oa)
390 set i
[lsearch
-exact $varccommits($v,$oa) $p]
392 set na
[llength
$varctok($v)]
393 # "%" sorts before "0"...
394 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
395 lappend varctok
($v) $tok
396 lappend varcrow
($v) {}
397 lappend varcix
($v) {}
398 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
399 set varccommits
($v,$na) [lrange
$ac $i end
]
400 lappend varcstart
($v) $p
401 foreach id
$varccommits($v,$na) {
402 set varcid
($v,$id) $na
404 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
405 lset vdownptr
($v) $oa $na
406 lappend vupptr
($v) $oa
407 lappend vleftptr
($v) 0
408 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
409 lset vupptr
($v) $b $na
413 proc renumbervarc
{a v
} {
414 global parents children varctok varcstart varccommits
415 global vupptr vdownptr vleftptr varcid vtokmod
417 set t1
[clock clicks
-milliseconds]
422 if {[info exists isrelated
($a)]} {
424 set id
[lindex
$varccommits($v,$a) end
]
425 foreach p
$parents($v,$id) {
426 if {[info exists varcid
($v,$p)]} {
427 set isrelated
($varcid($v,$p)) 1
432 set b
[lindex
$vdownptr($v) $a]
435 set b
[lindex
$vleftptr($v) $a]
437 set a
[lindex
$vupptr($v) $a]
443 set id
[lindex
$varcstart($v) $a]
445 foreach k
$children($v,$id) {
446 set ka
$varcid($v,$k)
447 if {[string compare
[lindex
$varctok($v) $ka] $tok] > 0} {
449 set tok
[lindex
$varctok($v) $ka]
453 set ka
$varcid($v,$ki)
454 set i
[lsearch
-exact $parents($v,$ki) $id]
455 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
456 append tok
[strrep
$j]
457 set oldtok
[lindex
$varctok($v) $a]
458 if {$tok eq
$oldtok} continue
459 lset varctok
($v) $a $tok
463 set b
[lindex
$vupptr($v) $a]
465 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
468 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
471 set c
[lindex
$vdownptr($v) $b]
473 lset vdownptr
($v) $b [lindex
$vleftptr($v) $a]
476 while {$b != 0 && [lindex
$vleftptr($v) $b] != $a} {
477 set b
[lindex
$vleftptr($v) $b]
480 lset vleftptr
($v) $b [lindex
$vleftptr($v) $a]
482 puts
"oops couldn't find $a in chain for [lindex $vupptr($v) $a]"
485 lset vupptr
($v) $a $ka
487 while {[incr i
] < [llength
$parents($v,$ki)]} {
488 set bi
[lindex
$parents($v,$ki) $i]
489 if {[info exists varcid
($v,$bi)]} {
490 set b
$varcid($v,$bi)
491 if {[lindex
$vupptr($v) $b] == $ka} {
493 lset vleftptr
($v) $a [lindex
$vleftptr($v) $b]
494 lset vleftptr
($v) $b $a
500 lset vleftptr
($v) $a [lindex
$vdownptr($v) $ka]
501 lset vdownptr
($v) $ka $a
505 set t2
[clock clicks
-milliseconds]
506 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
509 proc fix_reversal
{p a v
} {
510 global varcid varcstart varctok vupptr
512 set pa
$varcid($v,$p)
513 if {$p ne
[lindex
$varcstart($v) $pa]} {
515 set pa
$varcid($v,$p)
517 # seeds always need to be renumbered
518 if {[lindex
$vupptr($v) $pa] == 0 ||
519 [string compare
[lindex
$varctok($v) $a] \
520 [lindex
$varctok($v) $pa]] > 0} {
525 proc insertrow
{id p v
} {
526 global varcid varccommits parents children cmitlisted
527 global commitidx varctok vtokmod
530 set i
[lsearch
-exact $varccommits($v,$a) $p]
532 puts
"oops: insertrow can't find [shortids $p] on arc $a"
535 set children
($v,$id) {}
536 set parents
($v,$id) [list
$p]
537 set varcid
($v,$id) $a
538 lappend children
($v,$p) $id
539 set cmitlisted
($v,$id) 1
541 # note we deliberately don't update varcstart($v) even if $i == 0
542 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
543 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
549 proc removerow
{id v
} {
550 global varcid varccommits parents children commitidx
551 global varctok vtokmod cmitlisted
553 if {[llength
$parents($v,$id)] != 1} {
554 puts
"oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
557 set p
[lindex
$parents($v,$id) 0]
558 set a
$varcid($v,$id)
559 set i
[lsearch
-exact $varccommits($v,$a) $id]
561 puts
"oops: removerow can't find [shortids $id] on arc $a"
565 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
566 unset parents
($v,$id)
567 unset children
($v,$id)
568 unset cmitlisted
($v,$id)
569 incr commitidx
($v) -1
570 set j
[lsearch
-exact $children($v,$p) $id]
572 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
574 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
580 proc vtokcmp
{v a b
} {
581 global varctok varcid
583 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
584 [lindex
$varctok($v) $varcid($v,$b)]]
587 proc modify_arc
{v a
{lim
{}}} {
588 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
589 global vhighlights nhighlights fhighlights rhighlights
591 set vtokmod
($v) [lindex
$varctok($v) $a]
593 if {$v == $curview} {
594 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
595 set a
[lindex
$vupptr($v) $a]
601 set lim
[llength
$varccommits($v,$a)]
603 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
608 catch
{unset nhighlights
}
609 catch
{unset fhighlights
}
610 catch
{unset vhighlights
}
611 catch
{unset rhighlights
}
614 proc update_arcrows
{v
} {
615 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
616 global varcid vrownum varcorder varcix varccommits
617 global vupptr vdownptr vleftptr varctok
618 global displayorder parentlist curview cached_commitrow
620 set narctot
[expr {[llength
$varctok($v)] - 1}]
622 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
623 # go up the tree until we find something that has a row number,
624 # or we get to a seed
625 set a
[lindex
$vupptr($v) $a]
628 set a
[lindex
$vdownptr($v) 0]
631 set varcorder
($v) [list
$a]
633 lset varcrow
($v) $a 0
637 set arcn
[lindex
$varcix($v) $a]
638 # see if a is the last arc; if so, nothing to do
639 if {$arcn == $narctot - 1} {
642 if {[llength
$vrownum($v)] > $arcn + 1} {
643 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
644 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
646 set row
[lindex
$varcrow($v) $a]
648 if {$v == $curview} {
649 if {[llength
$displayorder] > $vrowmod($v)} {
650 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
651 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
653 catch
{unset cached_commitrow
}
657 incr row
[llength
$varccommits($v,$a)]
658 # go down if possible
659 set b
[lindex
$vdownptr($v) $a]
661 # if not, go left, or go up until we can go left
663 set b
[lindex
$vleftptr($v) $a]
665 set a
[lindex
$vupptr($v) $a]
671 lappend vrownum
($v) $row
672 lappend varcorder
($v) $a
673 lset varcix
($v) $a $arcn
674 lset varcrow
($v) $a $row
676 set vtokmod
($v) [lindex
$varctok($v) $p]
679 if {[info exists currentid
]} {
680 set selectedline
[rowofcommit
$currentid]
684 # Test whether view $v contains commit $id
685 proc commitinview
{id v
} {
688 return [info exists varcid
($v,$id)]
691 # Return the row number for commit $id in the current view
692 proc rowofcommit
{id
} {
693 global varcid varccommits varcrow curview cached_commitrow
694 global varctok vtokmod
696 if {[info exists cached_commitrow
($id)]} {
697 return $cached_commitrow($id)
700 if {![info exists varcid
($v,$id)]} {
701 puts
"oops rowofcommit no arc for [shortids $id]"
704 set a
$varcid($v,$id)
705 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] > 0} {
708 set i
[lsearch
-exact $varccommits($v,$a) $id]
710 puts
"oops didn't find commit [shortids $id] in arc $a"
713 incr i
[lindex
$varcrow($v) $a]
714 set cached_commitrow
($id) $i
718 proc bsearch
{l elt
} {
719 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
724 while {$hi - $lo > 1} {
725 set mid
[expr {int
(($lo + $hi) / 2)}]
726 set t
[lindex
$l $mid]
729 } elseif
{$elt > $t} {
738 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
739 proc make_disporder
{start end
} {
740 global vrownum curview commitidx displayorder parentlist
741 global varccommits varcorder parents vrowmod varcrow
742 global d_valid_start d_valid_end
744 if {$end > $vrowmod($curview)} {
745 update_arcrows
$curview
747 set ai
[bsearch
$vrownum($curview) $start]
748 set start
[lindex
$vrownum($curview) $ai]
749 set narc
[llength
$vrownum($curview)]
750 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
751 set a
[lindex
$varcorder($curview) $ai]
752 set l
[llength
$displayorder]
753 set al
[llength
$varccommits($curview,$a)]
756 set pad
[ntimes
[expr {$r - $l}] {}]
757 set displayorder
[concat
$displayorder $pad]
758 set parentlist
[concat
$parentlist $pad]
760 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
761 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
763 foreach id
$varccommits($curview,$a) {
764 lappend displayorder
$id
765 lappend parentlist
$parents($curview,$id)
767 } elseif
{[lindex
$displayorder $r] eq
{}} {
769 foreach id
$varccommits($curview,$a) {
770 lset displayorder
$i $id
771 lset parentlist
$i $parents($curview,$id)
779 proc commitonrow
{row
} {
782 set id
[lindex
$displayorder $row]
784 make_disporder
$row [expr {$row + 1}]
785 set id
[lindex
$displayorder $row]
790 proc closevarcs
{v
} {
791 global varctok varccommits varcid parents children
792 global cmitlisted commitidx commitinterest vtokmod
794 set missing_parents
0
796 set narcs
[llength
$varctok($v)]
797 for {set a
1} {$a < $narcs} {incr a
} {
798 set id
[lindex
$varccommits($v,$a) end
]
799 foreach p
$parents($v,$id) {
800 if {[info exists varcid
($v,$p)]} continue
801 # add p as a new commit
803 set cmitlisted
($v,$p) 0
804 set parents
($v,$p) {}
805 if {[llength
$children($v,$p)] == 1 &&
806 [llength
$parents($v,$id)] == 1} {
809 set b
[newvarc
$v $p]
812 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
815 lappend varccommits
($v,$b) $p
817 if {[info exists commitinterest
($p)]} {
818 foreach
script $commitinterest($p) {
819 lappend scripts
[string map
[list
"%I" $p] $script]
821 unset commitinterest
($id)
825 if {$missing_parents > 0} {
832 proc getcommitlines
{fd inst view
} {
833 global cmitlisted commitinterest leftover
834 global commitidx commitdata
835 global parents children curview hlview
836 global vnextroot idpending ordertok
837 global varccommits varcid varctok vtokmod
839 set stuff
[read $fd 500000]
840 # git log doesn't terminate the last commit with a null...
841 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
848 global commfd viewcomplete viewactive viewname progresscoords
851 set i
[lsearch
-exact $viewinstances($view) $inst]
853 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
855 # set it blocking so we wait for the process to terminate
856 fconfigure
$fd -blocking 1
857 if {[catch
{close
$fd} err
]} {
859 if {$view != $curview} {
860 set fv
" for the \"$viewname($view)\" view"
862 if {[string range
$err 0 4] == "usage"} {
863 set err
"Gitk: error reading commits$fv:\
864 bad arguments to git rev-list."
865 if {$viewname($view) eq
"Command line"} {
867 " (Note: arguments to gitk are passed to git rev-list\
868 to allow selection of commits to be displayed.)"
871 set err
"Error reading commits$fv: $err"
875 if {[incr viewactive
($view) -1] <= 0} {
876 set viewcomplete
($view) 1
877 # Check if we have seen any ids listed as parents that haven't
878 # appeared in the list
881 set progresscoords
{0 0}
884 if {$view == $curview} {
885 run chewcommits
$view
893 set i
[string first
"\0" $stuff $start]
895 append leftover
($inst) [string range
$stuff $start end
]
899 set cmit
$leftover($inst)
900 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
901 set leftover
($inst) {}
903 set cmit
[string range
$stuff $start [expr {$i - 1}]]
905 set start
[expr {$i + 1}]
906 set j
[string first
"\n" $cmit]
909 if {$j >= 0 && [string match
"commit *" $cmit]} {
910 set ids
[string range
$cmit 7 [expr {$j - 1}]]
911 if {[string match
{[-<>]*} $ids]} {
912 switch
-- [string index
$ids 0] {
917 set ids
[string range
$ids 1 end
]
921 if {[string length
$id] != 40} {
929 if {[string length
$shortcmit] > 80} {
930 set shortcmit
"[string range $shortcmit 0 80]..."
932 error_popup
"Can't parse git log output: {$shortcmit}"
935 set id
[lindex
$ids 0]
937 if {!$listed && [info exists parents
($vid)]} continue
939 set olds
[lrange
$ids 1 end
]
943 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
944 set cmitlisted
($vid) $listed
945 set parents
($vid) $olds
947 if {![info exists children
($vid)]} {
948 set children
($vid) {}
950 if {[llength
$children($vid)] == 1} {
951 set k
[lindex
$children($vid) 0]
952 if {[llength
$parents($view,$k)] == 1} {
953 set a
$varcid($view,$k)
959 set a
[newvarc
$view $id]
962 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
965 lappend varccommits
($view,$a) $id
969 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
971 if {[llength
[lappend children
($vp) $id]] > 1 &&
972 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
973 set children
($vp) [lsort
-command [list vtokcmp
$view] \
975 catch
{unset ordertok
}
978 if {[info exists varcid
($view,$p)]} {
979 fix_reversal
$p $a $view
984 incr commitidx
($view)
985 if {[info exists commitinterest
($id)]} {
986 foreach
script $commitinterest($id) {
987 lappend scripts
[string map
[list
"%I" $id] $script]
989 unset commitinterest
($id)
994 run chewcommits
$view
998 if {$view == $curview} {
999 # update progress bar
1000 global progressdirn progresscoords proglastnc
1001 set inc
[expr {($commitidx($view) - $proglastnc) * 0.0002}]
1002 set proglastnc
$commitidx($view)
1003 set l
[lindex
$progresscoords 0]
1004 set r
[lindex
$progresscoords 1]
1005 if {$progressdirn} {
1006 set r
[expr {$r + $inc}]
1012 set l
[expr {$r - 0.2}]
1015 set l
[expr {$l - $inc}]
1020 set r
[expr {$l + 0.2}]
1022 set progresscoords
[list
$l $r]
1029 proc chewcommits
{view
} {
1030 global curview hlview viewcomplete
1031 global pending_select
1033 if {$view == $curview} {
1035 if {$viewcomplete($view)} {
1037 global numcommits startmsecs
1038 global mainheadid commitinfo nullid
1040 if {[info exists pending_select
]} {
1041 set row
[first_real_row
]
1044 if {$commitidx($curview) > 0} {
1045 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1046 #puts "overall $ms ms for $numcommits commits"
1048 show_status
"No commits selected"
1053 if {[info exists hlview
] && $view == $hlview} {
1059 proc readcommit
{id
} {
1060 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1061 parsecommit
$id $contents 0
1064 proc parsecommit
{id contents listed
} {
1065 global commitinfo cdate
1074 set hdrend
[string first
"\n\n" $contents]
1076 # should never happen...
1077 set hdrend
[string length
$contents]
1079 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1080 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1081 foreach line
[split $header "\n"] {
1082 set tag
[lindex
$line 0]
1083 if {$tag == "author"} {
1084 set audate
[lindex
$line end-1
]
1085 set auname
[lrange
$line 1 end-2
]
1086 } elseif
{$tag == "committer"} {
1087 set comdate
[lindex
$line end-1
]
1088 set comname
[lrange
$line 1 end-2
]
1092 # take the first non-blank line of the comment as the headline
1093 set headline
[string trimleft
$comment]
1094 set i
[string first
"\n" $headline]
1096 set headline
[string range
$headline 0 $i]
1098 set headline
[string trimright
$headline]
1099 set i
[string first
"\r" $headline]
1101 set headline
[string trimright
[string range
$headline 0 $i]]
1104 # git rev-list indents the comment by 4 spaces;
1105 # if we got this via git cat-file, add the indentation
1107 foreach line
[split $comment "\n"] {
1108 append newcomment
" "
1109 append newcomment
$line
1110 append newcomment
"\n"
1112 set comment
$newcomment
1114 if {$comdate != {}} {
1115 set cdate
($id) $comdate
1117 set commitinfo
($id) [list
$headline $auname $audate \
1118 $comname $comdate $comment]
1121 proc getcommit
{id
} {
1122 global commitdata commitinfo
1124 if {[info exists commitdata
($id)]} {
1125 parsecommit
$id $commitdata($id) 1
1128 if {![info exists commitinfo
($id)]} {
1129 set commitinfo
($id) {"No commit information available"}
1136 global tagids idtags headids idheads tagobjid
1137 global otherrefids idotherrefs mainhead mainheadid
1139 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1142 set refd
[open
[list | git show-ref
-d] r
]
1143 while {[gets
$refd line
] >= 0} {
1144 if {[string index
$line 40] ne
" "} continue
1145 set id
[string range
$line 0 39]
1146 set ref
[string range
$line 41 end
]
1147 if {![string match
"refs/*" $ref]} continue
1148 set name
[string range
$ref 5 end
]
1149 if {[string match
"remotes/*" $name]} {
1150 if {![string match
"*/HEAD" $name]} {
1151 set headids
($name) $id
1152 lappend idheads
($id) $name
1154 } elseif
{[string match
"heads/*" $name]} {
1155 set name
[string range
$name 6 end
]
1156 set headids
($name) $id
1157 lappend idheads
($id) $name
1158 } elseif
{[string match
"tags/*" $name]} {
1159 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1160 # which is what we want since the former is the commit ID
1161 set name
[string range
$name 5 end
]
1162 if {[string match
"*^{}" $name]} {
1163 set name
[string range
$name 0 end-3
]
1165 set tagobjid
($name) $id
1167 set tagids
($name) $id
1168 lappend idtags
($id) $name
1170 set otherrefids
($name) $id
1171 lappend idotherrefs
($id) $name
1178 set thehead
[exec git symbolic-ref HEAD
]
1179 if {[string match
"refs/heads/*" $thehead]} {
1180 set mainhead
[string range
$thehead 11 end
]
1181 if {[info exists headids
($mainhead)]} {
1182 set mainheadid
$headids($mainhead)
1188 # skip over fake commits
1189 proc first_real_row
{} {
1190 global nullid nullid2 numcommits
1192 for {set row
0} {$row < $numcommits} {incr row
} {
1193 set id
[commitonrow
$row]
1194 if {$id ne
$nullid && $id ne
$nullid2} {
1201 # update things for a head moved to a child of its previous location
1202 proc movehead
{id name
} {
1203 global headids idheads
1205 removehead
$headids($name) $name
1206 set headids
($name) $id
1207 lappend idheads
($id) $name
1210 # update things when a head has been removed
1211 proc removehead
{id name
} {
1212 global headids idheads
1214 if {$idheads($id) eq
$name} {
1217 set i
[lsearch
-exact $idheads($id) $name]
1219 set idheads
($id) [lreplace
$idheads($id) $i $i]
1222 unset headids
($name)
1225 proc show_error
{w top msg
} {
1226 message
$w.m
-text $msg -justify center
-aspect 400
1227 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1228 button
$w.ok
-text OK
-command "destroy $top"
1229 pack
$w.ok
-side bottom
-fill x
1230 bind $top <Visibility
> "grab $top; focus $top"
1231 bind $top <Key-Return
> "destroy $top"
1235 proc error_popup msg
{
1239 show_error
$w $w $msg
1242 proc confirm_popup msg
{
1248 message
$w.m
-text $msg -justify center
-aspect 400
1249 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1250 button
$w.ok
-text OK
-command "set confirm_ok 1; destroy $w"
1251 pack
$w.ok
-side left
-fill x
1252 button
$w.cancel
-text Cancel
-command "destroy $w"
1253 pack
$w.cancel
-side right
-fill x
1254 bind $w <Visibility
> "grab $w; focus $w"
1259 proc makewindow
{} {
1260 global canv canv2 canv3 linespc charspc ctext cflist
1262 global findtype findtypemenu findloc findstring fstring geometry
1263 global entries sha1entry sha1string sha1but
1264 global diffcontextstring diffcontext
1265 global maincursor textcursor curtextcursor
1266 global rowctxmenu fakerowmenu mergemax wrapcomment
1267 global highlight_files gdttype
1268 global searchstring sstring
1269 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1270 global headctxmenu progresscanv progressitem progresscoords statusw
1271 global fprogitem fprogcoord lastprogupdate progupdatepending
1272 global rprogitem rprogcoord
1276 .bar add cascade
-label "File" -menu .bar.
file
1277 .bar configure
-font uifont
1279 .bar.
file add
command -label "Update" -command updatecommits
1280 .bar.
file add
command -label "Reload" -command reloadcommits
1281 .bar.
file add
command -label "Reread references" -command rereadrefs
1282 .bar.
file add
command -label "List references" -command showrefs
1283 .bar.
file add
command -label "Quit" -command doquit
1284 .bar.
file configure
-font uifont
1286 .bar add cascade
-label "Edit" -menu .bar.edit
1287 .bar.edit add
command -label "Preferences" -command doprefs
1288 .bar.edit configure
-font uifont
1290 menu .bar.view
-font uifont
1291 .bar add cascade
-label "View" -menu .bar.view
1292 .bar.view add
command -label "New view..." -command {newview
0}
1293 .bar.view add
command -label "Edit view..." -command editview \
1295 .bar.view add
command -label "Delete view" -command delview
-state disabled
1296 .bar.view add separator
1297 .bar.view add radiobutton
-label "All files" -command {showview
0} \
1298 -variable selectedview
-value 0
1301 .bar add cascade
-label "Help" -menu .bar.
help
1302 .bar.
help add
command -label "About gitk" -command about
1303 .bar.
help add
command -label "Key bindings" -command keys
1304 .bar.
help configure
-font uifont
1305 . configure
-menu .bar
1307 # the gui has upper and lower half, parts of a paned window.
1308 panedwindow .ctop
-orient vertical
1310 # possibly use assumed geometry
1311 if {![info exists geometry
(pwsash0
)]} {
1312 set geometry
(topheight
) [expr {15 * $linespc}]
1313 set geometry
(topwidth
) [expr {80 * $charspc}]
1314 set geometry
(botheight
) [expr {15 * $linespc}]
1315 set geometry
(botwidth
) [expr {50 * $charspc}]
1316 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1317 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1320 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1321 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1323 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1325 # create three canvases
1326 set cscroll .tf.histframe.csb
1327 set canv .tf.histframe.pwclist.canv
1329 -selectbackground $selectbgcolor \
1330 -background $bgcolor -bd 0 \
1331 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1332 .tf.histframe.pwclist add
$canv
1333 set canv2 .tf.histframe.pwclist.canv2
1335 -selectbackground $selectbgcolor \
1336 -background $bgcolor -bd 0 -yscrollincr $linespc
1337 .tf.histframe.pwclist add
$canv2
1338 set canv3 .tf.histframe.pwclist.canv3
1340 -selectbackground $selectbgcolor \
1341 -background $bgcolor -bd 0 -yscrollincr $linespc
1342 .tf.histframe.pwclist add
$canv3
1343 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1344 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1346 # a scroll bar to rule them
1347 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1348 pack
$cscroll -side right
-fill y
1349 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1350 lappend bglist
$canv $canv2 $canv3
1351 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1353 # we have two button bars at bottom of top frame. Bar 1
1355 frame .tf.lbar
-height 15
1357 set sha1entry .tf.bar.sha1
1358 set entries
$sha1entry
1359 set sha1but .tf.bar.sha1label
1360 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
1361 -command gotocommit
-width 8 -font uifont
1362 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1363 pack .tf.bar.sha1label
-side left
1364 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1365 trace add variable sha1string
write sha1change
1366 pack
$sha1entry -side left
-pady 2
1368 image create bitmap bm-left
-data {
1369 #define left_width 16
1370 #define left_height 16
1371 static unsigned char left_bits
[] = {
1372 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1373 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1374 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1376 image create bitmap bm-right
-data {
1377 #define right_width 16
1378 #define right_height 16
1379 static unsigned char right_bits
[] = {
1380 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1381 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1382 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1384 button .tf.bar.leftbut
-image bm-left
-command goback \
1385 -state disabled
-width 26
1386 pack .tf.bar.leftbut
-side left
-fill y
1387 button .tf.bar.rightbut
-image bm-right
-command goforw \
1388 -state disabled
-width 26
1389 pack .tf.bar.rightbut
-side left
-fill y
1391 # Status label and progress bar
1392 set statusw .tf.bar.status
1393 label
$statusw -width 15 -relief sunken
-font uifont
1394 pack
$statusw -side left
-padx 5
1395 set h
[expr {[font metrics uifont
-linespace] + 2}]
1396 set progresscanv .tf.bar.progress
1397 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1398 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1399 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1400 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1401 pack
$progresscanv -side right
-expand 1 -fill x
1402 set progresscoords
{0 0}
1405 bind $progresscanv <Configure
> adjustprogress
1406 set lastprogupdate
[clock clicks
-milliseconds]
1407 set progupdatepending
0
1409 # build up the bottom bar of upper window
1410 label .tf.lbar.flabel
-text "Find " -font uifont
1411 button .tf.lbar.fnext
-text "next" -command {dofind
1 1} -font uifont
1412 button .tf.lbar.fprev
-text "prev" -command {dofind
-1 1} -font uifont
1413 label .tf.lbar.flab2
-text " commit " -font uifont
1414 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1416 set gdttype
"containing:"
1417 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1420 "adding/removing string:"]
1421 trace add variable gdttype
write gdttype_change
1422 $gm conf
-font uifont
1423 .tf.lbar.gdttype conf
-font uifont
1424 pack .tf.lbar.gdttype
-side left
-fill y
1427 set fstring .tf.lbar.findstring
1428 lappend entries
$fstring
1429 entry
$fstring -width 30 -font textfont
-textvariable findstring
1430 trace add variable findstring
write find_change
1432 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1433 findtype Exact IgnCase Regexp
]
1434 trace add variable findtype
write findcom_change
1435 .tf.lbar.findtype configure
-font uifont
1436 .tf.lbar.findtype.menu configure
-font uifont
1437 set findloc
"All fields"
1438 tk_optionMenu .tf.lbar.findloc findloc
"All fields" Headline \
1439 Comments Author Committer
1440 trace add variable findloc
write find_change
1441 .tf.lbar.findloc configure
-font uifont
1442 .tf.lbar.findloc.menu configure
-font uifont
1443 pack .tf.lbar.findloc
-side right
1444 pack .tf.lbar.findtype
-side right
1445 pack
$fstring -side left
-expand 1 -fill x
1447 # Finish putting the upper half of the viewer together
1448 pack .tf.lbar
-in .tf
-side bottom
-fill x
1449 pack .tf.bar
-in .tf
-side bottom
-fill x
1450 pack .tf.histframe
-fill both
-side top
-expand 1
1452 .ctop paneconfigure .tf
-height $geometry(topheight
)
1453 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1455 # now build up the bottom
1456 panedwindow .pwbottom
-orient horizontal
1458 # lower left, a text box over search bar, scroll bar to the right
1459 # if we know window height, then that will set the lower text height, otherwise
1460 # we set lower text height which will drive window height
1461 if {[info exists geometry
(main
)]} {
1462 frame .bleft
-width $geometry(botwidth
)
1464 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
1469 button .bleft.top.search
-text "Search" -command dosearch \
1471 pack .bleft.top.search
-side left
-padx 5
1472 set sstring .bleft.top.sstring
1473 entry
$sstring -width 20 -font textfont
-textvariable searchstring
1474 lappend entries
$sstring
1475 trace add variable searchstring
write incrsearch
1476 pack
$sstring -side left
-expand 1 -fill x
1477 radiobutton .bleft.mid.
diff -text "Diff" -font uifont \
1478 -command changediffdisp
-variable diffelide
-value {0 0}
1479 radiobutton .bleft.mid.old
-text "Old version" -font uifont \
1480 -command changediffdisp
-variable diffelide
-value {0 1}
1481 radiobutton .bleft.mid.new
-text "New version" -font uifont \
1482 -command changediffdisp
-variable diffelide
-value {1 0}
1483 label .bleft.mid.labeldiffcontext
-text " Lines of context: " \
1485 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
1486 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
1487 -from 1 -increment 1 -to 10000000 \
1488 -validate all
-validatecommand "diffcontextvalidate %P" \
1489 -textvariable diffcontextstring
1490 .bleft.mid.diffcontext
set $diffcontext
1491 trace add variable diffcontextstring
write diffcontextchange
1492 lappend entries .bleft.mid.diffcontext
1493 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
1494 set ctext .bleft.ctext
1495 text
$ctext -background $bgcolor -foreground $fgcolor \
1496 -state disabled
-font textfont \
1497 -yscrollcommand scrolltext
-wrap none
1499 $ctext conf
-tabstyle wordprocessor
1501 scrollbar .bleft.sb
-command "$ctext yview"
1502 pack .bleft.top
-side top
-fill x
1503 pack .bleft.mid
-side top
-fill x
1504 pack .bleft.sb
-side right
-fill y
1505 pack
$ctext -side left
-fill both
-expand 1
1506 lappend bglist
$ctext
1507 lappend fglist
$ctext
1509 $ctext tag conf comment
-wrap $wrapcomment
1510 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
1511 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
1512 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
1513 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
1514 $ctext tag conf m0
-fore red
1515 $ctext tag conf m1
-fore blue
1516 $ctext tag conf m2
-fore green
1517 $ctext tag conf m3
-fore purple
1518 $ctext tag conf
m4 -fore brown
1519 $ctext tag conf m5
-fore "#009090"
1520 $ctext tag conf m6
-fore magenta
1521 $ctext tag conf m7
-fore "#808000"
1522 $ctext tag conf m8
-fore "#009000"
1523 $ctext tag conf m9
-fore "#ff0080"
1524 $ctext tag conf m10
-fore cyan
1525 $ctext tag conf m11
-fore "#b07070"
1526 $ctext tag conf m12
-fore "#70b0f0"
1527 $ctext tag conf m13
-fore "#70f0b0"
1528 $ctext tag conf m14
-fore "#f0b070"
1529 $ctext tag conf m15
-fore "#ff70b0"
1530 $ctext tag conf mmax
-fore darkgrey
1532 $ctext tag conf mresult
-font textfontbold
1533 $ctext tag conf msep
-font textfontbold
1534 $ctext tag conf found
-back yellow
1536 .pwbottom add .bleft
1537 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
1542 radiobutton .bright.mode.
patch -text "Patch" \
1543 -command reselectline
-variable cmitmode
-value "patch"
1544 .bright.mode.
patch configure
-font uifont
1545 radiobutton .bright.mode.tree
-text "Tree" \
1546 -command reselectline
-variable cmitmode
-value "tree"
1547 .bright.mode.tree configure
-font uifont
1548 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
1549 pack .bright.mode
-side top
-fill x
1550 set cflist .bright.cfiles
1551 set indent
[font measure mainfont
"nn"]
1553 -selectbackground $selectbgcolor \
1554 -background $bgcolor -foreground $fgcolor \
1556 -tabs [list
$indent [expr {2 * $indent}]] \
1557 -yscrollcommand ".bright.sb set" \
1558 -cursor [. cget
-cursor] \
1559 -spacing1 1 -spacing3 1
1560 lappend bglist
$cflist
1561 lappend fglist
$cflist
1562 scrollbar .bright.sb
-command "$cflist yview"
1563 pack .bright.sb
-side right
-fill y
1564 pack
$cflist -side left
-fill both
-expand 1
1565 $cflist tag configure highlight \
1566 -background [$cflist cget
-selectbackground]
1567 $cflist tag configure bold
-font mainfontbold
1569 .pwbottom add .bright
1572 # restore window position if known
1573 if {[info exists geometry
(main
)]} {
1574 wm geometry .
"$geometry(main)"
1577 if {[tk windowingsystem
] eq
{aqua
}} {
1583 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
1584 pack .ctop
-fill both
-expand 1
1585 bindall
<1> {selcanvline
%W
%x
%y
}
1586 #bindall <B1-Motion> {selcanvline %W %x %y}
1587 if {[tk windowingsystem
] == "win32"} {
1588 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
1589 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
1591 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
1592 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
1593 if {[tk windowingsystem
] eq
"aqua"} {
1594 bindall
<MouseWheel
> {
1595 set delta
[expr {- (%D
)}]
1596 allcanvs yview scroll
$delta units
1600 bindall
<2> "canvscan mark %W %x %y"
1601 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
1602 bindkey
<Home
> selfirstline
1603 bindkey
<End
> sellastline
1604 bind .
<Key-Up
> "selnextline -1"
1605 bind .
<Key-Down
> "selnextline 1"
1606 bind .
<Shift-Key-Up
> "dofind -1 0"
1607 bind .
<Shift-Key-Down
> "dofind 1 0"
1608 bindkey
<Key-Right
> "goforw"
1609 bindkey
<Key-Left
> "goback"
1610 bind .
<Key-Prior
> "selnextpage -1"
1611 bind .
<Key-Next
> "selnextpage 1"
1612 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
1613 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
1614 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
1615 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
1616 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1617 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1618 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
1619 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
1620 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
1621 bindkey p
"selnextline -1"
1622 bindkey n
"selnextline 1"
1625 bindkey i
"selnextline -1"
1626 bindkey k
"selnextline 1"
1629 bindkey b
"$ctext yview scroll -1 pages"
1630 bindkey d
"$ctext yview scroll 18 units"
1631 bindkey u
"$ctext yview scroll -18 units"
1632 bindkey
/ {dofind
1 1}
1633 bindkey
<Key-Return
> {dofind
1 1}
1634 bindkey ?
{dofind
-1 1}
1636 bindkey
<F5
> updatecommits
1637 bind .
<$M1B-q> doquit
1638 bind .
<$M1B-f> {dofind
1 1}
1639 bind .
<$M1B-g> {dofind
1 0}
1640 bind .
<$M1B-r> dosearchback
1641 bind .
<$M1B-s> dosearch
1642 bind .
<$M1B-equal> {incrfont
1}
1643 bind .
<$M1B-KP_Add> {incrfont
1}
1644 bind .
<$M1B-minus> {incrfont
-1}
1645 bind .
<$M1B-KP_Subtract> {incrfont
-1}
1646 wm protocol . WM_DELETE_WINDOW doquit
1647 bind .
<Button-1
> "click %W"
1648 bind $fstring <Key-Return
> {dofind
1 1}
1649 bind $sha1entry <Key-Return
> gotocommit
1650 bind $sha1entry <<PasteSelection>> clearsha1
1651 bind $cflist <1> {sel_flist %W %x %y; break}
1652 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1653 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1654 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1656 set maincursor [. cget -cursor]
1657 set textcursor [$ctext cget -cursor]
1658 set curtextcursor $textcursor
1660 set rowctxmenu .rowctxmenu
1661 menu $rowctxmenu -tearoff 0
1662 $rowctxmenu add command -label "Diff this -> selected" \
1663 -command {diffvssel 0}
1664 $rowctxmenu add command -label "Diff selected -> this" \
1665 -command {diffvssel 1}
1666 $rowctxmenu add command -label "Make patch" -command mkpatch
1667 $rowctxmenu add command -label "Create tag" -command mktag
1668 $rowctxmenu add command -label "Write commit to file" -command writecommit
1669 $rowctxmenu add command -label "Create new branch" -command mkbranch
1670 $rowctxmenu add command -label "Cherry-pick this commit" \
1672 $rowctxmenu add command -label "Reset HEAD branch to here" \
1675 set fakerowmenu .fakerowmenu
1676 menu $fakerowmenu -tearoff 0
1677 $fakerowmenu add command -label "Diff this -> selected" \
1678 -command {diffvssel 0}
1679 $fakerowmenu add command -label "Diff selected -> this" \
1680 -command {diffvssel 1}
1681 $fakerowmenu add command -label "Make patch" -command mkpatch
1682 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1683 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1684 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
1686 set headctxmenu .headctxmenu
1687 menu $headctxmenu -tearoff 0
1688 $headctxmenu add command -label "Check out this branch" \
1690 $headctxmenu add command -label "Remove this branch" \
1694 set flist_menu .flistctxmenu
1695 menu $flist_menu -tearoff 0
1696 $flist_menu add command -label "Highlight this too" \
1697 -command {flist_hl 0}
1698 $flist_menu add command -label "Highlight this only" \
1699 -command {flist_hl 1}
1702 # Windows sends all mouse wheel events to the current focused window, not
1703 # the one where the mouse hovers, so bind those events here and redirect
1704 # to the correct window
1705 proc windows_mousewheel_redirector {W X Y D} {
1706 global canv canv2 canv3
1707 set w [winfo containing -displayof $W $X $Y]
1709 set u [expr {$D < 0 ? 5 : -5}]
1710 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1711 allcanvs yview scroll $u units
1714 $w yview scroll $u units
1720 # mouse-2 makes all windows scan vertically, but only the one
1721 # the cursor is in scans horizontally
1722 proc canvscan {op w x y} {
1723 global canv canv2 canv3
1724 foreach c [list $canv $canv2 $canv3] {
1733 proc scrollcanv {cscroll f0 f1} {
1734 $cscroll set $f0 $f1
1739 # when we make a key binding for the toplevel, make sure
1740 # it doesn't get triggered when that key is pressed in the
1741 # find string entry widget.
1742 proc bindkey {ev script} {
1745 set escript [bind Entry $ev]
1746 if {$escript == {}} {
1747 set escript [bind Entry <Key>]
1749 foreach e $entries {
1750 bind $e $ev "$escript; break"
1754 # set the focus back to the toplevel for any click outside
1757 global ctext entries
1758 foreach e [concat $entries $ctext] {
1759 if {$w == $e} return
1764 # Adjust the progress bar for a change in requested extent or canvas size
1765 proc adjustprogress {} {
1766 global progresscanv progressitem progresscoords
1767 global fprogitem fprogcoord lastprogupdate progupdatepending
1768 global rprogitem rprogcoord
1770 set w [expr {[winfo width $progresscanv] - 4}]
1771 set x0 [expr {$w * [lindex $progresscoords 0]}]
1772 set x1 [expr {$w * [lindex $progresscoords 1]}]
1773 set h [winfo height $progresscanv]
1774 $progresscanv coords $progressitem $x0 0 $x1 $h
1775 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1776 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1777 set now [clock clicks -milliseconds]
1778 if {$now >= $lastprogupdate + 100} {
1779 set progupdatepending 0
1781 } elseif {!$progupdatepending} {
1782 set progupdatepending 1
1783 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1787 proc doprogupdate {} {
1788 global lastprogupdate progupdatepending
1790 if {$progupdatepending} {
1791 set progupdatepending 0
1792 set lastprogupdate [clock clicks -milliseconds]
1797 proc savestuff {w} {
1798 global canv canv2 canv3 mainfont textfont uifont tabstop
1799 global stuffsaved findmergefiles maxgraphpct
1800 global maxwidth showneartags showlocalchanges
1801 global viewname viewfiles viewargs viewperm nextviewnum
1802 global cmitmode wrapcomment datetimeformat limitdiffs
1803 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1805 if {$stuffsaved} return
1806 if {![winfo viewable .]} return
1808 set f [open "~/.gitk-new" w]
1809 puts $f [list set mainfont $mainfont]
1810 puts $f [list set textfont $textfont]
1811 puts $f [list set uifont $uifont]
1812 puts $f [list set tabstop $tabstop]
1813 puts $f [list set findmergefiles $findmergefiles]
1814 puts $f [list set maxgraphpct $maxgraphpct]
1815 puts $f [list set maxwidth $maxwidth]
1816 puts $f [list set cmitmode $cmitmode]
1817 puts $f [list set wrapcomment $wrapcomment]
1818 puts $f [list set showneartags $showneartags]
1819 puts $f [list set showlocalchanges $showlocalchanges]
1820 puts $f [list set datetimeformat $datetimeformat]
1821 puts $f [list set limitdiffs $limitdiffs]
1822 puts $f [list set bgcolor $bgcolor]
1823 puts $f [list set fgcolor $fgcolor]
1824 puts $f [list set colors $colors]
1825 puts $f [list set diffcolors $diffcolors]
1826 puts $f [list set diffcontext $diffcontext]
1827 puts $f [list set selectbgcolor $selectbgcolor]
1829 puts $f "set geometry(main) [wm geometry .]"
1830 puts $f "set geometry(topwidth) [winfo width .tf]"
1831 puts $f "set geometry(topheight) [winfo height .tf]"
1832 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1833 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1834 puts $f "set geometry(botwidth) [winfo width .bleft]"
1835 puts $f "set geometry(botheight) [winfo height .bleft]"
1837 puts -nonewline $f "set permviews {"
1838 for {set v 0} {$v < $nextviewnum} {incr v} {
1839 if {$viewperm($v)} {
1840 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1845 file rename -force "~/.gitk-new" "~/.gitk"
1850 proc resizeclistpanes {win w} {
1852 if {[info exists oldwidth($win)]} {
1853 set s0 [$win sash coord 0]
1854 set s1 [$win sash coord 1]
1856 set sash0 [expr {int($w/2 - 2)}]
1857 set sash1 [expr {int($w*5/6 - 2)}]
1859 set factor [expr {1.0 * $w / $oldwidth($win)}]
1860 set sash0 [expr {int($factor * [lindex $s0 0])}]
1861 set sash1 [expr {int($factor * [lindex $s1 0])}]
1865 if {$sash1 < $sash0 + 20} {
1866 set sash1 [expr {$sash0 + 20}]
1868 if {$sash1 > $w - 10} {
1869 set sash1 [expr {$w - 10}]
1870 if {$sash0 > $sash1 - 20} {
1871 set sash0 [expr {$sash1 - 20}]
1875 $win sash place 0 $sash0 [lindex $s0 1]
1876 $win sash place 1 $sash1 [lindex $s1 1]
1878 set oldwidth($win) $w
1881 proc resizecdetpanes {win w} {
1883 if {[info exists oldwidth($win)]} {
1884 set s0 [$win sash coord 0]
1886 set sash0 [expr {int($w*3/4 - 2)}]
1888 set factor [expr {1.0 * $w / $oldwidth($win)}]
1889 set sash0 [expr {int($factor * [lindex $s0 0])}]
1893 if {$sash0 > $w - 15} {
1894 set sash0 [expr {$w - 15}]
1897 $win sash place 0 $sash0 [lindex $s0 1]
1899 set oldwidth($win) $w
1902 proc allcanvs args {
1903 global canv canv2 canv3
1909 proc bindall {event action} {
1910 global canv canv2 canv3
1911 bind $canv $event $action
1912 bind $canv2 $event $action
1913 bind $canv3 $event $action
1919 if {[winfo exists $w]} {
1924 wm title $w "About gitk"
1925 message $w.m -text {
1926 Gitk - a commit viewer for git
1928 Copyright © 2005-2007 Paul Mackerras
1930 Use and redistribute under the terms of the GNU General Public License} \
1931 -justify center -aspect 400 -border 2 -bg white -relief groove
1932 pack $w.m -side top -fill x -padx 2 -pady 2
1933 $w.m configure -font uifont
1934 button $w.ok -text Close -command "destroy $w" -default active
1935 pack $w.ok -side bottom
1936 $w.ok configure -font uifont
1937 bind $w <Visibility> "focus $w.ok"
1938 bind $w <Key-Escape> "destroy $w"
1939 bind $w <Key-Return> "destroy $w"
1945 if {[winfo exists $w]} {
1949 if {[tk windowingsystem] eq {aqua}} {
1955 wm title $w "Gitk key bindings"
1956 message $w.m -text "
1960 <Home> Move to first commit
1961 <End> Move to last commit
1962 <Up>, p, i Move up one commit
1963 <Down>, n, k Move down one commit
1964 <Left>, z, j Go back in history list
1965 <Right>, x, l Go forward in history list
1966 <PageUp> Move up one page in commit list
1967 <PageDown> Move down one page in commit list
1968 <$M1T-Home> Scroll to top of commit list
1969 <$M1T-End> Scroll to bottom of commit list
1970 <$M1T-Up> Scroll commit list up one line
1971 <$M1T-Down> Scroll commit list down one line
1972 <$M1T-PageUp> Scroll commit list up one page
1973 <$M1T-PageDown> Scroll commit list down one page
1974 <Shift-Up> Find backwards (upwards, later commits)
1975 <Shift-Down> Find forwards (downwards, earlier commits)
1976 <Delete>, b Scroll diff view up one page
1977 <Backspace> Scroll diff view up one page
1978 <Space> Scroll diff view down one page
1979 u Scroll diff view up 18 lines
1980 d Scroll diff view down 18 lines
1982 <$M1T-G> Move to next find hit
1983 <Return> Move to next find hit
1984 / Move to next find hit, or redo find
1985 ? Move to previous find hit
1986 f Scroll diff view to next file
1987 <$M1T-S> Search for next hit in diff view
1988 <$M1T-R> Search for previous hit in diff view
1989 <$M1T-KP+> Increase font size
1990 <$M1T-plus> Increase font size
1991 <$M1T-KP-> Decrease font size
1992 <$M1T-minus> Decrease font size
1995 -justify left -bg white -border 2 -relief groove
1996 pack $w.m -side top -fill both -padx 2 -pady 2
1997 $w.m configure -font uifont
1998 button $w.ok -text Close -command "destroy $w" -default active
1999 pack $w.ok -side bottom
2000 $w.ok configure -font uifont
2001 bind $w <Visibility> "focus $w.ok"
2002 bind $w <Key-Escape> "destroy $w"
2003 bind $w <Key-Return> "destroy $w"
2006 # Procedures for manipulating the file list window at the
2007 # bottom right of the overall window.
2009 proc treeview {w l openlevs} {
2010 global treecontents treediropen treeheight treeparent treeindex
2020 set treecontents() {}
2021 $w conf -state normal
2023 while {[string range $f 0 $prefixend] ne $prefix} {
2024 if {$lev <= $openlevs} {
2025 $w mark set e:$treeindex($prefix) "end -1c"
2026 $w mark gravity e:$treeindex($prefix) left
2028 set treeheight($prefix) $ht
2029 incr ht [lindex $htstack end]
2030 set htstack [lreplace $htstack end end]
2031 set prefixend [lindex $prefendstack end]
2032 set prefendstack [lreplace $prefendstack end end]
2033 set prefix [string range $prefix 0 $prefixend]
2036 set tail [string range $f [expr {$prefixend+1}] end]
2037 while {[set slash [string first "/" $tail]] >= 0} {
2040 lappend prefendstack $prefixend
2041 incr prefixend [expr {$slash + 1}]
2042 set d [string range $tail 0 $slash]
2043 lappend treecontents($prefix) $d
2044 set oldprefix $prefix
2046 set treecontents($prefix) {}
2047 set treeindex($prefix) [incr ix]
2048 set treeparent($prefix) $oldprefix
2049 set tail [string range $tail [expr {$slash+1}] end]
2050 if {$lev <= $openlevs} {
2052 set treediropen($prefix) [expr {$lev < $openlevs}]
2053 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2054 $w mark set d:$ix "end -1c"
2055 $w mark gravity d:$ix left
2057 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2059 $w image create end -align center -image $bm -padx 1 \
2061 $w insert end $d [highlight_tag $prefix]
2062 $w mark set s:$ix "end -1c"
2063 $w mark gravity s:$ix left
2068 if {$lev <= $openlevs} {
2071 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2073 $w insert end $tail [highlight_tag $f]
2075 lappend treecontents($prefix) $tail
2078 while {$htstack ne {}} {
2079 set treeheight($prefix) $ht
2080 incr ht [lindex $htstack end]
2081 set htstack [lreplace $htstack end end]
2082 set prefixend [lindex $prefendstack end]
2083 set prefendstack [lreplace $prefendstack end end]
2084 set prefix [string range $prefix 0 $prefixend]
2086 $w conf -state disabled
2089 proc linetoelt {l} {
2090 global treeheight treecontents
2095 foreach e $treecontents($prefix) {
2100 if {[string index $e end] eq "/"} {
2101 set n $treeheight($prefix$e)
2113 proc highlight_tree {y prefix} {
2114 global treeheight treecontents cflist
2116 foreach e $treecontents($prefix) {
2118 if {[highlight_tag $path] ne {}} {
2119 $cflist tag add bold $y.0 "$y.0 lineend"
2122 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2123 set y [highlight_tree $y $path]
2129 proc treeclosedir {w dir} {
2130 global treediropen treeheight treeparent treeindex
2132 set ix $treeindex($dir)
2133 $w conf -state normal
2134 $w delete s:$ix e:$ix
2135 set treediropen($dir) 0
2136 $w image configure a:$ix -image tri-rt
2137 $w conf -state disabled
2138 set n [expr {1 - $treeheight($dir)}]
2139 while {$dir ne {}} {
2140 incr treeheight($dir) $n
2141 set dir $treeparent($dir)
2145 proc treeopendir {w dir} {
2146 global treediropen treeheight treeparent treecontents treeindex
2148 set ix $treeindex($dir)
2149 $w conf -state normal
2150 $w image configure a:$ix -image tri-dn
2151 $w mark set e:$ix s:$ix
2152 $w mark gravity e:$ix right
2155 set n [llength $treecontents($dir)]
2156 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2159 incr treeheight($x) $n
2161 foreach e $treecontents($dir) {
2163 if {[string index $e end] eq "/"} {
2164 set iy $treeindex($de)
2165 $w mark set d:$iy e:$ix
2166 $w mark gravity d:$iy left
2167 $w insert e:$ix $str
2168 set treediropen($de) 0
2169 $w image create e:$ix -align center -image tri-rt -padx 1 \
2171 $w insert e:$ix $e [highlight_tag $de]
2172 $w mark set s:$iy e:$ix
2173 $w mark gravity s:$iy left
2174 set treeheight($de) 1
2176 $w insert e:$ix $str
2177 $w insert e:$ix $e [highlight_tag $de]
2180 $w mark gravity e:$ix left
2181 $w conf -state disabled
2182 set treediropen($dir) 1
2183 set top [lindex [split [$w index @0,0] .] 0]
2184 set ht [$w cget -height]
2185 set l [lindex [split [$w index s:$ix] .] 0]
2188 } elseif {$l + $n + 1 > $top + $ht} {
2189 set top [expr {$l + $n + 2 - $ht}]
2197 proc treeclick {w x y} {
2198 global treediropen cmitmode ctext cflist cflist_top
2200 if {$cmitmode ne "tree"} return
2201 if {![info exists cflist_top]} return
2202 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2203 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2204 $cflist tag add highlight $l.0 "$l.0 lineend"
2210 set e [linetoelt $l]
2211 if {[string index $e end] ne "/"} {
2213 } elseif {$treediropen($e)} {
2220 proc setfilelist {id} {
2221 global treefilelist cflist
2223 treeview $cflist $treefilelist($id) 0
2226 image create bitmap tri-rt -background black -foreground blue -data {
2227 #define tri-rt_width 13
2228 #define tri-rt_height 13
2229 static unsigned char tri-rt_bits[] = {
2230 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2231 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2234 #define tri-rt-mask_width 13
2235 #define tri-rt-mask_height 13
2236 static unsigned char tri-rt-mask_bits[] = {
2237 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2238 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2241 image create bitmap tri-dn -background black -foreground blue -data {
2242 #define tri-dn_width 13
2243 #define tri-dn_height 13
2244 static unsigned char tri-dn_bits[] = {
2245 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2246 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2249 #define tri-dn-mask_width 13
2250 #define tri-dn-mask_height 13
2251 static unsigned char tri-dn-mask_bits[] = {
2252 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2253 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2257 image create bitmap reficon-T -background black -foreground yellow -data {
2258 #define tagicon_width 13
2259 #define tagicon_height 9
2260 static unsigned char tagicon_bits[] = {
2261 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2262 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2264 #define tagicon-mask_width 13
2265 #define tagicon-mask_height 9
2266 static unsigned char tagicon-mask_bits[] = {
2267 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2268 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2271 #define headicon_width 13
2272 #define headicon_height 9
2273 static unsigned char headicon_bits[] = {
2274 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2275 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2278 #define headicon-mask_width 13
2279 #define headicon-mask_height 9
2280 static unsigned char headicon-mask_bits[] = {
2281 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2282 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2284 image create bitmap reficon-H -background black -foreground green \
2285 -data $rectdata -maskdata $rectmask
2286 image create bitmap reficon-o -background black -foreground "#ddddff" \
2287 -data $rectdata -maskdata $rectmask
2289 proc init_flist {first} {
2290 global cflist cflist_top difffilestart
2292 $cflist conf -state normal
2293 $cflist delete 0.0 end
2295 $cflist insert end $first
2297 $cflist tag add highlight 1.0 "1.0 lineend"
2299 catch {unset cflist_top}
2301 $cflist conf -state disabled
2302 set difffilestart {}
2305 proc highlight_tag {f} {
2306 global highlight_paths
2308 foreach p $highlight_paths {
2309 if {[string match $p $f]} {
2316 proc highlight_filelist {} {
2317 global cmitmode cflist
2319 $cflist conf -state normal
2320 if {$cmitmode ne "tree"} {
2321 set end [lindex [split [$cflist index end] .] 0]
2322 for {set l 2} {$l < $end} {incr l} {
2323 set line [$cflist get $l.0 "$l.0 lineend"]
2324 if {[highlight_tag $line] ne {}} {
2325 $cflist tag add bold $l.0 "$l.0 lineend"
2331 $cflist conf -state disabled
2334 proc unhighlight_filelist {} {
2337 $cflist conf -state normal
2338 $cflist tag remove bold 1.0 end
2339 $cflist conf -state disabled
2342 proc add_flist {fl} {
2345 $cflist conf -state normal
2347 $cflist insert end "\n"
2348 $cflist insert end $f [highlight_tag $f]
2350 $cflist conf -state disabled
2353 proc sel_flist {w x y} {
2354 global ctext difffilestart cflist cflist_top cmitmode
2356 if {$cmitmode eq "tree"} return
2357 if {![info exists cflist_top]} return
2358 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2359 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2360 $cflist tag add highlight $l.0 "$l.0 lineend"
2365 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2369 proc pop_flist_menu {w X Y x y} {
2370 global ctext cflist cmitmode flist_menu flist_menu_file
2371 global treediffs diffids
2374 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2376 if {$cmitmode eq "tree"} {
2377 set e [linetoelt $l]
2378 if {[string index $e end] eq "/"} return
2380 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2382 set flist_menu_file $e
2383 tk_popup $flist_menu $X $Y
2386 proc flist_hl {only} {
2387 global flist_menu_file findstring gdttype
2389 set x [shellquote $flist_menu_file]
2390 if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
2393 append findstring " " $x
2395 set gdttype "touching paths:"
2398 # Functions for adding and removing shell-type quoting
2400 proc shellquote {str} {
2401 if {![string match "*\['\"\\ \t]*" $str]} {
2404 if {![string match "*\['\"\\]*" $str]} {
2407 if {![string match "*'*" $str]} {
2410 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2413 proc shellarglist {l} {
2419 append str [shellquote $a]
2424 proc shelldequote {str} {
2429 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2430 append ret [string range $str $used end]
2431 set used [string length $str]
2434 set first [lindex $first 0]
2435 set ch [string index $str $first]
2436 if {$first > $used} {
2437 append ret [string range $str $used [expr {$first - 1}]]
2440 if {$ch eq " " || $ch eq "\t"} break
2443 set first [string first "'" $str $used]
2445 error "unmatched single-quote"
2447 append ret [string range $str $used [expr {$first - 1}]]
2452 if {$used >= [string length $str]} {
2453 error "trailing backslash"
2455 append ret [string index $str $used]
2460 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2461 error "unmatched double-quote"
2463 set first [lindex $first 0]
2464 set ch [string index $str $first]
2465 if {$first > $used} {
2466 append ret [string range $str $used [expr {$first - 1}]]
2469 if {$ch eq "\""} break
2471 append ret [string index $str $used]
2475 return [list $used $ret]
2478 proc shellsplit {str} {
2481 set str [string trimleft $str]
2482 if {$str eq {}} break
2483 set dq [shelldequote $str]
2484 set n [lindex $dq 0]
2485 set word [lindex $dq 1]
2486 set str [string range $str $n end]
2492 # Code to implement multiple views
2494 proc newview {ishighlight} {
2495 global nextviewnum newviewname newviewperm uifont newishighlight
2496 global newviewargs revtreeargs
2498 set newishighlight $ishighlight
2500 if {[winfo exists $top]} {
2504 set newviewname($nextviewnum) "View $nextviewnum"
2505 set newviewperm($nextviewnum) 0
2506 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2507 vieweditor $top $nextviewnum "Gitk view definition"
2512 global viewname viewperm newviewname newviewperm
2513 global viewargs newviewargs
2515 set top .gitkvedit-$curview
2516 if {[winfo exists $top]} {
2520 set newviewname($curview) $viewname($curview)
2521 set newviewperm($curview) $viewperm($curview)
2522 set newviewargs($curview) [shellarglist $viewargs($curview)]
2523 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2526 proc vieweditor {top n title} {
2527 global newviewname newviewperm viewfiles
2531 wm title $top $title
2532 label $top.nl -text "Name" -font uifont
2533 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
2534 grid $top.nl $top.name -sticky w -pady 5
2535 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
2537 grid $top.perm - -pady 5 -sticky w
2538 message $top.al -aspect 1000 -font uifont \
2539 -text "Commits to include (arguments to git rev-list):"
2540 grid $top.al - -sticky w -pady 5
2541 entry $top.args -width 50 -textvariable newviewargs($n) \
2542 -background white -font uifont
2543 grid $top.args - -sticky ew -padx 5
2544 message $top.l -aspect 1000 -font uifont \
2545 -text "Enter files and directories to include, one per line:"
2546 grid $top.l - -sticky w
2547 text $top.t -width 40 -height 10 -background white -font uifont
2548 if {[info exists viewfiles($n)]} {
2549 foreach f $viewfiles($n) {
2550 $top.t insert end $f
2551 $top.t insert end "\n"
2553 $top.t delete {end - 1c} end
2554 $top.t mark set insert 0.0
2556 grid $top.t - -sticky ew -padx 5
2558 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
2560 button $top.buts.can -text "Cancel" -command [list destroy $top] \
2562 grid $top.buts.ok $top.buts.can
2563 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2564 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2565 grid $top.buts - -pady 10 -sticky ew
2569 proc doviewmenu {m first cmd op argv} {
2570 set nmenu [$m index end]
2571 for {set i $first} {$i <= $nmenu} {incr i} {
2572 if {[$m entrycget $i -command] eq $cmd} {
2573 eval $m $op $i $argv
2579 proc allviewmenus {n op args} {
2582 doviewmenu .bar.view 5 [list showview $n] $op $args
2583 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2586 proc newviewok {top n} {
2587 global nextviewnum newviewperm newviewname newishighlight
2588 global viewname viewfiles viewperm selectedview curview
2589 global viewargs newviewargs viewhlmenu
2592 set newargs [shellsplit $newviewargs($n)]
2594 error_popup "Error in commit selection arguments: $err"
2600 foreach f [split [$top.t get 0.0 end] "\n"] {
2601 set ft [string trim $f]
2606 if {![info exists viewfiles($n)]} {
2607 # creating a new view
2609 set viewname($n) $newviewname($n)
2610 set viewperm($n) $newviewperm($n)
2611 set viewfiles($n) $files
2612 set viewargs($n) $newargs
2614 if {!$newishighlight} {
2617 run addvhighlight $n
2620 # editing an existing view
2621 set viewperm($n) $newviewperm($n)
2622 if {$newviewname($n) ne $viewname($n)} {
2623 set viewname($n) $newviewname($n)
2624 doviewmenu .bar.view 5 [list showview $n] \
2625 entryconf [list -label $viewname($n)]
2626 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2627 # entryconf [list -label $viewname($n) -value $viewname($n)]
2629 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2630 set viewfiles($n) $files
2631 set viewargs($n) $newargs
2632 if {$curview == $n} {
2637 catch {destroy $top}
2641 global curview viewperm hlview selectedhlview
2643 if {$curview == 0} return
2644 if {[info exists hlview] && $hlview == $curview} {
2645 set selectedhlview None
2648 allviewmenus $curview delete
2649 set viewperm($curview) 0
2653 proc addviewmenu {n} {
2654 global viewname viewhlmenu
2656 .bar.view add radiobutton -label $viewname($n) \
2657 -command [list showview $n] -variable selectedview -value $n
2658 #$viewhlmenu add radiobutton -label $viewname($n) \
2659 # -command [list addvhighlight $n] -variable selectedhlview
2663 global curview viewfiles cached_commitrow ordertok
2664 global displayorder parentlist rowidlist rowisopt rowfinal
2665 global colormap rowtextx nextcolor canvxmax
2666 global numcommits viewcomplete
2667 global selectedline currentid canv canvy0
2669 global pending_select
2671 global selectedview selectfirst
2672 global hlview selectedhlview commitinterest
2674 if {$n == $curview} return
2676 set ymax [lindex [$canv cget -scrollregion] 3]
2677 set span [$canv yview]
2678 set ytop [expr {[lindex $span 0] * $ymax}]
2679 set ybot [expr {[lindex $span 1] * $ymax}]
2680 set yscreen [expr {($ybot - $ytop) / 2}]
2681 if {[info exists selectedline]} {
2682 set selid $currentid
2683 set y [yc $selectedline]
2684 if {$ytop < $y && $y < $ybot} {
2685 set yscreen [expr {$y - $ytop}]
2687 } elseif {[info exists pending_select]} {
2688 set selid $pending_select
2689 unset pending_select
2693 catch {unset treediffs}
2695 if {[info exists hlview] && $hlview == $n} {
2697 set selectedhlview None
2699 catch {unset commitinterest}
2700 catch {unset cached_commitrow}
2701 catch {unset ordertok}
2705 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2706 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2709 if {![info exists viewcomplete($n)]} {
2711 set pending_select $selid
2722 set numcommits $commitidx($n)
2724 catch {unset colormap}
2725 catch {unset rowtextx}
2727 set canvxmax [$canv cget -width]
2734 if {$selid ne {} && [commitinview $selid $n]} {
2735 set row [rowofcommit $selid]
2736 # try to get the selected row in the same position on the screen
2737 set ymax [lindex [$canv cget -scrollregion] 3]
2738 set ytop [expr {[yc $row] - $yscreen}]
2742 set yf [expr {$ytop * 1.0 / $ymax}]
2744 allcanvs yview moveto $yf
2748 } elseif {$selid ne {}} {
2749 set pending_select $selid
2751 set row [first_real_row]
2752 if {$row < $numcommits} {
2758 if {!$viewcomplete($n)} {
2759 if {$numcommits == 0} {
2760 show_status "Reading commits..."
2764 } elseif {$numcommits == 0} {
2765 show_status "No commits selected"
2769 # Stuff relating to the highlighting facility
2771 proc ishighlighted {row} {
2772 global vhighlights fhighlights nhighlights rhighlights
2774 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2775 return $nhighlights($row)
2777 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2778 return $vhighlights($row)
2780 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2781 return $fhighlights($row)
2783 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2784 return $rhighlights($row)
2789 proc bolden {row font} {
2790 global canv linehtag selectedline boldrows
2792 lappend boldrows $row
2793 $canv itemconf $linehtag($row) -font $font
2794 if {[info exists selectedline] && $row == $selectedline} {
2796 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2797 -outline {{}} -tags secsel \
2798 -fill [$canv cget -selectbackground]]
2803 proc bolden_name {row font} {
2804 global canv2 linentag selectedline boldnamerows
2806 lappend boldnamerows $row
2807 $canv2 itemconf $linentag($row) -font $font
2808 if {[info exists selectedline] && $row == $selectedline} {
2809 $canv2 delete secsel
2810 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2811 -outline {{}} -tags secsel \
2812 -fill [$canv2 cget -selectbackground]]
2821 foreach row $boldrows {
2822 if {![ishighlighted $row]} {
2823 bolden $row mainfont
2825 lappend stillbold $row
2828 set boldrows $stillbold
2831 proc addvhighlight {n} {
2832 global hlview viewcomplete curview vhl_done vhighlights commitidx
2834 if {[info exists hlview]} {
2838 if {$n != $curview && ![info exists viewcomplete($n)]} {
2841 set vhl_done $commitidx($hlview)
2842 if {$vhl_done > 0} {
2847 proc delvhighlight {} {
2848 global hlview vhighlights
2850 if {![info exists hlview]} return
2852 catch {unset vhighlights}
2856 proc vhighlightmore {} {
2857 global hlview vhl_done commitidx vhighlights curview
2859 set max $commitidx($hlview)
2860 set vr [visiblerows]
2861 set r0 [lindex $vr 0]
2862 set r1 [lindex $vr 1]
2863 for {set i $vhl_done} {$i < $max} {incr i} {
2864 set id [commitonrow $i $hlview]
2865 if {[commitinview $id $curview]} {
2866 set row [rowofcommit $id]
2867 if {$r0 <= $row && $row <= $r1} {
2868 if {![highlighted $row]} {
2869 bolden $row mainfontbold
2871 set vhighlights($row) 1
2878 proc askvhighlight {row id} {
2879 global hlview vhighlights iddrawn
2881 if {[commitinview $id $hlview]} {
2882 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2883 bolden $row mainfontbold
2885 set vhighlights($row) 1
2887 set vhighlights($row) 0
2891 proc hfiles_change {} {
2892 global highlight_files filehighlight fhighlights fh_serial
2893 global highlight_paths gdttype
2895 if {[info exists filehighlight]} {
2896 # delete previous highlights
2897 catch {close $filehighlight}
2899 catch {unset fhighlights}
2901 unhighlight_filelist
2903 set highlight_paths {}
2904 after cancel do_file_hl $fh_serial
2906 if {$highlight_files ne {}} {
2907 after 300 do_file_hl $fh_serial
2911 proc gdttype_change {name ix op} {
2912 global gdttype highlight_files findstring findpattern
2915 if {$findstring ne {}} {
2916 if {$gdttype eq "containing:"} {
2917 if {$highlight_files ne {}} {
2918 set highlight_files {}
2923 if {$findpattern ne {}} {
2927 set highlight_files $findstring
2932 # enable/disable findtype/findloc menus too
2935 proc find_change {name ix op} {
2936 global gdttype findstring highlight_files
2939 if {$gdttype eq "containing:"} {
2942 if {$highlight_files ne $findstring} {
2943 set highlight_files $findstring
2950 proc findcom_change args {
2951 global nhighlights boldnamerows
2952 global findpattern findtype findstring gdttype
2955 # delete previous highlights, if any
2956 foreach row $boldnamerows {
2957 bolden_name $row mainfont
2960 catch {unset nhighlights}
2963 if {$gdttype ne "containing:" || $findstring eq {}} {
2965 } elseif {$findtype eq "Regexp"} {
2966 set findpattern $findstring
2968 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2970 set findpattern "*$e*"
2974 proc makepatterns {l} {
2977 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2978 if {[string index $ee end] eq "/"} {
2988 proc do_file_hl {serial} {
2989 global highlight_files filehighlight highlight_paths gdttype fhl_list
2991 if {$gdttype eq "touching paths:"} {
2992 if {[catch {set paths [shellsplit $highlight_files]}]} return
2993 set highlight_paths [makepatterns $paths]
2995 set gdtargs [concat -- $paths]
2996 } elseif {$gdttype eq "adding/removing string:"} {
2997 set gdtargs [list "-S$highlight_files"]
2999 # must be "containing:", i.e. we're searching commit info
3002 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3003 set filehighlight [open $cmd r+]
3004 fconfigure $filehighlight -blocking 0
3005 filerun $filehighlight readfhighlight
3011 proc flushhighlights {} {
3012 global filehighlight fhl_list
3014 if {[info exists filehighlight]} {
3016 puts $filehighlight ""
3017 flush $filehighlight
3021 proc askfilehighlight {row id} {
3022 global filehighlight fhighlights fhl_list
3024 lappend fhl_list $id
3025 set fhighlights($row) -1
3026 puts $filehighlight $id
3029 proc readfhighlight {} {
3030 global filehighlight fhighlights curview iddrawn
3031 global fhl_list find_dirn
3033 if {![info exists filehighlight]} {
3037 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3038 set line [string trim $line]
3039 set i [lsearch -exact $fhl_list $line]
3040 if {$i < 0} continue
3041 for {set j 0} {$j < $i} {incr j} {
3042 set id [lindex $fhl_list $j]
3043 if {[commitinview $id $curview]} {
3044 set fhighlights([rowofcommit $id]) 0
3047 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3048 if {$line eq {}} continue
3049 if {![commitinview $line $curview]} continue
3050 set row [rowofcommit $line]
3051 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
3052 bolden $row mainfontbold
3054 set fhighlights($row) 1
3056 if {[eof $filehighlight]} {
3058 puts "oops, git diff-tree died"
3059 catch {close $filehighlight}
3063 if {[info exists find_dirn]} {
3069 proc doesmatch {f} {
3070 global findtype findpattern
3072 if {$findtype eq "Regexp"} {
3073 return [regexp $findpattern $f]
3074 } elseif {$findtype eq "IgnCase"} {
3075 return [string match -nocase $findpattern $f]
3077 return [string match $findpattern $f]
3081 proc askfindhighlight {row id} {
3082 global nhighlights commitinfo iddrawn
3084 global markingmatches
3086 if {![info exists commitinfo($id)]} {
3089 set info $commitinfo($id)
3091 set fldtypes {Headline Author Date Committer CDate Comments}
3092 foreach f $info ty $fldtypes {
3093 if {($findloc eq "All fields" || $findloc eq $ty) &&
3095 if {$ty eq "Author"} {
3102 if {$isbold && [info exists iddrawn($id)]} {
3103 if {![ishighlighted $row]} {
3104 bolden $row mainfontbold
3106 bolden_name $row mainfontbold
3109 if {$markingmatches} {
3110 markrowmatches $row $id
3113 set nhighlights($row) $isbold
3116 proc markrowmatches {row id} {
3117 global canv canv2 linehtag linentag commitinfo findloc
3119 set headline [lindex $commitinfo($id) 0]
3120 set author [lindex $commitinfo($id) 1]
3121 $canv delete match$row
3122 $canv2 delete match$row
3123 if {$findloc eq "All fields" || $findloc eq "Headline"} {
3124 set m [findmatches $headline]
3126 markmatches $canv $row $headline $linehtag($row) $m \
3127 [$canv itemcget $linehtag($row) -font] $row
3130 if {$findloc eq "All fields" || $findloc eq "Author"} {
3131 set m [findmatches $author]
3133 markmatches $canv2 $row $author $linentag($row) $m \
3134 [$canv2 itemcget $linentag($row) -font] $row
3139 proc vrel_change {name ix op} {
3140 global highlight_related
3143 if {$highlight_related ne "None"} {
3148 # prepare for testing whether commits are descendents or ancestors of a
3149 proc rhighlight_sel {a} {
3150 global descendent desc_todo ancestor anc_todo
3151 global highlight_related rhighlights
3153 catch {unset descendent}
3154 set desc_todo [list $a]
3155 catch {unset ancestor}
3156 set anc_todo [list $a]
3157 if {$highlight_related ne "None"} {
3163 proc rhighlight_none {} {
3166 catch {unset rhighlights}
3170 proc is_descendent {a} {
3171 global curview children descendent desc_todo
3174 set la [rowofcommit $a]
3178 for {set i 0} {$i < [llength $todo]} {incr i} {
3179 set do [lindex $todo $i]
3180 if {[rowofcommit $do] < $la} {
3181 lappend leftover $do
3184 foreach nk $children($v,$do) {
3185 if {![info exists descendent($nk)]} {
3186 set descendent($nk) 1
3194 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3198 set descendent($a) 0
3199 set desc_todo $leftover
3202 proc is_ancestor {a} {
3203 global curview parents ancestor anc_todo
3206 set la [rowofcommit $a]
3210 for {set i 0} {$i < [llength $todo]} {incr i} {
3211 set do [lindex $todo $i]
3212 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3213 lappend leftover $do
3216 foreach np $parents($v,$do) {
3217 if {![info exists ancestor($np)]} {
3226 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3231 set anc_todo $leftover
3234 proc askrelhighlight {row id} {
3235 global descendent highlight_related iddrawn rhighlights
3236 global selectedline ancestor
3238 if {![info exists selectedline]} return
3240 if {$highlight_related eq "Descendent" ||
3241 $highlight_related eq "Not descendent"} {
3242 if {![info exists descendent($id)]} {
3245 if {$descendent($id) == ($highlight_related eq "Descendent")} {
3248 } elseif {$highlight_related eq "Ancestor" ||
3249 $highlight_related eq "Not ancestor"} {
3250 if {![info exists ancestor($id)]} {
3253 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
3257 if {[info exists iddrawn($id)]} {
3258 if {$isbold && ![ishighlighted $row]} {
3259 bolden $row mainfontbold
3262 set rhighlights($row) $isbold
3265 # Graph layout functions
3267 proc shortids {ids} {
3270 if {[llength $id] > 1} {
3271 lappend res [shortids $id]
3272 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3273 lappend res [string range $id 0 7]
3284 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3285 if {($n & $mask) != 0} {
3286 set ret [concat $ret $o]
3288 set o [concat $o $o]
3293 proc ordertoken {id} {
3294 global ordertok curview varcid varcstart varctok curview parents children
3295 global nullid nullid2
3297 if {[info exists ordertok($id)]} {
3298 return $ordertok($id)
3303 if {[info exists varcid($curview,$id)]} {
3304 set a $varcid($curview,$id)
3305 set p [lindex $varcstart($curview) $a]
3307 set p [lindex $children($curview,$id) 0]
3309 if {[info exists ordertok($p)]} {
3310 set tok $ordertok($p)
3313 if {[llength $children($curview,$p)] == 0} {
3315 set tok [lindex $varctok($curview) $a]
3318 set id [lindex $children($curview,$p) 0]
3319 if {$id eq $nullid || $id eq $nullid2} {
3320 # XXX treat it as a root
3321 set tok [lindex $varctok($curview) $a]
3324 if {[llength $parents($curview,$id)] == 1} {
3325 lappend todo [list $p {}]
3327 set j [lsearch -exact $parents($curview,$id) $p]
3329 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3331 lappend todo [list $p [strrep $j]]
3334 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3335 set p [lindex $todo $i 0]
3336 append tok [lindex $todo $i 1]
3337 set ordertok($p) $tok
3339 set ordertok($origid) $tok
3343 # Work out where id should go in idlist so that order-token
3344 # values increase from left to right
3345 proc idcol {idlist id {i 0}} {
3346 set t [ordertoken $id]
3350 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3351 if {$i > [llength $idlist]} {
3352 set i [llength $idlist]
3354 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3357 if {$t > [ordertoken [lindex $idlist $i]]} {
3358 while {[incr i] < [llength $idlist] &&
3359 $t >= [ordertoken [lindex $idlist $i]]} {}
3365 proc initlayout {} {
3366 global rowidlist rowisopt rowfinal displayorder parentlist
3367 global numcommits canvxmax canv
3369 global colormap rowtextx
3379 set canvxmax [$canv cget -width]
3380 catch {unset colormap}
3381 catch {unset rowtextx}
3385 proc setcanvscroll {} {
3386 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3388 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3389 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3390 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3391 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3394 proc visiblerows {} {
3395 global canv numcommits linespc
3397 set ymax [lindex [$canv cget -scrollregion] 3]
3398 if {$ymax eq {} || $ymax == 0} return
3400 set y0 [expr {int([lindex $f 0] * $ymax)}]
3401 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3405 set y1 [expr {int([lindex $f 1] * $ymax)}]
3406 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3407 if {$r1 >= $numcommits} {
3408 set r1 [expr {$numcommits - 1}]
3410 return [list $r0 $r1]
3413 proc layoutmore {} {
3414 global commitidx viewcomplete curview
3415 global numcommits pending_select selectedline curview
3416 global selectfirst lastscrollset commitinterest
3418 set canshow $commitidx($curview)
3419 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3420 if {$numcommits == 0} {
3424 set prev $numcommits
3425 set numcommits $canshow
3426 set t [clock clicks -milliseconds]
3427 if {$prev < 100 || $viewcomplete($curview) || $t - $lastscrollset > 500} {
3428 set lastscrollset $t
3431 set rows [visiblerows]
3432 set r1 [lindex $rows 1]
3433 if {$r1 >= $canshow} {
3434 set r1 [expr {$canshow - 1}]
3439 if {[info exists pending_select] &&
3440 [commitinview $pending_select $curview]} {
3441 selectline [rowofcommit $pending_select] 1
3444 if {[info exists selectedline] || [info exists pending_select]} {
3447 set l [first_real_row]
3454 proc doshowlocalchanges {} {
3455 global curview mainheadid
3457 if {[commitinview $mainheadid $curview]} {
3460 lappend commitinterest($mainheadid) {dodiffindex}
3464 proc dohidelocalchanges {} {
3465 global nullid nullid2 lserial curview
3467 if {[commitinview $nullid $curview]} {
3468 removerow $nullid $curview
3470 if {[commitinview $nullid2 $curview]} {
3471 removerow $nullid2 $curview
3476 # spawn off a process to do git diff-index --cached HEAD
3477 proc dodiffindex {} {
3478 global lserial showlocalchanges
3480 if {!$showlocalchanges} return
3482 set fd [open "|git diff-index --cached HEAD" r]
3483 fconfigure $fd -blocking 0
3484 filerun $fd [list readdiffindex $fd $lserial]
3487 proc readdiffindex {fd serial} {
3488 global mainheadid nullid2 curview commitinfo commitdata lserial
3491 if {[gets $fd line] < 0} {
3497 # we only need to see one line and we don't really care what it says...
3500 if {$serial != $lserial} {
3504 # now see if there are any local changes not checked in to the index
3505 set fd [open "|git diff-files" r]
3506 fconfigure $fd -blocking 0
3507 filerun $fd [list readdifffiles $fd $serial]
3509 if {$isdiff && ![commitinview $nullid2 $curview]} {
3510 # add the line for the changes in the index to the graph
3511 set hl "Local changes checked in to index but not committed"
3512 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3513 set commitdata($nullid2) "\n $hl\n"
3514 insertrow $nullid2 $mainheadid $curview
3515 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
3516 removerow $nullid2 $curview
3521 proc readdifffiles {fd serial} {
3522 global mainheadid nullid nullid2 curview
3523 global commitinfo commitdata lserial
3526 if {[gets $fd line] < 0} {
3532 # we only need to see one line and we don't really care what it says...
3535 if {$serial != $lserial} {
3539 if {$isdiff && ![commitinview $nullid $curview]} {
3540 # add the line for the local diff to the graph
3541 set hl "Local uncommitted changes, not checked in to index"
3542 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3543 set commitdata($nullid) "\n $hl\n"
3544 if {[commitinview $nullid2 $curview]} {
3549 insertrow $nullid $p $curview
3550 } elseif {!$isdiff && [commitinview $nullid $curview]} {
3551 removerow $nullid $curview
3556 proc nextuse {id row} {
3557 global curview children
3559 if {[info exists children($curview,$id)]} {
3560 foreach kid $children($curview,$id) {
3561 if {![commitinview $kid $curview]} {
3564 if {[rowofcommit $kid] > $row} {
3565 return [rowofcommit $kid]
3569 if {[commitinview $id $curview]} {
3570 return [rowofcommit $id]
3575 proc prevuse {id row} {
3576 global curview children
3579 if {[info exists children($curview,$id)]} {
3580 foreach kid $children($curview,$id) {
3581 if {![commitinview $kid $curview]} break
3582 if {[rowofcommit $kid] < $row} {
3583 set ret [rowofcommit $kid]
3590 proc make_idlist {row} {
3591 global displayorder parentlist uparrowlen downarrowlen mingaplen
3592 global commitidx curview children
3594 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3598 set ra [expr {$row - $downarrowlen}]
3602 set rb [expr {$row + $uparrowlen}]
3603 if {$rb > $commitidx($curview)} {
3604 set rb $commitidx($curview)
3606 make_disporder $r [expr {$rb + 1}]
3608 for {} {$r < $ra} {incr r} {
3609 set nextid [lindex $displayorder [expr {$r + 1}]]
3610 foreach p [lindex $parentlist $r] {
3611 if {$p eq $nextid} continue
3612 set rn [nextuse $p $r]
3614 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3615 lappend ids [list [ordertoken $p] $p]
3619 for {} {$r < $row} {incr r} {
3620 set nextid [lindex $displayorder [expr {$r + 1}]]
3621 foreach p [lindex $parentlist $r] {
3622 if {$p eq $nextid} continue
3623 set rn [nextuse $p $r]
3624 if {$rn < 0 || $rn >= $row} {
3625 lappend ids [list [ordertoken $p] $p]
3629 set id [lindex $displayorder $row]
3630 lappend ids [list [ordertoken $id] $id]
3632 foreach p [lindex $parentlist $r] {
3633 set firstkid [lindex $children($curview,$p) 0]
3634 if {[rowofcommit $firstkid] < $row} {
3635 lappend ids [list [ordertoken $p] $p]
3639 set id [lindex $displayorder $r]
3641 set firstkid [lindex $children($curview,$id) 0]
3642 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3643 lappend ids [list [ordertoken $id] $id]
3648 foreach idx [lsort -unique $ids] {
3649 lappend idlist [lindex $idx 1]
3654 proc rowsequal {a b} {
3655 while {[set i [lsearch -exact $a {}]] >= 0} {
3656 set a [lreplace $a $i $i]
3658 while {[set i [lsearch -exact $b {}]] >= 0} {
3659 set b [lreplace $b $i $i]
3661 return [expr {$a eq $b}]
3664 proc makeupline {id row rend col} {
3665 global rowidlist uparrowlen downarrowlen mingaplen
3667 for {set r $rend} {1} {set r $rstart} {
3668 set rstart [prevuse $id $r]
3669 if {$rstart < 0} return
3670 if {$rstart < $row} break
3672 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3673 set rstart [expr {$rend - $uparrowlen - 1}]
3675 for {set r $rstart} {[incr r] <= $row} {} {
3676 set idlist [lindex $rowidlist $r]
3677 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3678 set col [idcol $idlist $id $col]
3679 lset rowidlist $r [linsert $idlist $col $id]
3685 proc layoutrows {row endrow} {
3686 global rowidlist rowisopt rowfinal displayorder
3687 global uparrowlen downarrowlen maxwidth mingaplen
3688 global children parentlist
3689 global commitidx viewcomplete curview
3691 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3694 set rm1 [expr {$row - 1}]
3695 foreach id [lindex $rowidlist $rm1] {
3700 set final [lindex $rowfinal $rm1]
3702 for {} {$row < $endrow} {incr row} {
3703 set rm1 [expr {$row - 1}]
3704 if {$rm1 < 0 || $idlist eq {}} {
3705 set idlist [make_idlist $row]
3708 set id [lindex $displayorder $rm1]
3709 set col [lsearch -exact $idlist $id]
3710 set idlist [lreplace $idlist $col $col]
3711 foreach p [lindex $parentlist $rm1] {
3712 if {[lsearch -exact $idlist $p] < 0} {
3713 set col [idcol $idlist $p $col]
3714 set idlist [linsert $idlist $col $p]
3715 # if not the first child, we have to insert a line going up
3716 if {$id ne [lindex $children($curview,$p) 0]} {
3717 makeupline $p $rm1 $row $col
3721 set id [lindex $displayorder $row]
3722 if {$row > $downarrowlen} {
3723 set termrow [expr {$row - $downarrowlen - 1}]
3724 foreach p [lindex $parentlist $termrow] {
3725 set i [lsearch -exact $idlist $p]
3726 if {$i < 0} continue
3727 set nr [nextuse $p $termrow]
3728 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3729 set idlist [lreplace $idlist $i $i]
3733 set col [lsearch -exact $idlist $id]
3735 set col [idcol $idlist $id]
3736 set idlist [linsert $idlist $col $id]
3737 if {$children($curview,$id) ne {}} {
3738 makeupline $id $rm1 $row $col
3741 set r [expr {$row + $uparrowlen - 1}]
3742 if {$r < $commitidx($curview)} {
3744 foreach p [lindex $parentlist $r] {
3745 if {[lsearch -exact $idlist $p] >= 0} continue
3746 set fk [lindex $children($curview,$p) 0]
3747 if {[rowofcommit $fk] < $row} {
3748 set x [idcol $idlist $p $x]
3749 set idlist [linsert $idlist $x $p]
3752 if {[incr r] < $commitidx($curview)} {
3753 set p [lindex $displayorder $r]
3754 if {[lsearch -exact $idlist $p] < 0} {
3755 set fk [lindex $children($curview,$p) 0]
3756 if {$fk ne {} && [rowofcommit $fk] < $row} {
3757 set x [idcol $idlist $p $x]
3758 set idlist [linsert $idlist $x $p]
3764 if {$final && !$viewcomplete($curview) &&
3765 $row + $uparrowlen + $mingaplen + $downarrowlen
3766 >= $commitidx($curview)} {
3769 set l [llength $rowidlist]
3771 lappend rowidlist $idlist
3773 lappend rowfinal $final
3774 } elseif {$row < $l} {
3775 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3776 lset rowidlist $row $idlist
3779 lset rowfinal $row $final
3781 set pad [ntimes [expr {$row - $l}] {}]
3782 set rowidlist [concat $rowidlist $pad]
3783 lappend rowidlist $idlist
3784 set rowfinal [concat $rowfinal $pad]
3785 lappend rowfinal $final
3786 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3792 proc changedrow {row} {
3793 global displayorder iddrawn rowisopt need_redisplay
3795 set l [llength $rowisopt]
3797 lset rowisopt $row 0
3798 if {$row + 1 < $l} {
3799 lset rowisopt [expr {$row + 1}] 0
3800 if {$row + 2 < $l} {
3801 lset rowisopt [expr {$row + 2}] 0
3805 set id [lindex $displayorder $row]
3806 if {[info exists iddrawn($id)]} {
3807 set need_redisplay 1
3811 proc insert_pad {row col npad} {
3814 set pad [ntimes $npad {}]
3815 set idlist [lindex $rowidlist $row]
3816 set bef [lrange $idlist 0 [expr {$col - 1}]]
3817 set aft [lrange $idlist $col end]
3818 set i [lsearch -exact $aft {}]
3820 set aft [lreplace $aft $i $i]
3822 lset rowidlist $row [concat $bef $pad $aft]
3826 proc optimize_rows {row col endrow} {
3827 global rowidlist rowisopt displayorder curview children
3832 for {} {$row < $endrow} {incr row; set col 0} {
3833 if {[lindex $rowisopt $row]} continue
3835 set y0 [expr {$row - 1}]
3836 set ym [expr {$row - 2}]
3837 set idlist [lindex $rowidlist $row]
3838 set previdlist [lindex $rowidlist $y0]
3839 if {$idlist eq {} || $previdlist eq {}} continue
3841 set pprevidlist [lindex $rowidlist $ym]
3842 if {$pprevidlist eq {}} continue
3848 for {} {$col < [llength $idlist]} {incr col} {
3849 set id [lindex $idlist $col]
3850 if {[lindex $previdlist $col] eq $id} continue
3855 set x0 [lsearch -exact $previdlist $id]
3856 if {$x0 < 0} continue
3857 set z [expr {$x0 - $col}]
3861 set xm [lsearch -exact $pprevidlist $id]
3863 set z0 [expr {$xm - $x0}]
3867 # if row y0 is the first child of $id then it's not an arrow
3868 if {[lindex $children($curview,$id) 0] ne
3869 [lindex $displayorder $y0]} {
3873 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3874 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3877 # Looking at lines from this row to the previous row,
3878 # make them go straight up if they end in an arrow on
3879 # the previous row; otherwise make them go straight up
3881 if {$z < -1 || ($z < 0 && $isarrow)} {
3882 # Line currently goes left too much;
3883 # insert pads in the previous row, then optimize it
3884 set npad [expr {-1 - $z + $isarrow}]
3885 insert_pad $y0 $x0 $npad
3887 optimize_rows $y0 $x0 $row
3889 set previdlist [lindex $rowidlist $y0]
3890 set x0 [lsearch -exact $previdlist $id]
3891 set z [expr {$x0 - $col}]
3893 set pprevidlist [lindex $rowidlist $ym]
3894 set xm [lsearch -exact $pprevidlist $id]
3895 set z0 [expr {$xm - $x0}]
3897 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3898 # Line currently goes right too much;
3899 # insert pads in this line
3900 set npad [expr {$z - 1 + $isarrow}]
3901 insert_pad $row $col $npad
3902 set idlist [lindex $rowidlist $row]
3904 set z [expr {$x0 - $col}]
3907 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3908 # this line links to its first child on row $row-2
3909 set id [lindex $displayorder $ym]
3910 set xc [lsearch -exact $pprevidlist $id]
3912 set z0 [expr {$xc - $x0}]
3915 # avoid lines jigging left then immediately right
3916 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3917 insert_pad $y0 $x0 1
3919 optimize_rows $y0 $x0 $row
3920 set previdlist [lindex $rowidlist $y0]
3924 # Find the first column that doesn't have a line going right
3925 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3926 set id [lindex $idlist $col]
3927 if {$id eq {}} break
3928 set x0 [lsearch -exact $previdlist $id]
3930 # check if this is the link to the first child
3931 set kid [lindex $displayorder $y0]
3932 if {[lindex $children($curview,$id) 0] eq $kid} {
3933 # it is, work out offset to child
3934 set x0 [lsearch -exact $previdlist $kid]
3937 if {$x0 <= $col} break
3939 # Insert a pad at that column as long as it has a line and
3940 # isn't the last column
3941 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3942 set idlist [linsert $idlist $col {}]
3943 lset rowidlist $row $idlist
3951 global canvx0 linespc
3952 return [expr {$canvx0 + $col * $linespc}]
3956 global canvy0 linespc
3957 return [expr {$canvy0 + $row * $linespc}]
3960 proc linewidth {id} {
3961 global thickerline lthickness
3964 if {[info exists thickerline] && $id eq $thickerline} {
3965 set wid [expr {2 * $lthickness}]
3970 proc rowranges {id} {
3971 global curview children uparrowlen downarrowlen
3974 set kids $children($curview,$id)
3980 foreach child $kids {
3981 if {![commitinview $child $curview]} break
3982 set row [rowofcommit $child]
3983 if {![info exists prev]} {
3984 lappend ret [expr {$row + 1}]
3986 if {$row <= $prevrow} {
3987 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
3989 # see if the line extends the whole way from prevrow to row
3990 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3991 [lsearch -exact [lindex $rowidlist \
3992 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3993 # it doesn't, see where it ends
3994 set r [expr {$prevrow + $downarrowlen}]
3995 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3996 while {[incr r -1] > $prevrow &&
3997 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3999 while {[incr r] <= $row &&
4000 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4004 # see where it starts up again
4005 set r [expr {$row - $uparrowlen}]
4006 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4007 while {[incr r] < $row &&
4008 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4010 while {[incr r -1] >= $prevrow &&
4011 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4017 if {$child eq $id} {
4026 proc drawlineseg {id row endrow arrowlow} {
4027 global rowidlist displayorder iddrawn linesegs
4028 global canv colormap linespc curview maxlinelen parentlist
4030 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4031 set le [expr {$row + 1}]
4034 set c [lsearch -exact [lindex $rowidlist $le] $id]
4040 set x [lindex $displayorder $le]
4045 if {[info exists iddrawn($x)] || $le == $endrow} {
4046 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4062 if {[info exists linesegs($id)]} {
4063 set lines $linesegs($id)
4065 set r0 [lindex $li 0]
4067 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4077 set li [lindex $lines [expr {$i-1}]]
4078 set r1 [lindex $li 1]
4079 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4084 set x [lindex $cols [expr {$le - $row}]]
4085 set xp [lindex $cols [expr {$le - 1 - $row}]]
4086 set dir [expr {$xp - $x}]
4088 set ith [lindex $lines $i 2]
4089 set coords [$canv coords $ith]
4090 set ah [$canv itemcget $ith -arrow]
4091 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4092 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4093 if {$x2 ne {} && $x - $x2 == $dir} {
4094 set coords [lrange $coords 0 end-2]
4097 set coords [list [xc $le $x] [yc $le]]
4100 set itl [lindex $lines [expr {$i-1}] 2]
4101 set al [$canv itemcget $itl -arrow]
4102 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4103 } elseif {$arrowlow} {
4104 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4105 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4109 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4110 for {set y $le} {[incr y -1] > $row} {} {
4112 set xp [lindex $cols [expr {$y - 1 - $row}]]
4113 set ndir [expr {$xp - $x}]
4114 if {$dir != $ndir || $xp < 0} {
4115 lappend coords [xc $y $x] [yc $y]
4121 # join parent line to first child
4122 set ch [lindex $displayorder $row]
4123 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4125 puts "oops: drawlineseg: child $ch not on row $row"
4126 } elseif {$xc != $x} {
4127 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4128 set d [expr {int(0.5 * $linespc)}]
4131 set x2 [expr {$x1 - $d}]
4133 set x2 [expr {$x1 + $d}]
4136 set y1 [expr {$y2 + $d}]
4137 lappend coords $x1 $y1 $x2 $y2
4138 } elseif {$xc < $x - 1} {
4139 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4140 } elseif {$xc > $x + 1} {
4141 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4145 lappend coords [xc $row $x] [yc $row]
4147 set xn [xc $row $xp]
4149 lappend coords $xn $yn
4153 set t [$canv create line $coords -width [linewidth $id] \
4154 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4157 set lines [linsert $lines $i [list $row $le $t]]
4159 $canv coords $ith $coords
4160 if {$arrow ne $ah} {
4161 $canv itemconf $ith -arrow $arrow
4163 lset lines $i 0 $row
4166 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4167 set ndir [expr {$xo - $xp}]
4168 set clow [$canv coords $itl]
4169 if {$dir == $ndir} {
4170 set clow [lrange $clow 2 end]
4172 set coords [concat $coords $clow]
4174 lset lines [expr {$i-1}] 1 $le
4176 # coalesce two pieces
4178 set b [lindex $lines [expr {$i-1}] 0]
4179 set e [lindex $lines $i 1]
4180 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4182 $canv coords $itl $coords
4183 if {$arrow ne $al} {
4184 $canv itemconf $itl -arrow $arrow
4188 set linesegs($id) $lines
4192 proc drawparentlinks {id row} {
4193 global rowidlist canv colormap curview parentlist
4194 global idpos linespc
4196 set rowids [lindex $rowidlist $row]
4197 set col [lsearch -exact $rowids $id]
4198 if {$col < 0} return
4199 set olds [lindex $parentlist $row]
4200 set row2 [expr {$row + 1}]
4201 set x [xc $row $col]
4204 set d [expr {int(0.5 * $linespc)}]
4205 set ymid [expr {$y + $d}]
4206 set ids [lindex $rowidlist $row2]
4207 # rmx = right-most X coord used
4210 set i [lsearch -exact $ids $p]
4212 puts "oops, parent $p of $id not in list"
4215 set x2 [xc $row2 $i]
4219 set j [lsearch -exact $rowids $p]
4221 # drawlineseg will do this one for us
4225 # should handle duplicated parents here...
4226 set coords [list $x $y]
4228 # if attaching to a vertical segment, draw a smaller
4229 # slant for visual distinctness
4232 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4234 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4236 } elseif {$i < $col && $i < $j} {
4237 # segment slants towards us already
4238 lappend coords [xc $row $j] $y
4240 if {$i < $col - 1} {
4241 lappend coords [expr {$x2 + $linespc}] $y
4242 } elseif {$i > $col + 1} {
4243 lappend coords [expr {$x2 - $linespc}] $y
4245 lappend coords $x2 $y2
4248 lappend coords $x2 $y2
4250 set t [$canv create line $coords -width [linewidth $p] \
4251 -fill $colormap($p) -tags lines.$p]
4255 if {$rmx > [lindex $idpos($id) 1]} {
4256 lset idpos($id) 1 $rmx
4261 proc drawlines {id} {
4264 $canv itemconf lines.$id -width [linewidth $id]
4267 proc drawcmittext {id row col} {
4268 global linespc canv canv2 canv3 fgcolor curview
4269 global cmitlisted commitinfo rowidlist parentlist
4270 global rowtextx idpos idtags idheads idotherrefs
4271 global linehtag linentag linedtag selectedline
4272 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4274 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4275 set listed $cmitlisted($curview,$id)
4276 if {$id eq $nullid} {
4278 } elseif {$id eq $nullid2} {
4281 set ofill [expr {$listed != 0? "blue": "white"}]
4283 set x [xc $row $col]
4285 set orad [expr {$linespc / 3}]
4287 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4288 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4289 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4290 } elseif {$listed == 2} {
4291 # triangle pointing left for left-side commits
4292 set t [$canv create polygon \
4293 [expr {$x - $orad}] $y \
4294 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4295 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4296 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4298 # triangle pointing right for right-side commits
4299 set t [$canv create polygon \
4300 [expr {$x + $orad - 1}] $y \
4301 [expr {$x - $orad}] [expr {$y - $orad}] \
4302 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4303 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4306 $canv bind $t <1> {selcanvline {} %x %y}
4307 set rmx [llength [lindex $rowidlist $row]]
4308 set olds [lindex $parentlist $row]
4310 set nextids [lindex $rowidlist [expr {$row + 1}]]
4312 set i [lsearch -exact $nextids $p]
4318 set xt [xc $row $rmx]
4319 set rowtextx($row) $xt
4320 set idpos($id) [list $x $xt $y]
4321 if {[info exists idtags($id)] || [info exists idheads($id)]
4322 || [info exists idotherrefs($id)]} {
4323 set xt [drawtags $id $x $xt $y]
4325 set headline [lindex $commitinfo($id) 0]
4326 set name [lindex $commitinfo($id) 1]
4327 set date [lindex $commitinfo($id) 2]
4328 set date [formatdate $date]
4331 set isbold [ishighlighted $row]
4333 lappend boldrows $row
4334 set font mainfontbold
4336 lappend boldnamerows $row
4337 set nfont mainfontbold
4340 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4341 -text $headline -font $font -tags text]
4342 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4343 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4344 -text $name -font $nfont -tags text]
4345 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4346 -text $date -font mainfont -tags text]
4347 if {[info exists selectedline] && $selectedline == $row} {
4350 set xr [expr {$xt + [font measure $font $headline]}]
4351 if {$xr > $canvxmax} {
4357 proc drawcmitrow {row} {
4358 global displayorder rowidlist nrows_drawn
4359 global iddrawn markingmatches
4360 global commitinfo numcommits
4361 global filehighlight fhighlights findpattern nhighlights
4362 global hlview vhighlights
4363 global highlight_related rhighlights
4365 if {$row >= $numcommits} return
4367 set id [lindex $displayorder $row]
4368 if {[info exists hlview] && ![info exists vhighlights($row)]} {
4369 askvhighlight $row $id
4371 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
4372 askfilehighlight $row $id
4374 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
4375 askfindhighlight $row $id
4377 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
4378 askrelhighlight $row $id
4380 if {![info exists iddrawn($id)]} {
4381 set col [lsearch -exact [lindex $rowidlist $row] $id]
4383 puts "oops, row $row id $id not in list"
4386 if {![info exists commitinfo($id)]} {
4390 drawcmittext $id $row $col
4394 if {$markingmatches} {
4395 markrowmatches $row $id
4399 proc drawcommits {row {endrow {}}} {
4400 global numcommits iddrawn displayorder curview need_redisplay
4401 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4406 if {$endrow eq {}} {
4409 if {$endrow >= $numcommits} {
4410 set endrow [expr {$numcommits - 1}]
4413 set rl1 [expr {$row - $downarrowlen - 3}]
4417 set ro1 [expr {$row - 3}]
4421 set r2 [expr {$endrow + $uparrowlen + 3}]
4422 if {$r2 > $numcommits} {
4425 for {set r $rl1} {$r < $r2} {incr r} {
4426 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4430 set rl1 [expr {$r + 1}]
4436 optimize_rows $ro1 0 $r2
4437 if {$need_redisplay || $nrows_drawn > 2000} {
4442 # make the lines join to already-drawn rows either side
4443 set r [expr {$row - 1}]
4444 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4447 set er [expr {$endrow + 1}]
4448 if {$er >= $numcommits ||
4449 ![info exists iddrawn([lindex $displayorder $er])]} {
4452 for {} {$r <= $er} {incr r} {
4453 set id [lindex $displayorder $r]
4454 set wasdrawn [info exists iddrawn($id)]
4456 if {$r == $er} break
4457 set nextid [lindex $displayorder [expr {$r + 1}]]
4458 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4459 drawparentlinks $id $r
4461 set rowids [lindex $rowidlist $r]
4462 foreach lid $rowids {
4463 if {$lid eq {}} continue
4464 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4466 # see if this is the first child of any of its parents
4467 foreach p [lindex $parentlist $r] {
4468 if {[lsearch -exact $rowids $p] < 0} {
4469 # make this line extend up to the child
4470 set lineend($p) [drawlineseg $p $r $er 0]
4474 set lineend($lid) [drawlineseg $lid $r $er 1]
4480 proc undolayout {row} {
4481 global uparrowlen mingaplen downarrowlen
4482 global rowidlist rowisopt rowfinal need_redisplay
4484 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4488 if {[llength $rowidlist] > $r} {
4490 set rowidlist [lrange $rowidlist 0 $r]
4491 set rowfinal [lrange $rowfinal 0 $r]
4492 set rowisopt [lrange $rowisopt 0 $r]
4493 set need_redisplay 1
4498 proc drawfrac {f0 f1} {
4501 set ymax [lindex [$canv cget -scrollregion] 3]
4502 if {$ymax eq {} || $ymax == 0} return
4503 set y0 [expr {int($f0 * $ymax)}]
4504 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4505 set y1 [expr {int($f1 * $ymax)}]
4506 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4507 drawcommits $row $endrow
4510 proc drawvisible {} {
4512 eval drawfrac [$canv yview]
4515 proc clear_display {} {
4516 global iddrawn linesegs need_redisplay nrows_drawn
4517 global vhighlights fhighlights nhighlights rhighlights
4520 catch {unset iddrawn}
4521 catch {unset linesegs}
4522 catch {unset vhighlights}
4523 catch {unset fhighlights}
4524 catch {unset nhighlights}
4525 catch {unset rhighlights}
4526 set need_redisplay 0
4530 proc findcrossings {id} {
4531 global rowidlist parentlist numcommits displayorder
4535 foreach {s e} [rowranges $id] {
4536 if {$e >= $numcommits} {
4537 set e [expr {$numcommits - 1}]
4539 if {$e <= $s} continue
4540 for {set row $e} {[incr row -1] >= $s} {} {
4541 set x [lsearch -exact [lindex $rowidlist $row] $id]
4543 set olds [lindex $parentlist $row]
4544 set kid [lindex $displayorder $row]
4545 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4546 if {$kidx < 0} continue
4547 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4549 set px [lsearch -exact $nextrow $p]
4550 if {$px < 0} continue
4551 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4552 if {[lsearch -exact $ccross $p] >= 0} continue
4553 if {$x == $px + ($kidx < $px? -1: 1)} {
4555 } elseif {[lsearch -exact $cross $p] < 0} {
4562 return [concat $ccross {{}} $cross]
4565 proc assigncolor {id} {
4566 global colormap colors nextcolor
4567 global parents children children curview
4569 if {[info exists colormap($id)]} return
4570 set ncolors [llength $colors]
4571 if {[info exists children($curview,$id)]} {
4572 set kids $children($curview,$id)
4576 if {[llength $kids] == 1} {
4577 set child [lindex $kids 0]
4578 if {[info exists colormap($child)]
4579 && [llength $parents($curview,$child)] == 1} {
4580 set colormap($id) $colormap($child)
4586 foreach x [findcrossings $id] {
4588 # delimiter between corner crossings and other crossings
4589 if {[llength $badcolors] >= $ncolors - 1} break
4590 set origbad $badcolors
4592 if {[info exists colormap($x)]
4593 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4594 lappend badcolors $colormap($x)
4597 if {[llength $badcolors] >= $ncolors} {
4598 set badcolors $origbad
4600 set origbad $badcolors
4601 if {[llength $badcolors] < $ncolors - 1} {
4602 foreach child $kids {
4603 if {[info exists colormap($child)]
4604 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4605 lappend badcolors $colormap($child)
4607 foreach p $parents($curview,$child) {
4608 if {[info exists colormap($p)]
4609 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4610 lappend badcolors $colormap($p)
4614 if {[llength $badcolors] >= $ncolors} {
4615 set badcolors $origbad
4618 for {set i 0} {$i <= $ncolors} {incr i} {
4619 set c [lindex $colors $nextcolor]
4620 if {[incr nextcolor] >= $ncolors} {
4623 if {[lsearch -exact $badcolors $c]} break
4625 set colormap($id) $c
4628 proc bindline {t id} {
4631 $canv bind $t <Enter> "lineenter %x %y $id"
4632 $canv bind $t <Motion> "linemotion %x %y $id"
4633 $canv bind $t <Leave> "lineleave $id"
4634 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4637 proc drawtags {id x xt y1} {
4638 global idtags idheads idotherrefs mainhead
4639 global linespc lthickness
4640 global canv rowtextx curview fgcolor bgcolor
4645 if {[info exists idtags($id)]} {
4646 set marks $idtags($id)
4647 set ntags [llength $marks]
4649 if {[info exists idheads($id)]} {
4650 set marks [concat $marks $idheads($id)]
4651 set nheads [llength $idheads($id)]
4653 if {[info exists idotherrefs($id)]} {
4654 set marks [concat $marks $idotherrefs($id)]
4660 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4661 set yt [expr {$y1 - 0.5 * $linespc}]
4662 set yb [expr {$yt + $linespc - 1}]
4666 foreach tag $marks {
4668 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4669 set wid [font measure mainfontbold $tag]
4671 set wid [font measure mainfont $tag]
4675 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4677 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4678 -width $lthickness -fill black -tags tag.$id]
4680 foreach tag $marks x $xvals wid $wvals {
4681 set xl [expr {$x + $delta}]
4682 set xr [expr {$x + $delta + $wid + $lthickness}]
4684 if {[incr ntags -1] >= 0} {
4686 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4687 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4688 -width 1 -outline black -fill yellow -tags tag.$id]
4689 $canv bind $t <1> [list showtag $tag 1]
4690 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4692 # draw a head or other ref
4693 if {[incr nheads -1] >= 0} {
4695 if {$tag eq $mainhead} {
4696 set font mainfontbold
4701 set xl [expr {$xl - $delta/2}]
4702 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4703 -width 1 -outline black -fill $col -tags tag.$id
4704 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4705 set rwid [font measure mainfont $remoteprefix]
4706 set xi [expr {$x + 1}]
4707 set yti [expr {$yt + 1}]
4708 set xri [expr {$x + $rwid}]
4709 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4710 -width 0 -fill "#ffddaa" -tags tag.$id
4713 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4714 -font $font -tags [list tag.$id text]]
4716 $canv bind $t <1> [list showtag $tag 1]
4717 } elseif {$nheads >= 0} {
4718 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4724 proc xcoord {i level ln} {
4725 global canvx0 xspc1 xspc2
4727 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4728 if {$i > 0 && $i == $level} {
4729 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4730 } elseif {$i > $level} {
4731 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4736 proc show_status {msg} {
4740 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4741 -tags text -fill $fgcolor
4744 # Don't change the text pane cursor if it is currently the hand cursor,
4745 # showing that we are over a sha1 ID link.
4746 proc settextcursor {c} {
4747 global ctext curtextcursor
4749 if {[$ctext cget -cursor] == $curtextcursor} {
4750 $ctext config -cursor $c
4752 set curtextcursor $c
4755 proc nowbusy {what {name {}}} {
4756 global isbusy busyname statusw
4758 if {[array names isbusy] eq {}} {
4759 . config -cursor watch
4763 set busyname($what) $name
4765 $statusw conf -text $name
4769 proc notbusy {what} {
4770 global isbusy maincursor textcursor busyname statusw
4774 if {$busyname($what) ne {} &&
4775 [$statusw cget -text] eq $busyname($what)} {
4776 $statusw conf -text {}
4779 if {[array names isbusy] eq {}} {
4780 . config -cursor $maincursor
4781 settextcursor $textcursor
4785 proc findmatches {f} {
4786 global findtype findstring
4787 if {$findtype == "Regexp"} {
4788 set matches [regexp -indices -all -inline $findstring $f]
4791 if {$findtype == "IgnCase"} {
4792 set f [string tolower $f]
4793 set fs [string tolower $fs]
4797 set l [string length $fs]
4798 while {[set j [string first $fs $f $i]] >= 0} {
4799 lappend matches [list $j [expr {$j+$l-1}]]
4800 set i [expr {$j + $l}]
4806 proc dofind {{dirn 1} {wrap 1}} {
4807 global findstring findstartline findcurline selectedline numcommits
4808 global gdttype filehighlight fh_serial find_dirn findallowwrap
4810 if {[info exists find_dirn]} {
4811 if {$find_dirn == $dirn} return
4815 if {$findstring eq {} || $numcommits == 0} return
4816 if {![info exists selectedline]} {
4817 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4819 set findstartline $selectedline
4821 set findcurline $findstartline
4822 nowbusy finding "Searching"
4823 if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4824 after cancel do_file_hl $fh_serial
4825 do_file_hl $fh_serial
4828 set findallowwrap $wrap
4832 proc stopfinding {} {
4833 global find_dirn findcurline fprogcoord
4835 if {[info exists find_dirn]} {
4845 global commitdata commitinfo numcommits findpattern findloc
4846 global findstartline findcurline findallowwrap
4847 global find_dirn gdttype fhighlights fprogcoord
4848 global curview varcorder vrownum varccommits
4850 if {![info exists find_dirn]} {
4853 set fldtypes {Headline Author Date Committer CDate Comments}
4856 if {$find_dirn > 0} {
4858 if {$l >= $numcommits} {
4861 if {$l <= $findstartline} {
4862 set lim [expr {$findstartline + 1}]
4865 set moretodo $findallowwrap
4872 if {$l >= $findstartline} {
4873 set lim [expr {$findstartline - 1}]
4876 set moretodo $findallowwrap
4879 set n [expr {($lim - $l) * $find_dirn}]
4886 set ai [bsearch $vrownum($curview) $l]
4887 set a [lindex $varcorder($curview) $ai]
4888 set arow [lindex $vrownum($curview) $ai]
4889 set ids [lindex $varccommits($curview,$a)]
4890 set arowend [expr {$arow + [llength $ids]}]
4891 if {$gdttype eq "containing:"} {
4892 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4893 if {$l < $arow || $l >= $arowend} {
4895 set a [lindex $varcorder($curview) $ai]
4896 set arow [lindex $vrownum($curview) $ai]
4897 set ids [lindex $varccommits($curview,$a)]
4898 set arowend [expr {$arow + [llength $ids]}]
4900 set id [lindex $ids [expr {$l - $arow}]]
4901 # shouldn't happen unless git log doesn't give all the commits...
4902 if {![info exists commitdata($id)] ||
4903 ![doesmatch $commitdata($id)]} {
4906 if {![info exists commitinfo($id)]} {
4909 set info $commitinfo($id)
4910 foreach f $info ty $fldtypes {
4911 if {($findloc eq "All fields" || $findloc eq $ty) &&
4920 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4921 if {$l < $arow || $l >= $arowend} {
4923 set a [lindex $varcorder($curview) $ai]
4924 set arow [lindex $vrownum($curview) $ai]
4925 set ids [lindex $varccommits($curview,$a)]
4926 set arowend [expr {$arow + [llength $ids]}]
4928 set id [lindex $ids [expr {$l - $arow}]]
4929 if {![info exists fhighlights($l)]} {
4930 askfilehighlight $l $id
4933 set findcurline [expr {$l - $find_dirn}]
4935 } elseif {$fhighlights($l)} {
4941 if {$found || ($domore && !$moretodo)} {
4957 set findcurline [expr {$l - $find_dirn}]
4959 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
4963 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4968 proc findselectline {l} {
4969 global findloc commentend ctext findcurline markingmatches gdttype
4971 set markingmatches 1
4974 if {$findloc == "All fields" || $findloc == "Comments"} {
4975 # highlight the matches in the comments
4976 set f [$ctext get 1.0 $commentend]
4977 set matches [findmatches $f]
4978 foreach match $matches {
4979 set start [lindex $match 0]
4980 set end [expr {[lindex $match 1] + 1}]
4981 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4987 # mark the bits of a headline or author that match a find string
4988 proc markmatches {canv l str tag matches font row} {
4991 set bbox [$canv bbox $tag]
4992 set x0 [lindex $bbox 0]
4993 set y0 [lindex $bbox 1]
4994 set y1 [lindex $bbox 3]
4995 foreach match $matches {
4996 set start [lindex $match 0]
4997 set end [lindex $match 1]
4998 if {$start > $end} continue
4999 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5000 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5001 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5002 [expr {$x0+$xlen+2}] $y1 \
5003 -outline {} -tags [list match$l matches] -fill yellow]
5005 if {[info exists selectedline] && $row == $selectedline} {
5006 $canv raise $t secsel
5011 proc unmarkmatches {} {
5012 global markingmatches
5014 allcanvs delete matches
5015 set markingmatches 0
5019 proc selcanvline {w x y} {
5020 global canv canvy0 ctext linespc
5022 set ymax [lindex [$canv cget -scrollregion] 3]
5023 if {$ymax == {}} return
5024 set yfrac [lindex [$canv yview] 0]
5025 set y [expr {$y + $yfrac * $ymax}]
5026 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5031 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
5037 proc commit_descriptor {p} {
5039 if {![info exists commitinfo($p)]} {
5043 if {[llength $commitinfo($p)] > 1} {
5044 set l [lindex $commitinfo($p) 0]
5049 # append some text to the ctext widget, and make any SHA1 ID
5050 # that we know about be a clickable link.
5051 proc appendwithlinks {text tags} {
5052 global ctext linknum curview pendinglinks
5054 set start [$ctext index "end - 1c"]
5055 $ctext insert end $text $tags
5056 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5060 set linkid [string range $text $s $e]
5062 $ctext tag delete link$linknum
5063 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5064 setlink $linkid link$linknum
5069 proc setlink {id lk} {
5070 global curview ctext pendinglinks commitinterest
5072 if {[commitinview $id $curview]} {
5073 $ctext tag conf $lk -foreground blue -underline 1
5074 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5075 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5076 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5078 lappend pendinglinks($id) $lk
5079 lappend commitinterest($id) {makelink %I}
5083 proc makelink {id} {
5086 if {![info exists pendinglinks($id)]} return
5087 foreach lk $pendinglinks($id) {
5090 unset pendinglinks($id)
5093 proc linkcursor {w inc} {
5094 global linkentercount curtextcursor
5096 if {[incr linkentercount $inc] > 0} {
5097 $w configure -cursor hand2
5099 $w configure -cursor $curtextcursor
5100 if {$linkentercount < 0} {
5101 set linkentercount 0
5106 proc viewnextline {dir} {
5110 set ymax [lindex [$canv cget -scrollregion] 3]
5111 set wnow [$canv yview]
5112 set wtop [expr {[lindex $wnow 0] * $ymax}]
5113 set newtop [expr {$wtop + $dir * $linespc}]
5116 } elseif {$newtop > $ymax} {
5119 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5122 # add a list of tag or branch names at position pos
5123 # returns the number of names inserted
5124 proc appendrefs {pos ids var} {
5125 global ctext linknum curview $var maxrefs
5127 if {[catch {$ctext index $pos}]} {
5130 $ctext conf -state normal
5131 $ctext delete $pos "$pos lineend"
5134 foreach tag [set $var\($id\)] {
5135 lappend tags [list $tag $id]
5138 if {[llength $tags] > $maxrefs} {
5139 $ctext insert $pos "many ([llength $tags])"
5141 set tags [lsort -index 0 -decreasing $tags]
5144 set id [lindex $ti 1]
5147 $ctext tag delete $lk
5148 $ctext insert $pos $sep
5149 $ctext insert $pos [lindex $ti 0] $lk
5154 $ctext conf -state disabled
5155 return [llength $tags]
5158 # called when we have finished computing the nearby tags
5159 proc dispneartags {delay} {
5160 global selectedline currentid showneartags tagphase
5162 if {![info exists selectedline] || !$showneartags} return
5163 after cancel dispnexttag
5165 after 200 dispnexttag
5168 after idle dispnexttag
5173 proc dispnexttag {} {
5174 global selectedline currentid showneartags tagphase ctext
5176 if {![info exists selectedline] || !$showneartags} return
5177 switch -- $tagphase {
5179 set dtags [desctags $currentid]
5181 appendrefs precedes $dtags idtags
5185 set atags [anctags $currentid]
5187 appendrefs follows $atags idtags
5191 set dheads [descheads $currentid]
5192 if {$dheads ne {}} {
5193 if {[appendrefs branch $dheads idheads] > 1
5194 && [$ctext get "branch -3c"] eq "h"} {
5195 # turn "Branch" into "Branches"
5196 $ctext conf -state normal
5197 $ctext insert "branch -2c" "es"
5198 $ctext conf -state disabled
5203 if {[incr tagphase] <= 2} {
5204 after idle dispnexttag
5208 proc make_secsel {l} {
5209 global linehtag linentag linedtag canv canv2 canv3
5211 if {![info exists linehtag($l)]} return
5213 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5214 -tags secsel -fill [$canv cget -selectbackground]]
5216 $canv2 delete secsel
5217 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5218 -tags secsel -fill [$canv2 cget -selectbackground]]
5220 $canv3 delete secsel
5221 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5222 -tags secsel -fill [$canv3 cget -selectbackground]]
5226 proc selectline {l isnew} {
5227 global canv ctext commitinfo selectedline
5228 global canvy0 linespc parents children curview
5229 global currentid sha1entry
5230 global commentend idtags linknum
5231 global mergemax numcommits pending_select
5232 global cmitmode showneartags allcommits
5234 catch {unset pending_select}
5239 if {$l < 0 || $l >= $numcommits} return
5240 set y [expr {$canvy0 + $l * $linespc}]
5241 set ymax [lindex [$canv cget -scrollregion] 3]
5242 set ytop [expr {$y - $linespc - 1}]
5243 set ybot [expr {$y + $linespc + 1}]
5244 set wnow [$canv yview]
5245 set wtop [expr {[lindex $wnow 0] * $ymax}]
5246 set wbot [expr {[lindex $wnow 1] * $ymax}]
5247 set wh [expr {$wbot - $wtop}]
5249 if {$ytop < $wtop} {
5250 if {$ybot < $wtop} {
5251 set newtop [expr {$y - $wh / 2.0}]
5254 if {$newtop > $wtop - $linespc} {
5255 set newtop [expr {$wtop - $linespc}]
5258 } elseif {$ybot > $wbot} {
5259 if {$ytop > $wbot} {
5260 set newtop [expr {$y - $wh / 2.0}]
5262 set newtop [expr {$ybot - $wh}]
5263 if {$newtop < $wtop + $linespc} {
5264 set newtop [expr {$wtop + $linespc}]
5268 if {$newtop != $wtop} {
5272 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5279 addtohistory [list selectline $l 0]
5284 set id [commitonrow $l]
5286 $sha1entry delete 0 end
5287 $sha1entry insert 0 $id
5288 $sha1entry selection from 0
5289 $sha1entry selection to end
5292 $ctext conf -state normal
5295 set info $commitinfo($id)
5296 set date [formatdate [lindex $info 2]]
5297 $ctext insert end "Author: [lindex $info 1] $date\n"
5298 set date [formatdate [lindex $info 4]]
5299 $ctext insert end "Committer: [lindex $info 3] $date\n"
5300 if {[info exists idtags($id)]} {
5301 $ctext insert end "Tags:"
5302 foreach tag $idtags($id) {
5303 $ctext insert end " $tag"
5305 $ctext insert end "\n"
5309 set olds $parents($curview,$id)
5310 if {[llength $olds] > 1} {
5313 if {$np >= $mergemax} {
5318 $ctext insert end "Parent: " $tag
5319 appendwithlinks [commit_descriptor $p] {}
5324 append headers "Parent: [commit_descriptor $p]"
5328 foreach c $children($curview,$id) {
5329 append headers "Child: [commit_descriptor $c]"
5332 # make anything that looks like a SHA1 ID be a clickable link
5333 appendwithlinks $headers {}
5334 if {$showneartags} {
5335 if {![info exists allcommits]} {
5338 $ctext insert end "Branch: "
5339 $ctext mark set branch "end -1c"
5340 $ctext mark gravity branch left
5341 $ctext insert end "\nFollows: "
5342 $ctext mark set follows "end -1c"
5343 $ctext mark gravity follows left
5344 $ctext insert end "\nPrecedes: "
5345 $ctext mark set precedes "end -1c"
5346 $ctext mark gravity precedes left
5347 $ctext insert end "\n"
5350 $ctext insert end "\n"
5351 set comment [lindex $info 5]
5352 if {[string first "\r" $comment] >= 0} {
5353 set comment [string map {"\r" "\n "} $comment]
5355 appendwithlinks $comment {comment}
5357 $ctext tag remove found 1.0 end
5358 $ctext conf -state disabled
5359 set commentend [$ctext index "end - 1c"]
5361 init_flist "Comments"
5362 if {$cmitmode eq "tree"} {
5364 } elseif {[llength $olds] <= 1} {
5371 proc selfirstline {} {
5376 proc sellastline {} {
5379 set l [expr {$numcommits - 1}]
5383 proc selnextline {dir} {
5386 if {![info exists selectedline]} return
5387 set l [expr {$selectedline + $dir}]
5392 proc selnextpage {dir} {
5393 global canv linespc selectedline numcommits
5395 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5399 allcanvs yview scroll [expr {$dir * $lpp}] units
5401 if {![info exists selectedline]} return
5402 set l [expr {$selectedline + $dir * $lpp}]
5405 } elseif {$l >= $numcommits} {
5406 set l [expr $numcommits - 1]
5412 proc unselectline {} {
5413 global selectedline currentid
5415 catch {unset selectedline}
5416 catch {unset currentid}
5417 allcanvs delete secsel
5421 proc reselectline {} {
5424 if {[info exists selectedline]} {
5425 selectline $selectedline 0
5429 proc addtohistory {cmd} {
5430 global history historyindex curview
5432 set elt [list $curview $cmd]
5433 if {$historyindex > 0
5434 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5438 if {$historyindex < [llength $history]} {
5439 set history [lreplace $history $historyindex end $elt]
5441 lappend history $elt
5444 if {$historyindex > 1} {
5445 .tf.bar.leftbut conf -state normal
5447 .tf.bar.leftbut conf -state disabled
5449 .tf.bar.rightbut conf -state disabled
5455 set view [lindex $elt 0]
5456 set cmd [lindex $elt 1]
5457 if {$curview != $view} {
5464 global history historyindex
5467 if {$historyindex > 1} {
5468 incr historyindex -1
5469 godo [lindex $history [expr {$historyindex - 1}]]
5470 .tf.bar.rightbut conf -state normal
5472 if {$historyindex <= 1} {
5473 .tf.bar.leftbut conf -state disabled
5478 global history historyindex
5481 if {$historyindex < [llength $history]} {
5482 set cmd [lindex $history $historyindex]
5485 .tf.bar.leftbut conf -state normal
5487 if {$historyindex >= [llength $history]} {
5488 .tf.bar.rightbut conf -state disabled
5493 global treefilelist treeidlist diffids diffmergeid treepending
5494 global nullid nullid2
5497 catch {unset diffmergeid}
5498 if {![info exists treefilelist($id)]} {
5499 if {![info exists treepending]} {
5500 if {$id eq $nullid} {
5501 set cmd [list | git ls-files]
5502 } elseif {$id eq $nullid2} {
5503 set cmd [list | git ls-files --stage -t]
5505 set cmd [list | git ls-tree -r $id]
5507 if {[catch {set gtf [open $cmd r]}]} {
5511 set treefilelist($id) {}
5512 set treeidlist($id) {}
5513 fconfigure $gtf -blocking 0
5514 filerun $gtf [list gettreeline $gtf $id]
5521 proc gettreeline {gtf id} {
5522 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5525 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5526 if {$diffids eq $nullid} {
5529 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5530 set i [string first "\t" $line]
5531 if {$i < 0} continue
5532 set sha1 [lindex $line 2]
5533 set fname [string range $line [expr {$i+1}] end]
5534 if {[string index $fname 0] eq "\""} {
5535 set fname [lindex $fname 0]
5537 lappend treeidlist($id) $sha1
5539 lappend treefilelist($id) $fname
5542 return [expr {$nl >= 1000? 2: 1}]
5546 if {$cmitmode ne "tree"} {
5547 if {![info exists diffmergeid]} {
5548 gettreediffs $diffids
5550 } elseif {$id ne $diffids} {
5559 global treefilelist treeidlist diffids nullid nullid2
5560 global ctext commentend
5562 set i [lsearch -exact $treefilelist($diffids) $f]
5564 puts "oops, $f not in list for id $diffids"
5567 if {$diffids eq $nullid} {
5568 if {[catch {set bf [open $f r]} err]} {
5569 puts "oops, can't read $f: $err"
5573 set blob [lindex $treeidlist($diffids) $i]
5574 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5575 puts "oops, error reading blob $blob: $err"
5579 fconfigure $bf -blocking 0
5580 filerun $bf [list getblobline $bf $diffids]
5581 $ctext config -state normal
5582 clear_ctext $commentend
5583 $ctext insert end "\n"
5584 $ctext insert end "$f\n" filesep
5585 $ctext config -state disabled
5586 $ctext yview $commentend
5590 proc getblobline {bf id} {
5591 global diffids cmitmode ctext
5593 if {$id ne $diffids || $cmitmode ne "tree"} {
5597 $ctext config -state normal
5599 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5600 $ctext insert end "$line\n"
5603 # delete last newline
5604 $ctext delete "end - 2c" "end - 1c"
5608 $ctext config -state disabled
5609 return [expr {$nl >= 1000? 2: 1}]
5612 proc mergediff {id} {
5613 global diffmergeid mdifffd
5616 global limitdiffs viewfiles curview
5620 # this doesn't seem to actually affect anything...
5621 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5622 if {$limitdiffs && $viewfiles($curview) ne {}} {
5623 set cmd [concat $cmd -- $viewfiles($curview)]
5625 if {[catch {set mdf [open $cmd r]} err]} {
5626 error_popup "Error getting merge diffs: $err"
5629 fconfigure $mdf -blocking 0
5630 set mdifffd($id) $mdf
5631 set np [llength $parents($curview,$id)]
5633 filerun $mdf [list getmergediffline $mdf $id $np]
5636 proc getmergediffline {mdf id np} {
5637 global diffmergeid ctext cflist mergemax
5638 global difffilestart mdifffd
5640 $ctext conf -state normal
5642 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5643 if {![info exists diffmergeid] || $id != $diffmergeid
5644 || $mdf != $mdifffd($id)} {
5648 if {[regexp {^diff --cc (.*)} $line match fname]} {
5649 # start of a new file
5650 $ctext insert end "\n"
5651 set here [$ctext index "end - 1c"]
5652 lappend difffilestart $here
5653 add_flist [list $fname]
5654 set l [expr {(78 - [string length $fname]) / 2}]
5655 set pad [string range "----------------------------------------" 1 $l]
5656 $ctext insert end "$pad $fname $pad\n" filesep
5657 } elseif {[regexp {^@@} $line]} {
5658 $ctext insert end "$line\n" hunksep
5659 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5662 # parse the prefix - one ' ', '-' or '+' for each parent
5667 for {set j 0} {$j < $np} {incr j} {
5668 set c [string range $line $j $j]
5671 } elseif {$c == "-"} {
5673 } elseif {$c == "+"} {
5682 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5683 # line doesn't appear in result, parents in $minuses have the line
5684 set num [lindex $minuses 0]
5685 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5686 # line appears in result, parents in $pluses don't have the line
5687 lappend tags mresult
5688 set num [lindex $spaces 0]
5691 if {$num >= $mergemax} {
5696 $ctext insert end "$line\n" $tags
5699 $ctext conf -state disabled
5704 return [expr {$nr >= 1000? 2: 1}]
5707 proc startdiff {ids} {
5708 global treediffs diffids treepending diffmergeid nullid nullid2
5712 catch {unset diffmergeid}
5713 if {![info exists treediffs($ids)] ||
5714 [lsearch -exact $ids $nullid] >= 0 ||
5715 [lsearch -exact $ids $nullid2] >= 0} {
5716 if {![info exists treepending]} {
5724 proc path_filter {filter name} {
5726 set l [string length $p]
5727 if {[string index $p end] eq "/"} {
5728 if {[string compare -length $l $p $name] == 0} {
5732 if {[string compare -length $l $p $name] == 0 &&
5733 ([string length $name] == $l ||
5734 [string index $name $l] eq "/")} {
5742 proc addtocflist {ids} {
5745 add_flist $treediffs($ids)
5749 proc diffcmd {ids flags} {
5750 global nullid nullid2
5752 set i [lsearch -exact $ids $nullid]
5753 set j [lsearch -exact $ids $nullid2]
5755 if {[llength $ids] > 1 && $j < 0} {
5756 # comparing working directory with some specific revision
5757 set cmd [concat | git diff-index $flags]
5759 lappend cmd -R [lindex $ids 1]
5761 lappend cmd [lindex $ids 0]
5764 # comparing working directory with index
5765 set cmd [concat | git diff-files $flags]
5770 } elseif {$j >= 0} {
5771 set cmd [concat | git diff-index --cached $flags]
5772 if {[llength $ids] > 1} {
5773 # comparing index with specific revision
5775 lappend cmd -R [lindex $ids 1]
5777 lappend cmd [lindex $ids 0]
5780 # comparing index with HEAD
5784 set cmd [concat | git diff-tree -r $flags $ids]
5789 proc gettreediffs {ids} {
5790 global treediff treepending
5792 set treepending $ids
5794 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5795 fconfigure $gdtf -blocking 0
5796 filerun $gdtf [list gettreediffline $gdtf $ids]
5799 proc gettreediffline {gdtf ids} {
5800 global treediff treediffs treepending diffids diffmergeid
5801 global cmitmode viewfiles curview limitdiffs
5804 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5805 set i [string first "\t" $line]
5807 set file [string range $line [expr {$i+1}] end]
5808 if {[string index $file 0] eq "\""} {
5809 set file [lindex $file 0]
5811 lappend treediff $file
5815 return [expr {$nr >= 1000? 2: 1}]
5818 if {$limitdiffs && $viewfiles($curview) ne {}} {
5820 foreach f $treediff {
5821 if {[path_filter $viewfiles($curview) $f]} {
5825 set treediffs($ids) $flist
5827 set treediffs($ids) $treediff
5830 if {$cmitmode eq "tree"} {
5832 } elseif {$ids != $diffids} {
5833 if {![info exists diffmergeid]} {
5834 gettreediffs $diffids
5842 # empty string or positive integer
5843 proc diffcontextvalidate {v} {
5844 return [regexp {^(|[1-9][0-9]*)$} $v]
5847 proc diffcontextchange {n1 n2 op} {
5848 global diffcontextstring diffcontext
5850 if {[string is integer -strict $diffcontextstring]} {
5851 if {$diffcontextstring > 0} {
5852 set diffcontext $diffcontextstring
5858 proc getblobdiffs {ids} {
5859 global blobdifffd diffids env
5860 global diffinhdr treediffs
5862 global limitdiffs viewfiles curview
5864 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5865 if {$limitdiffs && $viewfiles($curview) ne {}} {
5866 set cmd [concat $cmd -- $viewfiles($curview)]
5868 if {[catch {set bdf [open $cmd r]} err]} {
5869 puts "error getting diffs: $err"
5873 fconfigure $bdf -blocking 0
5874 set blobdifffd($ids) $bdf
5875 filerun $bdf [list getblobdiffline $bdf $diffids]
5878 proc setinlist {var i val} {
5881 while {[llength [set $var]] < $i} {
5884 if {[llength [set $var]] == $i} {
5891 proc makediffhdr {fname ids} {
5892 global ctext curdiffstart treediffs
5894 set i [lsearch -exact $treediffs($ids) $fname]
5896 setinlist difffilestart $i $curdiffstart
5898 set l [expr {(78 - [string length $fname]) / 2}]
5899 set pad [string range "----------------------------------------" 1 $l]
5900 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5903 proc getblobdiffline {bdf ids} {
5904 global diffids blobdifffd ctext curdiffstart
5905 global diffnexthead diffnextnote difffilestart
5906 global diffinhdr treediffs
5909 $ctext conf -state normal
5910 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5911 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5915 if {![string compare -length 11 "diff --git " $line]} {
5916 # trim off "diff --git "
5917 set line [string range $line 11 end]
5919 # start of a new file
5920 $ctext insert end "\n"
5921 set curdiffstart [$ctext index "end - 1c"]
5922 $ctext insert end "\n" filesep
5923 # If the name hasn't changed the length will be odd,
5924 # the middle char will be a space, and the two bits either
5925 # side will be a/name and b/name, or "a/name" and "b/name".
5926 # If the name has changed we'll get "rename from" and
5927 # "rename to" or "copy from" and "copy to" lines following this,
5928 # and we'll use them to get the filenames.
5929 # This complexity is necessary because spaces in the filename(s)
5930 # don't get escaped.
5931 set l [string length $line]
5932 set i [expr {$l / 2}]
5933 if {!(($l & 1) && [string index $line $i] eq " " &&
5934 [string range $line 2 [expr {$i - 1}]] eq \
5935 [string range $line [expr {$i + 3}] end])} {
5938 # unescape if quoted and chop off the a/ from the front
5939 if {[string index $line 0] eq "\""} {
5940 set fname [string range [lindex $line 0] 2 end]
5942 set fname [string range $line 2 [expr {$i - 1}]]
5944 makediffhdr $fname $ids
5946 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5947 $line match f1l f1c f2l f2c rest]} {
5948 $ctext insert end "$line\n" hunksep
5951 } elseif {$diffinhdr} {
5952 if {![string compare -length 12 "rename from " $line]} {
5953 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5954 if {[string index $fname 0] eq "\""} {
5955 set fname [lindex $fname 0]
5957 set i [lsearch -exact $treediffs($ids) $fname]
5959 setinlist difffilestart $i $curdiffstart
5961 } elseif {![string compare -length 10 $line "rename to "] ||
5962 ![string compare -length 8 $line "copy to "]} {
5963 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5964 if {[string index $fname 0] eq "\""} {
5965 set fname [lindex $fname 0]
5967 makediffhdr $fname $ids
5968 } elseif {[string compare -length 3 $line "---"] == 0} {
5971 } elseif {[string compare -length 3 $line "+++"] == 0} {
5975 $ctext insert end "$line\n" filesep
5978 set x [string range $line 0 0]
5979 if {$x == "-" || $x == "+"} {
5980 set tag [expr {$x == "+"}]
5981 $ctext insert end "$line\n" d$tag
5982 } elseif {$x == " "} {
5983 $ctext insert end "$line\n"
5985 # "\ No newline at end of file",
5986 # or something else we don't recognize
5987 $ctext insert end "$line\n" hunksep
5991 $ctext conf -state disabled
5996 return [expr {$nr >= 1000? 2: 1}]
5999 proc changediffdisp {} {
6000 global ctext diffelide
6002 $ctext tag conf d0 -elide [lindex $diffelide 0]
6003 $ctext tag conf d1 -elide [lindex $diffelide 1]
6007 global difffilestart ctext
6008 set prev [lindex $difffilestart 0]
6009 set here [$ctext index @0,0]
6010 foreach loc $difffilestart {
6011 if {[$ctext compare $loc >= $here]} {
6021 global difffilestart ctext
6022 set here [$ctext index @0,0]
6023 foreach loc $difffilestart {
6024 if {[$ctext compare $loc > $here]} {
6031 proc clear_ctext {{first 1.0}} {
6032 global ctext smarktop smarkbot
6035 set l [lindex [split $first .] 0]
6036 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6039 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6042 $ctext delete $first end
6043 if {$first eq "1.0"} {
6044 catch {unset pendinglinks}
6048 proc settabs {{firstab {}}} {
6049 global firsttabstop tabstop ctext have_tk85
6051 if {$firstab ne {} && $have_tk85} {
6052 set firsttabstop $firstab
6054 set w [font measure textfont "0"]
6055 if {$firsttabstop != 0} {
6056 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6057 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6058 } elseif {$have_tk85 || $tabstop != 8} {
6059 $ctext conf -tabs [expr {$tabstop * $w}]
6061 $ctext conf -tabs {}
6065 proc incrsearch {name ix op} {
6066 global ctext searchstring searchdirn
6068 $ctext tag remove found 1.0 end
6069 if {[catch {$ctext index anchor}]} {
6070 # no anchor set, use start of selection, or of visible area
6071 set sel [$ctext tag ranges sel]
6073 $ctext mark set anchor [lindex $sel 0]
6074 } elseif {$searchdirn eq "-forwards"} {
6075 $ctext mark set anchor @0,0
6077 $ctext mark set anchor @0,[winfo height $ctext]
6080 if {$searchstring ne {}} {
6081 set here [$ctext search $searchdirn -- $searchstring anchor]
6090 global sstring ctext searchstring searchdirn
6093 $sstring icursor end
6094 set searchdirn -forwards
6095 if {$searchstring ne {}} {
6096 set sel [$ctext tag ranges sel]
6098 set start "[lindex $sel 0] + 1c"
6099 } elseif {[catch {set start [$ctext index anchor]}]} {
6102 set match [$ctext search -count mlen -- $searchstring $start]
6103 $ctext tag remove sel 1.0 end
6109 set mend "$match + $mlen c"
6110 $ctext tag add sel $match $mend
6111 $ctext mark unset anchor
6115 proc dosearchback {} {
6116 global sstring ctext searchstring searchdirn
6119 $sstring icursor end
6120 set searchdirn -backwards
6121 if {$searchstring ne {}} {
6122 set sel [$ctext tag ranges sel]
6124 set start [lindex $sel 0]
6125 } elseif {[catch {set start [$ctext index anchor]}]} {
6126 set start @0,[winfo height $ctext]
6128 set match [$ctext search -backwards -count ml -- $searchstring $start]
6129 $ctext tag remove sel 1.0 end
6135 set mend "$match + $ml c"
6136 $ctext tag add sel $match $mend
6137 $ctext mark unset anchor
6141 proc searchmark {first last} {
6142 global ctext searchstring
6146 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6147 if {$match eq {}} break
6148 set mend "$match + $mlen c"
6149 $ctext tag add found $match $mend
6153 proc searchmarkvisible {doall} {
6154 global ctext smarktop smarkbot
6156 set topline [lindex [split [$ctext index @0,0] .] 0]
6157 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6158 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6159 # no overlap with previous
6160 searchmark $topline $botline
6161 set smarktop $topline
6162 set smarkbot $botline
6164 if {$topline < $smarktop} {
6165 searchmark $topline [expr {$smarktop-1}]
6166 set smarktop $topline
6168 if {$botline > $smarkbot} {
6169 searchmark [expr {$smarkbot+1}] $botline
6170 set smarkbot $botline
6175 proc scrolltext {f0 f1} {
6178 .bleft.sb set $f0 $f1
6179 if {$searchstring ne {}} {
6185 global linespc charspc canvx0 canvy0
6186 global xspc1 xspc2 lthickness
6188 set linespc [font metrics mainfont -linespace]
6189 set charspc [font measure mainfont "m"]
6190 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6191 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6192 set lthickness [expr {int($linespc / 9) + 1}]
6193 set xspc1(0) $linespc
6201 set ymax [lindex [$canv cget -scrollregion] 3]
6202 if {$ymax eq {} || $ymax == 0} return
6203 set span [$canv yview]
6206 allcanvs yview moveto [lindex $span 0]
6208 if {[info exists selectedline]} {
6209 selectline $selectedline 0
6210 allcanvs yview moveto [lindex $span 0]
6214 proc parsefont {f n} {
6217 set fontattr($f,family) [lindex $n 0]
6219 if {$s eq {} || $s == 0} {
6222 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6224 set fontattr($f,size) $s
6225 set fontattr($f,weight) normal
6226 set fontattr($f,slant) roman
6227 foreach style [lrange $n 2 end] {
6230 "bold" {set fontattr($f,weight) $style}
6232 "italic" {set fontattr($f,slant) $style}
6237 proc fontflags {f {isbold 0}} {
6240 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6241 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6242 -slant $fontattr($f,slant)]
6248 set n [list $fontattr($f,family) $fontattr($f,size)]
6249 if {$fontattr($f,weight) eq "bold"} {
6252 if {$fontattr($f,slant) eq "italic"} {
6258 proc incrfont {inc} {
6259 global mainfont textfont ctext canv cflist showrefstop
6260 global stopped entries fontattr
6263 set s $fontattr(mainfont,size)
6268 set fontattr(mainfont,size) $s
6269 font config mainfont -size $s
6270 font config mainfontbold -size $s
6271 set mainfont [fontname mainfont]
6272 set s $fontattr(textfont,size)
6277 set fontattr(textfont,size) $s
6278 font config textfont -size $s
6279 font config textfontbold -size $s
6280 set textfont [fontname textfont]
6287 global sha1entry sha1string
6288 if {[string length $sha1string] == 40} {
6289 $sha1entry delete 0 end
6293 proc sha1change {n1 n2 op} {
6294 global sha1string currentid sha1but
6295 if {$sha1string == {}
6296 || ([info exists currentid] && $sha1string == $currentid)} {
6301 if {[$sha1but cget -state] == $state} return
6302 if {$state == "normal"} {
6303 $sha1but conf -state normal -relief raised -text "Goto: "
6305 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
6309 proc gotocommit {} {
6310 global sha1string tagids headids curview varcid
6312 if {$sha1string == {}
6313 || ([info exists currentid] && $sha1string == $currentid)} return
6314 if {[info exists tagids($sha1string)]} {
6315 set id $tagids($sha1string)
6316 } elseif {[info exists headids($sha1string)]} {
6317 set id $headids($sha1string)
6319 set id [string tolower $sha1string]
6320 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6321 set matches [array names varcid "$curview,$id*"]
6322 if {$matches ne {}} {
6323 if {[llength $matches] > 1} {
6324 error_popup "Short SHA1 id $id is ambiguous"
6327 set id [lindex [split [lindex $matches 0] ","] 1]
6331 if {[commitinview $id $curview]} {
6332 selectline [rowofcommit $id] 1
6335 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6340 error_popup "$type $sha1string is not known"
6343 proc lineenter {x y id} {
6344 global hoverx hovery hoverid hovertimer
6345 global commitinfo canv
6347 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6351 if {[info exists hovertimer]} {
6352 after cancel $hovertimer
6354 set hovertimer [after 500 linehover]
6358 proc linemotion {x y id} {
6359 global hoverx hovery hoverid hovertimer
6361 if {[info exists hoverid] && $id == $hoverid} {
6364 if {[info exists hovertimer]} {
6365 after cancel $hovertimer
6367 set hovertimer [after 500 linehover]
6371 proc lineleave {id} {
6372 global hoverid hovertimer canv
6374 if {[info exists hoverid] && $id == $hoverid} {
6376 if {[info exists hovertimer]} {
6377 after cancel $hovertimer
6385 global hoverx hovery hoverid hovertimer
6386 global canv linespc lthickness
6389 set text [lindex $commitinfo($hoverid) 0]
6390 set ymax [lindex [$canv cget -scrollregion] 3]
6391 if {$ymax == {}} return
6392 set yfrac [lindex [$canv yview] 0]
6393 set x [expr {$hoverx + 2 * $linespc}]
6394 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6395 set x0 [expr {$x - 2 * $lthickness}]
6396 set y0 [expr {$y - 2 * $lthickness}]
6397 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6398 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6399 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6400 -fill \#ffff80 -outline black -width 1 -tags hover]
6402 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6407 proc clickisonarrow {id y} {
6410 set ranges [rowranges $id]
6411 set thresh [expr {2 * $lthickness + 6}]
6412 set n [expr {[llength $ranges] - 1}]
6413 for {set i 1} {$i < $n} {incr i} {
6414 set row [lindex $ranges $i]
6415 if {abs([yc $row] - $y) < $thresh} {
6422 proc arrowjump {id n y} {
6425 # 1 <-> 2, 3 <-> 4, etc...
6426 set n [expr {(($n - 1) ^ 1) + 1}]
6427 set row [lindex [rowranges $id] $n]
6429 set ymax [lindex [$canv cget -scrollregion] 3]
6430 if {$ymax eq {} || $ymax <= 0} return
6431 set view [$canv yview]
6432 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6433 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6437 allcanvs yview moveto $yfrac
6440 proc lineclick {x y id isnew} {
6441 global ctext commitinfo children canv thickerline curview
6443 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6448 # draw this line thicker than normal
6452 set ymax [lindex [$canv cget -scrollregion] 3]
6453 if {$ymax eq {}} return
6454 set yfrac [lindex [$canv yview] 0]
6455 set y [expr {$y + $yfrac * $ymax}]
6457 set dirn [clickisonarrow $id $y]
6459 arrowjump $id $dirn $y
6464 addtohistory [list lineclick $x $y $id 0]
6466 # fill the details pane with info about this line
6467 $ctext conf -state normal
6470 $ctext insert end "Parent:\t"
6471 $ctext insert end $id link0
6473 set info $commitinfo($id)
6474 $ctext insert end "\n\t[lindex $info 0]\n"
6475 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
6476 set date [formatdate [lindex $info 2]]
6477 $ctext insert end "\tDate:\t$date\n"
6478 set kids $children($curview,$id)
6480 $ctext insert end "\nChildren:"
6482 foreach child $kids {
6484 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6485 set info $commitinfo($child)
6486 $ctext insert end "\n\t"
6487 $ctext insert end $child link$i
6488 setlink $child link$i
6489 $ctext insert end "\n\t[lindex $info 0]"
6490 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
6491 set date [formatdate [lindex $info 2]]
6492 $ctext insert end "\n\tDate:\t$date\n"
6495 $ctext conf -state disabled
6499 proc normalline {} {
6501 if {[info exists thickerline]} {
6510 if {[commitinview $id $curview]} {
6511 selectline [rowofcommit $id] 1
6517 if {![info exists startmstime]} {
6518 set startmstime [clock clicks -milliseconds]
6520 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6523 proc rowmenu {x y id} {
6524 global rowctxmenu selectedline rowmenuid curview
6525 global nullid nullid2 fakerowmenu mainhead
6529 if {![info exists selectedline]
6530 || [rowofcommit $id] eq $selectedline} {
6535 if {$id ne $nullid && $id ne $nullid2} {
6536 set menu $rowctxmenu
6537 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6539 set menu $fakerowmenu
6541 $menu entryconfigure "Diff this*" -state $state
6542 $menu entryconfigure "Diff selected*" -state $state
6543 $menu entryconfigure "Make patch" -state $state
6544 tk_popup $menu $x $y
6547 proc diffvssel {dirn} {
6548 global rowmenuid selectedline
6550 if {![info exists selectedline]} return
6552 set oldid [commitonrow $selectedline]
6553 set newid $rowmenuid
6555 set oldid $rowmenuid
6556 set newid [commitonrow $selectedline]
6558 addtohistory [list doseldiff $oldid $newid]
6559 doseldiff $oldid $newid
6562 proc doseldiff {oldid newid} {
6566 $ctext conf -state normal
6569 $ctext insert end "From "
6570 $ctext insert end $oldid link0
6571 setlink $oldid link0
6572 $ctext insert end "\n "
6573 $ctext insert end [lindex $commitinfo($oldid) 0]
6574 $ctext insert end "\n\nTo "
6575 $ctext insert end $newid link1
6576 setlink $newid link1
6577 $ctext insert end "\n "
6578 $ctext insert end [lindex $commitinfo($newid) 0]
6579 $ctext insert end "\n"
6580 $ctext conf -state disabled
6581 $ctext tag remove found 1.0 end
6582 startdiff [list $oldid $newid]
6586 global rowmenuid currentid commitinfo patchtop patchnum
6588 if {![info exists currentid]} return
6589 set oldid $currentid
6590 set oldhead [lindex $commitinfo($oldid) 0]
6591 set newid $rowmenuid
6592 set newhead [lindex $commitinfo($newid) 0]
6595 catch {destroy $top}
6597 label $top.title -text "Generate patch"
6598 grid $top.title - -pady 10
6599 label $top.from -text "From:"
6600 entry $top.fromsha1 -width 40 -relief flat
6601 $top.fromsha1 insert 0 $oldid
6602 $top.fromsha1 conf -state readonly
6603 grid $top.from $top.fromsha1 -sticky w
6604 entry $top.fromhead -width 60 -relief flat
6605 $top.fromhead insert 0 $oldhead
6606 $top.fromhead conf -state readonly
6607 grid x $top.fromhead -sticky w
6608 label $top.to -text "To:"
6609 entry $top.tosha1 -width 40 -relief flat
6610 $top.tosha1 insert 0 $newid
6611 $top.tosha1 conf -state readonly
6612 grid $top.to $top.tosha1 -sticky w
6613 entry $top.tohead -width 60 -relief flat
6614 $top.tohead insert 0 $newhead
6615 $top.tohead conf -state readonly
6616 grid x $top.tohead -sticky w
6617 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6618 grid $top.rev x -pady 10
6619 label $top.flab -text "Output file:"
6620 entry $top.fname -width 60
6621 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6623 grid $top.flab $top.fname -sticky w
6625 button $top.buts.gen -text "Generate" -command mkpatchgo
6626 button $top.buts.can -text "Cancel" -command mkpatchcan
6627 grid $top.buts.gen $top.buts.can
6628 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6629 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6630 grid $top.buts - -pady 10 -sticky ew
6634 proc mkpatchrev {} {
6637 set oldid [$patchtop.fromsha1 get]
6638 set oldhead [$patchtop.fromhead get]
6639 set newid [$patchtop.tosha1 get]
6640 set newhead [$patchtop.tohead get]
6641 foreach e [list fromsha1 fromhead tosha1 tohead] \
6642 v [list $newid $newhead $oldid $oldhead] {
6643 $patchtop.$e conf -state normal
6644 $patchtop.$e delete 0 end
6645 $patchtop.$e insert 0 $v
6646 $patchtop.$e conf -state readonly
6651 global patchtop nullid nullid2
6653 set oldid [$patchtop.fromsha1 get]
6654 set newid [$patchtop.tosha1 get]
6655 set fname [$patchtop.fname get]
6656 set cmd [diffcmd [list $oldid $newid] -p]
6657 # trim off the initial "|"
6658 set cmd [lrange $cmd 1 end]
6659 lappend cmd >$fname &
6660 if {[catch {eval exec $cmd} err]} {
6661 error_popup "Error creating patch: $err"
6663 catch {destroy $patchtop}
6667 proc mkpatchcan {} {
6670 catch {destroy $patchtop}
6675 global rowmenuid mktagtop commitinfo
6679 catch {destroy $top}
6681 label $top.title -text "Create tag"
6682 grid $top.title - -pady 10
6683 label $top.id -text "ID:"
6684 entry $top.sha1 -width 40 -relief flat
6685 $top.sha1 insert 0 $rowmenuid
6686 $top.sha1 conf -state readonly
6687 grid $top.id $top.sha1 -sticky w
6688 entry $top.head -width 60 -relief flat
6689 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6690 $top.head conf -state readonly
6691 grid x $top.head -sticky w
6692 label $top.tlab -text "Tag name:"
6693 entry $top.tag -width 60
6694 grid $top.tlab $top.tag -sticky w
6696 button $top.buts.gen -text "Create" -command mktaggo
6697 button $top.buts.can -text "Cancel" -command mktagcan
6698 grid $top.buts.gen $top.buts.can
6699 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6700 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6701 grid $top.buts - -pady 10 -sticky ew
6706 global mktagtop env tagids idtags
6708 set id [$mktagtop.sha1 get]
6709 set tag [$mktagtop.tag get]
6711 error_popup "No tag name specified"
6714 if {[info exists tagids($tag)]} {
6715 error_popup "Tag \"$tag\" already exists"
6720 set fname [file join $dir "refs/tags" $tag]
6721 set f [open $fname w]
6725 error_popup "Error creating tag: $err"
6729 set tagids($tag) $id
6730 lappend idtags($id) $tag
6737 proc redrawtags {id} {
6738 global canv linehtag idpos selectedline curview
6739 global canvxmax iddrawn
6741 if {![commitinview $id $curview]} return
6742 if {![info exists iddrawn($id)]} return
6743 drawcommits [rowofcommit $id]
6744 $canv delete tag.$id
6745 set xt [eval drawtags $id $idpos($id)]
6746 $canv coords $linehtag([rowofcommit $id]) $xt [lindex $idpos($id) 2]
6747 set text [$canv itemcget $linehtag([rowofcommit $id]) -text]
6748 set xr [expr {$xt + [font measure mainfont $text]}]
6749 if {$xr > $canvxmax} {
6753 if {[info exists selectedline]
6754 && $selectedline == [rowofcommit $id]} {
6755 selectline $selectedline 0
6762 catch {destroy $mktagtop}
6771 proc writecommit {} {
6772 global rowmenuid wrcomtop commitinfo wrcomcmd
6774 set top .writecommit
6776 catch {destroy $top}
6778 label $top.title -text "Write commit to file"
6779 grid $top.title - -pady 10
6780 label $top.id -text "ID:"
6781 entry $top.sha1 -width 40 -relief flat
6782 $top.sha1 insert 0 $rowmenuid
6783 $top.sha1 conf -state readonly
6784 grid $top.id $top.sha1 -sticky w
6785 entry $top.head -width 60 -relief flat
6786 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6787 $top.head conf -state readonly
6788 grid x $top.head -sticky w
6789 label $top.clab -text "Command:"
6790 entry $top.cmd -width 60 -textvariable wrcomcmd
6791 grid $top.clab $top.cmd -sticky w -pady 10
6792 label $top.flab -text "Output file:"
6793 entry $top.fname -width 60
6794 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6795 grid $top.flab $top.fname -sticky w
6797 button $top.buts.gen -text "Write" -command wrcomgo
6798 button $top.buts.can -text "Cancel" -command wrcomcan
6799 grid $top.buts.gen $top.buts.can
6800 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6801 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6802 grid $top.buts - -pady 10 -sticky ew
6809 set id [$wrcomtop.sha1 get]
6810 set cmd "echo $id | [$wrcomtop.cmd get]"
6811 set fname [$wrcomtop.fname get]
6812 if {[catch {exec sh -c $cmd >$fname &} err]} {
6813 error_popup "Error writing commit: $err"
6815 catch {destroy $wrcomtop}
6822 catch {destroy $wrcomtop}
6827 global rowmenuid mkbrtop
6830 catch {destroy $top}
6832 label $top.title -text "Create new branch"
6833 grid $top.title - -pady 10
6834 label $top.id -text "ID:"
6835 entry $top.sha1 -width 40 -relief flat
6836 $top.sha1 insert 0 $rowmenuid
6837 $top.sha1 conf -state readonly
6838 grid $top.id $top.sha1 -sticky w
6839 label $top.nlab -text "Name:"
6840 entry $top.name -width 40
6841 grid $top.nlab $top.name -sticky w
6843 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6844 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6845 grid $top.buts.go $top.buts.can
6846 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6847 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6848 grid $top.buts - -pady 10 -sticky ew
6853 global headids idheads
6855 set name [$top.name get]
6856 set id [$top.sha1 get]
6858 error_popup "Please specify a name for the new branch"
6861 catch {destroy $top}
6865 exec git branch $name $id
6870 set headids($name) $id
6871 lappend idheads($id) $name
6880 proc cherrypick {} {
6881 global rowmenuid curview
6884 set oldhead [exec git rev-parse HEAD]
6885 set dheads [descheads $rowmenuid]
6886 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6887 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6888 included in branch $mainhead -- really re-apply it?"]
6891 nowbusy cherrypick "Cherry-picking"
6893 # Unfortunately git-cherry-pick writes stuff to stderr even when
6894 # no error occurs, and exec takes that as an indication of error...
6895 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6900 set newhead [exec git rev-parse HEAD]
6901 if {$newhead eq $oldhead} {
6903 error_popup "No changes committed"
6906 addnewchild $newhead $oldhead
6907 if {[commitinview $oldhead $curview]} {
6908 insertrow $newhead $oldhead $curview
6909 if {$mainhead ne {}} {
6910 movehead $newhead $mainhead
6911 movedhead $newhead $mainhead
6920 global mainheadid mainhead rowmenuid confirm_ok resettype
6923 set w ".confirmreset"
6926 wm title $w "Confirm reset"
6927 message $w.m -text \
6928 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6929 -justify center -aspect 1000
6930 pack $w.m -side top -fill x -padx 20 -pady 20
6931 frame $w.f -relief sunken -border 2
6932 message $w.f.rt -text "Reset type:" -aspect 1000
6933 grid $w.f.rt -sticky w
6935 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6936 -text "Soft: Leave working tree and index untouched"
6937 grid $w.f.soft -sticky w
6938 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6939 -text "Mixed: Leave working tree untouched, reset index"
6940 grid $w.f.mixed -sticky w
6941 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6942 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6943 grid $w.f.hard -sticky w
6944 pack $w.f -side top -fill x
6945 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6946 pack $w.ok -side left -fill x -padx 20 -pady 20
6947 button $w.cancel -text Cancel -command "destroy $w"
6948 pack $w.cancel -side right -fill x -padx 20 -pady 20
6949 bind $w <Visibility> "grab $w; focus $w"
6951 if {!$confirm_ok} return
6952 if {[catch {set fd [open \
6953 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6957 filerun $fd [list readresetstat $fd]
6958 nowbusy reset "Resetting"
6962 proc readresetstat {fd} {
6963 global mainhead mainheadid showlocalchanges rprogcoord
6965 if {[gets $fd line] >= 0} {
6966 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6967 set rprogcoord [expr {1.0 * $m / $n}]
6975 if {[catch {close $fd} err]} {
6978 set oldhead $mainheadid
6979 set newhead [exec git rev-parse HEAD]
6980 if {$newhead ne $oldhead} {
6981 movehead $newhead $mainhead
6982 movedhead $newhead $mainhead
6983 set mainheadid $newhead
6987 if {$showlocalchanges} {
6993 # context menu for a head
6994 proc headmenu {x y id head} {
6995 global headmenuid headmenuhead headctxmenu mainhead
6999 set headmenuhead $head
7001 if {$head eq $mainhead} {
7004 $headctxmenu entryconfigure 0 -state $state
7005 $headctxmenu entryconfigure 1 -state $state
7006 tk_popup $headctxmenu $x $y
7010 global headmenuid headmenuhead mainhead headids
7011 global showlocalchanges mainheadid
7013 # check the tree is clean first??
7014 set oldmainhead $mainhead
7015 nowbusy checkout "Checking out"
7019 exec git checkout -q $headmenuhead
7025 set mainhead $headmenuhead
7026 set mainheadid $headmenuid
7027 if {[info exists headids($oldmainhead)]} {
7028 redrawtags $headids($oldmainhead)
7030 redrawtags $headmenuid
7032 if {$showlocalchanges} {
7038 global headmenuid headmenuhead mainhead
7041 set head $headmenuhead
7043 # this check shouldn't be needed any more...
7044 if {$head eq $mainhead} {
7045 error_popup "Cannot delete the currently checked-out branch"
7048 set dheads [descheads $id]
7049 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7050 # the stuff on this branch isn't on any other branch
7051 if {![confirm_popup "The commits on branch $head aren't on any other\
7052 branch.\nReally delete branch $head?"]} return
7056 if {[catch {exec git branch -D $head} err]} {
7061 removehead $id $head
7062 removedhead $id $head
7069 # Display a list of tags and heads
7071 global showrefstop bgcolor fgcolor selectbgcolor
7072 global bglist fglist reflistfilter reflist maincursor
7075 set showrefstop $top
7076 if {[winfo exists $top]} {
7082 wm title $top "Tags and heads: [file tail [pwd]]"
7083 text $top.list -background $bgcolor -foreground $fgcolor \
7084 -selectbackground $selectbgcolor -font mainfont \
7085 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7086 -width 30 -height 20 -cursor $maincursor \
7087 -spacing1 1 -spacing3 1 -state disabled
7088 $top.list tag configure highlight -background $selectbgcolor
7089 lappend bglist $top.list
7090 lappend fglist $top.list
7091 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7092 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7093 grid $top.list $top.ysb -sticky nsew
7094 grid $top.xsb x -sticky ew
7096 label $top.f.l -text "Filter: " -font uifont
7097 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
7098 set reflistfilter "*"
7099 trace add variable reflistfilter write reflistfilter_change
7100 pack $top.f.e -side right -fill x -expand 1
7101 pack $top.f.l -side left
7102 grid $top.f - -sticky ew -pady 2
7103 button $top.close -command [list destroy $top] -text "Close" \
7106 grid columnconfigure $top 0 -weight 1
7107 grid rowconfigure $top 0 -weight 1
7108 bind $top.list <1> {break}
7109 bind $top.list <B1-Motion> {break}
7110 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7115 proc sel_reflist {w x y} {
7116 global showrefstop reflist headids tagids otherrefids
7118 if {![winfo exists $showrefstop]} return
7119 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7120 set ref [lindex $reflist [expr {$l-1}]]
7121 set n [lindex $ref 0]
7122 switch -- [lindex $ref 1] {
7123 "H" {selbyid $headids($n)}
7124 "T" {selbyid $tagids($n)}
7125 "o" {selbyid $otherrefids($n)}
7127 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7130 proc unsel_reflist {} {
7133 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7134 $showrefstop.list tag remove highlight 0.0 end
7137 proc reflistfilter_change {n1 n2 op} {
7138 global reflistfilter
7140 after cancel refill_reflist
7141 after 200 refill_reflist
7144 proc refill_reflist {} {
7145 global reflist reflistfilter showrefstop headids tagids otherrefids
7146 global curview commitinterest
7148 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7150 foreach n [array names headids] {
7151 if {[string match $reflistfilter $n]} {
7152 if {[commitinview $headids($n) $curview]} {
7153 lappend refs [list $n H]
7155 set commitinterest($headids($n)) {run refill_reflist}
7159 foreach n [array names tagids] {
7160 if {[string match $reflistfilter $n]} {
7161 if {[commitinview $tagids($n) $curview]} {
7162 lappend refs [list $n T]
7164 set commitinterest($tagids($n)) {run refill_reflist}
7168 foreach n [array names otherrefids] {
7169 if {[string match $reflistfilter $n]} {
7170 if {[commitinview $otherrefids($n) $curview]} {
7171 lappend refs [list $n o]
7173 set commitinterest($otherrefids($n)) {run refill_reflist}
7177 set refs [lsort -index 0 $refs]
7178 if {$refs eq $reflist} return
7180 # Update the contents of $showrefstop.list according to the
7181 # differences between $reflist (old) and $refs (new)
7182 $showrefstop.list conf -state normal
7183 $showrefstop.list insert end "\n"
7186 while {$i < [llength $reflist] || $j < [llength $refs]} {
7187 if {$i < [llength $reflist]} {
7188 if {$j < [llength $refs]} {
7189 set cmp [string compare [lindex $reflist $i 0] \
7190 [lindex $refs $j 0]]
7192 set cmp [string compare [lindex $reflist $i 1] \
7193 [lindex $refs $j 1]]
7203 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7211 set l [expr {$j + 1}]
7212 $showrefstop.list image create $l.0 -align baseline \
7213 -image reficon-[lindex $refs $j 1] -padx 2
7214 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7220 # delete last newline
7221 $showrefstop.list delete end-2c end-1c
7222 $showrefstop.list conf -state disabled
7225 # Stuff for finding nearby tags
7226 proc getallcommits {} {
7227 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7228 global idheads idtags idotherrefs allparents tagobjid
7230 if {![info exists allcommits]} {
7236 set allccache [file join [gitdir] "gitk.cache"]
7238 set f [open $allccache r]
7247 set cmd [list | git rev-list --parents]
7248 set allcupdate [expr {$seeds ne {}}]
7252 set refs [concat [array names idheads] [array names idtags] \
7253 [array names idotherrefs]]
7256 foreach name [array names tagobjid] {
7257 lappend tagobjs $tagobjid($name)
7259 foreach id [lsort -unique $refs] {
7260 if {![info exists allparents($id)] &&
7261 [lsearch -exact $tagobjs $id] < 0} {
7272 set fd [open [concat $cmd $ids] r]
7273 fconfigure $fd -blocking 0
7276 filerun $fd [list getallclines $fd]
7282 # Since most commits have 1 parent and 1 child, we group strings of
7283 # such commits into "arcs" joining branch/merge points (BMPs), which
7284 # are commits that either don't have 1 parent or don't have 1 child.
7286 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7287 # arcout(id) - outgoing arcs for BMP
7288 # arcids(a) - list of IDs on arc including end but not start
7289 # arcstart(a) - BMP ID at start of arc
7290 # arcend(a) - BMP ID at end of arc
7291 # growing(a) - arc a is still growing
7292 # arctags(a) - IDs out of arcids (excluding end) that have tags
7293 # archeads(a) - IDs out of arcids (excluding end) that have heads
7294 # The start of an arc is at the descendent end, so "incoming" means
7295 # coming from descendents, and "outgoing" means going towards ancestors.
7297 proc getallclines {fd} {
7298 global allparents allchildren idtags idheads nextarc
7299 global arcnos arcids arctags arcout arcend arcstart archeads growing
7300 global seeds allcommits cachedarcs allcupdate
7303 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7304 set id [lindex $line 0]
7305 if {[info exists allparents($id)]} {
7310 set olds [lrange $line 1 end]
7311 set allparents($id) $olds
7312 if {![info exists allchildren($id)]} {
7313 set allchildren($id) {}
7318 if {[llength $olds] == 1 && [llength $a] == 1} {
7319 lappend arcids($a) $id
7320 if {[info exists idtags($id)]} {
7321 lappend arctags($a) $id
7323 if {[info exists idheads($id)]} {
7324 lappend archeads($a) $id
7326 if {[info exists allparents($olds)]} {
7327 # seen parent already
7328 if {![info exists arcout($olds)]} {
7331 lappend arcids($a) $olds
7332 set arcend($a) $olds
7335 lappend allchildren($olds) $id
7336 lappend arcnos($olds) $a
7340 foreach a $arcnos($id) {
7341 lappend arcids($a) $id
7348 lappend allchildren($p) $id
7349 set a [incr nextarc]
7350 set arcstart($a) $id
7357 if {[info exists allparents($p)]} {
7358 # seen it already, may need to make a new branch
7359 if {![info exists arcout($p)]} {
7362 lappend arcids($a) $p
7366 lappend arcnos($p) $a
7371 global cached_dheads cached_dtags cached_atags
7372 catch {unset cached_dheads}
7373 catch {unset cached_dtags}
7374 catch {unset cached_atags}
7377 return [expr {$nid >= 1000? 2: 1}]
7381 fconfigure $fd -blocking 1
7384 # got an error reading the list of commits
7385 # if we were updating, try rereading the whole thing again
7391 error_popup "Error reading commit topology information;\
7392 branch and preceding/following tag information\
7393 will be incomplete.\n($err)"
7396 if {[incr allcommits -1] == 0} {
7406 proc recalcarc {a} {
7407 global arctags archeads arcids idtags idheads
7411 foreach id [lrange $arcids($a) 0 end-1] {
7412 if {[info exists idtags($id)]} {
7415 if {[info exists idheads($id)]} {
7420 set archeads($a) $ah
7424 global arcnos arcids nextarc arctags archeads idtags idheads
7425 global arcstart arcend arcout allparents growing
7428 if {[llength $a] != 1} {
7429 puts "oops splitarc called but [llength $a] arcs already"
7433 set i [lsearch -exact $arcids($a) $p]
7435 puts "oops splitarc $p not in arc $a"
7438 set na [incr nextarc]
7439 if {[info exists arcend($a)]} {
7440 set arcend($na) $arcend($a)
7442 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7443 set j [lsearch -exact $arcnos($l) $a]
7444 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7446 set tail [lrange $arcids($a) [expr {$i+1}] end]
7447 set arcids($a) [lrange $arcids($a) 0 $i]
7449 set arcstart($na) $p
7451 set arcids($na) $tail
7452 if {[info exists growing($a)]} {
7458 if {[llength $arcnos($id)] == 1} {
7461 set j [lsearch -exact $arcnos($id) $a]
7462 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7466 # reconstruct tags and heads lists
7467 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7472 set archeads($na) {}
7476 # Update things for a new commit added that is a child of one
7477 # existing commit. Used when cherry-picking.
7478 proc addnewchild {id p} {
7479 global allparents allchildren idtags nextarc
7480 global arcnos arcids arctags arcout arcend arcstart archeads growing
7481 global seeds allcommits
7483 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7484 set allparents($id) [list $p]
7485 set allchildren($id) {}
7488 lappend allchildren($p) $id
7489 set a [incr nextarc]
7490 set arcstart($a) $id
7493 set arcids($a) [list $p]
7495 if {![info exists arcout($p)]} {
7498 lappend arcnos($p) $a
7499 set arcout($id) [list $a]
7502 # This implements a cache for the topology information.
7503 # The cache saves, for each arc, the start and end of the arc,
7504 # the ids on the arc, and the outgoing arcs from the end.
7505 proc readcache {f} {
7506 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7507 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7512 if {$lim - $a > 500} {
7513 set lim [expr {$a + 500}]
7517 # finish reading the cache and setting up arctags, etc.
7519 if {$line ne "1"} {error "bad final version"}
7521 foreach id [array names idtags] {
7522 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7523 [llength $allparents($id)] == 1} {
7524 set a [lindex $arcnos($id) 0]
7525 if {$arctags($a) eq {}} {
7530 foreach id [array names idheads] {
7531 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7532 [llength $allparents($id)] == 1} {
7533 set a [lindex $arcnos($id) 0]
7534 if {$archeads($a) eq {}} {
7539 foreach id [lsort -unique $possible_seeds] {
7540 if {$arcnos($id) eq {}} {
7546 while {[incr a] <= $lim} {
7548 if {[llength $line] != 3} {error "bad line"}
7549 set s [lindex $line 0]
7551 lappend arcout($s) $a
7552 if {![info exists arcnos($s)]} {
7553 lappend possible_seeds $s
7556 set e [lindex $line 1]
7561 if {![info exists arcout($e)]} {
7565 set arcids($a) [lindex $line 2]
7566 foreach id $arcids($a) {
7567 lappend allparents($s) $id
7569 lappend arcnos($id) $a
7571 if {![info exists allparents($s)]} {
7572 set allparents($s) {}
7577 set nextarc [expr {$a - 1}]
7590 global nextarc cachedarcs possible_seeds
7594 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7595 # make sure it's an integer
7596 set cachedarcs [expr {int([lindex $line 1])}]
7597 if {$cachedarcs < 0} {error "bad number of arcs"}
7599 set possible_seeds {}
7607 proc dropcache {err} {
7608 global allcwait nextarc cachedarcs seeds
7610 #puts "dropping cache ($err)"
7611 foreach v {arcnos arcout arcids arcstart arcend growing \
7612 arctags archeads allparents allchildren} {
7623 proc writecache {f} {
7624 global cachearc cachedarcs allccache
7625 global arcstart arcend arcnos arcids arcout
7629 if {$lim - $a > 1000} {
7630 set lim [expr {$a + 1000}]
7633 while {[incr a] <= $lim} {
7634 if {[info exists arcend($a)]} {
7635 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7637 puts $f [list $arcstart($a) {} $arcids($a)]
7642 catch {file delete $allccache}
7643 #puts "writing cache failed ($err)"
7646 set cachearc [expr {$a - 1}]
7647 if {$a > $cachedarcs} {
7656 global nextarc cachedarcs cachearc allccache
7658 if {$nextarc == $cachedarcs} return
7660 set cachedarcs $nextarc
7662 set f [open $allccache w]
7663 puts $f [list 1 $cachedarcs]
7668 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7669 # or 0 if neither is true.
7670 proc anc_or_desc {a b} {
7671 global arcout arcstart arcend arcnos cached_isanc
7673 if {$arcnos($a) eq $arcnos($b)} {
7674 # Both are on the same arc(s); either both are the same BMP,
7675 # or if one is not a BMP, the other is also not a BMP or is
7676 # the BMP at end of the arc (and it only has 1 incoming arc).
7677 # Or both can be BMPs with no incoming arcs.
7678 if {$a eq $b || $arcnos($a) eq {}} {
7681 # assert {[llength $arcnos($a)] == 1}
7682 set arc [lindex $arcnos($a) 0]
7683 set i [lsearch -exact $arcids($arc) $a]
7684 set j [lsearch -exact $arcids($arc) $b]
7685 if {$i < 0 || $i > $j} {
7692 if {![info exists arcout($a)]} {
7693 set arc [lindex $arcnos($a) 0]
7694 if {[info exists arcend($arc)]} {
7695 set aend $arcend($arc)
7699 set a $arcstart($arc)
7703 if {![info exists arcout($b)]} {
7704 set arc [lindex $arcnos($b) 0]
7705 if {[info exists arcend($arc)]} {
7706 set bend $arcend($arc)
7710 set b $arcstart($arc)
7720 if {[info exists cached_isanc($a,$bend)]} {
7721 if {$cached_isanc($a,$bend)} {
7725 if {[info exists cached_isanc($b,$aend)]} {
7726 if {$cached_isanc($b,$aend)} {
7729 if {[info exists cached_isanc($a,$bend)]} {
7734 set todo [list $a $b]
7737 for {set i 0} {$i < [llength $todo]} {incr i} {
7738 set x [lindex $todo $i]
7739 if {$anc($x) eq {}} {
7742 foreach arc $arcnos($x) {
7743 set xd $arcstart($arc)
7745 set cached_isanc($a,$bend) 1
7746 set cached_isanc($b,$aend) 0
7748 } elseif {$xd eq $aend} {
7749 set cached_isanc($b,$aend) 1
7750 set cached_isanc($a,$bend) 0
7753 if {![info exists anc($xd)]} {
7754 set anc($xd) $anc($x)
7756 } elseif {$anc($xd) ne $anc($x)} {
7761 set cached_isanc($a,$bend) 0
7762 set cached_isanc($b,$aend) 0
7766 # This identifies whether $desc has an ancestor that is
7767 # a growing tip of the graph and which is not an ancestor of $anc
7768 # and returns 0 if so and 1 if not.
7769 # If we subsequently discover a tag on such a growing tip, and that
7770 # turns out to be a descendent of $anc (which it could, since we
7771 # don't necessarily see children before parents), then $desc
7772 # isn't a good choice to display as a descendent tag of
7773 # $anc (since it is the descendent of another tag which is
7774 # a descendent of $anc). Similarly, $anc isn't a good choice to
7775 # display as a ancestor tag of $desc.
7777 proc is_certain {desc anc} {
7778 global arcnos arcout arcstart arcend growing problems
7781 if {[llength $arcnos($anc)] == 1} {
7782 # tags on the same arc are certain
7783 if {$arcnos($desc) eq $arcnos($anc)} {
7786 if {![info exists arcout($anc)]} {
7787 # if $anc is partway along an arc, use the start of the arc instead
7788 set a [lindex $arcnos($anc) 0]
7789 set anc $arcstart($a)
7792 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7795 set a [lindex $arcnos($desc) 0]
7801 set anclist [list $x]
7805 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7806 set x [lindex $anclist $i]
7811 foreach a $arcout($x) {
7812 if {[info exists growing($a)]} {
7813 if {![info exists growanc($x)] && $dl($x)} {
7819 if {[info exists dl($y)]} {
7823 if {![info exists done($y)]} {
7826 if {[info exists growanc($x)]} {
7830 for {set k 0} {$k < [llength $xl]} {incr k} {
7831 set z [lindex $xl $k]
7832 foreach c $arcout($z) {
7833 if {[info exists arcend($c)]} {
7835 if {[info exists dl($v)] && $dl($v)} {
7837 if {![info exists done($v)]} {
7840 if {[info exists growanc($v)]} {
7850 } elseif {$y eq $anc || !$dl($x)} {
7861 foreach x [array names growanc] {
7870 proc validate_arctags {a} {
7871 global arctags idtags
7875 foreach id $arctags($a) {
7877 if {![info exists idtags($id)]} {
7878 set na [lreplace $na $i $i]
7885 proc validate_archeads {a} {
7886 global archeads idheads
7889 set na $archeads($a)
7890 foreach id $archeads($a) {
7892 if {![info exists idheads($id)]} {
7893 set na [lreplace $na $i $i]
7897 set archeads($a) $na
7900 # Return the list of IDs that have tags that are descendents of id,
7901 # ignoring IDs that are descendents of IDs already reported.
7902 proc desctags {id} {
7903 global arcnos arcstart arcids arctags idtags allparents
7904 global growing cached_dtags
7906 if {![info exists allparents($id)]} {
7909 set t1 [clock clicks -milliseconds]
7911 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7912 # part-way along an arc; check that arc first
7913 set a [lindex $arcnos($id) 0]
7914 if {$arctags($a) ne {}} {
7916 set i [lsearch -exact $arcids($a) $id]
7918 foreach t $arctags($a) {
7919 set j [lsearch -exact $arcids($a) $t]
7927 set id $arcstart($a)
7928 if {[info exists idtags($id)]} {
7932 if {[info exists cached_dtags($id)]} {
7933 return $cached_dtags($id)
7940 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7941 set id [lindex $todo $i]
7943 set ta [info exists hastaggedancestor($id)]
7947 # ignore tags on starting node
7948 if {!$ta && $i > 0} {
7949 if {[info exists idtags($id)]} {
7952 } elseif {[info exists cached_dtags($id)]} {
7953 set tagloc($id) $cached_dtags($id)
7957 foreach a $arcnos($id) {
7959 if {!$ta && $arctags($a) ne {}} {
7961 if {$arctags($a) ne {}} {
7962 lappend tagloc($id) [lindex $arctags($a) end]
7965 if {$ta || $arctags($a) ne {}} {
7966 set tomark [list $d]
7967 for {set j 0} {$j < [llength $tomark]} {incr j} {
7968 set dd [lindex $tomark $j]
7969 if {![info exists hastaggedancestor($dd)]} {
7970 if {[info exists done($dd)]} {
7971 foreach b $arcnos($dd) {
7972 lappend tomark $arcstart($b)
7974 if {[info exists tagloc($dd)]} {
7977 } elseif {[info exists queued($dd)]} {
7980 set hastaggedancestor($dd) 1
7984 if {![info exists queued($d)]} {
7987 if {![info exists hastaggedancestor($d)]} {
7994 foreach id [array names tagloc] {
7995 if {![info exists hastaggedancestor($id)]} {
7996 foreach t $tagloc($id) {
7997 if {[lsearch -exact $tags $t] < 0} {
8003 set t2 [clock clicks -milliseconds]
8006 # remove tags that are descendents of other tags
8007 for {set i 0} {$i < [llength $tags]} {incr i} {
8008 set a [lindex $tags $i]
8009 for {set j 0} {$j < $i} {incr j} {
8010 set b [lindex $tags $j]
8011 set r [anc_or_desc $a $b]
8013 set tags [lreplace $tags $j $j]
8016 } elseif {$r == -1} {
8017 set tags [lreplace $tags $i $i]
8024 if {[array names growing] ne {}} {
8025 # graph isn't finished, need to check if any tag could get
8026 # eclipsed by another tag coming later. Simply ignore any
8027 # tags that could later get eclipsed.
8030 if {[is_certain $t $origid]} {
8034 if {$tags eq $ctags} {
8035 set cached_dtags($origid) $tags
8040 set cached_dtags($origid) $tags
8042 set t3 [clock clicks -milliseconds]
8043 if {0 && $t3 - $t1 >= 100} {
8044 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8045 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8051 global arcnos arcids arcout arcend arctags idtags allparents
8052 global growing cached_atags
8054 if {![info exists allparents($id)]} {
8057 set t1 [clock clicks -milliseconds]
8059 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8060 # part-way along an arc; check that arc first
8061 set a [lindex $arcnos($id) 0]
8062 if {$arctags($a) ne {}} {
8064 set i [lsearch -exact $arcids($a) $id]
8065 foreach t $arctags($a) {
8066 set j [lsearch -exact $arcids($a) $t]
8072 if {![info exists arcend($a)]} {
8076 if {[info exists idtags($id)]} {
8080 if {[info exists cached_atags($id)]} {
8081 return $cached_atags($id)
8089 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8090 set id [lindex $todo $i]
8092 set td [info exists hastaggeddescendent($id)]
8096 # ignore tags on starting node
8097 if {!$td && $i > 0} {
8098 if {[info exists idtags($id)]} {
8101 } elseif {[info exists cached_atags($id)]} {
8102 set tagloc($id) $cached_atags($id)
8106 foreach a $arcout($id) {
8107 if {!$td && $arctags($a) ne {}} {
8109 if {$arctags($a) ne {}} {
8110 lappend tagloc($id) [lindex $arctags($a) 0]
8113 if {![info exists arcend($a)]} continue
8115 if {$td || $arctags($a) ne {}} {
8116 set tomark [list $d]
8117 for {set j 0} {$j < [llength $tomark]} {incr j} {
8118 set dd [lindex $tomark $j]
8119 if {![info exists hastaggeddescendent($dd)]} {
8120 if {[info exists done($dd)]} {
8121 foreach b $arcout($dd) {
8122 if {[info exists arcend($b)]} {
8123 lappend tomark $arcend($b)
8126 if {[info exists tagloc($dd)]} {
8129 } elseif {[info exists queued($dd)]} {
8132 set hastaggeddescendent($dd) 1
8136 if {![info exists queued($d)]} {
8139 if {![info exists hastaggeddescendent($d)]} {
8145 set t2 [clock clicks -milliseconds]
8148 foreach id [array names tagloc] {
8149 if {![info exists hastaggeddescendent($id)]} {
8150 foreach t $tagloc($id) {
8151 if {[lsearch -exact $tags $t] < 0} {
8158 # remove tags that are ancestors of other tags
8159 for {set i 0} {$i < [llength $tags]} {incr i} {
8160 set a [lindex $tags $i]
8161 for {set j 0} {$j < $i} {incr j} {
8162 set b [lindex $tags $j]
8163 set r [anc_or_desc $a $b]
8165 set tags [lreplace $tags $j $j]
8168 } elseif {$r == 1} {
8169 set tags [lreplace $tags $i $i]
8176 if {[array names growing] ne {}} {
8177 # graph isn't finished, need to check if any tag could get
8178 # eclipsed by another tag coming later. Simply ignore any
8179 # tags that could later get eclipsed.
8182 if {[is_certain $origid $t]} {
8186 if {$tags eq $ctags} {
8187 set cached_atags($origid) $tags
8192 set cached_atags($origid) $tags
8194 set t3 [clock clicks -milliseconds]
8195 if {0 && $t3 - $t1 >= 100} {
8196 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8197 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8202 # Return the list of IDs that have heads that are descendents of id,
8203 # including id itself if it has a head.
8204 proc descheads {id} {
8205 global arcnos arcstart arcids archeads idheads cached_dheads
8208 if {![info exists allparents($id)]} {
8212 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8213 # part-way along an arc; check it first
8214 set a [lindex $arcnos($id) 0]
8215 if {$archeads($a) ne {}} {
8216 validate_archeads $a
8217 set i [lsearch -exact $arcids($a) $id]
8218 foreach t $archeads($a) {
8219 set j [lsearch -exact $arcids($a) $t]
8224 set id $arcstart($a)
8230 for {set i 0} {$i < [llength $todo]} {incr i} {
8231 set id [lindex $todo $i]
8232 if {[info exists cached_dheads($id)]} {
8233 set ret [concat $ret $cached_dheads($id)]
8235 if {[info exists idheads($id)]} {
8238 foreach a $arcnos($id) {
8239 if {$archeads($a) ne {}} {
8240 validate_archeads $a
8241 if {$archeads($a) ne {}} {
8242 set ret [concat $ret $archeads($a)]
8246 if {![info exists seen($d)]} {
8253 set ret [lsort -unique $ret]
8254 set cached_dheads($origid) $ret
8255 return [concat $ret $aret]
8258 proc addedtag {id} {
8259 global arcnos arcout cached_dtags cached_atags
8261 if {![info exists arcnos($id)]} return
8262 if {![info exists arcout($id)]} {
8263 recalcarc [lindex $arcnos($id) 0]
8265 catch {unset cached_dtags}
8266 catch {unset cached_atags}
8269 proc addedhead {hid head} {
8270 global arcnos arcout cached_dheads
8272 if {![info exists arcnos($hid)]} return
8273 if {![info exists arcout($hid)]} {
8274 recalcarc [lindex $arcnos($hid) 0]
8276 catch {unset cached_dheads}
8279 proc removedhead {hid head} {
8280 global cached_dheads
8282 catch {unset cached_dheads}
8285 proc movedhead {hid head} {
8286 global arcnos arcout cached_dheads
8288 if {![info exists arcnos($hid)]} return
8289 if {![info exists arcout($hid)]} {
8290 recalcarc [lindex $arcnos($hid) 0]
8292 catch {unset cached_dheads}
8295 proc changedrefs {} {
8296 global cached_dheads cached_dtags cached_atags
8297 global arctags archeads arcnos arcout idheads idtags
8299 foreach id [concat [array names idheads] [array names idtags]] {
8300 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8301 set a [lindex $arcnos($id) 0]
8302 if {![info exists donearc($a)]} {
8308 catch {unset cached_dtags}
8309 catch {unset cached_atags}
8310 catch {unset cached_dheads}
8313 proc rereadrefs {} {
8314 global idtags idheads idotherrefs mainhead
8316 set refids [concat [array names idtags] \
8317 [array names idheads] [array names idotherrefs]]
8318 foreach id $refids {
8319 if {![info exists ref($id)]} {
8320 set ref($id) [listrefs $id]
8323 set oldmainhead $mainhead
8326 set refids [lsort -unique [concat $refids [array names idtags] \
8327 [array names idheads] [array names idotherrefs]]]
8328 foreach id $refids {
8329 set v [listrefs $id]
8330 if {![info exists ref($id)] || $ref($id) != $v ||
8331 ($id eq $oldmainhead && $id ne $mainhead) ||
8332 ($id eq $mainhead && $id ne $oldmainhead)} {
8339 proc listrefs {id} {
8340 global idtags idheads idotherrefs
8343 if {[info exists idtags($id)]} {
8347 if {[info exists idheads($id)]} {
8351 if {[info exists idotherrefs($id)]} {
8352 set z $idotherrefs($id)
8354 return [list $x $y $z]
8357 proc showtag {tag isnew} {
8358 global ctext tagcontents tagids linknum tagobjid
8361 addtohistory [list showtag $tag 0]
8363 $ctext conf -state normal
8367 if {![info exists tagcontents($tag)]} {
8369 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8372 if {[info exists tagcontents($tag)]} {
8373 set text $tagcontents($tag)
8375 set text "Tag: $tag\nId: $tagids($tag)"
8377 appendwithlinks $text {}
8378 $ctext conf -state disabled
8389 proc mkfontdisp {font top which} {
8390 global fontattr fontpref $font
8392 set fontpref($font) [set $font]
8393 button $top.${font}but -text $which -font optionfont \
8394 -command [list choosefont $font $which]
8395 label $top.$font -relief flat -font $font \
8396 -text $fontattr($font,family) -justify left
8397 grid x $top.${font}but $top.$font -sticky w
8400 proc choosefont {font which} {
8401 global fontparam fontlist fonttop fontattr
8403 set fontparam(which) $which
8404 set fontparam(font) $font
8405 set fontparam(family) [font actual $font -family]
8406 set fontparam(size) $fontattr($font,size)
8407 set fontparam(weight) $fontattr($font,weight)
8408 set fontparam(slant) $fontattr($font,slant)
8411 if {![winfo exists $top]} {
8413 eval font config sample [font actual $font]
8415 wm title $top "Gitk font chooser"
8416 label $top.l -textvariable fontparam(which) -font uifont
8417 pack $top.l -side top
8418 set fontlist [lsort [font families]]
8420 listbox $top.f.fam -listvariable fontlist \
8421 -yscrollcommand [list $top.f.sb set]
8422 bind $top.f.fam <<ListboxSelect>> selfontfam
8423 scrollbar $top.f.sb -command [list $top.f.fam yview]
8424 pack $top.f.sb -side right -fill y
8425 pack $top.f.fam -side left -fill both -expand 1
8426 pack $top.f -side top -fill both -expand 1
8428 spinbox $top.g.size -from 4 -to 40 -width 4 \
8429 -textvariable fontparam(size) \
8430 -validatecommand {string is integer -strict %s}
8431 checkbutton $top.g.bold -padx 5 \
8432 -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
8433 -variable fontparam(weight) -onvalue bold -offvalue normal
8434 checkbutton $top.g.ital -padx 5 \
8435 -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0 \
8436 -variable fontparam(slant) -onvalue italic -offvalue roman
8437 pack $top.g.size $top.g.bold $top.g.ital -side left
8438 pack $top.g -side top
8439 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8441 $top.c create text 100 25 -anchor center -text $which -font sample \
8442 -fill black -tags text
8443 bind $top.c <Configure> [list centertext $top.c]
8444 pack $top.c -side top -fill x
8446 button $top.buts.ok -text "OK" -command fontok -default active \
8448 button $top.buts.can -text "Cancel" -command fontcan -default normal \
8450 grid $top.buts.ok $top.buts.can
8451 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8452 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8453 pack $top.buts -side bottom -fill x
8454 trace add variable fontparam write chg_fontparam
8457 $top.c itemconf text -text $which
8459 set i [lsearch -exact $fontlist $fontparam(family)]
8461 $top.f.fam selection set $i
8466 proc centertext {w} {
8467 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8471 global fontparam fontpref prefstop
8473 set f $fontparam(font)
8474 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8475 if {$fontparam(weight) eq "bold"} {
8476 lappend fontpref($f) "bold"
8478 if {$fontparam(slant) eq "italic"} {
8479 lappend fontpref($f) "italic"
8482 $w conf -text $fontparam(family) -font $fontpref($f)
8488 global fonttop fontparam
8490 if {[info exists fonttop]} {
8491 catch {destroy $fonttop}
8492 catch {font delete sample}
8498 proc selfontfam {} {
8499 global fonttop fontparam
8501 set i [$fonttop.f.fam curselection]
8503 set fontparam(family) [$fonttop.f.fam get $i]
8507 proc chg_fontparam {v sub op} {
8510 font config sample -$sub $fontparam($sub)
8514 global maxwidth maxgraphpct
8515 global oldprefs prefstop showneartags showlocalchanges
8516 global bgcolor fgcolor ctext diffcolors selectbgcolor
8517 global uifont tabstop limitdiffs
8521 if {[winfo exists $top]} {
8525 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8526 limitdiffs tabstop} {
8527 set oldprefs($v) [set $v]
8530 wm title $top "Gitk preferences"
8531 label $top.ldisp -text "Commit list display options"
8532 $top.ldisp configure -font uifont
8533 grid $top.ldisp - -sticky w -pady 10
8534 label $top.spacer -text " "
8535 label $top.maxwidthl -text "Maximum graph width (lines)" \
8537 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8538 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8539 label $top.maxpctl -text "Maximum graph width (% of pane)" \
8541 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8542 grid x $top.maxpctl $top.maxpct -sticky w
8543 frame $top.showlocal
8544 label $top.showlocal.l -text "Show local changes" -font optionfont
8545 checkbutton $top.showlocal.b -variable showlocalchanges
8546 pack $top.showlocal.b $top.showlocal.l -side left
8547 grid x $top.showlocal -sticky w
8549 label $top.ddisp -text "Diff display options"
8550 $top.ddisp configure -font uifont
8551 grid $top.ddisp - -sticky w -pady 10
8552 label $top.tabstopl -text "Tab spacing" -font optionfont
8553 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8554 grid x $top.tabstopl $top.tabstop -sticky w
8556 label $top.ntag.l -text "Display nearby tags" -font optionfont
8557 checkbutton $top.ntag.b -variable showneartags
8558 pack $top.ntag.b $top.ntag.l -side left
8559 grid x $top.ntag -sticky w
8561 label $top.ldiff.l -text "Limit diffs to listed paths" -font optionfont
8562 checkbutton $top.ldiff.b -variable limitdiffs
8563 pack $top.ldiff.b $top.ldiff.l -side left
8564 grid x $top.ldiff -sticky w
8566 label $top.cdisp -text "Colors: press to choose"
8567 $top.cdisp configure -font uifont
8568 grid $top.cdisp - -sticky w -pady 10
8569 label $top.bg -padx 40 -relief sunk -background $bgcolor
8570 button $top.bgbut -text "Background" -font optionfont \
8571 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8572 grid x $top.bgbut $top.bg -sticky w
8573 label $top.fg -padx 40 -relief sunk -background $fgcolor
8574 button $top.fgbut -text "Foreground" -font optionfont \
8575 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8576 grid x $top.fgbut $top.fg -sticky w
8577 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8578 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8579 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8580 [list $ctext tag conf d0 -foreground]]
8581 grid x $top.diffoldbut $top.diffold -sticky w
8582 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8583 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8584 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8585 [list $ctext tag conf d1 -foreground]]
8586 grid x $top.diffnewbut $top.diffnew -sticky w
8587 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8588 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8589 -command [list choosecolor diffcolors 2 $top.hunksep \
8590 "diff hunk header" \
8591 [list $ctext tag conf hunksep -foreground]]
8592 grid x $top.hunksepbut $top.hunksep -sticky w
8593 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8594 button $top.selbgbut -text "Select bg" -font optionfont \
8595 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8596 grid x $top.selbgbut $top.selbgsep -sticky w
8598 label $top.cfont -text "Fonts: press to choose"
8599 $top.cfont configure -font uifont
8600 grid $top.cfont - -sticky w -pady 10
8601 mkfontdisp mainfont $top "Main font"
8602 mkfontdisp textfont $top "Diff display font"
8603 mkfontdisp uifont $top "User interface font"
8606 button $top.buts.ok -text "OK" -command prefsok -default active
8607 $top.buts.ok configure -font uifont
8608 button $top.buts.can -text "Cancel" -command prefscan -default normal
8609 $top.buts.can configure -font uifont
8610 grid $top.buts.ok $top.buts.can
8611 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8612 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8613 grid $top.buts - - -pady 10 -sticky ew
8614 bind $top <Visibility> "focus $top.buts.ok"
8617 proc choosecolor {v vi w x cmd} {
8620 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8621 -title "Gitk: choose color for $x"]
8622 if {$c eq {}} return
8623 $w conf -background $c
8629 global bglist cflist
8631 $w configure -selectbackground $c
8633 $cflist tag configure highlight \
8634 -background [$cflist cget -selectbackground]
8635 allcanvs itemconf secsel -fill $c
8642 $w conf -background $c
8650 $w conf -foreground $c
8652 allcanvs itemconf text -fill $c
8653 $canv itemconf circle -outline $c
8657 global oldprefs prefstop
8659 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8660 limitdiffs tabstop} {
8662 set $v $oldprefs($v)
8664 catch {destroy $prefstop}
8670 global maxwidth maxgraphpct
8671 global oldprefs prefstop showneartags showlocalchanges
8672 global fontpref mainfont textfont uifont
8673 global limitdiffs treediffs
8675 catch {destroy $prefstop}
8679 if {$mainfont ne $fontpref(mainfont)} {
8680 set mainfont $fontpref(mainfont)
8681 parsefont mainfont $mainfont
8682 eval font configure mainfont [fontflags mainfont]
8683 eval font configure mainfontbold [fontflags mainfont 1]
8687 if {$textfont ne $fontpref(textfont)} {
8688 set textfont $fontpref(textfont)
8689 parsefont textfont $textfont
8690 eval font configure textfont [fontflags textfont]
8691 eval font configure textfontbold [fontflags textfont 1]
8693 if {$uifont ne $fontpref(uifont)} {
8694 set uifont $fontpref(uifont)
8695 parsefont uifont $uifont
8696 eval font configure uifont [fontflags uifont]
8699 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8700 if {$showlocalchanges} {
8706 if {$limitdiffs != $oldprefs(limitdiffs)} {
8707 # treediffs elements are limited by path
8708 catch {unset treediffs}
8710 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8711 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8713 } elseif {$showneartags != $oldprefs(showneartags) ||
8714 $limitdiffs != $oldprefs(limitdiffs)} {
8719 proc formatdate {d} {
8720 global datetimeformat
8722 set d [clock format $d -format $datetimeformat]
8727 # This list of encoding names and aliases is distilled from
8728 # http://www.iana.org/assignments/character-sets.
8729 # Not all of them are supported by Tcl.
8730 set encoding_aliases {
8731 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8732 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8733 { ISO-10646-UTF-1 csISO10646UTF1 }
8734 { ISO_646.basic:1983 ref csISO646basic1983 }
8735 { INVARIANT csINVARIANT }
8736 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8737 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8738 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8739 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8740 { NATS-DANO iso-ir-9-1 csNATSDANO }
8741 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8742 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8743 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8744 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8745 { ISO-2022-KR csISO2022KR }
8747 { ISO-2022-JP csISO2022JP }
8748 { ISO-2022-JP-2 csISO2022JP2 }
8749 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8751 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8752 { IT iso-ir-15 ISO646-IT csISO15Italian }
8753 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8754 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8755 { greek7-old iso-ir-18 csISO18Greek7Old }
8756 { latin-greek iso-ir-19 csISO19LatinGreek }
8757 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8758 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8759 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8760 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8761 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8762 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8763 { INIS iso-ir-49 csISO49INIS }
8764 { INIS-8 iso-ir-50 csISO50INIS8 }
8765 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8766 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8767 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8768 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8769 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8770 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8772 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8773 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8774 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8775 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8776 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8777 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8778 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8779 { greek7 iso-ir-88 csISO88Greek7 }
8780 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8781 { iso-ir-90 csISO90 }
8782 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8783 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8784 csISO92JISC62991984b }
8785 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8786 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8787 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8788 csISO95JIS62291984handadd }
8789 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8790 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8791 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8792 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8794 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8795 { T.61-7bit iso-ir-102 csISO102T617bit }
8796 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8797 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8798 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8799 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8800 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8801 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8802 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8803 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8804 arabic csISOLatinArabic }
8805 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8806 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8807 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8808 greek greek8 csISOLatinGreek }
8809 { T.101-G2 iso-ir-128 csISO128T101G2 }
8810 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8812 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8813 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8814 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8815 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8816 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8817 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8818 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8819 csISOLatinCyrillic }
8820 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8821 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8822 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8823 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8824 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8825 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8826 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8827 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8828 { ISO_10367-box iso-ir-155 csISO10367Box }
8829 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8830 { latin-lap lap iso-ir-158 csISO158Lap }
8831 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8832 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8835 { JIS_X0201 X0201 csHalfWidthKatakana }
8836 { KSC5636 ISO646-KR csKSC5636 }
8837 { ISO-10646-UCS-2 csUnicode }
8838 { ISO-10646-UCS-4 csUCS4 }
8839 { DEC-MCS dec csDECMCS }
8840 { hp-roman8 roman8 r8 csHPRoman8 }
8841 { macintosh mac csMacintosh }
8842 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8844 { IBM038 EBCDIC-INT cp038 csIBM038 }
8845 { IBM273 CP273 csIBM273 }
8846 { IBM274 EBCDIC-BE CP274 csIBM274 }
8847 { IBM275 EBCDIC-BR cp275 csIBM275 }
8848 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8849 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8850 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8851 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8852 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8853 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8854 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8855 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8856 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8857 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8858 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8859 { IBM437 cp437 437 csPC8CodePage437 }
8860 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8861 { IBM775 cp775 csPC775Baltic }
8862 { IBM850 cp850 850 csPC850Multilingual }
8863 { IBM851 cp851 851 csIBM851 }
8864 { IBM852 cp852 852 csPCp852 }
8865 { IBM855 cp855 855 csIBM855 }
8866 { IBM857 cp857 857 csIBM857 }
8867 { IBM860 cp860 860 csIBM860 }
8868 { IBM861 cp861 861 cp-is csIBM861 }
8869 { IBM862 cp862 862 csPC862LatinHebrew }
8870 { IBM863 cp863 863 csIBM863 }
8871 { IBM864 cp864 csIBM864 }
8872 { IBM865 cp865 865 csIBM865 }
8873 { IBM866 cp866 866 csIBM866 }
8874 { IBM868 CP868 cp-ar csIBM868 }
8875 { IBM869 cp869 869 cp-gr csIBM869 }
8876 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8877 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8878 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8879 { IBM891 cp891 csIBM891 }
8880 { IBM903 cp903 csIBM903 }
8881 { IBM904 cp904 904 csIBBM904 }
8882 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8883 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8884 { IBM1026 CP1026 csIBM1026 }
8885 { EBCDIC-AT-DE csIBMEBCDICATDE }
8886 { EBCDIC-AT-DE-A csEBCDICATDEA }
8887 { EBCDIC-CA-FR csEBCDICCAFR }
8888 { EBCDIC-DK-NO csEBCDICDKNO }
8889 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8890 { EBCDIC-FI-SE csEBCDICFISE }
8891 { EBCDIC-FI-SE-A csEBCDICFISEA }
8892 { EBCDIC-FR csEBCDICFR }
8893 { EBCDIC-IT csEBCDICIT }
8894 { EBCDIC-PT csEBCDICPT }
8895 { EBCDIC-ES csEBCDICES }
8896 { EBCDIC-ES-A csEBCDICESA }
8897 { EBCDIC-ES-S csEBCDICESS }
8898 { EBCDIC-UK csEBCDICUK }
8899 { EBCDIC-US csEBCDICUS }
8900 { UNKNOWN-8BIT csUnknown8BiT }
8901 { MNEMONIC csMnemonic }
8906 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8907 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8908 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8909 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8910 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8911 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8912 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8913 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8914 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8915 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8916 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8917 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8918 { IBM1047 IBM-1047 }
8919 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8920 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8921 { UNICODE-1-1 csUnicode11 }
8924 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8925 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8927 { ISO-8859-15 ISO_8859-15 Latin-9 }
8928 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8929 { GBK CP936 MS936 windows-936 }
8930 { JIS_Encoding csJISEncoding }
8931 { Shift_JIS MS_Kanji csShiftJIS }
8932 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8934 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8935 { ISO-10646-UCS-Basic csUnicodeASCII }
8936 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8937 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8938 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8939 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8940 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8941 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8942 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8943 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8944 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8945 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8946 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8947 { Ventura-US csVenturaUS }
8948 { Ventura-International csVenturaInternational }
8949 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8950 { PC8-Turkish csPC8Turkish }
8951 { IBM-Symbols csIBMSymbols }
8952 { IBM-Thai csIBMThai }
8953 { HP-Legal csHPLegal }
8954 { HP-Pi-font csHPPiFont }
8955 { HP-Math8 csHPMath8 }
8956 { Adobe-Symbol-Encoding csHPPSMath }
8957 { HP-DeskTop csHPDesktop }
8958 { Ventura-Math csVenturaMath }
8959 { Microsoft-Publishing csMicrosoftPublishing }
8960 { Windows-31J csWindows31J }
8965 proc tcl_encoding {enc} {
8966 global encoding_aliases
8967 set names [encoding names]
8968 set lcnames [string tolower $names]
8969 set enc [string tolower $enc]
8970 set i [lsearch -exact $lcnames $enc]
8972 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8973 if {[regsub {^iso[-_]} $enc iso encx]} {
8974 set i [lsearch -exact $lcnames $encx]
8978 foreach l $encoding_aliases {
8979 set ll [string tolower $l]
8980 if {[lsearch -exact $ll $enc] < 0} continue
8981 # look through the aliases for one that tcl knows about
8983 set i [lsearch -exact $lcnames $e]
8985 if {[regsub {^iso[-_]} $e iso ex]} {
8986 set i [lsearch -exact $lcnames $ex]
8995 return [lindex $names $i]
9000 # First check that Tcl/Tk is recent enough
9001 if {[catch {package require Tk 8.4} err]} {
9002 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9003 Gitk requires at least Tcl/Tk 8.4."
9009 set wrcomcmd "git diff-tree --stdin -p --pretty"
9013 set gitencoding [exec git config --get i18n.commitencoding]
9015 if {$gitencoding == ""} {
9016 set gitencoding "utf-8"
9018 set tclencoding [tcl_encoding $gitencoding]
9019 if {$tclencoding == {}} {
9020 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9023 set mainfont {Helvetica 9}
9024 set textfont {Courier 9}
9025 set uifont {Helvetica 9 bold}
9027 set findmergefiles 0
9035 set cmitmode "patch"
9036 set wrapcomment "none"
9040 set showlocalchanges 1
9042 set datetimeformat "%Y-%m-%d %H:%M:%S"
9044 set colors {green red blue magenta darkgrey brown orange}
9047 set diffcolors {red "#00a000" blue}
9049 set selectbgcolor gray85
9051 catch {source ~/.gitk}
9053 font create optionfont -family sans-serif -size -12
9055 parsefont mainfont $mainfont
9056 eval font create mainfont [fontflags mainfont]
9057 eval font create mainfontbold [fontflags mainfont 1]
9059 parsefont textfont $textfont
9060 eval font create textfont [fontflags textfont]
9061 eval font create textfontbold [fontflags textfont 1]
9063 parsefont uifont $uifont
9064 eval font create uifont [fontflags uifont]
9066 # check that we can find a .git directory somewhere...
9067 if {[catch {set gitdir [gitdir]}]} {
9068 show_error {} . "Cannot find a git repository here."
9071 if {![file isdirectory $gitdir]} {
9072 show_error {} . "Cannot find the git directory \"$gitdir\"."
9078 set cmdline_files {}
9083 "-d" { set datemode 1 }
9086 lappend revtreeargs $arg
9089 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9093 lappend revtreeargs $arg
9099 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9100 # no -- on command line, but some arguments (other than -d)
9102 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9103 set cmdline_files [split $f "\n"]
9104 set n [llength $cmdline_files]
9105 set revtreeargs [lrange $revtreeargs 0 end-$n]
9106 # Unfortunately git rev-parse doesn't produce an error when
9107 # something is both a revision and a filename. To be consistent
9108 # with git log and git rev-list, check revtreeargs for filenames.
9109 foreach arg $revtreeargs {
9110 if {[file exists $arg]} {
9111 show_error {} . "Ambiguous argument '$arg': both revision\
9117 # unfortunately we get both stdout and stderr in $err,
9118 # so look for "fatal:".
9119 set i [string first "fatal:" $err]
9121 set err [string range $err [expr {$i + 6}] end]
9123 show_error {} . "Bad arguments to gitk:\n$err"
9129 # find the list of unmerged files
9133 set fd [open "| git ls-files -u" r]
9135 show_error {} . "Couldn't get list of unmerged files: $err"
9138 while {[gets $fd line] >= 0} {
9139 set i [string first "\t" $line]
9140 if {$i < 0} continue
9141 set fname [string range $line [expr {$i+1}] end]
9142 if {[lsearch -exact $mlist $fname] >= 0} continue
9144 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9145 lappend mlist $fname
9150 if {$nr_unmerged == 0} {
9151 show_error {} . "No files selected: --merge specified but\
9152 no files are unmerged."
9154 show_error {} . "No files selected: --merge specified but\
9155 no unmerged files are within file limit."
9159 set cmdline_files $mlist
9162 set nullid "0000000000000000000000000000000000000000"
9163 set nullid2 "0000000000000000000000000000000000000001"
9165 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9172 set highlight_paths {}
9174 set searchdirn -forwards
9178 set markingmatches 0
9179 set linkentercount 0
9180 set need_redisplay 0
9187 set selectedhlview None
9188 set highlight_related None
9189 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]