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
[exec git rev-parse
--default HEAD
--revs-only \
111 set viewincl
($view) {}
113 if {![string match
"^*" $c]} {
114 lappend viewincl
($view) $c
118 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
119 --boundary $commits "--" $viewfiles($view)] r
]
121 error_popup
"Error executing git log: $err"
124 set i
[incr loginstance
]
125 set viewinstances
($view) [list
$i]
128 if {$showlocalchanges} {
129 lappend commitinterest
($mainheadid) {dodiffindex
}
131 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
132 if {$tclencoding != {}} {
133 fconfigure
$fd -encoding $tclencoding
135 filerun
$fd [list getcommitlines
$fd $i $view]
136 nowbusy
$view "Reading"
137 if {$view == $curview} {
139 set progresscoords
{0 0}
144 proc stop_rev_list
{view
} {
145 global commfd viewinstances leftover
147 foreach inst
$viewinstances($view) {
148 set fd
$commfd($inst)
156 unset leftover
($inst)
158 set viewinstances
($view) {}
165 start_rev_list
$curview
166 show_status
"Reading commits..."
169 proc updatecommits
{} {
170 global curview viewargs viewfiles viewincl viewinstances
171 global viewactive viewcomplete loginstance tclencoding
172 global varcid startmsecs commfd getdbg showneartags leftover
176 set commits
[exec git rev-parse
--default HEAD
--revs-only \
181 if {[string match
"^*" $c]} {
184 if {!([info exists varcid
($view,$c)] ||
185 [lsearch
-exact $viewincl($view) $c] >= 0)} {
193 foreach id
$viewincl($view) {
196 set viewincl
($view) [concat
$viewincl($view) $pos]
198 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
199 --boundary $pos $neg "--" $viewfiles($view)] r
]
201 error_popup
"Error executing git log: $err"
204 if {$viewactive($view) == 0} {
205 set startmsecs
[clock clicks
-milliseconds]
207 set i
[incr loginstance
]
208 lappend viewinstances
($view) $i
211 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
212 if {$tclencoding != {}} {
213 fconfigure
$fd -encoding $tclencoding
215 filerun
$fd [list getcommitlines
$fd $i $view]
216 incr viewactive
($view)
217 set viewcomplete
($view) 0
218 nowbusy
$view "Reading"
226 proc reloadcommits
{} {
227 global curview viewcomplete selectedline currentid thickerline
228 global showneartags treediffs commitinterest cached_commitrow
229 global progresscoords
231 if {!$viewcomplete($curview)} {
232 stop_rev_list
$curview
233 set progresscoords
{0 0}
237 catch
{unset selectedline
}
238 catch
{unset currentid
}
239 catch
{unset thickerline
}
240 catch
{unset treediffs
}
247 catch
{unset commitinterest
}
248 catch
{unset cached_commitrow
}
253 # This makes a string representation of a positive integer which
254 # sorts as a string in numerical order
257 return [format
"%x" $n]
258 } elseif
{$n < 256} {
259 return [format
"x%.2x" $n]
260 } elseif
{$n < 65536} {
261 return [format
"y%.4x" $n]
263 return [format
"z%.8x" $n]
266 # Procedures used in reordering commits from git log (without
267 # --topo-order) into the order for display.
269 proc varcinit
{view
} {
270 global vseeds varcstart vupptr vdownptr vleftptr varctok varcrow
271 global vtokmod varcmod varcix uat
274 set varcstart
($view) {{}}
275 set vupptr
($view) {0}
276 set vdownptr
($view) {0}
277 set vleftptr
($view) {0}
278 set varctok
($view) {{}}
279 set varcrow
($view) {{}}
280 set vtokmod
($view) {}
282 set varcix
($view) {{}}
286 proc resetvarcs
{view
} {
287 global varcid varccommits parents children vseedcount ordertok
289 foreach vid
[array names varcid
$view,*] {
294 # some commits might have children but haven't been seen yet
295 foreach vid
[array names children
$view,*] {
298 foreach va
[array names varccommits
$view,*] {
299 unset varccommits
($va)
301 foreach vd
[array names vseedcount
$view,*] {
302 unset vseedcount
($vd)
304 foreach vid
[array names ordertok
$view,*] {
309 proc newvarc
{view id
} {
310 global varcid varctok parents children vseeds
311 global vupptr vdownptr vleftptr varcrow varcix varcstart
312 global commitdata commitinfo vseedcount
314 set a
[llength
$varctok($view)]
316 if {[llength
$children($vid)] == 0} {
317 if {![info exists commitinfo
($id)]} {
318 parsecommit
$id $commitdata($id) 1
320 set cdate
[lindex
$commitinfo($id) 4]
321 if {![string is integer
-strict $cdate]} {
324 if {![info exists vseedcount
($view,$cdate)]} {
325 set vseedcount
($view,$cdate) -1
327 set c
[incr vseedcount
($view,$cdate)]
328 set cdate
[expr {$cdate ^
0xffffffff}]
329 set tok
"s[strrep $cdate][strrep $c]"
330 lappend vseeds
($view) $id
331 lappend vupptr
($view) 0
332 set ka
[lindex
$vdownptr($view) 0]
334 [string compare
$tok [lindex
$varctok($view) $ka]] < 0} {
335 lset vdownptr
($view) 0 $a
336 lappend vleftptr
($view) $ka
338 while {[set b
[lindex
$vleftptr($view) $ka]] != 0 &&
339 [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
342 lset vleftptr
($view) $ka $a
343 lappend vleftptr
($view) $b
347 foreach k
$children($vid) {
348 set ka
$varcid($view,$k)
349 if {[string compare
[lindex
$varctok($view) $ka] $tok] > 0} {
351 set tok
[lindex
$varctok($view) $ka]
354 set ka
$varcid($view,$ki)
355 lappend vupptr
($view) $ka
356 set i
[lsearch
-exact $parents($view,$ki) $id]
357 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
359 while {[incr i
] < [llength
$parents($view,$ki)]} {
360 set bi
[lindex
$parents($view,$ki) $i]
361 if {[info exists varcid
($view,$bi)]} {
362 set b
$varcid($view,$bi)
363 if {[lindex
$vupptr($view) $b] == $ka} {
365 lappend vleftptr
($view) [lindex
$vleftptr($view) $b]
366 lset vleftptr
($view) $b $a
372 lappend vleftptr
($view) [lindex
$vdownptr($view) $ka]
373 lset vdownptr
($view) $ka $a
375 append tok
[strrep
$j]
377 lappend varctok
($view) $tok
378 lappend varcstart
($view) $id
379 lappend vdownptr
($view) 0
380 lappend varcrow
($view) {}
381 lappend varcix
($view) {}
385 proc splitvarc
{p v
} {
386 global varcid varcstart varccommits varctok
387 global vupptr vdownptr vleftptr varcix varcrow
389 set oa
$varcid($v,$p)
390 set ac
$varccommits($v,$oa)
391 set i
[lsearch
-exact $varccommits($v,$oa) $p]
393 set na
[llength
$varctok($v)]
394 # "%" sorts before "0"...
395 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
396 lappend varctok
($v) $tok
397 lappend varcrow
($v) {}
398 lappend varcix
($v) {}
399 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
400 set varccommits
($v,$na) [lrange
$ac $i end
]
401 lappend varcstart
($v) $p
402 foreach id
$varccommits($v,$na) {
403 set varcid
($v,$id) $na
405 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
406 lset vdownptr
($v) $oa $na
407 lappend vupptr
($v) $oa
408 lappend vleftptr
($v) 0
409 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
410 lset vupptr
($v) $b $na
414 proc renumbervarc
{a v
} {
415 global parents children varctok varcstart varccommits
416 global vupptr vdownptr vleftptr varcid vtokmod varcmod
418 set t1
[clock clicks
-milliseconds]
423 if {[info exists isrelated
($a)]} {
425 set id
[lindex
$varccommits($v,$a) end
]
426 foreach p
$parents($v,$id) {
427 if {[info exists varcid
($v,$p)]} {
428 set isrelated
($varcid($v,$p)) 1
433 set b
[lindex
$vdownptr($v) $a]
436 set b
[lindex
$vleftptr($v) $a]
438 set a
[lindex
$vupptr($v) $a]
444 set id
[lindex
$varcstart($v) $a]
446 foreach k
$children($v,$id) {
447 set ka
$varcid($v,$k)
448 if {[string compare
[lindex
$varctok($v) $ka] $tok] > 0} {
450 set tok
[lindex
$varctok($v) $ka]
454 set ka
$varcid($v,$ki)
455 set i
[lsearch
-exact $parents($v,$ki) $id]
456 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
457 append tok
[strrep
$j]
458 set oldtok
[lindex
$varctok($v) $a]
459 if {$tok eq
$oldtok} continue
460 lset varctok
($v) $a $tok
464 set b
[lindex
$vupptr($v) $a]
466 set c
[lindex
$vdownptr($v) $b]
468 lset vdownptr
($v) $b [lindex
$vleftptr($v) $a]
471 while {$b != 0 && [lindex
$vleftptr($v) $b] != $a} {
472 set b
[lindex
$vleftptr($v) $b]
475 lset vleftptr
($v) $b [lindex
$vleftptr($v) $a]
477 puts
"oops couldn't find $a in chain for [lindex $vupptr($v) $a]"
480 lset vupptr
($v) $a $ka
482 while {[incr i
] < [llength
$parents($v,$ki)]} {
483 set bi
[lindex
$parents($v,$ki) $i]
484 if {[info exists varcid
($v,$bi)]} {
485 set b
$varcid($v,$bi)
486 if {[lindex
$vupptr($v) $b] == $ka} {
488 lset vleftptr
($v) $a [lindex
$vleftptr($v) $b]
489 lset vleftptr
($v) $b $a
495 lset vleftptr
($v) $a [lindex
$vdownptr($v) $ka]
496 lset vdownptr
($v) $ka $a
500 set t2
[clock clicks
-milliseconds]
501 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
504 proc fix_reversal
{p a v
} {
505 global varcid varcstart varctok vupptr vseeds
507 set pa
$varcid($v,$p)
508 if {$p ne
[lindex
$varcstart($v) $pa]} {
510 set pa
$varcid($v,$p)
512 # seeds always need to be renumbered (and taken out of the seeds list)
513 if {[lindex
$vupptr($v) $pa] == 0} {
514 set i
[lsearch
-exact $vseeds($v) $p]
516 set vseeds
($v) [lreplace
$vseeds($v) $i $i]
518 puts
"oops couldn't find [shortids $p] in seeds"
521 } elseif
{[string compare
[lindex
$varctok($v) $a] \
522 [lindex
$varctok($v) $pa]] > 0} {
527 proc insertrow
{id p v
} {
528 global varcid varccommits parents children cmitlisted ordertok
529 global commitidx varctok vtokmod varcmod
532 set i
[lsearch
-exact $varccommits($v,$a) $p]
534 puts
"oops: insertrow can't find [shortids $p] on arc $a"
537 set children
($v,$id) {}
538 set parents
($v,$id) [list
$p]
539 set varcid
($v,$id) $a
540 if {[llength
[lappend children
($v,$p) $id]] > 1 &&
541 [vtokcmp
$v [lindex
$children($v,$p) end-1
] $id] > 0} {
542 set children
($v,$p) [lsort
-command [list vtokcmp
$v] $children($v,$p)]
544 set cmitlisted
($v,$id) 1
546 set ordertok
($v,$id) $ordertok($v,$p)
547 # note we deliberately don't update varcstart($v) even if $i == 0
548 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
549 set tok
[lindex
$varctok($v) $a]
550 if {[string compare
$tok $vtokmod($v)] < 0} {
557 proc removerow
{id v
} {
558 global varcid varccommits parents children commitidx ordertok
559 global varctok vtokmod varcmod
561 if {[llength
$parents($v,$id)] != 1} {
562 puts
"oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
565 set p
[lindex
$parents($v,$id) 0]
566 set a
$varcid($v,$id)
567 set i
[lsearch
-exact $varccommits($v,$a) $id]
569 puts
"oops: removerow can't find [shortids $id] on arc $a"
573 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
574 unset parents
($v,$id)
575 unset children
($v,$id)
576 unset cmitlisted
($v,$id)
577 unset ordertok
($v,$id)
578 incr commitidx
($v) -1
579 set j
[lsearch
-exact $children($v,$p) $id]
581 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
583 set tok
[lindex
$varctok($v) $a]
584 if {[string compare
$tok $vtokmod($v)] < 0} {
591 proc vtokcmp
{v a b
} {
592 global varctok varcid
594 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
595 [lindex
$varctok($v) $varcid($v,$b)]]
598 proc update_arcrows
{v
} {
599 global vtokmod varcmod varcrow commitidx currentid selectedline
600 global varcid vseeds vrownum varcorder varcix varccommits
601 global vupptr vdownptr vleftptr varctok
602 global uat displayorder parentlist curview cached_commitrow
604 set t1
[clock clicks
-milliseconds]
605 set narctot
[expr {[llength
$varctok($v)] - 1}]
607 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
608 # go up the tree until we find something that has a row number,
609 # or we get to a seed
610 set a
[lindex
$vupptr($v) $a]
613 set a
[lindex
$vdownptr($v) 0]
616 set varcorder
($v) [list
$a]
618 lset varcrow
($v) $a 0
622 set arcn
[lindex
$varcix($v) $a]
623 # see if a is the last arc; if so, nothing to do
624 if {$arcn == $narctot - 1} {
627 if {[llength
$vrownum($v)] > $arcn + 1} {
628 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
629 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
631 set row
[lindex
$varcrow($v) $a]
633 if {[llength
$displayorder] > $row} {
634 set displayorder
[lrange
$displayorder 0 [expr {$row - 1}]]
635 set parentlist
[lrange
$parentlist 0 [expr {$row - 1}]]
637 if {$v == $curview} {
638 catch
{unset cached_commitrow
}
643 incr row
[llength
$varccommits($v,$a)]
644 # go down if possible
645 set b
[lindex
$vdownptr($v) $a]
647 # if not, go left, or go up until we can go left
649 set b
[lindex
$vleftptr($v) $a]
651 set a
[lindex
$vupptr($v) $a]
657 lappend vrownum
($v) $row
658 lappend varcorder
($v) $a
659 lset varcix
($v) $a $arcn
660 lset varcrow
($v) $a $row
662 if {[info exists currentid
]} {
663 set selectedline
[rowofcommit
$currentid]
666 if {$row != $commitidx($v)} {
667 puts
"oops update_arcrows got to row $row out of $commitidx($v)"
671 set vtokmod
($v) [lindex
$varctok($v) $p]
674 set t2
[clock clicks
-milliseconds]
675 incr uat
[expr {$t2-$t1}]
678 # Test whether view $v contains commit $id
679 proc commitinview
{id v
} {
682 return [info exists varcid
($v,$id)]
685 # Return the row number for commit $id in the current view
686 proc rowofcommit
{id
} {
687 global varcid varccommits varcrow curview cached_commitrow
689 if {[info exists cached_commitrow
($id)]} {
690 return $cached_commitrow($id)
693 if {![info exists varcid
($v,$id)]} {
694 puts
"oops rowofcommit no arc for [shortids $id]"
697 set a
$varcid($v,$id)
698 set i
[lsearch
-exact $varccommits($v,$a) $id]
700 puts
"oops didn't find commit [shortids $id] in arc $a"
703 incr i
[lindex
$varcrow($v) $a]
704 set cached_commitrow
($id) $i
708 proc bsearch
{l elt
} {
709 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
714 while {$hi - $lo > 1} {
715 set mid
[expr {int
(($lo + $hi) / 2)}]
716 set t
[lindex
$l $mid]
719 } elseif
{$elt > $t} {
728 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
729 proc make_disporder
{start end
} {
730 global vrownum curview commitidx displayorder parentlist
731 global varccommits varcorder parents
732 global d_valid_start d_valid_end
734 set ai
[bsearch
$vrownum($curview) $start]
735 set start
[lindex
$vrownum($curview) $ai]
736 set narc
[llength
$vrownum($curview)]
737 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
738 set a
[lindex
$varcorder($curview) $ai]
739 set l
[llength
$displayorder]
740 set al
[llength
$varccommits($curview,$a)]
743 set pad
[ntimes
[expr {$r - $l}] {}]
744 set displayorder
[concat
$displayorder $pad]
745 set parentlist
[concat
$parentlist $pad]
747 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
748 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
750 foreach id
$varccommits($curview,$a) {
751 lappend displayorder
$id
752 lappend parentlist
$parents($curview,$id)
754 } elseif
{[lindex
$displayorder $r] eq
{}} {
756 foreach id
$varccommits($curview,$a) {
757 lset displayorder
$i $id
758 lset parentlist
$i $parents($curview,$id)
766 proc commitonrow
{row
} {
769 set id
[lindex
$displayorder $row]
771 make_disporder
$row [expr {$row + 1}]
772 set id
[lindex
$displayorder $row]
777 proc closevarcs
{v
} {
778 global varctok varccommits varcid parents children
779 global cmitlisted commitidx commitinterest vtokmod varcmod
781 set missing_parents
0
783 set narcs
[llength
$varctok($v)]
784 for {set a
1} {$a < $narcs} {incr a
} {
785 set id
[lindex
$varccommits($v,$a) end
]
786 foreach p
$parents($v,$id) {
787 if {[info exists varcid
($v,$p)]} continue
788 # add p as a new commit
790 set cmitlisted
($v,$p) 0
791 set parents
($v,$p) {}
792 if {[llength
$children($v,$p)] == 1 &&
793 [llength
$parents($v,$id)] == 1} {
796 set b
[newvarc
$v $p]
799 lappend varccommits
($v,$b) $p
800 set tok
[lindex
$varctok($v) $b]
801 if {[string compare
$tok $vtokmod($v)] < 0} {
806 if {[info exists commitinterest
($p)]} {
807 foreach
script $commitinterest($p) {
808 lappend scripts
[string map
[list
"%I" $p] $script]
810 unset commitinterest
($id)
814 if {$missing_parents > 0} {
822 proc getcommitlines
{fd inst view
} {
823 global cmitlisted commitinterest leftover getdbg
824 global commitidx commitdata
825 global parents children curview hlview
826 global ordertok vnextroot idpending
827 global varccommits varcid varctok vtokmod varcmod
829 set stuff
[read $fd 500000]
830 # git log doesn't terminate the last commit with a null...
831 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
838 global commfd viewcomplete viewactive viewname progresscoords
841 set i
[lsearch
-exact $viewinstances($view) $inst]
843 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
845 # set it blocking so we wait for the process to terminate
846 fconfigure
$fd -blocking 1
847 if {[catch
{close
$fd} err
]} {
849 if {$view != $curview} {
850 set fv
" for the \"$viewname($view)\" view"
852 if {[string range
$err 0 4] == "usage"} {
853 set err
"Gitk: error reading commits$fv:\
854 bad arguments to git rev-list."
855 if {$viewname($view) eq
"Command line"} {
857 " (Note: arguments to gitk are passed to git rev-list\
858 to allow selection of commits to be displayed.)"
861 set err
"Error reading commits$fv: $err"
865 if {[incr viewactive
($view) -1] <= 0} {
866 set viewcomplete
($view) 1
867 # Check if we have seen any ids listed as parents that haven't
868 # appeared in the list
871 set progresscoords
{0 0}
874 if {$view == $curview} {
875 run chewcommits
$view
883 set i
[string first
"\0" $stuff $start]
885 append leftover
($inst) [string range
$stuff $start end
]
889 set cmit
$leftover($inst)
890 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
891 set leftover
($inst) {}
893 set cmit
[string range
$stuff $start [expr {$i - 1}]]
895 set start
[expr {$i + 1}]
896 set j
[string first
"\n" $cmit]
899 if {$j >= 0 && [string match
"commit *" $cmit]} {
900 set ids
[string range
$cmit 7 [expr {$j - 1}]]
901 if {[string match
{[-<>]*} $ids]} {
902 switch
-- [string index
$ids 0] {
907 set ids
[string range
$ids 1 end
]
911 if {[string length
$id] != 40} {
919 if {[string length
$shortcmit] > 80} {
920 set shortcmit
"[string range $shortcmit 0 80]..."
922 error_popup
"Can't parse git log output: {$shortcmit}"
925 set id
[lindex
$ids 0]
927 if {!$listed && [info exists parents
($vid)]} continue
928 if {![info exists ordertok
($vid)]} {
929 set otok
"o[strrep $vnextroot($view)]"
930 incr vnextroot
($view)
931 set ordertok
($vid) $otok
933 set otok
$ordertok($vid)
936 set olds
[lrange
$ids 1 end
]
937 if {[llength
$olds] == 1} {
938 set p
[lindex
$olds 0]
939 if {![info exists ordertok
($view,$p)]} {
940 set ordertok
($view,$p) $ordertok($vid)
945 if {![info exists ordertok
($view,$p)]} {
946 set ordertok
($view,$p) "$otok[strrep $i]]"
954 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
955 set cmitlisted
($vid) $listed
956 set parents
($vid) $olds
958 if {![info exists children
($vid)]} {
959 set children
($vid) {}
961 if {[llength
$children($vid)] == 1} {
962 set k
[lindex
$children($vid) 0]
963 if {[llength
$parents($view,$k)] == 1} {
964 set a
$varcid($view,$k)
970 set a
[newvarc
$view $id]
973 lappend varccommits
($view,$a) $id
974 set tok
[lindex
$varctok($view) $a]
977 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
979 if {[llength
[lappend children
($vp) $id]] > 1 &&
980 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
981 set children
($vp) [lsort
-command [list vtokcmp
$view] \
985 if {[info exists varcid
($view,$p)]} {
986 fix_reversal
$p $a $view
990 if {[string compare
$tok $vtokmod($view)] < 0} {
991 set vtokmod
($view) $tok
992 set varcmod
($view) $a
995 incr commitidx
($view)
996 if {[info exists commitinterest
($id)]} {
997 foreach
script $commitinterest($id) {
998 lappend scripts
[string map
[list
"%I" $id] $script]
1000 unset commitinterest
($id)
1005 update_arcrows
$view
1006 run chewcommits
$view
1007 foreach s
$scripts {
1010 if {$view == $curview} {
1011 # update progress bar
1012 global progressdirn progresscoords proglastnc
1013 set inc
[expr {($commitidx($view) - $proglastnc) * 0.0002}]
1014 set proglastnc
$commitidx($view)
1015 set l
[lindex
$progresscoords 0]
1016 set r
[lindex
$progresscoords 1]
1017 if {$progressdirn} {
1018 set r
[expr {$r + $inc}]
1024 set l
[expr {$r - 0.2}]
1027 set l
[expr {$l - $inc}]
1032 set r
[expr {$l + 0.2}]
1034 set progresscoords
[list
$l $r]
1041 proc chewcommits
{view
} {
1042 global curview hlview viewcomplete
1043 global pending_select
1045 if {$view == $curview} {
1047 if {$viewcomplete($view)} {
1049 global numcommits startmsecs
1050 global mainheadid commitinfo nullid
1052 if {[info exists pending_select
]} {
1053 set row
[first_real_row
]
1056 if {$commitidx($curview) > 0} {
1057 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1058 #puts "overall $ms ms for $numcommits commits"
1060 #puts "${uat}ms in update_arcrows"
1062 show_status
"No commits selected"
1067 if {[info exists hlview
] && $view == $hlview} {
1073 proc readcommit
{id
} {
1074 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1075 parsecommit
$id $contents 0
1078 proc parsecommit
{id contents listed
} {
1079 global commitinfo cdate
1088 set hdrend
[string first
"\n\n" $contents]
1090 # should never happen...
1091 set hdrend
[string length
$contents]
1093 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1094 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1095 foreach line
[split $header "\n"] {
1096 set tag
[lindex
$line 0]
1097 if {$tag == "author"} {
1098 set audate
[lindex
$line end-1
]
1099 set auname
[lrange
$line 1 end-2
]
1100 } elseif
{$tag == "committer"} {
1101 set comdate
[lindex
$line end-1
]
1102 set comname
[lrange
$line 1 end-2
]
1106 # take the first non-blank line of the comment as the headline
1107 set headline
[string trimleft
$comment]
1108 set i
[string first
"\n" $headline]
1110 set headline
[string range
$headline 0 $i]
1112 set headline
[string trimright
$headline]
1113 set i
[string first
"\r" $headline]
1115 set headline
[string trimright
[string range
$headline 0 $i]]
1118 # git rev-list indents the comment by 4 spaces;
1119 # if we got this via git cat-file, add the indentation
1121 foreach line
[split $comment "\n"] {
1122 append newcomment
" "
1123 append newcomment
$line
1124 append newcomment
"\n"
1126 set comment
$newcomment
1128 if {$comdate != {}} {
1129 set cdate
($id) $comdate
1131 set commitinfo
($id) [list
$headline $auname $audate \
1132 $comname $comdate $comment]
1135 proc getcommit
{id
} {
1136 global commitdata commitinfo
1138 if {[info exists commitdata
($id)]} {
1139 parsecommit
$id $commitdata($id) 1
1142 if {![info exists commitinfo
($id)]} {
1143 set commitinfo
($id) {"No commit information available"}
1150 global tagids idtags headids idheads tagobjid
1151 global otherrefids idotherrefs mainhead mainheadid
1153 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1156 set refd
[open
[list | git show-ref
-d] r
]
1157 while {[gets
$refd line
] >= 0} {
1158 if {[string index
$line 40] ne
" "} continue
1159 set id
[string range
$line 0 39]
1160 set ref
[string range
$line 41 end
]
1161 if {![string match
"refs/*" $ref]} continue
1162 set name
[string range
$ref 5 end
]
1163 if {[string match
"remotes/*" $name]} {
1164 if {![string match
"*/HEAD" $name]} {
1165 set headids
($name) $id
1166 lappend idheads
($id) $name
1168 } elseif
{[string match
"heads/*" $name]} {
1169 set name
[string range
$name 6 end
]
1170 set headids
($name) $id
1171 lappend idheads
($id) $name
1172 } elseif
{[string match
"tags/*" $name]} {
1173 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1174 # which is what we want since the former is the commit ID
1175 set name
[string range
$name 5 end
]
1176 if {[string match
"*^{}" $name]} {
1177 set name
[string range
$name 0 end-3
]
1179 set tagobjid
($name) $id
1181 set tagids
($name) $id
1182 lappend idtags
($id) $name
1184 set otherrefids
($name) $id
1185 lappend idotherrefs
($id) $name
1192 set thehead
[exec git symbolic-ref HEAD
]
1193 if {[string match
"refs/heads/*" $thehead]} {
1194 set mainhead
[string range
$thehead 11 end
]
1195 if {[info exists headids
($mainhead)]} {
1196 set mainheadid
$headids($mainhead)
1202 # skip over fake commits
1203 proc first_real_row
{} {
1204 global nullid nullid2 numcommits
1206 for {set row
0} {$row < $numcommits} {incr row
} {
1207 set id
[commitonrow
$row]
1208 if {$id ne
$nullid && $id ne
$nullid2} {
1215 # update things for a head moved to a child of its previous location
1216 proc movehead
{id name
} {
1217 global headids idheads
1219 removehead
$headids($name) $name
1220 set headids
($name) $id
1221 lappend idheads
($id) $name
1224 # update things when a head has been removed
1225 proc removehead
{id name
} {
1226 global headids idheads
1228 if {$idheads($id) eq
$name} {
1231 set i
[lsearch
-exact $idheads($id) $name]
1233 set idheads
($id) [lreplace
$idheads($id) $i $i]
1236 unset headids
($name)
1239 proc show_error
{w top msg
} {
1240 message
$w.m
-text $msg -justify center
-aspect 400
1241 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1242 button
$w.ok
-text OK
-command "destroy $top"
1243 pack
$w.ok
-side bottom
-fill x
1244 bind $top <Visibility
> "grab $top; focus $top"
1245 bind $top <Key-Return
> "destroy $top"
1249 proc error_popup msg
{
1253 show_error
$w $w $msg
1256 proc confirm_popup msg
{
1262 message
$w.m
-text $msg -justify center
-aspect 400
1263 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1264 button
$w.ok
-text OK
-command "set confirm_ok 1; destroy $w"
1265 pack
$w.ok
-side left
-fill x
1266 button
$w.cancel
-text Cancel
-command "destroy $w"
1267 pack
$w.cancel
-side right
-fill x
1268 bind $w <Visibility
> "grab $w; focus $w"
1273 proc makewindow
{} {
1274 global canv canv2 canv3 linespc charspc ctext cflist
1276 global findtype findtypemenu findloc findstring fstring geometry
1277 global entries sha1entry sha1string sha1but
1278 global diffcontextstring diffcontext
1279 global maincursor textcursor curtextcursor
1280 global rowctxmenu fakerowmenu mergemax wrapcomment
1281 global highlight_files gdttype
1282 global searchstring sstring
1283 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1284 global headctxmenu progresscanv progressitem progresscoords statusw
1285 global fprogitem fprogcoord lastprogupdate progupdatepending
1286 global rprogitem rprogcoord
1290 .bar add cascade
-label "File" -menu .bar.
file
1291 .bar configure
-font uifont
1293 .bar.
file add
command -label "Update" -command updatecommits
1294 .bar.
file add
command -label "Reload" -command reloadcommits
1295 .bar.
file add
command -label "Reread references" -command rereadrefs
1296 .bar.
file add
command -label "List references" -command showrefs
1297 .bar.
file add
command -label "Quit" -command doquit
1298 .bar.
file configure
-font uifont
1300 .bar add cascade
-label "Edit" -menu .bar.edit
1301 .bar.edit add
command -label "Preferences" -command doprefs
1302 .bar.edit configure
-font uifont
1304 menu .bar.view
-font uifont
1305 .bar add cascade
-label "View" -menu .bar.view
1306 .bar.view add
command -label "New view..." -command {newview
0}
1307 .bar.view add
command -label "Edit view..." -command editview \
1309 .bar.view add
command -label "Delete view" -command delview
-state disabled
1310 .bar.view add separator
1311 .bar.view add radiobutton
-label "All files" -command {showview
0} \
1312 -variable selectedview
-value 0
1315 .bar add cascade
-label "Help" -menu .bar.
help
1316 .bar.
help add
command -label "About gitk" -command about
1317 .bar.
help add
command -label "Key bindings" -command keys
1318 .bar.
help configure
-font uifont
1319 . configure
-menu .bar
1321 # the gui has upper and lower half, parts of a paned window.
1322 panedwindow .ctop
-orient vertical
1324 # possibly use assumed geometry
1325 if {![info exists geometry
(pwsash0
)]} {
1326 set geometry
(topheight
) [expr {15 * $linespc}]
1327 set geometry
(topwidth
) [expr {80 * $charspc}]
1328 set geometry
(botheight
) [expr {15 * $linespc}]
1329 set geometry
(botwidth
) [expr {50 * $charspc}]
1330 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1331 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1334 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1335 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1337 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1339 # create three canvases
1340 set cscroll .tf.histframe.csb
1341 set canv .tf.histframe.pwclist.canv
1343 -selectbackground $selectbgcolor \
1344 -background $bgcolor -bd 0 \
1345 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1346 .tf.histframe.pwclist add
$canv
1347 set canv2 .tf.histframe.pwclist.canv2
1349 -selectbackground $selectbgcolor \
1350 -background $bgcolor -bd 0 -yscrollincr $linespc
1351 .tf.histframe.pwclist add
$canv2
1352 set canv3 .tf.histframe.pwclist.canv3
1354 -selectbackground $selectbgcolor \
1355 -background $bgcolor -bd 0 -yscrollincr $linespc
1356 .tf.histframe.pwclist add
$canv3
1357 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1358 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1360 # a scroll bar to rule them
1361 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1362 pack
$cscroll -side right
-fill y
1363 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1364 lappend bglist
$canv $canv2 $canv3
1365 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1367 # we have two button bars at bottom of top frame. Bar 1
1369 frame .tf.lbar
-height 15
1371 set sha1entry .tf.bar.sha1
1372 set entries
$sha1entry
1373 set sha1but .tf.bar.sha1label
1374 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
1375 -command gotocommit
-width 8 -font uifont
1376 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1377 pack .tf.bar.sha1label
-side left
1378 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1379 trace add variable sha1string
write sha1change
1380 pack
$sha1entry -side left
-pady 2
1382 image create bitmap bm-left
-data {
1383 #define left_width 16
1384 #define left_height 16
1385 static unsigned char left_bits
[] = {
1386 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1387 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1388 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1390 image create bitmap bm-right
-data {
1391 #define right_width 16
1392 #define right_height 16
1393 static unsigned char right_bits
[] = {
1394 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1395 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1396 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1398 button .tf.bar.leftbut
-image bm-left
-command goback \
1399 -state disabled
-width 26
1400 pack .tf.bar.leftbut
-side left
-fill y
1401 button .tf.bar.rightbut
-image bm-right
-command goforw \
1402 -state disabled
-width 26
1403 pack .tf.bar.rightbut
-side left
-fill y
1405 # Status label and progress bar
1406 set statusw .tf.bar.status
1407 label
$statusw -width 15 -relief sunken
-font uifont
1408 pack
$statusw -side left
-padx 5
1409 set h
[expr {[font metrics uifont
-linespace] + 2}]
1410 set progresscanv .tf.bar.progress
1411 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1412 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1413 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1414 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1415 pack
$progresscanv -side right
-expand 1 -fill x
1416 set progresscoords
{0 0}
1419 bind $progresscanv <Configure
> adjustprogress
1420 set lastprogupdate
[clock clicks
-milliseconds]
1421 set progupdatepending
0
1423 # build up the bottom bar of upper window
1424 label .tf.lbar.flabel
-text "Find " -font uifont
1425 button .tf.lbar.fnext
-text "next" -command {dofind
1 1} -font uifont
1426 button .tf.lbar.fprev
-text "prev" -command {dofind
-1 1} -font uifont
1427 label .tf.lbar.flab2
-text " commit " -font uifont
1428 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1430 set gdttype
"containing:"
1431 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1434 "adding/removing string:"]
1435 trace add variable gdttype
write gdttype_change
1436 $gm conf
-font uifont
1437 .tf.lbar.gdttype conf
-font uifont
1438 pack .tf.lbar.gdttype
-side left
-fill y
1441 set fstring .tf.lbar.findstring
1442 lappend entries
$fstring
1443 entry
$fstring -width 30 -font textfont
-textvariable findstring
1444 trace add variable findstring
write find_change
1446 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1447 findtype Exact IgnCase Regexp
]
1448 trace add variable findtype
write findcom_change
1449 .tf.lbar.findtype configure
-font uifont
1450 .tf.lbar.findtype.menu configure
-font uifont
1451 set findloc
"All fields"
1452 tk_optionMenu .tf.lbar.findloc findloc
"All fields" Headline \
1453 Comments Author Committer
1454 trace add variable findloc
write find_change
1455 .tf.lbar.findloc configure
-font uifont
1456 .tf.lbar.findloc.menu configure
-font uifont
1457 pack .tf.lbar.findloc
-side right
1458 pack .tf.lbar.findtype
-side right
1459 pack
$fstring -side left
-expand 1 -fill x
1461 # Finish putting the upper half of the viewer together
1462 pack .tf.lbar
-in .tf
-side bottom
-fill x
1463 pack .tf.bar
-in .tf
-side bottom
-fill x
1464 pack .tf.histframe
-fill both
-side top
-expand 1
1466 .ctop paneconfigure .tf
-height $geometry(topheight
)
1467 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1469 # now build up the bottom
1470 panedwindow .pwbottom
-orient horizontal
1472 # lower left, a text box over search bar, scroll bar to the right
1473 # if we know window height, then that will set the lower text height, otherwise
1474 # we set lower text height which will drive window height
1475 if {[info exists geometry
(main
)]} {
1476 frame .bleft
-width $geometry(botwidth
)
1478 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
1483 button .bleft.top.search
-text "Search" -command dosearch \
1485 pack .bleft.top.search
-side left
-padx 5
1486 set sstring .bleft.top.sstring
1487 entry
$sstring -width 20 -font textfont
-textvariable searchstring
1488 lappend entries
$sstring
1489 trace add variable searchstring
write incrsearch
1490 pack
$sstring -side left
-expand 1 -fill x
1491 radiobutton .bleft.mid.
diff -text "Diff" -font uifont \
1492 -command changediffdisp
-variable diffelide
-value {0 0}
1493 radiobutton .bleft.mid.old
-text "Old version" -font uifont \
1494 -command changediffdisp
-variable diffelide
-value {0 1}
1495 radiobutton .bleft.mid.new
-text "New version" -font uifont \
1496 -command changediffdisp
-variable diffelide
-value {1 0}
1497 label .bleft.mid.labeldiffcontext
-text " Lines of context: " \
1499 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
1500 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
1501 -from 1 -increment 1 -to 10000000 \
1502 -validate all
-validatecommand "diffcontextvalidate %P" \
1503 -textvariable diffcontextstring
1504 .bleft.mid.diffcontext
set $diffcontext
1505 trace add variable diffcontextstring
write diffcontextchange
1506 lappend entries .bleft.mid.diffcontext
1507 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
1508 set ctext .bleft.ctext
1509 text
$ctext -background $bgcolor -foreground $fgcolor \
1510 -state disabled
-font textfont \
1511 -yscrollcommand scrolltext
-wrap none
1513 $ctext conf
-tabstyle wordprocessor
1515 scrollbar .bleft.sb
-command "$ctext yview"
1516 pack .bleft.top
-side top
-fill x
1517 pack .bleft.mid
-side top
-fill x
1518 pack .bleft.sb
-side right
-fill y
1519 pack
$ctext -side left
-fill both
-expand 1
1520 lappend bglist
$ctext
1521 lappend fglist
$ctext
1523 $ctext tag conf comment
-wrap $wrapcomment
1524 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
1525 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
1526 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
1527 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
1528 $ctext tag conf m0
-fore red
1529 $ctext tag conf m1
-fore blue
1530 $ctext tag conf m2
-fore green
1531 $ctext tag conf m3
-fore purple
1532 $ctext tag conf
m4 -fore brown
1533 $ctext tag conf m5
-fore "#009090"
1534 $ctext tag conf m6
-fore magenta
1535 $ctext tag conf m7
-fore "#808000"
1536 $ctext tag conf m8
-fore "#009000"
1537 $ctext tag conf m9
-fore "#ff0080"
1538 $ctext tag conf m10
-fore cyan
1539 $ctext tag conf m11
-fore "#b07070"
1540 $ctext tag conf m12
-fore "#70b0f0"
1541 $ctext tag conf m13
-fore "#70f0b0"
1542 $ctext tag conf m14
-fore "#f0b070"
1543 $ctext tag conf m15
-fore "#ff70b0"
1544 $ctext tag conf mmax
-fore darkgrey
1546 $ctext tag conf mresult
-font textfontbold
1547 $ctext tag conf msep
-font textfontbold
1548 $ctext tag conf found
-back yellow
1550 .pwbottom add .bleft
1551 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
1556 radiobutton .bright.mode.
patch -text "Patch" \
1557 -command reselectline
-variable cmitmode
-value "patch"
1558 .bright.mode.
patch configure
-font uifont
1559 radiobutton .bright.mode.tree
-text "Tree" \
1560 -command reselectline
-variable cmitmode
-value "tree"
1561 .bright.mode.tree configure
-font uifont
1562 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
1563 pack .bright.mode
-side top
-fill x
1564 set cflist .bright.cfiles
1565 set indent
[font measure mainfont
"nn"]
1567 -selectbackground $selectbgcolor \
1568 -background $bgcolor -foreground $fgcolor \
1570 -tabs [list
$indent [expr {2 * $indent}]] \
1571 -yscrollcommand ".bright.sb set" \
1572 -cursor [. cget
-cursor] \
1573 -spacing1 1 -spacing3 1
1574 lappend bglist
$cflist
1575 lappend fglist
$cflist
1576 scrollbar .bright.sb
-command "$cflist yview"
1577 pack .bright.sb
-side right
-fill y
1578 pack
$cflist -side left
-fill both
-expand 1
1579 $cflist tag configure highlight \
1580 -background [$cflist cget
-selectbackground]
1581 $cflist tag configure bold
-font mainfontbold
1583 .pwbottom add .bright
1586 # restore window position if known
1587 if {[info exists geometry
(main
)]} {
1588 wm geometry .
"$geometry(main)"
1591 if {[tk windowingsystem
] eq
{aqua
}} {
1597 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
1598 pack .ctop
-fill both
-expand 1
1599 bindall
<1> {selcanvline
%W
%x
%y
}
1600 #bindall <B1-Motion> {selcanvline %W %x %y}
1601 if {[tk windowingsystem
] == "win32"} {
1602 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
1603 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
1605 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
1606 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
1607 if {[tk windowingsystem
] eq
"aqua"} {
1608 bindall
<MouseWheel
> {
1609 set delta
[expr {- (%D
)}]
1610 allcanvs yview scroll
$delta units
1614 bindall
<2> "canvscan mark %W %x %y"
1615 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
1616 bindkey
<Home
> selfirstline
1617 bindkey
<End
> sellastline
1618 bind .
<Key-Up
> "selnextline -1"
1619 bind .
<Key-Down
> "selnextline 1"
1620 bind .
<Shift-Key-Up
> "dofind -1 0"
1621 bind .
<Shift-Key-Down
> "dofind 1 0"
1622 bindkey
<Key-Right
> "goforw"
1623 bindkey
<Key-Left
> "goback"
1624 bind .
<Key-Prior
> "selnextpage -1"
1625 bind .
<Key-Next
> "selnextpage 1"
1626 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
1627 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
1628 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
1629 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
1630 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1631 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1632 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
1633 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
1634 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
1635 bindkey p
"selnextline -1"
1636 bindkey n
"selnextline 1"
1639 bindkey i
"selnextline -1"
1640 bindkey k
"selnextline 1"
1643 bindkey b
"$ctext yview scroll -1 pages"
1644 bindkey d
"$ctext yview scroll 18 units"
1645 bindkey u
"$ctext yview scroll -18 units"
1646 bindkey
/ {dofind
1 1}
1647 bindkey
<Key-Return
> {dofind
1 1}
1648 bindkey ?
{dofind
-1 1}
1650 bindkey
<F5
> updatecommits
1651 bind .
<$M1B-q> doquit
1652 bind .
<$M1B-f> {dofind
1 1}
1653 bind .
<$M1B-g> {dofind
1 0}
1654 bind .
<$M1B-r> dosearchback
1655 bind .
<$M1B-s> dosearch
1656 bind .
<$M1B-equal> {incrfont
1}
1657 bind .
<$M1B-KP_Add> {incrfont
1}
1658 bind .
<$M1B-minus> {incrfont
-1}
1659 bind .
<$M1B-KP_Subtract> {incrfont
-1}
1660 wm protocol . WM_DELETE_WINDOW doquit
1661 bind .
<Button-1
> "click %W"
1662 bind $fstring <Key-Return
> {dofind
1 1}
1663 bind $sha1entry <Key-Return
> gotocommit
1664 bind $sha1entry <<PasteSelection>> clearsha1
1665 bind $cflist <1> {sel_flist %W %x %y; break}
1666 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1667 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1668 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1670 set maincursor [. cget -cursor]
1671 set textcursor [$ctext cget -cursor]
1672 set curtextcursor $textcursor
1674 set rowctxmenu .rowctxmenu
1675 menu $rowctxmenu -tearoff 0
1676 $rowctxmenu add command -label "Diff this -> selected" \
1677 -command {diffvssel 0}
1678 $rowctxmenu add command -label "Diff selected -> this" \
1679 -command {diffvssel 1}
1680 $rowctxmenu add command -label "Make patch" -command mkpatch
1681 $rowctxmenu add command -label "Create tag" -command mktag
1682 $rowctxmenu add command -label "Write commit to file" -command writecommit
1683 $rowctxmenu add command -label "Create new branch" -command mkbranch
1684 $rowctxmenu add command -label "Cherry-pick this commit" \
1686 $rowctxmenu add command -label "Reset HEAD branch to here" \
1689 set fakerowmenu .fakerowmenu
1690 menu $fakerowmenu -tearoff 0
1691 $fakerowmenu add command -label "Diff this -> selected" \
1692 -command {diffvssel 0}
1693 $fakerowmenu add command -label "Diff selected -> this" \
1694 -command {diffvssel 1}
1695 $fakerowmenu add command -label "Make patch" -command mkpatch
1696 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1697 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1698 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
1700 set headctxmenu .headctxmenu
1701 menu $headctxmenu -tearoff 0
1702 $headctxmenu add command -label "Check out this branch" \
1704 $headctxmenu add command -label "Remove this branch" \
1708 set flist_menu .flistctxmenu
1709 menu $flist_menu -tearoff 0
1710 $flist_menu add command -label "Highlight this too" \
1711 -command {flist_hl 0}
1712 $flist_menu add command -label "Highlight this only" \
1713 -command {flist_hl 1}
1716 # Windows sends all mouse wheel events to the current focused window, not
1717 # the one where the mouse hovers, so bind those events here and redirect
1718 # to the correct window
1719 proc windows_mousewheel_redirector {W X Y D} {
1720 global canv canv2 canv3
1721 set w [winfo containing -displayof $W $X $Y]
1723 set u [expr {$D < 0 ? 5 : -5}]
1724 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1725 allcanvs yview scroll $u units
1728 $w yview scroll $u units
1734 # mouse-2 makes all windows scan vertically, but only the one
1735 # the cursor is in scans horizontally
1736 proc canvscan {op w x y} {
1737 global canv canv2 canv3
1738 foreach c [list $canv $canv2 $canv3] {
1747 proc scrollcanv {cscroll f0 f1} {
1748 $cscroll set $f0 $f1
1753 # when we make a key binding for the toplevel, make sure
1754 # it doesn't get triggered when that key is pressed in the
1755 # find string entry widget.
1756 proc bindkey {ev script} {
1759 set escript [bind Entry $ev]
1760 if {$escript == {}} {
1761 set escript [bind Entry <Key>]
1763 foreach e $entries {
1764 bind $e $ev "$escript; break"
1768 # set the focus back to the toplevel for any click outside
1771 global ctext entries
1772 foreach e [concat $entries $ctext] {
1773 if {$w == $e} return
1778 # Adjust the progress bar for a change in requested extent or canvas size
1779 proc adjustprogress {} {
1780 global progresscanv progressitem progresscoords
1781 global fprogitem fprogcoord lastprogupdate progupdatepending
1782 global rprogitem rprogcoord
1784 set w [expr {[winfo width $progresscanv] - 4}]
1785 set x0 [expr {$w * [lindex $progresscoords 0]}]
1786 set x1 [expr {$w * [lindex $progresscoords 1]}]
1787 set h [winfo height $progresscanv]
1788 $progresscanv coords $progressitem $x0 0 $x1 $h
1789 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1790 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1791 set now [clock clicks -milliseconds]
1792 if {$now >= $lastprogupdate + 100} {
1793 set progupdatepending 0
1795 } elseif {!$progupdatepending} {
1796 set progupdatepending 1
1797 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1801 proc doprogupdate {} {
1802 global lastprogupdate progupdatepending
1804 if {$progupdatepending} {
1805 set progupdatepending 0
1806 set lastprogupdate [clock clicks -milliseconds]
1811 proc savestuff {w} {
1812 global canv canv2 canv3 mainfont textfont uifont tabstop
1813 global stuffsaved findmergefiles maxgraphpct
1814 global maxwidth showneartags showlocalchanges
1815 global viewname viewfiles viewargs viewperm nextviewnum
1816 global cmitmode wrapcomment datetimeformat limitdiffs
1817 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1819 if {$stuffsaved} return
1820 if {![winfo viewable .]} return
1822 set f [open "~/.gitk-new" w]
1823 puts $f [list set mainfont $mainfont]
1824 puts $f [list set textfont $textfont]
1825 puts $f [list set uifont $uifont]
1826 puts $f [list set tabstop $tabstop]
1827 puts $f [list set findmergefiles $findmergefiles]
1828 puts $f [list set maxgraphpct $maxgraphpct]
1829 puts $f [list set maxwidth $maxwidth]
1830 puts $f [list set cmitmode $cmitmode]
1831 puts $f [list set wrapcomment $wrapcomment]
1832 puts $f [list set showneartags $showneartags]
1833 puts $f [list set showlocalchanges $showlocalchanges]
1834 puts $f [list set datetimeformat $datetimeformat]
1835 puts $f [list set limitdiffs $limitdiffs]
1836 puts $f [list set bgcolor $bgcolor]
1837 puts $f [list set fgcolor $fgcolor]
1838 puts $f [list set colors $colors]
1839 puts $f [list set diffcolors $diffcolors]
1840 puts $f [list set diffcontext $diffcontext]
1841 puts $f [list set selectbgcolor $selectbgcolor]
1843 puts $f "set geometry(main) [wm geometry .]"
1844 puts $f "set geometry(topwidth) [winfo width .tf]"
1845 puts $f "set geometry(topheight) [winfo height .tf]"
1846 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1847 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1848 puts $f "set geometry(botwidth) [winfo width .bleft]"
1849 puts $f "set geometry(botheight) [winfo height .bleft]"
1851 puts -nonewline $f "set permviews {"
1852 for {set v 0} {$v < $nextviewnum} {incr v} {
1853 if {$viewperm($v)} {
1854 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1859 file rename -force "~/.gitk-new" "~/.gitk"
1864 proc resizeclistpanes {win w} {
1866 if {[info exists oldwidth($win)]} {
1867 set s0 [$win sash coord 0]
1868 set s1 [$win sash coord 1]
1870 set sash0 [expr {int($w/2 - 2)}]
1871 set sash1 [expr {int($w*5/6 - 2)}]
1873 set factor [expr {1.0 * $w / $oldwidth($win)}]
1874 set sash0 [expr {int($factor * [lindex $s0 0])}]
1875 set sash1 [expr {int($factor * [lindex $s1 0])}]
1879 if {$sash1 < $sash0 + 20} {
1880 set sash1 [expr {$sash0 + 20}]
1882 if {$sash1 > $w - 10} {
1883 set sash1 [expr {$w - 10}]
1884 if {$sash0 > $sash1 - 20} {
1885 set sash0 [expr {$sash1 - 20}]
1889 $win sash place 0 $sash0 [lindex $s0 1]
1890 $win sash place 1 $sash1 [lindex $s1 1]
1892 set oldwidth($win) $w
1895 proc resizecdetpanes {win w} {
1897 if {[info exists oldwidth($win)]} {
1898 set s0 [$win sash coord 0]
1900 set sash0 [expr {int($w*3/4 - 2)}]
1902 set factor [expr {1.0 * $w / $oldwidth($win)}]
1903 set sash0 [expr {int($factor * [lindex $s0 0])}]
1907 if {$sash0 > $w - 15} {
1908 set sash0 [expr {$w - 15}]
1911 $win sash place 0 $sash0 [lindex $s0 1]
1913 set oldwidth($win) $w
1916 proc allcanvs args {
1917 global canv canv2 canv3
1923 proc bindall {event action} {
1924 global canv canv2 canv3
1925 bind $canv $event $action
1926 bind $canv2 $event $action
1927 bind $canv3 $event $action
1933 if {[winfo exists $w]} {
1938 wm title $w "About gitk"
1939 message $w.m -text {
1940 Gitk - a commit viewer for git
1942 Copyright © 2005-2006 Paul Mackerras
1944 Use and redistribute under the terms of the GNU General Public License} \
1945 -justify center -aspect 400 -border 2 -bg white -relief groove
1946 pack $w.m -side top -fill x -padx 2 -pady 2
1947 $w.m configure -font uifont
1948 button $w.ok -text Close -command "destroy $w" -default active
1949 pack $w.ok -side bottom
1950 $w.ok configure -font uifont
1951 bind $w <Visibility> "focus $w.ok"
1952 bind $w <Key-Escape> "destroy $w"
1953 bind $w <Key-Return> "destroy $w"
1959 if {[winfo exists $w]} {
1963 if {[tk windowingsystem] eq {aqua}} {
1969 wm title $w "Gitk key bindings"
1970 message $w.m -text "
1974 <Home> Move to first commit
1975 <End> Move to last commit
1976 <Up>, p, i Move up one commit
1977 <Down>, n, k Move down one commit
1978 <Left>, z, j Go back in history list
1979 <Right>, x, l Go forward in history list
1980 <PageUp> Move up one page in commit list
1981 <PageDown> Move down one page in commit list
1982 <$M1T-Home> Scroll to top of commit list
1983 <$M1T-End> Scroll to bottom of commit list
1984 <$M1T-Up> Scroll commit list up one line
1985 <$M1T-Down> Scroll commit list down one line
1986 <$M1T-PageUp> Scroll commit list up one page
1987 <$M1T-PageDown> Scroll commit list down one page
1988 <Shift-Up> Find backwards (upwards, later commits)
1989 <Shift-Down> Find forwards (downwards, earlier commits)
1990 <Delete>, b Scroll diff view up one page
1991 <Backspace> Scroll diff view up one page
1992 <Space> Scroll diff view down one page
1993 u Scroll diff view up 18 lines
1994 d Scroll diff view down 18 lines
1996 <$M1T-G> Move to next find hit
1997 <Return> Move to next find hit
1998 / Move to next find hit, or redo find
1999 ? Move to previous find hit
2000 f Scroll diff view to next file
2001 <$M1T-S> Search for next hit in diff view
2002 <$M1T-R> Search for previous hit in diff view
2003 <$M1T-KP+> Increase font size
2004 <$M1T-plus> Increase font size
2005 <$M1T-KP-> Decrease font size
2006 <$M1T-minus> Decrease font size
2009 -justify left -bg white -border 2 -relief groove
2010 pack $w.m -side top -fill both -padx 2 -pady 2
2011 $w.m configure -font uifont
2012 button $w.ok -text Close -command "destroy $w" -default active
2013 pack $w.ok -side bottom
2014 $w.ok configure -font uifont
2015 bind $w <Visibility> "focus $w.ok"
2016 bind $w <Key-Escape> "destroy $w"
2017 bind $w <Key-Return> "destroy $w"
2020 # Procedures for manipulating the file list window at the
2021 # bottom right of the overall window.
2023 proc treeview {w l openlevs} {
2024 global treecontents treediropen treeheight treeparent treeindex
2034 set treecontents() {}
2035 $w conf -state normal
2037 while {[string range $f 0 $prefixend] ne $prefix} {
2038 if {$lev <= $openlevs} {
2039 $w mark set e:$treeindex($prefix) "end -1c"
2040 $w mark gravity e:$treeindex($prefix) left
2042 set treeheight($prefix) $ht
2043 incr ht [lindex $htstack end]
2044 set htstack [lreplace $htstack end end]
2045 set prefixend [lindex $prefendstack end]
2046 set prefendstack [lreplace $prefendstack end end]
2047 set prefix [string range $prefix 0 $prefixend]
2050 set tail [string range $f [expr {$prefixend+1}] end]
2051 while {[set slash [string first "/" $tail]] >= 0} {
2054 lappend prefendstack $prefixend
2055 incr prefixend [expr {$slash + 1}]
2056 set d [string range $tail 0 $slash]
2057 lappend treecontents($prefix) $d
2058 set oldprefix $prefix
2060 set treecontents($prefix) {}
2061 set treeindex($prefix) [incr ix]
2062 set treeparent($prefix) $oldprefix
2063 set tail [string range $tail [expr {$slash+1}] end]
2064 if {$lev <= $openlevs} {
2066 set treediropen($prefix) [expr {$lev < $openlevs}]
2067 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2068 $w mark set d:$ix "end -1c"
2069 $w mark gravity d:$ix left
2071 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2073 $w image create end -align center -image $bm -padx 1 \
2075 $w insert end $d [highlight_tag $prefix]
2076 $w mark set s:$ix "end -1c"
2077 $w mark gravity s:$ix left
2082 if {$lev <= $openlevs} {
2085 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2087 $w insert end $tail [highlight_tag $f]
2089 lappend treecontents($prefix) $tail
2092 while {$htstack ne {}} {
2093 set treeheight($prefix) $ht
2094 incr ht [lindex $htstack end]
2095 set htstack [lreplace $htstack end end]
2096 set prefixend [lindex $prefendstack end]
2097 set prefendstack [lreplace $prefendstack end end]
2098 set prefix [string range $prefix 0 $prefixend]
2100 $w conf -state disabled
2103 proc linetoelt {l} {
2104 global treeheight treecontents
2109 foreach e $treecontents($prefix) {
2114 if {[string index $e end] eq "/"} {
2115 set n $treeheight($prefix$e)
2127 proc highlight_tree {y prefix} {
2128 global treeheight treecontents cflist
2130 foreach e $treecontents($prefix) {
2132 if {[highlight_tag $path] ne {}} {
2133 $cflist tag add bold $y.0 "$y.0 lineend"
2136 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2137 set y [highlight_tree $y $path]
2143 proc treeclosedir {w dir} {
2144 global treediropen treeheight treeparent treeindex
2146 set ix $treeindex($dir)
2147 $w conf -state normal
2148 $w delete s:$ix e:$ix
2149 set treediropen($dir) 0
2150 $w image configure a:$ix -image tri-rt
2151 $w conf -state disabled
2152 set n [expr {1 - $treeheight($dir)}]
2153 while {$dir ne {}} {
2154 incr treeheight($dir) $n
2155 set dir $treeparent($dir)
2159 proc treeopendir {w dir} {
2160 global treediropen treeheight treeparent treecontents treeindex
2162 set ix $treeindex($dir)
2163 $w conf -state normal
2164 $w image configure a:$ix -image tri-dn
2165 $w mark set e:$ix s:$ix
2166 $w mark gravity e:$ix right
2169 set n [llength $treecontents($dir)]
2170 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2173 incr treeheight($x) $n
2175 foreach e $treecontents($dir) {
2177 if {[string index $e end] eq "/"} {
2178 set iy $treeindex($de)
2179 $w mark set d:$iy e:$ix
2180 $w mark gravity d:$iy left
2181 $w insert e:$ix $str
2182 set treediropen($de) 0
2183 $w image create e:$ix -align center -image tri-rt -padx 1 \
2185 $w insert e:$ix $e [highlight_tag $de]
2186 $w mark set s:$iy e:$ix
2187 $w mark gravity s:$iy left
2188 set treeheight($de) 1
2190 $w insert e:$ix $str
2191 $w insert e:$ix $e [highlight_tag $de]
2194 $w mark gravity e:$ix left
2195 $w conf -state disabled
2196 set treediropen($dir) 1
2197 set top [lindex [split [$w index @0,0] .] 0]
2198 set ht [$w cget -height]
2199 set l [lindex [split [$w index s:$ix] .] 0]
2202 } elseif {$l + $n + 1 > $top + $ht} {
2203 set top [expr {$l + $n + 2 - $ht}]
2211 proc treeclick {w x y} {
2212 global treediropen cmitmode ctext cflist cflist_top
2214 if {$cmitmode ne "tree"} return
2215 if {![info exists cflist_top]} return
2216 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2217 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2218 $cflist tag add highlight $l.0 "$l.0 lineend"
2224 set e [linetoelt $l]
2225 if {[string index $e end] ne "/"} {
2227 } elseif {$treediropen($e)} {
2234 proc setfilelist {id} {
2235 global treefilelist cflist
2237 treeview $cflist $treefilelist($id) 0
2240 image create bitmap tri-rt -background black -foreground blue -data {
2241 #define tri-rt_width 13
2242 #define tri-rt_height 13
2243 static unsigned char tri-rt_bits[] = {
2244 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2245 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2248 #define tri-rt-mask_width 13
2249 #define tri-rt-mask_height 13
2250 static unsigned char tri-rt-mask_bits[] = {
2251 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2252 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2255 image create bitmap tri-dn -background black -foreground blue -data {
2256 #define tri-dn_width 13
2257 #define tri-dn_height 13
2258 static unsigned char tri-dn_bits[] = {
2259 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2260 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2263 #define tri-dn-mask_width 13
2264 #define tri-dn-mask_height 13
2265 static unsigned char tri-dn-mask_bits[] = {
2266 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2267 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2271 image create bitmap reficon-T -background black -foreground yellow -data {
2272 #define tagicon_width 13
2273 #define tagicon_height 9
2274 static unsigned char tagicon_bits[] = {
2275 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2276 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2278 #define tagicon-mask_width 13
2279 #define tagicon-mask_height 9
2280 static unsigned char tagicon-mask_bits[] = {
2281 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2282 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2285 #define headicon_width 13
2286 #define headicon_height 9
2287 static unsigned char headicon_bits[] = {
2288 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2289 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2292 #define headicon-mask_width 13
2293 #define headicon-mask_height 9
2294 static unsigned char headicon-mask_bits[] = {
2295 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2296 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2298 image create bitmap reficon-H -background black -foreground green \
2299 -data $rectdata -maskdata $rectmask
2300 image create bitmap reficon-o -background black -foreground "#ddddff" \
2301 -data $rectdata -maskdata $rectmask
2303 proc init_flist {first} {
2304 global cflist cflist_top difffilestart
2306 $cflist conf -state normal
2307 $cflist delete 0.0 end
2309 $cflist insert end $first
2311 $cflist tag add highlight 1.0 "1.0 lineend"
2313 catch {unset cflist_top}
2315 $cflist conf -state disabled
2316 set difffilestart {}
2319 proc highlight_tag {f} {
2320 global highlight_paths
2322 foreach p $highlight_paths {
2323 if {[string match $p $f]} {
2330 proc highlight_filelist {} {
2331 global cmitmode cflist
2333 $cflist conf -state normal
2334 if {$cmitmode ne "tree"} {
2335 set end [lindex [split [$cflist index end] .] 0]
2336 for {set l 2} {$l < $end} {incr l} {
2337 set line [$cflist get $l.0 "$l.0 lineend"]
2338 if {[highlight_tag $line] ne {}} {
2339 $cflist tag add bold $l.0 "$l.0 lineend"
2345 $cflist conf -state disabled
2348 proc unhighlight_filelist {} {
2351 $cflist conf -state normal
2352 $cflist tag remove bold 1.0 end
2353 $cflist conf -state disabled
2356 proc add_flist {fl} {
2359 $cflist conf -state normal
2361 $cflist insert end "\n"
2362 $cflist insert end $f [highlight_tag $f]
2364 $cflist conf -state disabled
2367 proc sel_flist {w x y} {
2368 global ctext difffilestart cflist cflist_top cmitmode
2370 if {$cmitmode eq "tree"} return
2371 if {![info exists cflist_top]} return
2372 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2373 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2374 $cflist tag add highlight $l.0 "$l.0 lineend"
2379 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2383 proc pop_flist_menu {w X Y x y} {
2384 global ctext cflist cmitmode flist_menu flist_menu_file
2385 global treediffs diffids
2388 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2390 if {$cmitmode eq "tree"} {
2391 set e [linetoelt $l]
2392 if {[string index $e end] eq "/"} return
2394 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2396 set flist_menu_file $e
2397 tk_popup $flist_menu $X $Y
2400 proc flist_hl {only} {
2401 global flist_menu_file findstring gdttype
2403 set x [shellquote $flist_menu_file]
2404 if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
2407 append findstring " " $x
2409 set gdttype "touching paths:"
2412 # Functions for adding and removing shell-type quoting
2414 proc shellquote {str} {
2415 if {![string match "*\['\"\\ \t]*" $str]} {
2418 if {![string match "*\['\"\\]*" $str]} {
2421 if {![string match "*'*" $str]} {
2424 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2427 proc shellarglist {l} {
2433 append str [shellquote $a]
2438 proc shelldequote {str} {
2443 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2444 append ret [string range $str $used end]
2445 set used [string length $str]
2448 set first [lindex $first 0]
2449 set ch [string index $str $first]
2450 if {$first > $used} {
2451 append ret [string range $str $used [expr {$first - 1}]]
2454 if {$ch eq " " || $ch eq "\t"} break
2457 set first [string first "'" $str $used]
2459 error "unmatched single-quote"
2461 append ret [string range $str $used [expr {$first - 1}]]
2466 if {$used >= [string length $str]} {
2467 error "trailing backslash"
2469 append ret [string index $str $used]
2474 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2475 error "unmatched double-quote"
2477 set first [lindex $first 0]
2478 set ch [string index $str $first]
2479 if {$first > $used} {
2480 append ret [string range $str $used [expr {$first - 1}]]
2483 if {$ch eq "\""} break
2485 append ret [string index $str $used]
2489 return [list $used $ret]
2492 proc shellsplit {str} {
2495 set str [string trimleft $str]
2496 if {$str eq {}} break
2497 set dq [shelldequote $str]
2498 set n [lindex $dq 0]
2499 set word [lindex $dq 1]
2500 set str [string range $str $n end]
2506 # Code to implement multiple views
2508 proc newview {ishighlight} {
2509 global nextviewnum newviewname newviewperm uifont newishighlight
2510 global newviewargs revtreeargs
2512 set newishighlight $ishighlight
2514 if {[winfo exists $top]} {
2518 set newviewname($nextviewnum) "View $nextviewnum"
2519 set newviewperm($nextviewnum) 0
2520 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2521 vieweditor $top $nextviewnum "Gitk view definition"
2526 global viewname viewperm newviewname newviewperm
2527 global viewargs newviewargs
2529 set top .gitkvedit-$curview
2530 if {[winfo exists $top]} {
2534 set newviewname($curview) $viewname($curview)
2535 set newviewperm($curview) $viewperm($curview)
2536 set newviewargs($curview) [shellarglist $viewargs($curview)]
2537 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2540 proc vieweditor {top n title} {
2541 global newviewname newviewperm viewfiles
2545 wm title $top $title
2546 label $top.nl -text "Name" -font uifont
2547 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
2548 grid $top.nl $top.name -sticky w -pady 5
2549 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
2551 grid $top.perm - -pady 5 -sticky w
2552 message $top.al -aspect 1000 -font uifont \
2553 -text "Commits to include (arguments to git rev-list):"
2554 grid $top.al - -sticky w -pady 5
2555 entry $top.args -width 50 -textvariable newviewargs($n) \
2556 -background white -font uifont
2557 grid $top.args - -sticky ew -padx 5
2558 message $top.l -aspect 1000 -font uifont \
2559 -text "Enter files and directories to include, one per line:"
2560 grid $top.l - -sticky w
2561 text $top.t -width 40 -height 10 -background white -font uifont
2562 if {[info exists viewfiles($n)]} {
2563 foreach f $viewfiles($n) {
2564 $top.t insert end $f
2565 $top.t insert end "\n"
2567 $top.t delete {end - 1c} end
2568 $top.t mark set insert 0.0
2570 grid $top.t - -sticky ew -padx 5
2572 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
2574 button $top.buts.can -text "Cancel" -command [list destroy $top] \
2576 grid $top.buts.ok $top.buts.can
2577 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2578 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2579 grid $top.buts - -pady 10 -sticky ew
2583 proc doviewmenu {m first cmd op argv} {
2584 set nmenu [$m index end]
2585 for {set i $first} {$i <= $nmenu} {incr i} {
2586 if {[$m entrycget $i -command] eq $cmd} {
2587 eval $m $op $i $argv
2593 proc allviewmenus {n op args} {
2596 doviewmenu .bar.view 5 [list showview $n] $op $args
2597 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2600 proc newviewok {top n} {
2601 global nextviewnum newviewperm newviewname newishighlight
2602 global viewname viewfiles viewperm selectedview curview
2603 global viewargs newviewargs viewhlmenu
2606 set newargs [shellsplit $newviewargs($n)]
2608 error_popup "Error in commit selection arguments: $err"
2614 foreach f [split [$top.t get 0.0 end] "\n"] {
2615 set ft [string trim $f]
2620 if {![info exists viewfiles($n)]} {
2621 # creating a new view
2623 set viewname($n) $newviewname($n)
2624 set viewperm($n) $newviewperm($n)
2625 set viewfiles($n) $files
2626 set viewargs($n) $newargs
2628 if {!$newishighlight} {
2631 run addvhighlight $n
2634 # editing an existing view
2635 set viewperm($n) $newviewperm($n)
2636 if {$newviewname($n) ne $viewname($n)} {
2637 set viewname($n) $newviewname($n)
2638 doviewmenu .bar.view 5 [list showview $n] \
2639 entryconf [list -label $viewname($n)]
2640 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2641 # entryconf [list -label $viewname($n) -value $viewname($n)]
2643 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2644 set viewfiles($n) $files
2645 set viewargs($n) $newargs
2646 if {$curview == $n} {
2651 catch {destroy $top}
2655 global curview viewperm hlview selectedhlview
2657 if {$curview == 0} return
2658 if {[info exists hlview] && $hlview == $curview} {
2659 set selectedhlview None
2662 allviewmenus $curview delete
2663 set viewperm($curview) 0
2667 proc addviewmenu {n} {
2668 global viewname viewhlmenu
2670 .bar.view add radiobutton -label $viewname($n) \
2671 -command [list showview $n] -variable selectedview -value $n
2672 #$viewhlmenu add radiobutton -label $viewname($n) \
2673 # -command [list addvhighlight $n] -variable selectedhlview
2677 global curview viewfiles cached_commitrow
2678 global displayorder parentlist rowidlist rowisopt rowfinal
2679 global colormap rowtextx nextcolor canvxmax
2680 global numcommits viewcomplete
2681 global selectedline currentid canv canvy0
2683 global pending_select
2685 global selectedview selectfirst
2686 global hlview selectedhlview commitinterest
2688 if {$n == $curview} return
2690 set ymax [lindex [$canv cget -scrollregion] 3]
2691 set span [$canv yview]
2692 set ytop [expr {[lindex $span 0] * $ymax}]
2693 set ybot [expr {[lindex $span 1] * $ymax}]
2694 set yscreen [expr {($ybot - $ytop) / 2}]
2695 if {[info exists selectedline]} {
2696 set selid $currentid
2697 set y [yc $selectedline]
2698 if {$ytop < $y && $y < $ybot} {
2699 set yscreen [expr {$y - $ytop}]
2701 } elseif {[info exists pending_select]} {
2702 set selid $pending_select
2703 unset pending_select
2707 catch {unset treediffs}
2709 if {[info exists hlview] && $hlview == $n} {
2711 set selectedhlview None
2713 catch {unset commitinterest}
2714 catch {unset cached_commitrow}
2718 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2719 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2722 if {![info exists viewcomplete($n)]} {
2724 set pending_select $selid
2735 set numcommits $commitidx($n)
2737 catch {unset colormap}
2738 catch {unset rowtextx}
2740 set canvxmax [$canv cget -width]
2747 if {$selid ne {} && [commitinview $selid $n]} {
2748 set row [rowofcommit $selid]
2749 # try to get the selected row in the same position on the screen
2750 set ymax [lindex [$canv cget -scrollregion] 3]
2751 set ytop [expr {[yc $row] - $yscreen}]
2755 set yf [expr {$ytop * 1.0 / $ymax}]
2757 allcanvs yview moveto $yf
2761 } elseif {$selid ne {}} {
2762 set pending_select $selid
2764 set row [first_real_row]
2765 if {$row < $numcommits} {
2771 if {!$viewcomplete($n)} {
2772 if {$numcommits == 0} {
2773 show_status "Reading commits..."
2777 } elseif {$numcommits == 0} {
2778 show_status "No commits selected"
2782 # Stuff relating to the highlighting facility
2784 proc ishighlighted {row} {
2785 global vhighlights fhighlights nhighlights rhighlights
2787 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2788 return $nhighlights($row)
2790 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2791 return $vhighlights($row)
2793 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2794 return $fhighlights($row)
2796 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2797 return $rhighlights($row)
2802 proc bolden {row font} {
2803 global canv linehtag selectedline boldrows
2805 lappend boldrows $row
2806 $canv itemconf $linehtag($row) -font $font
2807 if {[info exists selectedline] && $row == $selectedline} {
2809 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2810 -outline {{}} -tags secsel \
2811 -fill [$canv cget -selectbackground]]
2816 proc bolden_name {row font} {
2817 global canv2 linentag selectedline boldnamerows
2819 lappend boldnamerows $row
2820 $canv2 itemconf $linentag($row) -font $font
2821 if {[info exists selectedline] && $row == $selectedline} {
2822 $canv2 delete secsel
2823 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2824 -outline {{}} -tags secsel \
2825 -fill [$canv2 cget -selectbackground]]
2834 foreach row $boldrows {
2835 if {![ishighlighted $row]} {
2836 bolden $row mainfont
2838 lappend stillbold $row
2841 set boldrows $stillbold
2844 proc addvhighlight {n} {
2845 global hlview viewcomplete curview vhl_done vhighlights commitidx
2847 if {[info exists hlview]} {
2851 if {$n != $curview && ![info exists viewcomplete($n)]} {
2854 set vhl_done $commitidx($hlview)
2855 if {$vhl_done > 0} {
2860 proc delvhighlight {} {
2861 global hlview vhighlights
2863 if {![info exists hlview]} return
2865 catch {unset vhighlights}
2869 proc vhighlightmore {} {
2870 global hlview vhl_done commitidx vhighlights curview
2872 set max $commitidx($hlview)
2873 set vr [visiblerows]
2874 set r0 [lindex $vr 0]
2875 set r1 [lindex $vr 1]
2876 for {set i $vhl_done} {$i < $max} {incr i} {
2877 set id [commitonrow $i $hlview]
2878 if {[commitinview $id $curview]} {
2879 set row [rowofcommit $id]
2880 if {$r0 <= $row && $row <= $r1} {
2881 if {![highlighted $row]} {
2882 bolden $row mainfontbold
2884 set vhighlights($row) 1
2891 proc askvhighlight {row id} {
2892 global hlview vhighlights iddrawn
2894 if {[commitinview $id $hlview]} {
2895 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2896 bolden $row mainfontbold
2898 set vhighlights($row) 1
2900 set vhighlights($row) 0
2904 proc hfiles_change {} {
2905 global highlight_files filehighlight fhighlights fh_serial
2906 global highlight_paths gdttype
2908 if {[info exists filehighlight]} {
2909 # delete previous highlights
2910 catch {close $filehighlight}
2912 catch {unset fhighlights}
2914 unhighlight_filelist
2916 set highlight_paths {}
2917 after cancel do_file_hl $fh_serial
2919 if {$highlight_files ne {}} {
2920 after 300 do_file_hl $fh_serial
2924 proc gdttype_change {name ix op} {
2925 global gdttype highlight_files findstring findpattern
2928 if {$findstring ne {}} {
2929 if {$gdttype eq "containing:"} {
2930 if {$highlight_files ne {}} {
2931 set highlight_files {}
2936 if {$findpattern ne {}} {
2940 set highlight_files $findstring
2945 # enable/disable findtype/findloc menus too
2948 proc find_change {name ix op} {
2949 global gdttype findstring highlight_files
2952 if {$gdttype eq "containing:"} {
2955 if {$highlight_files ne $findstring} {
2956 set highlight_files $findstring
2963 proc findcom_change args {
2964 global nhighlights boldnamerows
2965 global findpattern findtype findstring gdttype
2968 # delete previous highlights, if any
2969 foreach row $boldnamerows {
2970 bolden_name $row mainfont
2973 catch {unset nhighlights}
2976 if {$gdttype ne "containing:" || $findstring eq {}} {
2978 } elseif {$findtype eq "Regexp"} {
2979 set findpattern $findstring
2981 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2983 set findpattern "*$e*"
2987 proc makepatterns {l} {
2990 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2991 if {[string index $ee end] eq "/"} {
3001 proc do_file_hl {serial} {
3002 global highlight_files filehighlight highlight_paths gdttype fhl_list
3004 if {$gdttype eq "touching paths:"} {
3005 if {[catch {set paths [shellsplit $highlight_files]}]} return
3006 set highlight_paths [makepatterns $paths]
3008 set gdtargs [concat -- $paths]
3009 } elseif {$gdttype eq "adding/removing string:"} {
3010 set gdtargs [list "-S$highlight_files"]
3012 # must be "containing:", i.e. we're searching commit info
3015 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3016 set filehighlight [open $cmd r+]
3017 fconfigure $filehighlight -blocking 0
3018 filerun $filehighlight readfhighlight
3024 proc flushhighlights {} {
3025 global filehighlight fhl_list
3027 if {[info exists filehighlight]} {
3029 puts $filehighlight ""
3030 flush $filehighlight
3034 proc askfilehighlight {row id} {
3035 global filehighlight fhighlights fhl_list
3037 lappend fhl_list $id
3038 set fhighlights($row) -1
3039 puts $filehighlight $id
3042 proc readfhighlight {} {
3043 global filehighlight fhighlights curview iddrawn
3044 global fhl_list find_dirn
3046 if {![info exists filehighlight]} {
3050 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3051 set line [string trim $line]
3052 set i [lsearch -exact $fhl_list $line]
3053 if {$i < 0} continue
3054 for {set j 0} {$j < $i} {incr j} {
3055 set id [lindex $fhl_list $j]
3056 if {[commitinview $id $curview]} {
3057 set fhighlights([rowofcommit $id]) 0
3060 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3061 if {$line eq {}} continue
3062 if {![commitinview $line $curview]} continue
3063 set row [rowofcommit $line]
3064 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
3065 bolden $row mainfontbold
3067 set fhighlights($row) 1
3069 if {[eof $filehighlight]} {
3071 puts "oops, git diff-tree died"
3072 catch {close $filehighlight}
3076 if {[info exists find_dirn]} {
3082 proc doesmatch {f} {
3083 global findtype findpattern
3085 if {$findtype eq "Regexp"} {
3086 return [regexp $findpattern $f]
3087 } elseif {$findtype eq "IgnCase"} {
3088 return [string match -nocase $findpattern $f]
3090 return [string match $findpattern $f]
3094 proc askfindhighlight {row id} {
3095 global nhighlights commitinfo iddrawn
3097 global markingmatches
3099 if {![info exists commitinfo($id)]} {
3102 set info $commitinfo($id)
3104 set fldtypes {Headline Author Date Committer CDate Comments}
3105 foreach f $info ty $fldtypes {
3106 if {($findloc eq "All fields" || $findloc eq $ty) &&
3108 if {$ty eq "Author"} {
3115 if {$isbold && [info exists iddrawn($id)]} {
3116 if {![ishighlighted $row]} {
3117 bolden $row mainfontbold
3119 bolden_name $row mainfontbold
3122 if {$markingmatches} {
3123 markrowmatches $row $id
3126 set nhighlights($row) $isbold
3129 proc markrowmatches {row id} {
3130 global canv canv2 linehtag linentag commitinfo findloc
3132 set headline [lindex $commitinfo($id) 0]
3133 set author [lindex $commitinfo($id) 1]
3134 $canv delete match$row
3135 $canv2 delete match$row
3136 if {$findloc eq "All fields" || $findloc eq "Headline"} {
3137 set m [findmatches $headline]
3139 markmatches $canv $row $headline $linehtag($row) $m \
3140 [$canv itemcget $linehtag($row) -font] $row
3143 if {$findloc eq "All fields" || $findloc eq "Author"} {
3144 set m [findmatches $author]
3146 markmatches $canv2 $row $author $linentag($row) $m \
3147 [$canv2 itemcget $linentag($row) -font] $row
3152 proc vrel_change {name ix op} {
3153 global highlight_related
3156 if {$highlight_related ne "None"} {
3161 # prepare for testing whether commits are descendents or ancestors of a
3162 proc rhighlight_sel {a} {
3163 global descendent desc_todo ancestor anc_todo
3164 global highlight_related rhighlights
3166 catch {unset descendent}
3167 set desc_todo [list $a]
3168 catch {unset ancestor}
3169 set anc_todo [list $a]
3170 if {$highlight_related ne "None"} {
3176 proc rhighlight_none {} {
3179 catch {unset rhighlights}
3183 proc is_descendent {a} {
3184 global curview children descendent desc_todo
3187 set la [rowofcommit $a]
3191 for {set i 0} {$i < [llength $todo]} {incr i} {
3192 set do [lindex $todo $i]
3193 if {[rowofcommit $do] < $la} {
3194 lappend leftover $do
3197 foreach nk $children($v,$do) {
3198 if {![info exists descendent($nk)]} {
3199 set descendent($nk) 1
3207 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3211 set descendent($a) 0
3212 set desc_todo $leftover
3215 proc is_ancestor {a} {
3216 global curview parents ancestor anc_todo
3219 set la [rowofcommit $a]
3223 for {set i 0} {$i < [llength $todo]} {incr i} {
3224 set do [lindex $todo $i]
3225 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3226 lappend leftover $do
3229 foreach np $parents($v,$do) {
3230 if {![info exists ancestor($np)]} {
3239 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3244 set anc_todo $leftover
3247 proc askrelhighlight {row id} {
3248 global descendent highlight_related iddrawn rhighlights
3249 global selectedline ancestor
3251 if {![info exists selectedline]} return
3253 if {$highlight_related eq "Descendent" ||
3254 $highlight_related eq "Not descendent"} {
3255 if {![info exists descendent($id)]} {
3258 if {$descendent($id) == ($highlight_related eq "Descendent")} {
3261 } elseif {$highlight_related eq "Ancestor" ||
3262 $highlight_related eq "Not ancestor"} {
3263 if {![info exists ancestor($id)]} {
3266 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
3270 if {[info exists iddrawn($id)]} {
3271 if {$isbold && ![ishighlighted $row]} {
3272 bolden $row mainfontbold
3275 set rhighlights($row) $isbold
3278 # Graph layout functions
3280 proc shortids {ids} {
3283 if {[llength $id] > 1} {
3284 lappend res [shortids $id]
3285 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3286 lappend res [string range $id 0 7]
3297 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3298 if {($n & $mask) != 0} {
3299 set ret [concat $ret $o]
3301 set o [concat $o $o]
3306 # Work out where id should go in idlist so that order-token
3307 # values increase from left to right
3308 proc idcol {idlist id {i 0}} {
3309 global ordertok curview
3311 set t $ordertok($curview,$id)
3312 if {$i >= [llength $idlist] ||
3313 $t < $ordertok($curview,[lindex $idlist $i])} {
3314 if {$i > [llength $idlist]} {
3315 set i [llength $idlist]
3317 while {[incr i -1] >= 0 &&
3318 $t < $ordertok($curview,[lindex $idlist $i])} {}
3321 if {$t > $ordertok($curview,[lindex $idlist $i])} {
3322 while {[incr i] < [llength $idlist] &&
3323 $t >= $ordertok($curview,[lindex $idlist $i])} {}
3329 proc initlayout {} {
3330 global rowidlist rowisopt rowfinal displayorder parentlist
3331 global numcommits canvxmax canv
3333 global colormap rowtextx
3343 set canvxmax [$canv cget -width]
3344 catch {unset colormap}
3345 catch {unset rowtextx}
3349 proc setcanvscroll {} {
3350 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3352 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3353 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3354 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3355 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3358 proc visiblerows {} {
3359 global canv numcommits linespc
3361 set ymax [lindex [$canv cget -scrollregion] 3]
3362 if {$ymax eq {} || $ymax == 0} return
3364 set y0 [expr {int([lindex $f 0] * $ymax)}]
3365 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3369 set y1 [expr {int([lindex $f 1] * $ymax)}]
3370 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3371 if {$r1 >= $numcommits} {
3372 set r1 [expr {$numcommits - 1}]
3374 return [list $r0 $r1]
3377 proc layoutmore {} {
3378 global commitidx viewcomplete numcommits
3379 global uparrowlen downarrowlen mingaplen curview
3381 set show $commitidx($curview)
3382 if {$show > $numcommits || $viewcomplete($curview)} {
3383 showstuff $show $viewcomplete($curview)
3387 proc showstuff {canshow last} {
3388 global numcommits pending_select selectedline curview
3390 global lastscrollset commitinterest
3392 if {$numcommits == 0} {
3394 set phase "incrdraw"
3398 set prev $numcommits
3399 set numcommits $canshow
3400 set t [clock clicks -milliseconds]
3401 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
3402 set lastscrollset $t
3405 set rows [visiblerows]
3406 set r1 [lindex $rows 1]
3407 if {$r1 >= $canshow} {
3408 set r1 [expr {$canshow - 1}]
3413 if {[info exists pending_select] &&
3414 [commitinview $pending_select $curview]} {
3415 selectline [rowofcommit $pending_select] 1
3418 if {[info exists selectedline] || [info exists pending_select]} {
3421 set l [first_real_row]
3428 proc doshowlocalchanges {} {
3429 global curview mainheadid phase
3431 if {[commitinview $mainheadid $curview]} {
3433 } elseif {$phase ne {}} {
3434 lappend commitinterest($mainheadid) {}
3438 proc dohidelocalchanges {} {
3439 global nullid nullid2 lserial curview
3441 if {[commitinview $nullid $curview]} {
3442 removerow $nullid $curview
3444 if {[commitinview $nullid2 $curview]} {
3445 removerow $nullid2 $curview
3450 # spawn off a process to do git diff-index --cached HEAD
3451 proc dodiffindex {} {
3452 global lserial showlocalchanges
3454 if {!$showlocalchanges} return
3456 set fd [open "|git diff-index --cached HEAD" r]
3457 fconfigure $fd -blocking 0
3458 filerun $fd [list readdiffindex $fd $lserial]
3461 proc readdiffindex {fd serial} {
3462 global mainheadid nullid2 curview commitinfo commitdata lserial
3465 if {[gets $fd line] < 0} {
3471 # we only need to see one line and we don't really care what it says...
3474 # now see if there are any local changes not checked in to the index
3475 if {$serial == $lserial} {
3476 set fd [open "|git diff-files" r]
3477 fconfigure $fd -blocking 0
3478 filerun $fd [list readdifffiles $fd $serial]
3481 if {$isdiff && $serial == $lserial && ![commitinview $nullid2 $curview]} {
3482 # add the line for the changes in the index to the graph
3483 set hl "Local changes checked in to index but not committed"
3484 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3485 set commitdata($nullid2) "\n $hl\n"
3486 insertrow $nullid2 $mainheadid $curview
3491 proc readdifffiles {fd serial} {
3492 global mainheadid nullid nullid2 curview
3493 global commitinfo commitdata lserial
3496 if {[gets $fd line] < 0} {
3502 # we only need to see one line and we don't really care what it says...
3505 if {$isdiff && $serial == $lserial && ![commitinview $nullid $curview]} {
3506 # add the line for the local diff to the graph
3507 set hl "Local uncommitted changes, not checked in to index"
3508 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3509 set commitdata($nullid) "\n $hl\n"
3510 if {[commitinview $nullid2 $curview]} {
3515 insertrow $nullid $p $curview
3520 proc nextuse {id row} {
3521 global curview children
3523 if {[info exists children($curview,$id)]} {
3524 foreach kid $children($curview,$id) {
3525 if {![commitinview $kid $curview]} {
3528 if {[rowofcommit $kid] > $row} {
3529 return [rowofcommit $kid]
3533 if {[commitinview $id $curview]} {
3534 return [rowofcommit $id]
3539 proc prevuse {id row} {
3540 global curview children
3543 if {[info exists children($curview,$id)]} {
3544 foreach kid $children($curview,$id) {
3545 if {![commitinview $kid $curview]} break
3546 if {[rowofcommit $kid] < $row} {
3547 set ret [rowofcommit $kid]
3554 proc make_idlist {row} {
3555 global displayorder parentlist uparrowlen downarrowlen mingaplen
3556 global commitidx curview ordertok children
3558 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3562 set ra [expr {$row - $downarrowlen}]
3566 set rb [expr {$row + $uparrowlen}]
3567 if {$rb > $commitidx($curview)} {
3568 set rb $commitidx($curview)
3570 make_disporder $r [expr {$rb + 1}]
3572 for {} {$r < $ra} {incr r} {
3573 set nextid [lindex $displayorder [expr {$r + 1}]]
3574 foreach p [lindex $parentlist $r] {
3575 if {$p eq $nextid} continue
3576 set rn [nextuse $p $r]
3578 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3579 lappend ids [list $ordertok($curview,$p) $p]
3583 for {} {$r < $row} {incr r} {
3584 set nextid [lindex $displayorder [expr {$r + 1}]]
3585 foreach p [lindex $parentlist $r] {
3586 if {$p eq $nextid} continue
3587 set rn [nextuse $p $r]
3588 if {$rn < 0 || $rn >= $row} {
3589 lappend ids [list $ordertok($curview,$p) $p]
3593 set id [lindex $displayorder $row]
3594 lappend ids [list $ordertok($curview,$id) $id]
3596 foreach p [lindex $parentlist $r] {
3597 set firstkid [lindex $children($curview,$p) 0]
3598 if {[rowofcommit $firstkid] < $row} {
3599 lappend ids [list $ordertok($curview,$p) $p]
3603 set id [lindex $displayorder $r]
3605 set firstkid [lindex $children($curview,$id) 0]
3606 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3607 lappend ids [list $ordertok($curview,$id) $id]
3612 foreach idx [lsort -unique $ids] {
3613 lappend idlist [lindex $idx 1]
3618 proc rowsequal {a b} {
3619 while {[set i [lsearch -exact $a {}]] >= 0} {
3620 set a [lreplace $a $i $i]
3622 while {[set i [lsearch -exact $b {}]] >= 0} {
3623 set b [lreplace $b $i $i]
3625 return [expr {$a eq $b}]
3628 proc makeupline {id row rend col} {
3629 global rowidlist uparrowlen downarrowlen mingaplen
3631 for {set r $rend} {1} {set r $rstart} {
3632 set rstart [prevuse $id $r]
3633 if {$rstart < 0} return
3634 if {$rstart < $row} break
3636 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3637 set rstart [expr {$rend - $uparrowlen - 1}]
3639 for {set r $rstart} {[incr r] <= $row} {} {
3640 set idlist [lindex $rowidlist $r]
3641 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3642 set col [idcol $idlist $id $col]
3643 lset rowidlist $r [linsert $idlist $col $id]
3649 proc layoutrows {row endrow} {
3650 global rowidlist rowisopt rowfinal displayorder
3651 global uparrowlen downarrowlen maxwidth mingaplen
3652 global children parentlist
3653 global commitidx viewcomplete curview
3655 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3658 set rm1 [expr {$row - 1}]
3659 foreach id [lindex $rowidlist $rm1] {
3664 set final [lindex $rowfinal $rm1]
3666 for {} {$row < $endrow} {incr row} {
3667 set rm1 [expr {$row - 1}]
3668 if {$rm1 < 0 || $idlist eq {}} {
3669 set idlist [make_idlist $row]
3672 set id [lindex $displayorder $rm1]
3673 set col [lsearch -exact $idlist $id]
3674 set idlist [lreplace $idlist $col $col]
3675 foreach p [lindex $parentlist $rm1] {
3676 if {[lsearch -exact $idlist $p] < 0} {
3677 set col [idcol $idlist $p $col]
3678 set idlist [linsert $idlist $col $p]
3679 # if not the first child, we have to insert a line going up
3680 if {$id ne [lindex $children($curview,$p) 0]} {
3681 makeupline $p $rm1 $row $col
3685 set id [lindex $displayorder $row]
3686 if {$row > $downarrowlen} {
3687 set termrow [expr {$row - $downarrowlen - 1}]
3688 foreach p [lindex $parentlist $termrow] {
3689 set i [lsearch -exact $idlist $p]
3690 if {$i < 0} continue
3691 set nr [nextuse $p $termrow]
3692 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3693 set idlist [lreplace $idlist $i $i]
3697 set col [lsearch -exact $idlist $id]
3699 set col [idcol $idlist $id]
3700 set idlist [linsert $idlist $col $id]
3701 if {$children($curview,$id) ne {}} {
3702 makeupline $id $rm1 $row $col
3705 set r [expr {$row + $uparrowlen - 1}]
3706 if {$r < $commitidx($curview)} {
3708 foreach p [lindex $parentlist $r] {
3709 if {[lsearch -exact $idlist $p] >= 0} continue
3710 set fk [lindex $children($curview,$p) 0]
3711 if {[rowofcommit $fk] < $row} {
3712 set x [idcol $idlist $p $x]
3713 set idlist [linsert $idlist $x $p]
3716 if {[incr r] < $commitidx($curview)} {
3717 set p [lindex $displayorder $r]
3718 if {[lsearch -exact $idlist $p] < 0} {
3719 set fk [lindex $children($curview,$p) 0]
3720 if {$fk ne {} && [rowofcommit $fk] < $row} {
3721 set x [idcol $idlist $p $x]
3722 set idlist [linsert $idlist $x $p]
3728 if {$final && !$viewcomplete($curview) &&
3729 $row + $uparrowlen + $mingaplen + $downarrowlen
3730 >= $commitidx($curview)} {
3733 set l [llength $rowidlist]
3735 lappend rowidlist $idlist
3737 lappend rowfinal $final
3738 } elseif {$row < $l} {
3739 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3740 lset rowidlist $row $idlist
3743 lset rowfinal $row $final
3745 set pad [ntimes [expr {$row - $l}] {}]
3746 set rowidlist [concat $rowidlist $pad]
3747 lappend rowidlist $idlist
3748 set rowfinal [concat $rowfinal $pad]
3749 lappend rowfinal $final
3750 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3756 proc changedrow {row} {
3757 global displayorder iddrawn rowisopt need_redisplay
3759 set l [llength $rowisopt]
3761 lset rowisopt $row 0
3762 if {$row + 1 < $l} {
3763 lset rowisopt [expr {$row + 1}] 0
3764 if {$row + 2 < $l} {
3765 lset rowisopt [expr {$row + 2}] 0
3769 set id [lindex $displayorder $row]
3770 if {[info exists iddrawn($id)]} {
3771 set need_redisplay 1
3775 proc insert_pad {row col npad} {
3778 set pad [ntimes $npad {}]
3779 set idlist [lindex $rowidlist $row]
3780 set bef [lrange $idlist 0 [expr {$col - 1}]]
3781 set aft [lrange $idlist $col end]
3782 set i [lsearch -exact $aft {}]
3784 set aft [lreplace $aft $i $i]
3786 lset rowidlist $row [concat $bef $pad $aft]
3790 proc optimize_rows {row col endrow} {
3791 global rowidlist rowisopt displayorder curview children
3796 for {} {$row < $endrow} {incr row; set col 0} {
3797 if {[lindex $rowisopt $row]} continue
3799 set y0 [expr {$row - 1}]
3800 set ym [expr {$row - 2}]
3801 set idlist [lindex $rowidlist $row]
3802 set previdlist [lindex $rowidlist $y0]
3803 if {$idlist eq {} || $previdlist eq {}} continue
3805 set pprevidlist [lindex $rowidlist $ym]
3806 if {$pprevidlist eq {}} continue
3812 for {} {$col < [llength $idlist]} {incr col} {
3813 set id [lindex $idlist $col]
3814 if {[lindex $previdlist $col] eq $id} continue
3819 set x0 [lsearch -exact $previdlist $id]
3820 if {$x0 < 0} continue
3821 set z [expr {$x0 - $col}]
3825 set xm [lsearch -exact $pprevidlist $id]
3827 set z0 [expr {$xm - $x0}]
3831 # if row y0 is the first child of $id then it's not an arrow
3832 if {[lindex $children($curview,$id) 0] ne
3833 [lindex $displayorder $y0]} {
3837 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3838 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3841 # Looking at lines from this row to the previous row,
3842 # make them go straight up if they end in an arrow on
3843 # the previous row; otherwise make them go straight up
3845 if {$z < -1 || ($z < 0 && $isarrow)} {
3846 # Line currently goes left too much;
3847 # insert pads in the previous row, then optimize it
3848 set npad [expr {-1 - $z + $isarrow}]
3849 insert_pad $y0 $x0 $npad
3851 optimize_rows $y0 $x0 $row
3853 set previdlist [lindex $rowidlist $y0]
3854 set x0 [lsearch -exact $previdlist $id]
3855 set z [expr {$x0 - $col}]
3857 set pprevidlist [lindex $rowidlist $ym]
3858 set xm [lsearch -exact $pprevidlist $id]
3859 set z0 [expr {$xm - $x0}]
3861 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3862 # Line currently goes right too much;
3863 # insert pads in this line
3864 set npad [expr {$z - 1 + $isarrow}]
3865 insert_pad $row $col $npad
3866 set idlist [lindex $rowidlist $row]
3868 set z [expr {$x0 - $col}]
3871 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3872 # this line links to its first child on row $row-2
3873 set id [lindex $displayorder $ym]
3874 set xc [lsearch -exact $pprevidlist $id]
3876 set z0 [expr {$xc - $x0}]
3879 # avoid lines jigging left then immediately right
3880 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3881 insert_pad $y0 $x0 1
3883 optimize_rows $y0 $x0 $row
3884 set previdlist [lindex $rowidlist $y0]
3888 # Find the first column that doesn't have a line going right
3889 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3890 set id [lindex $idlist $col]
3891 if {$id eq {}} break
3892 set x0 [lsearch -exact $previdlist $id]
3894 # check if this is the link to the first child
3895 set kid [lindex $displayorder $y0]
3896 if {[lindex $children($curview,$id) 0] eq $kid} {
3897 # it is, work out offset to child
3898 set x0 [lsearch -exact $previdlist $kid]
3901 if {$x0 <= $col} break
3903 # Insert a pad at that column as long as it has a line and
3904 # isn't the last column
3905 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3906 set idlist [linsert $idlist $col {}]
3907 lset rowidlist $row $idlist
3915 global canvx0 linespc
3916 return [expr {$canvx0 + $col * $linespc}]
3920 global canvy0 linespc
3921 return [expr {$canvy0 + $row * $linespc}]
3924 proc linewidth {id} {
3925 global thickerline lthickness
3928 if {[info exists thickerline] && $id eq $thickerline} {
3929 set wid [expr {2 * $lthickness}]
3934 proc rowranges {id} {
3935 global curview children uparrowlen downarrowlen
3938 set kids $children($curview,$id)
3944 foreach child $kids {
3945 if {![commitinview $child $curview]} break
3946 set row [rowofcommit $child]
3947 if {![info exists prev]} {
3948 lappend ret [expr {$row + 1}]
3950 if {$row <= $prevrow} {
3951 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
3953 # see if the line extends the whole way from prevrow to row
3954 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3955 [lsearch -exact [lindex $rowidlist \
3956 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3957 # it doesn't, see where it ends
3958 set r [expr {$prevrow + $downarrowlen}]
3959 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3960 while {[incr r -1] > $prevrow &&
3961 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3963 while {[incr r] <= $row &&
3964 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3968 # see where it starts up again
3969 set r [expr {$row - $uparrowlen}]
3970 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3971 while {[incr r] < $row &&
3972 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3974 while {[incr r -1] >= $prevrow &&
3975 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3981 if {$child eq $id} {
3990 proc drawlineseg {id row endrow arrowlow} {
3991 global rowidlist displayorder iddrawn linesegs
3992 global canv colormap linespc curview maxlinelen parentlist
3994 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3995 set le [expr {$row + 1}]
3998 set c [lsearch -exact [lindex $rowidlist $le] $id]
4004 set x [lindex $displayorder $le]
4009 if {[info exists iddrawn($x)] || $le == $endrow} {
4010 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4026 if {[info exists linesegs($id)]} {
4027 set lines $linesegs($id)
4029 set r0 [lindex $li 0]
4031 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4041 set li [lindex $lines [expr {$i-1}]]
4042 set r1 [lindex $li 1]
4043 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4048 set x [lindex $cols [expr {$le - $row}]]
4049 set xp [lindex $cols [expr {$le - 1 - $row}]]
4050 set dir [expr {$xp - $x}]
4052 set ith [lindex $lines $i 2]
4053 set coords [$canv coords $ith]
4054 set ah [$canv itemcget $ith -arrow]
4055 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4056 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4057 if {$x2 ne {} && $x - $x2 == $dir} {
4058 set coords [lrange $coords 0 end-2]
4061 set coords [list [xc $le $x] [yc $le]]
4064 set itl [lindex $lines [expr {$i-1}] 2]
4065 set al [$canv itemcget $itl -arrow]
4066 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4067 } elseif {$arrowlow} {
4068 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4069 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4073 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4074 for {set y $le} {[incr y -1] > $row} {} {
4076 set xp [lindex $cols [expr {$y - 1 - $row}]]
4077 set ndir [expr {$xp - $x}]
4078 if {$dir != $ndir || $xp < 0} {
4079 lappend coords [xc $y $x] [yc $y]
4085 # join parent line to first child
4086 set ch [lindex $displayorder $row]
4087 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4089 puts "oops: drawlineseg: child $ch not on row $row"
4090 } elseif {$xc != $x} {
4091 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4092 set d [expr {int(0.5 * $linespc)}]
4095 set x2 [expr {$x1 - $d}]
4097 set x2 [expr {$x1 + $d}]
4100 set y1 [expr {$y2 + $d}]
4101 lappend coords $x1 $y1 $x2 $y2
4102 } elseif {$xc < $x - 1} {
4103 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4104 } elseif {$xc > $x + 1} {
4105 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4109 lappend coords [xc $row $x] [yc $row]
4111 set xn [xc $row $xp]
4113 lappend coords $xn $yn
4117 set t [$canv create line $coords -width [linewidth $id] \
4118 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4121 set lines [linsert $lines $i [list $row $le $t]]
4123 $canv coords $ith $coords
4124 if {$arrow ne $ah} {
4125 $canv itemconf $ith -arrow $arrow
4127 lset lines $i 0 $row
4130 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4131 set ndir [expr {$xo - $xp}]
4132 set clow [$canv coords $itl]
4133 if {$dir == $ndir} {
4134 set clow [lrange $clow 2 end]
4136 set coords [concat $coords $clow]
4138 lset lines [expr {$i-1}] 1 $le
4140 # coalesce two pieces
4142 set b [lindex $lines [expr {$i-1}] 0]
4143 set e [lindex $lines $i 1]
4144 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4146 $canv coords $itl $coords
4147 if {$arrow ne $al} {
4148 $canv itemconf $itl -arrow $arrow
4152 set linesegs($id) $lines
4156 proc drawparentlinks {id row} {
4157 global rowidlist canv colormap curview parentlist
4158 global idpos linespc
4160 set rowids [lindex $rowidlist $row]
4161 set col [lsearch -exact $rowids $id]
4162 if {$col < 0} return
4163 set olds [lindex $parentlist $row]
4164 set row2 [expr {$row + 1}]
4165 set x [xc $row $col]
4168 set d [expr {int(0.5 * $linespc)}]
4169 set ymid [expr {$y + $d}]
4170 set ids [lindex $rowidlist $row2]
4171 # rmx = right-most X coord used
4174 set i [lsearch -exact $ids $p]
4176 puts "oops, parent $p of $id not in list"
4179 set x2 [xc $row2 $i]
4183 set j [lsearch -exact $rowids $p]
4185 # drawlineseg will do this one for us
4189 # should handle duplicated parents here...
4190 set coords [list $x $y]
4192 # if attaching to a vertical segment, draw a smaller
4193 # slant for visual distinctness
4196 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4198 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4200 } elseif {$i < $col && $i < $j} {
4201 # segment slants towards us already
4202 lappend coords [xc $row $j] $y
4204 if {$i < $col - 1} {
4205 lappend coords [expr {$x2 + $linespc}] $y
4206 } elseif {$i > $col + 1} {
4207 lappend coords [expr {$x2 - $linespc}] $y
4209 lappend coords $x2 $y2
4212 lappend coords $x2 $y2
4214 set t [$canv create line $coords -width [linewidth $p] \
4215 -fill $colormap($p) -tags lines.$p]
4219 if {$rmx > [lindex $idpos($id) 1]} {
4220 lset idpos($id) 1 $rmx
4225 proc drawlines {id} {
4228 $canv itemconf lines.$id -width [linewidth $id]
4231 proc drawcmittext {id row col} {
4232 global linespc canv canv2 canv3 fgcolor curview
4233 global cmitlisted commitinfo rowidlist parentlist
4234 global rowtextx idpos idtags idheads idotherrefs
4235 global linehtag linentag linedtag selectedline
4236 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4238 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4239 set listed $cmitlisted($curview,$id)
4240 if {$id eq $nullid} {
4242 } elseif {$id eq $nullid2} {
4245 set ofill [expr {$listed != 0? "blue": "white"}]
4247 set x [xc $row $col]
4249 set orad [expr {$linespc / 3}]
4251 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4252 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4253 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4254 } elseif {$listed == 2} {
4255 # triangle pointing left for left-side commits
4256 set t [$canv create polygon \
4257 [expr {$x - $orad}] $y \
4258 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4259 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4260 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4262 # triangle pointing right for right-side commits
4263 set t [$canv create polygon \
4264 [expr {$x + $orad - 1}] $y \
4265 [expr {$x - $orad}] [expr {$y - $orad}] \
4266 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4267 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4270 $canv bind $t <1> {selcanvline {} %x %y}
4271 set rmx [llength [lindex $rowidlist $row]]
4272 set olds [lindex $parentlist $row]
4274 set nextids [lindex $rowidlist [expr {$row + 1}]]
4276 set i [lsearch -exact $nextids $p]
4282 set xt [xc $row $rmx]
4283 set rowtextx($row) $xt
4284 set idpos($id) [list $x $xt $y]
4285 if {[info exists idtags($id)] || [info exists idheads($id)]
4286 || [info exists idotherrefs($id)]} {
4287 set xt [drawtags $id $x $xt $y]
4289 set headline [lindex $commitinfo($id) 0]
4290 set name [lindex $commitinfo($id) 1]
4291 set date [lindex $commitinfo($id) 2]
4292 set date [formatdate $date]
4295 set isbold [ishighlighted $row]
4297 lappend boldrows $row
4298 set font mainfontbold
4300 lappend boldnamerows $row
4301 set nfont mainfontbold
4304 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4305 -text $headline -font $font -tags text]
4306 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4307 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4308 -text $name -font $nfont -tags text]
4309 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4310 -text $date -font mainfont -tags text]
4311 if {[info exists selectedline] && $selectedline == $row} {
4314 set xr [expr {$xt + [font measure $font $headline]}]
4315 if {$xr > $canvxmax} {
4321 proc drawcmitrow {row} {
4322 global displayorder rowidlist nrows_drawn
4323 global iddrawn markingmatches
4324 global commitinfo numcommits
4325 global filehighlight fhighlights findpattern nhighlights
4326 global hlview vhighlights
4327 global highlight_related rhighlights
4329 if {$row >= $numcommits} return
4331 set id [lindex $displayorder $row]
4332 if {[info exists hlview] && ![info exists vhighlights($row)]} {
4333 askvhighlight $row $id
4335 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
4336 askfilehighlight $row $id
4338 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
4339 askfindhighlight $row $id
4341 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
4342 askrelhighlight $row $id
4344 if {![info exists iddrawn($id)]} {
4345 set col [lsearch -exact [lindex $rowidlist $row] $id]
4347 puts "oops, row $row id $id not in list"
4350 if {![info exists commitinfo($id)]} {
4354 drawcmittext $id $row $col
4358 if {$markingmatches} {
4359 markrowmatches $row $id
4363 proc drawcommits {row {endrow {}}} {
4364 global numcommits iddrawn displayorder curview need_redisplay
4365 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4370 if {$endrow eq {}} {
4373 if {$endrow >= $numcommits} {
4374 set endrow [expr {$numcommits - 1}]
4377 set rl1 [expr {$row - $downarrowlen - 3}]
4381 set ro1 [expr {$row - 3}]
4385 set r2 [expr {$endrow + $uparrowlen + 3}]
4386 if {$r2 > $numcommits} {
4389 for {set r $rl1} {$r < $r2} {incr r} {
4390 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4394 set rl1 [expr {$r + 1}]
4400 optimize_rows $ro1 0 $r2
4401 if {$need_redisplay || $nrows_drawn > 2000} {
4406 # make the lines join to already-drawn rows either side
4407 set r [expr {$row - 1}]
4408 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4411 set er [expr {$endrow + 1}]
4412 if {$er >= $numcommits ||
4413 ![info exists iddrawn([lindex $displayorder $er])]} {
4416 for {} {$r <= $er} {incr r} {
4417 set id [lindex $displayorder $r]
4418 set wasdrawn [info exists iddrawn($id)]
4420 if {$r == $er} break
4421 set nextid [lindex $displayorder [expr {$r + 1}]]
4422 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4423 drawparentlinks $id $r
4425 set rowids [lindex $rowidlist $r]
4426 foreach lid $rowids {
4427 if {$lid eq {}} continue
4428 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4430 # see if this is the first child of any of its parents
4431 foreach p [lindex $parentlist $r] {
4432 if {[lsearch -exact $rowids $p] < 0} {
4433 # make this line extend up to the child
4434 set lineend($p) [drawlineseg $p $r $er 0]
4438 set lineend($lid) [drawlineseg $lid $r $er 1]
4444 proc undolayout {row} {
4445 global uparrowlen mingaplen downarrowlen
4446 global rowidlist rowisopt rowfinal need_redisplay
4448 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4452 if {[llength $rowidlist] > $r} {
4454 set rowidlist [lrange $rowidlist 0 $r]
4455 set rowfinal [lrange $rowfinal 0 $r]
4456 set rowisopt [lrange $rowisopt 0 $r]
4457 set need_redisplay 1
4462 proc drawfrac {f0 f1} {
4465 set ymax [lindex [$canv cget -scrollregion] 3]
4466 if {$ymax eq {} || $ymax == 0} return
4467 set y0 [expr {int($f0 * $ymax)}]
4468 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4469 set y1 [expr {int($f1 * $ymax)}]
4470 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4471 drawcommits $row $endrow
4474 proc drawvisible {} {
4476 eval drawfrac [$canv yview]
4479 proc clear_display {} {
4480 global iddrawn linesegs need_redisplay nrows_drawn
4481 global vhighlights fhighlights nhighlights rhighlights
4484 catch {unset iddrawn}
4485 catch {unset linesegs}
4486 catch {unset vhighlights}
4487 catch {unset fhighlights}
4488 catch {unset nhighlights}
4489 catch {unset rhighlights}
4490 set need_redisplay 0
4494 proc findcrossings {id} {
4495 global rowidlist parentlist numcommits displayorder
4499 foreach {s e} [rowranges $id] {
4500 if {$e >= $numcommits} {
4501 set e [expr {$numcommits - 1}]
4503 if {$e <= $s} continue
4504 for {set row $e} {[incr row -1] >= $s} {} {
4505 set x [lsearch -exact [lindex $rowidlist $row] $id]
4507 set olds [lindex $parentlist $row]
4508 set kid [lindex $displayorder $row]
4509 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4510 if {$kidx < 0} continue
4511 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4513 set px [lsearch -exact $nextrow $p]
4514 if {$px < 0} continue
4515 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4516 if {[lsearch -exact $ccross $p] >= 0} continue
4517 if {$x == $px + ($kidx < $px? -1: 1)} {
4519 } elseif {[lsearch -exact $cross $p] < 0} {
4526 return [concat $ccross {{}} $cross]
4529 proc assigncolor {id} {
4530 global colormap colors nextcolor
4531 global parents children children curview
4533 if {[info exists colormap($id)]} return
4534 set ncolors [llength $colors]
4535 if {[info exists children($curview,$id)]} {
4536 set kids $children($curview,$id)
4540 if {[llength $kids] == 1} {
4541 set child [lindex $kids 0]
4542 if {[info exists colormap($child)]
4543 && [llength $parents($curview,$child)] == 1} {
4544 set colormap($id) $colormap($child)
4550 foreach x [findcrossings $id] {
4552 # delimiter between corner crossings and other crossings
4553 if {[llength $badcolors] >= $ncolors - 1} break
4554 set origbad $badcolors
4556 if {[info exists colormap($x)]
4557 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4558 lappend badcolors $colormap($x)
4561 if {[llength $badcolors] >= $ncolors} {
4562 set badcolors $origbad
4564 set origbad $badcolors
4565 if {[llength $badcolors] < $ncolors - 1} {
4566 foreach child $kids {
4567 if {[info exists colormap($child)]
4568 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4569 lappend badcolors $colormap($child)
4571 foreach p $parents($curview,$child) {
4572 if {[info exists colormap($p)]
4573 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4574 lappend badcolors $colormap($p)
4578 if {[llength $badcolors] >= $ncolors} {
4579 set badcolors $origbad
4582 for {set i 0} {$i <= $ncolors} {incr i} {
4583 set c [lindex $colors $nextcolor]
4584 if {[incr nextcolor] >= $ncolors} {
4587 if {[lsearch -exact $badcolors $c]} break
4589 set colormap($id) $c
4592 proc bindline {t id} {
4595 $canv bind $t <Enter> "lineenter %x %y $id"
4596 $canv bind $t <Motion> "linemotion %x %y $id"
4597 $canv bind $t <Leave> "lineleave $id"
4598 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4601 proc drawtags {id x xt y1} {
4602 global idtags idheads idotherrefs mainhead
4603 global linespc lthickness
4604 global canv rowtextx curview fgcolor bgcolor
4609 if {[info exists idtags($id)]} {
4610 set marks $idtags($id)
4611 set ntags [llength $marks]
4613 if {[info exists idheads($id)]} {
4614 set marks [concat $marks $idheads($id)]
4615 set nheads [llength $idheads($id)]
4617 if {[info exists idotherrefs($id)]} {
4618 set marks [concat $marks $idotherrefs($id)]
4624 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4625 set yt [expr {$y1 - 0.5 * $linespc}]
4626 set yb [expr {$yt + $linespc - 1}]
4630 foreach tag $marks {
4632 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4633 set wid [font measure mainfontbold $tag]
4635 set wid [font measure mainfont $tag]
4639 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4641 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4642 -width $lthickness -fill black -tags tag.$id]
4644 foreach tag $marks x $xvals wid $wvals {
4645 set xl [expr {$x + $delta}]
4646 set xr [expr {$x + $delta + $wid + $lthickness}]
4648 if {[incr ntags -1] >= 0} {
4650 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4651 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4652 -width 1 -outline black -fill yellow -tags tag.$id]
4653 $canv bind $t <1> [list showtag $tag 1]
4654 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4656 # draw a head or other ref
4657 if {[incr nheads -1] >= 0} {
4659 if {$tag eq $mainhead} {
4660 set font mainfontbold
4665 set xl [expr {$xl - $delta/2}]
4666 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4667 -width 1 -outline black -fill $col -tags tag.$id
4668 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4669 set rwid [font measure mainfont $remoteprefix]
4670 set xi [expr {$x + 1}]
4671 set yti [expr {$yt + 1}]
4672 set xri [expr {$x + $rwid}]
4673 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4674 -width 0 -fill "#ffddaa" -tags tag.$id
4677 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4678 -font $font -tags [list tag.$id text]]
4680 $canv bind $t <1> [list showtag $tag 1]
4681 } elseif {$nheads >= 0} {
4682 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4688 proc xcoord {i level ln} {
4689 global canvx0 xspc1 xspc2
4691 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4692 if {$i > 0 && $i == $level} {
4693 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4694 } elseif {$i > $level} {
4695 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4700 proc show_status {msg} {
4704 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4705 -tags text -fill $fgcolor
4708 # Don't change the text pane cursor if it is currently the hand cursor,
4709 # showing that we are over a sha1 ID link.
4710 proc settextcursor {c} {
4711 global ctext curtextcursor
4713 if {[$ctext cget -cursor] == $curtextcursor} {
4714 $ctext config -cursor $c
4716 set curtextcursor $c
4719 proc nowbusy {what {name {}}} {
4720 global isbusy busyname statusw
4722 if {[array names isbusy] eq {}} {
4723 . config -cursor watch
4727 set busyname($what) $name
4729 $statusw conf -text $name
4733 proc notbusy {what} {
4734 global isbusy maincursor textcursor busyname statusw
4738 if {$busyname($what) ne {} &&
4739 [$statusw cget -text] eq $busyname($what)} {
4740 $statusw conf -text {}
4743 if {[array names isbusy] eq {}} {
4744 . config -cursor $maincursor
4745 settextcursor $textcursor
4749 proc findmatches {f} {
4750 global findtype findstring
4751 if {$findtype == "Regexp"} {
4752 set matches [regexp -indices -all -inline $findstring $f]
4755 if {$findtype == "IgnCase"} {
4756 set f [string tolower $f]
4757 set fs [string tolower $fs]
4761 set l [string length $fs]
4762 while {[set j [string first $fs $f $i]] >= 0} {
4763 lappend matches [list $j [expr {$j+$l-1}]]
4764 set i [expr {$j + $l}]
4770 proc dofind {{dirn 1} {wrap 1}} {
4771 global findstring findstartline findcurline selectedline numcommits
4772 global gdttype filehighlight fh_serial find_dirn findallowwrap
4774 if {[info exists find_dirn]} {
4775 if {$find_dirn == $dirn} return
4779 if {$findstring eq {} || $numcommits == 0} return
4780 if {![info exists selectedline]} {
4781 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4783 set findstartline $selectedline
4785 set findcurline $findstartline
4786 nowbusy finding "Searching"
4787 if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4788 after cancel do_file_hl $fh_serial
4789 do_file_hl $fh_serial
4792 set findallowwrap $wrap
4796 proc stopfinding {} {
4797 global find_dirn findcurline fprogcoord
4799 if {[info exists find_dirn]} {
4809 global commitdata commitinfo numcommits findpattern findloc
4810 global findstartline findcurline findallowwrap
4811 global find_dirn gdttype fhighlights fprogcoord
4812 global curview varcorder vrownum varccommits
4814 if {![info exists find_dirn]} {
4817 set fldtypes {Headline Author Date Committer CDate Comments}
4820 if {$find_dirn > 0} {
4822 if {$l >= $numcommits} {
4825 if {$l <= $findstartline} {
4826 set lim [expr {$findstartline + 1}]
4829 set moretodo $findallowwrap
4836 if {$l >= $findstartline} {
4837 set lim [expr {$findstartline - 1}]
4840 set moretodo $findallowwrap
4843 set n [expr {($lim - $l) * $find_dirn}]
4850 set ai [bsearch $vrownum($curview) $l]
4851 set a [lindex $varcorder($curview) $ai]
4852 set arow [lindex $vrownum($curview) $ai]
4853 set ids [lindex $varccommits($curview,$a)]
4854 set arowend [expr {$arow + [llength $ids]}]
4855 if {$gdttype eq "containing:"} {
4856 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4857 if {$l < $arow || $l >= $arowend} {
4859 set a [lindex $varcorder($curview) $ai]
4860 set arow [lindex $vrownum($curview) $ai]
4861 set ids [lindex $varccommits($curview,$a)]
4862 set arowend [expr {$arow + [llength $ids]}]
4864 set id [lindex $ids [expr {$l - $arow}]]
4865 # shouldn't happen unless git log doesn't give all the commits...
4866 if {![info exists commitdata($id)] ||
4867 ![doesmatch $commitdata($id)]} {
4870 if {![info exists commitinfo($id)]} {
4873 set info $commitinfo($id)
4874 foreach f $info ty $fldtypes {
4875 if {($findloc eq "All fields" || $findloc eq $ty) &&
4884 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4885 if {$l < $arow || $l >= $arowend} {
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]}]
4892 set id [lindex $ids [expr {$l - $arow}]]
4893 if {![info exists fhighlights($l)]} {
4894 askfilehighlight $l $id
4897 set findcurline [expr {$l - $find_dirn}]
4899 } elseif {$fhighlights($l)} {
4905 if {$found || ($domore && !$moretodo)} {
4921 set findcurline [expr {$l - $find_dirn}]
4923 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
4927 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4932 proc findselectline {l} {
4933 global findloc commentend ctext findcurline markingmatches gdttype
4935 set markingmatches 1
4938 if {$findloc == "All fields" || $findloc == "Comments"} {
4939 # highlight the matches in the comments
4940 set f [$ctext get 1.0 $commentend]
4941 set matches [findmatches $f]
4942 foreach match $matches {
4943 set start [lindex $match 0]
4944 set end [expr {[lindex $match 1] + 1}]
4945 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4951 # mark the bits of a headline or author that match a find string
4952 proc markmatches {canv l str tag matches font row} {
4955 set bbox [$canv bbox $tag]
4956 set x0 [lindex $bbox 0]
4957 set y0 [lindex $bbox 1]
4958 set y1 [lindex $bbox 3]
4959 foreach match $matches {
4960 set start [lindex $match 0]
4961 set end [lindex $match 1]
4962 if {$start > $end} continue
4963 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4964 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4965 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4966 [expr {$x0+$xlen+2}] $y1 \
4967 -outline {} -tags [list match$l matches] -fill yellow]
4969 if {[info exists selectedline] && $row == $selectedline} {
4970 $canv raise $t secsel
4975 proc unmarkmatches {} {
4976 global markingmatches
4978 allcanvs delete matches
4979 set markingmatches 0
4983 proc selcanvline {w x y} {
4984 global canv canvy0 ctext linespc
4986 set ymax [lindex [$canv cget -scrollregion] 3]
4987 if {$ymax == {}} return
4988 set yfrac [lindex [$canv yview] 0]
4989 set y [expr {$y + $yfrac * $ymax}]
4990 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4995 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
5001 proc commit_descriptor {p} {
5003 if {![info exists commitinfo($p)]} {
5007 if {[llength $commitinfo($p)] > 1} {
5008 set l [lindex $commitinfo($p) 0]
5013 # append some text to the ctext widget, and make any SHA1 ID
5014 # that we know about be a clickable link.
5015 proc appendwithlinks {text tags} {
5016 global ctext linknum curview pendinglinks
5018 set start [$ctext index "end - 1c"]
5019 $ctext insert end $text $tags
5020 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5024 set linkid [string range $text $s $e]
5026 $ctext tag delete link$linknum
5027 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5028 setlink $linkid link$linknum
5033 proc setlink {id lk} {
5034 global curview ctext pendinglinks commitinterest
5036 if {[commitinview $id $curview]} {
5037 $ctext tag conf $lk -foreground blue -underline 1
5038 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5039 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5040 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5042 lappend pendinglinks($id) $lk
5043 lappend commitinterest($id) {makelink %I}
5047 proc makelink {id} {
5050 if {![info exists pendinglinks($id)]} return
5051 foreach lk $pendinglinks($id) {
5054 unset pendinglinks($id)
5057 proc linkcursor {w inc} {
5058 global linkentercount curtextcursor
5060 if {[incr linkentercount $inc] > 0} {
5061 $w configure -cursor hand2
5063 $w configure -cursor $curtextcursor
5064 if {$linkentercount < 0} {
5065 set linkentercount 0
5070 proc viewnextline {dir} {
5074 set ymax [lindex [$canv cget -scrollregion] 3]
5075 set wnow [$canv yview]
5076 set wtop [expr {[lindex $wnow 0] * $ymax}]
5077 set newtop [expr {$wtop + $dir * $linespc}]
5080 } elseif {$newtop > $ymax} {
5083 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5086 # add a list of tag or branch names at position pos
5087 # returns the number of names inserted
5088 proc appendrefs {pos ids var} {
5089 global ctext linknum curview $var maxrefs
5091 if {[catch {$ctext index $pos}]} {
5094 $ctext conf -state normal
5095 $ctext delete $pos "$pos lineend"
5098 foreach tag [set $var\($id\)] {
5099 lappend tags [list $tag $id]
5102 if {[llength $tags] > $maxrefs} {
5103 $ctext insert $pos "many ([llength $tags])"
5105 set tags [lsort -index 0 -decreasing $tags]
5108 set id [lindex $ti 1]
5111 $ctext tag delete $lk
5112 $ctext insert $pos $sep
5113 $ctext insert $pos [lindex $ti 0] $lk
5118 $ctext conf -state disabled
5119 return [llength $tags]
5122 # called when we have finished computing the nearby tags
5123 proc dispneartags {delay} {
5124 global selectedline currentid showneartags tagphase
5126 if {![info exists selectedline] || !$showneartags} return
5127 after cancel dispnexttag
5129 after 200 dispnexttag
5132 after idle dispnexttag
5137 proc dispnexttag {} {
5138 global selectedline currentid showneartags tagphase ctext
5140 if {![info exists selectedline] || !$showneartags} return
5141 switch -- $tagphase {
5143 set dtags [desctags $currentid]
5145 appendrefs precedes $dtags idtags
5149 set atags [anctags $currentid]
5151 appendrefs follows $atags idtags
5155 set dheads [descheads $currentid]
5156 if {$dheads ne {}} {
5157 if {[appendrefs branch $dheads idheads] > 1
5158 && [$ctext get "branch -3c"] eq "h"} {
5159 # turn "Branch" into "Branches"
5160 $ctext conf -state normal
5161 $ctext insert "branch -2c" "es"
5162 $ctext conf -state disabled
5167 if {[incr tagphase] <= 2} {
5168 after idle dispnexttag
5172 proc make_secsel {l} {
5173 global linehtag linentag linedtag canv canv2 canv3
5175 if {![info exists linehtag($l)]} return
5177 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5178 -tags secsel -fill [$canv cget -selectbackground]]
5180 $canv2 delete secsel
5181 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5182 -tags secsel -fill [$canv2 cget -selectbackground]]
5184 $canv3 delete secsel
5185 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5186 -tags secsel -fill [$canv3 cget -selectbackground]]
5190 proc selectline {l isnew} {
5191 global canv ctext commitinfo selectedline
5192 global canvy0 linespc parents children curview
5193 global currentid sha1entry
5194 global commentend idtags linknum
5195 global mergemax numcommits pending_select
5196 global cmitmode showneartags allcommits
5198 catch {unset pending_select}
5203 if {$l < 0 || $l >= $numcommits} return
5204 set y [expr {$canvy0 + $l * $linespc}]
5205 set ymax [lindex [$canv cget -scrollregion] 3]
5206 set ytop [expr {$y - $linespc - 1}]
5207 set ybot [expr {$y + $linespc + 1}]
5208 set wnow [$canv yview]
5209 set wtop [expr {[lindex $wnow 0] * $ymax}]
5210 set wbot [expr {[lindex $wnow 1] * $ymax}]
5211 set wh [expr {$wbot - $wtop}]
5213 if {$ytop < $wtop} {
5214 if {$ybot < $wtop} {
5215 set newtop [expr {$y - $wh / 2.0}]
5218 if {$newtop > $wtop - $linespc} {
5219 set newtop [expr {$wtop - $linespc}]
5222 } elseif {$ybot > $wbot} {
5223 if {$ytop > $wbot} {
5224 set newtop [expr {$y - $wh / 2.0}]
5226 set newtop [expr {$ybot - $wh}]
5227 if {$newtop < $wtop + $linespc} {
5228 set newtop [expr {$wtop + $linespc}]
5232 if {$newtop != $wtop} {
5236 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5243 addtohistory [list selectline $l 0]
5248 set id [commitonrow $l]
5250 $sha1entry delete 0 end
5251 $sha1entry insert 0 $id
5252 $sha1entry selection from 0
5253 $sha1entry selection to end
5256 $ctext conf -state normal
5259 set info $commitinfo($id)
5260 set date [formatdate [lindex $info 2]]
5261 $ctext insert end "Author: [lindex $info 1] $date\n"
5262 set date [formatdate [lindex $info 4]]
5263 $ctext insert end "Committer: [lindex $info 3] $date\n"
5264 if {[info exists idtags($id)]} {
5265 $ctext insert end "Tags:"
5266 foreach tag $idtags($id) {
5267 $ctext insert end " $tag"
5269 $ctext insert end "\n"
5273 set olds $parents($curview,$id)
5274 if {[llength $olds] > 1} {
5277 if {$np >= $mergemax} {
5282 $ctext insert end "Parent: " $tag
5283 appendwithlinks [commit_descriptor $p] {}
5288 append headers "Parent: [commit_descriptor $p]"
5292 foreach c $children($curview,$id) {
5293 append headers "Child: [commit_descriptor $c]"
5296 # make anything that looks like a SHA1 ID be a clickable link
5297 appendwithlinks $headers {}
5298 if {$showneartags} {
5299 if {![info exists allcommits]} {
5302 $ctext insert end "Branch: "
5303 $ctext mark set branch "end -1c"
5304 $ctext mark gravity branch left
5305 $ctext insert end "\nFollows: "
5306 $ctext mark set follows "end -1c"
5307 $ctext mark gravity follows left
5308 $ctext insert end "\nPrecedes: "
5309 $ctext mark set precedes "end -1c"
5310 $ctext mark gravity precedes left
5311 $ctext insert end "\n"
5314 $ctext insert end "\n"
5315 set comment [lindex $info 5]
5316 if {[string first "\r" $comment] >= 0} {
5317 set comment [string map {"\r" "\n "} $comment]
5319 appendwithlinks $comment {comment}
5321 $ctext tag remove found 1.0 end
5322 $ctext conf -state disabled
5323 set commentend [$ctext index "end - 1c"]
5325 init_flist "Comments"
5326 if {$cmitmode eq "tree"} {
5328 } elseif {[llength $olds] <= 1} {
5335 proc selfirstline {} {
5340 proc sellastline {} {
5343 set l [expr {$numcommits - 1}]
5347 proc selnextline {dir} {
5350 if {![info exists selectedline]} return
5351 set l [expr {$selectedline + $dir}]
5356 proc selnextpage {dir} {
5357 global canv linespc selectedline numcommits
5359 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5363 allcanvs yview scroll [expr {$dir * $lpp}] units
5365 if {![info exists selectedline]} return
5366 set l [expr {$selectedline + $dir * $lpp}]
5369 } elseif {$l >= $numcommits} {
5370 set l [expr $numcommits - 1]
5376 proc unselectline {} {
5377 global selectedline currentid
5379 catch {unset selectedline}
5380 catch {unset currentid}
5381 allcanvs delete secsel
5385 proc reselectline {} {
5388 if {[info exists selectedline]} {
5389 selectline $selectedline 0
5393 proc addtohistory {cmd} {
5394 global history historyindex curview
5396 set elt [list $curview $cmd]
5397 if {$historyindex > 0
5398 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5402 if {$historyindex < [llength $history]} {
5403 set history [lreplace $history $historyindex end $elt]
5405 lappend history $elt
5408 if {$historyindex > 1} {
5409 .tf.bar.leftbut conf -state normal
5411 .tf.bar.leftbut conf -state disabled
5413 .tf.bar.rightbut conf -state disabled
5419 set view [lindex $elt 0]
5420 set cmd [lindex $elt 1]
5421 if {$curview != $view} {
5428 global history historyindex
5431 if {$historyindex > 1} {
5432 incr historyindex -1
5433 godo [lindex $history [expr {$historyindex - 1}]]
5434 .tf.bar.rightbut conf -state normal
5436 if {$historyindex <= 1} {
5437 .tf.bar.leftbut conf -state disabled
5442 global history historyindex
5445 if {$historyindex < [llength $history]} {
5446 set cmd [lindex $history $historyindex]
5449 .tf.bar.leftbut conf -state normal
5451 if {$historyindex >= [llength $history]} {
5452 .tf.bar.rightbut conf -state disabled
5457 global treefilelist treeidlist diffids diffmergeid treepending
5458 global nullid nullid2
5461 catch {unset diffmergeid}
5462 if {![info exists treefilelist($id)]} {
5463 if {![info exists treepending]} {
5464 if {$id eq $nullid} {
5465 set cmd [list | git ls-files]
5466 } elseif {$id eq $nullid2} {
5467 set cmd [list | git ls-files --stage -t]
5469 set cmd [list | git ls-tree -r $id]
5471 if {[catch {set gtf [open $cmd r]}]} {
5475 set treefilelist($id) {}
5476 set treeidlist($id) {}
5477 fconfigure $gtf -blocking 0
5478 filerun $gtf [list gettreeline $gtf $id]
5485 proc gettreeline {gtf id} {
5486 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5489 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5490 if {$diffids eq $nullid} {
5493 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5494 set i [string first "\t" $line]
5495 if {$i < 0} continue
5496 set sha1 [lindex $line 2]
5497 set fname [string range $line [expr {$i+1}] end]
5498 if {[string index $fname 0] eq "\""} {
5499 set fname [lindex $fname 0]
5501 lappend treeidlist($id) $sha1
5503 lappend treefilelist($id) $fname
5506 return [expr {$nl >= 1000? 2: 1}]
5510 if {$cmitmode ne "tree"} {
5511 if {![info exists diffmergeid]} {
5512 gettreediffs $diffids
5514 } elseif {$id ne $diffids} {
5523 global treefilelist treeidlist diffids nullid nullid2
5524 global ctext commentend
5526 set i [lsearch -exact $treefilelist($diffids) $f]
5528 puts "oops, $f not in list for id $diffids"
5531 if {$diffids eq $nullid} {
5532 if {[catch {set bf [open $f r]} err]} {
5533 puts "oops, can't read $f: $err"
5537 set blob [lindex $treeidlist($diffids) $i]
5538 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5539 puts "oops, error reading blob $blob: $err"
5543 fconfigure $bf -blocking 0
5544 filerun $bf [list getblobline $bf $diffids]
5545 $ctext config -state normal
5546 clear_ctext $commentend
5547 $ctext insert end "\n"
5548 $ctext insert end "$f\n" filesep
5549 $ctext config -state disabled
5550 $ctext yview $commentend
5554 proc getblobline {bf id} {
5555 global diffids cmitmode ctext
5557 if {$id ne $diffids || $cmitmode ne "tree"} {
5561 $ctext config -state normal
5563 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5564 $ctext insert end "$line\n"
5567 # delete last newline
5568 $ctext delete "end - 2c" "end - 1c"
5572 $ctext config -state disabled
5573 return [expr {$nl >= 1000? 2: 1}]
5576 proc mergediff {id} {
5577 global diffmergeid mdifffd
5580 global limitdiffs viewfiles curview
5584 # this doesn't seem to actually affect anything...
5585 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5586 if {$limitdiffs && $viewfiles($curview) ne {}} {
5587 set cmd [concat $cmd -- $viewfiles($curview)]
5589 if {[catch {set mdf [open $cmd r]} err]} {
5590 error_popup "Error getting merge diffs: $err"
5593 fconfigure $mdf -blocking 0
5594 set mdifffd($id) $mdf
5595 set np [llength $parents($curview,$id)]
5597 filerun $mdf [list getmergediffline $mdf $id $np]
5600 proc getmergediffline {mdf id np} {
5601 global diffmergeid ctext cflist mergemax
5602 global difffilestart mdifffd
5604 $ctext conf -state normal
5606 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5607 if {![info exists diffmergeid] || $id != $diffmergeid
5608 || $mdf != $mdifffd($id)} {
5612 if {[regexp {^diff --cc (.*)} $line match fname]} {
5613 # start of a new file
5614 $ctext insert end "\n"
5615 set here [$ctext index "end - 1c"]
5616 lappend difffilestart $here
5617 add_flist [list $fname]
5618 set l [expr {(78 - [string length $fname]) / 2}]
5619 set pad [string range "----------------------------------------" 1 $l]
5620 $ctext insert end "$pad $fname $pad\n" filesep
5621 } elseif {[regexp {^@@} $line]} {
5622 $ctext insert end "$line\n" hunksep
5623 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5626 # parse the prefix - one ' ', '-' or '+' for each parent
5631 for {set j 0} {$j < $np} {incr j} {
5632 set c [string range $line $j $j]
5635 } elseif {$c == "-"} {
5637 } elseif {$c == "+"} {
5646 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5647 # line doesn't appear in result, parents in $minuses have the line
5648 set num [lindex $minuses 0]
5649 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5650 # line appears in result, parents in $pluses don't have the line
5651 lappend tags mresult
5652 set num [lindex $spaces 0]
5655 if {$num >= $mergemax} {
5660 $ctext insert end "$line\n" $tags
5663 $ctext conf -state disabled
5668 return [expr {$nr >= 1000? 2: 1}]
5671 proc startdiff {ids} {
5672 global treediffs diffids treepending diffmergeid nullid nullid2
5676 catch {unset diffmergeid}
5677 if {![info exists treediffs($ids)] ||
5678 [lsearch -exact $ids $nullid] >= 0 ||
5679 [lsearch -exact $ids $nullid2] >= 0} {
5680 if {![info exists treepending]} {
5688 proc path_filter {filter name} {
5690 set l [string length $p]
5691 if {[string index $p end] eq "/"} {
5692 if {[string compare -length $l $p $name] == 0} {
5696 if {[string compare -length $l $p $name] == 0 &&
5697 ([string length $name] == $l ||
5698 [string index $name $l] eq "/")} {
5706 proc addtocflist {ids} {
5709 add_flist $treediffs($ids)
5713 proc diffcmd {ids flags} {
5714 global nullid nullid2
5716 set i [lsearch -exact $ids $nullid]
5717 set j [lsearch -exact $ids $nullid2]
5719 if {[llength $ids] > 1 && $j < 0} {
5720 # comparing working directory with some specific revision
5721 set cmd [concat | git diff-index $flags]
5723 lappend cmd -R [lindex $ids 1]
5725 lappend cmd [lindex $ids 0]
5728 # comparing working directory with index
5729 set cmd [concat | git diff-files $flags]
5734 } elseif {$j >= 0} {
5735 set cmd [concat | git diff-index --cached $flags]
5736 if {[llength $ids] > 1} {
5737 # comparing index with specific revision
5739 lappend cmd -R [lindex $ids 1]
5741 lappend cmd [lindex $ids 0]
5744 # comparing index with HEAD
5748 set cmd [concat | git diff-tree -r $flags $ids]
5753 proc gettreediffs {ids} {
5754 global treediff treepending
5756 set treepending $ids
5758 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5759 fconfigure $gdtf -blocking 0
5760 filerun $gdtf [list gettreediffline $gdtf $ids]
5763 proc gettreediffline {gdtf ids} {
5764 global treediff treediffs treepending diffids diffmergeid
5765 global cmitmode viewfiles curview limitdiffs
5768 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5769 set i [string first "\t" $line]
5771 set file [string range $line [expr {$i+1}] end]
5772 if {[string index $file 0] eq "\""} {
5773 set file [lindex $file 0]
5775 lappend treediff $file
5779 return [expr {$nr >= 1000? 2: 1}]
5782 if {$limitdiffs && $viewfiles($curview) ne {}} {
5784 foreach f $treediff {
5785 if {[path_filter $viewfiles($curview) $f]} {
5789 set treediffs($ids) $flist
5791 set treediffs($ids) $treediff
5794 if {$cmitmode eq "tree"} {
5796 } elseif {$ids != $diffids} {
5797 if {![info exists diffmergeid]} {
5798 gettreediffs $diffids
5806 # empty string or positive integer
5807 proc diffcontextvalidate {v} {
5808 return [regexp {^(|[1-9][0-9]*)$} $v]
5811 proc diffcontextchange {n1 n2 op} {
5812 global diffcontextstring diffcontext
5814 if {[string is integer -strict $diffcontextstring]} {
5815 if {$diffcontextstring > 0} {
5816 set diffcontext $diffcontextstring
5822 proc getblobdiffs {ids} {
5823 global blobdifffd diffids env
5824 global diffinhdr treediffs
5826 global limitdiffs viewfiles curview
5828 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5829 if {$limitdiffs && $viewfiles($curview) ne {}} {
5830 set cmd [concat $cmd -- $viewfiles($curview)]
5832 if {[catch {set bdf [open $cmd r]} err]} {
5833 puts "error getting diffs: $err"
5837 fconfigure $bdf -blocking 0
5838 set blobdifffd($ids) $bdf
5839 filerun $bdf [list getblobdiffline $bdf $diffids]
5842 proc setinlist {var i val} {
5845 while {[llength [set $var]] < $i} {
5848 if {[llength [set $var]] == $i} {
5855 proc makediffhdr {fname ids} {
5856 global ctext curdiffstart treediffs
5858 set i [lsearch -exact $treediffs($ids) $fname]
5860 setinlist difffilestart $i $curdiffstart
5862 set l [expr {(78 - [string length $fname]) / 2}]
5863 set pad [string range "----------------------------------------" 1 $l]
5864 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5867 proc getblobdiffline {bdf ids} {
5868 global diffids blobdifffd ctext curdiffstart
5869 global diffnexthead diffnextnote difffilestart
5870 global diffinhdr treediffs
5873 $ctext conf -state normal
5874 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5875 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5879 if {![string compare -length 11 "diff --git " $line]} {
5880 # trim off "diff --git "
5881 set line [string range $line 11 end]
5883 # start of a new file
5884 $ctext insert end "\n"
5885 set curdiffstart [$ctext index "end - 1c"]
5886 $ctext insert end "\n" filesep
5887 # If the name hasn't changed the length will be odd,
5888 # the middle char will be a space, and the two bits either
5889 # side will be a/name and b/name, or "a/name" and "b/name".
5890 # If the name has changed we'll get "rename from" and
5891 # "rename to" or "copy from" and "copy to" lines following this,
5892 # and we'll use them to get the filenames.
5893 # This complexity is necessary because spaces in the filename(s)
5894 # don't get escaped.
5895 set l [string length $line]
5896 set i [expr {$l / 2}]
5897 if {!(($l & 1) && [string index $line $i] eq " " &&
5898 [string range $line 2 [expr {$i - 1}]] eq \
5899 [string range $line [expr {$i + 3}] end])} {
5902 # unescape if quoted and chop off the a/ from the front
5903 if {[string index $line 0] eq "\""} {
5904 set fname [string range [lindex $line 0] 2 end]
5906 set fname [string range $line 2 [expr {$i - 1}]]
5908 makediffhdr $fname $ids
5910 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5911 $line match f1l f1c f2l f2c rest]} {
5912 $ctext insert end "$line\n" hunksep
5915 } elseif {$diffinhdr} {
5916 if {![string compare -length 12 "rename from " $line]} {
5917 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5918 if {[string index $fname 0] eq "\""} {
5919 set fname [lindex $fname 0]
5921 set i [lsearch -exact $treediffs($ids) $fname]
5923 setinlist difffilestart $i $curdiffstart
5925 } elseif {![string compare -length 10 $line "rename to "] ||
5926 ![string compare -length 8 $line "copy to "]} {
5927 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5928 if {[string index $fname 0] eq "\""} {
5929 set fname [lindex $fname 0]
5931 makediffhdr $fname $ids
5932 } elseif {[string compare -length 3 $line "---"] == 0} {
5935 } elseif {[string compare -length 3 $line "+++"] == 0} {
5939 $ctext insert end "$line\n" filesep
5942 set x [string range $line 0 0]
5943 if {$x == "-" || $x == "+"} {
5944 set tag [expr {$x == "+"}]
5945 $ctext insert end "$line\n" d$tag
5946 } elseif {$x == " "} {
5947 $ctext insert end "$line\n"
5949 # "\ No newline at end of file",
5950 # or something else we don't recognize
5951 $ctext insert end "$line\n" hunksep
5955 $ctext conf -state disabled
5960 return [expr {$nr >= 1000? 2: 1}]
5963 proc changediffdisp {} {
5964 global ctext diffelide
5966 $ctext tag conf d0 -elide [lindex $diffelide 0]
5967 $ctext tag conf d1 -elide [lindex $diffelide 1]
5971 global difffilestart ctext
5972 set prev [lindex $difffilestart 0]
5973 set here [$ctext index @0,0]
5974 foreach loc $difffilestart {
5975 if {[$ctext compare $loc >= $here]} {
5985 global difffilestart ctext
5986 set here [$ctext index @0,0]
5987 foreach loc $difffilestart {
5988 if {[$ctext compare $loc > $here]} {
5995 proc clear_ctext {{first 1.0}} {
5996 global ctext smarktop smarkbot
5999 set l [lindex [split $first .] 0]
6000 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6003 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6006 $ctext delete $first end
6007 if {$first eq "1.0"} {
6008 catch {unset pendinglinks}
6012 proc settabs {{firstab {}}} {
6013 global firsttabstop tabstop ctext have_tk85
6015 if {$firstab ne {} && $have_tk85} {
6016 set firsttabstop $firstab
6018 set w [font measure textfont "0"]
6019 if {$firsttabstop != 0} {
6020 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6021 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6022 } elseif {$have_tk85 || $tabstop != 8} {
6023 $ctext conf -tabs [expr {$tabstop * $w}]
6025 $ctext conf -tabs {}
6029 proc incrsearch {name ix op} {
6030 global ctext searchstring searchdirn
6032 $ctext tag remove found 1.0 end
6033 if {[catch {$ctext index anchor}]} {
6034 # no anchor set, use start of selection, or of visible area
6035 set sel [$ctext tag ranges sel]
6037 $ctext mark set anchor [lindex $sel 0]
6038 } elseif {$searchdirn eq "-forwards"} {
6039 $ctext mark set anchor @0,0
6041 $ctext mark set anchor @0,[winfo height $ctext]
6044 if {$searchstring ne {}} {
6045 set here [$ctext search $searchdirn -- $searchstring anchor]
6054 global sstring ctext searchstring searchdirn
6057 $sstring icursor end
6058 set searchdirn -forwards
6059 if {$searchstring ne {}} {
6060 set sel [$ctext tag ranges sel]
6062 set start "[lindex $sel 0] + 1c"
6063 } elseif {[catch {set start [$ctext index anchor]}]} {
6066 set match [$ctext search -count mlen -- $searchstring $start]
6067 $ctext tag remove sel 1.0 end
6073 set mend "$match + $mlen c"
6074 $ctext tag add sel $match $mend
6075 $ctext mark unset anchor
6079 proc dosearchback {} {
6080 global sstring ctext searchstring searchdirn
6083 $sstring icursor end
6084 set searchdirn -backwards
6085 if {$searchstring ne {}} {
6086 set sel [$ctext tag ranges sel]
6088 set start [lindex $sel 0]
6089 } elseif {[catch {set start [$ctext index anchor]}]} {
6090 set start @0,[winfo height $ctext]
6092 set match [$ctext search -backwards -count ml -- $searchstring $start]
6093 $ctext tag remove sel 1.0 end
6099 set mend "$match + $ml c"
6100 $ctext tag add sel $match $mend
6101 $ctext mark unset anchor
6105 proc searchmark {first last} {
6106 global ctext searchstring
6110 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6111 if {$match eq {}} break
6112 set mend "$match + $mlen c"
6113 $ctext tag add found $match $mend
6117 proc searchmarkvisible {doall} {
6118 global ctext smarktop smarkbot
6120 set topline [lindex [split [$ctext index @0,0] .] 0]
6121 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6122 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6123 # no overlap with previous
6124 searchmark $topline $botline
6125 set smarktop $topline
6126 set smarkbot $botline
6128 if {$topline < $smarktop} {
6129 searchmark $topline [expr {$smarktop-1}]
6130 set smarktop $topline
6132 if {$botline > $smarkbot} {
6133 searchmark [expr {$smarkbot+1}] $botline
6134 set smarkbot $botline
6139 proc scrolltext {f0 f1} {
6142 .bleft.sb set $f0 $f1
6143 if {$searchstring ne {}} {
6149 global linespc charspc canvx0 canvy0
6150 global xspc1 xspc2 lthickness
6152 set linespc [font metrics mainfont -linespace]
6153 set charspc [font measure mainfont "m"]
6154 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6155 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6156 set lthickness [expr {int($linespc / 9) + 1}]
6157 set xspc1(0) $linespc
6165 set ymax [lindex [$canv cget -scrollregion] 3]
6166 if {$ymax eq {} || $ymax == 0} return
6167 set span [$canv yview]
6170 allcanvs yview moveto [lindex $span 0]
6172 if {[info exists selectedline]} {
6173 selectline $selectedline 0
6174 allcanvs yview moveto [lindex $span 0]
6178 proc parsefont {f n} {
6181 set fontattr($f,family) [lindex $n 0]
6183 if {$s eq {} || $s == 0} {
6186 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6188 set fontattr($f,size) $s
6189 set fontattr($f,weight) normal
6190 set fontattr($f,slant) roman
6191 foreach style [lrange $n 2 end] {
6194 "bold" {set fontattr($f,weight) $style}
6196 "italic" {set fontattr($f,slant) $style}
6201 proc fontflags {f {isbold 0}} {
6204 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6205 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6206 -slant $fontattr($f,slant)]
6212 set n [list $fontattr($f,family) $fontattr($f,size)]
6213 if {$fontattr($f,weight) eq "bold"} {
6216 if {$fontattr($f,slant) eq "italic"} {
6222 proc incrfont {inc} {
6223 global mainfont textfont ctext canv cflist showrefstop
6224 global stopped entries fontattr
6227 set s $fontattr(mainfont,size)
6232 set fontattr(mainfont,size) $s
6233 font config mainfont -size $s
6234 font config mainfontbold -size $s
6235 set mainfont [fontname mainfont]
6236 set s $fontattr(textfont,size)
6241 set fontattr(textfont,size) $s
6242 font config textfont -size $s
6243 font config textfontbold -size $s
6244 set textfont [fontname textfont]
6251 global sha1entry sha1string
6252 if {[string length $sha1string] == 40} {
6253 $sha1entry delete 0 end
6257 proc sha1change {n1 n2 op} {
6258 global sha1string currentid sha1but
6259 if {$sha1string == {}
6260 || ([info exists currentid] && $sha1string == $currentid)} {
6265 if {[$sha1but cget -state] == $state} return
6266 if {$state == "normal"} {
6267 $sha1but conf -state normal -relief raised -text "Goto: "
6269 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
6273 proc gotocommit {} {
6274 global sha1string tagids headids curview varcid
6276 if {$sha1string == {}
6277 || ([info exists currentid] && $sha1string == $currentid)} return
6278 if {[info exists tagids($sha1string)]} {
6279 set id $tagids($sha1string)
6280 } elseif {[info exists headids($sha1string)]} {
6281 set id $headids($sha1string)
6283 set id [string tolower $sha1string]
6284 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6285 set matches [array names varcid "$curview,$id*"]
6286 if {$matches ne {}} {
6287 if {[llength $matches] > 1} {
6288 error_popup "Short SHA1 id $id is ambiguous"
6291 set id [lindex [split [lindex $matches 0] ","] 1]
6295 if {[commitinview $id $curview]} {
6296 selectline [rowofcommit $id] 1
6299 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6304 error_popup "$type $sha1string is not known"
6307 proc lineenter {x y id} {
6308 global hoverx hovery hoverid hovertimer
6309 global commitinfo canv
6311 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6315 if {[info exists hovertimer]} {
6316 after cancel $hovertimer
6318 set hovertimer [after 500 linehover]
6322 proc linemotion {x y id} {
6323 global hoverx hovery hoverid hovertimer
6325 if {[info exists hoverid] && $id == $hoverid} {
6328 if {[info exists hovertimer]} {
6329 after cancel $hovertimer
6331 set hovertimer [after 500 linehover]
6335 proc lineleave {id} {
6336 global hoverid hovertimer canv
6338 if {[info exists hoverid] && $id == $hoverid} {
6340 if {[info exists hovertimer]} {
6341 after cancel $hovertimer
6349 global hoverx hovery hoverid hovertimer
6350 global canv linespc lthickness
6353 set text [lindex $commitinfo($hoverid) 0]
6354 set ymax [lindex [$canv cget -scrollregion] 3]
6355 if {$ymax == {}} return
6356 set yfrac [lindex [$canv yview] 0]
6357 set x [expr {$hoverx + 2 * $linespc}]
6358 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6359 set x0 [expr {$x - 2 * $lthickness}]
6360 set y0 [expr {$y - 2 * $lthickness}]
6361 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6362 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6363 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6364 -fill \#ffff80 -outline black -width 1 -tags hover]
6366 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6371 proc clickisonarrow {id y} {
6374 set ranges [rowranges $id]
6375 set thresh [expr {2 * $lthickness + 6}]
6376 set n [expr {[llength $ranges] - 1}]
6377 for {set i 1} {$i < $n} {incr i} {
6378 set row [lindex $ranges $i]
6379 if {abs([yc $row] - $y) < $thresh} {
6386 proc arrowjump {id n y} {
6389 # 1 <-> 2, 3 <-> 4, etc...
6390 set n [expr {(($n - 1) ^ 1) + 1}]
6391 set row [lindex [rowranges $id] $n]
6393 set ymax [lindex [$canv cget -scrollregion] 3]
6394 if {$ymax eq {} || $ymax <= 0} return
6395 set view [$canv yview]
6396 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6397 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6401 allcanvs yview moveto $yfrac
6404 proc lineclick {x y id isnew} {
6405 global ctext commitinfo children canv thickerline curview
6407 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6412 # draw this line thicker than normal
6416 set ymax [lindex [$canv cget -scrollregion] 3]
6417 if {$ymax eq {}} return
6418 set yfrac [lindex [$canv yview] 0]
6419 set y [expr {$y + $yfrac * $ymax}]
6421 set dirn [clickisonarrow $id $y]
6423 arrowjump $id $dirn $y
6428 addtohistory [list lineclick $x $y $id 0]
6430 # fill the details pane with info about this line
6431 $ctext conf -state normal
6434 $ctext insert end "Parent:\t"
6435 $ctext insert end $id link0
6437 set info $commitinfo($id)
6438 $ctext insert end "\n\t[lindex $info 0]\n"
6439 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
6440 set date [formatdate [lindex $info 2]]
6441 $ctext insert end "\tDate:\t$date\n"
6442 set kids $children($curview,$id)
6444 $ctext insert end "\nChildren:"
6446 foreach child $kids {
6448 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6449 set info $commitinfo($child)
6450 $ctext insert end "\n\t"
6451 $ctext insert end $child link$i
6452 setlink $child link$i
6453 $ctext insert end "\n\t[lindex $info 0]"
6454 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
6455 set date [formatdate [lindex $info 2]]
6456 $ctext insert end "\n\tDate:\t$date\n"
6459 $ctext conf -state disabled
6463 proc normalline {} {
6465 if {[info exists thickerline]} {
6474 if {[commitinview $id $curview]} {
6475 selectline [rowofcommit $id] 1
6481 if {![info exists startmstime]} {
6482 set startmstime [clock clicks -milliseconds]
6484 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6487 proc rowmenu {x y id} {
6488 global rowctxmenu selectedline rowmenuid curview
6489 global nullid nullid2 fakerowmenu mainhead
6493 if {![info exists selectedline]
6494 || [rowofcommit $id] eq $selectedline} {
6499 if {$id ne $nullid && $id ne $nullid2} {
6500 set menu $rowctxmenu
6501 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6503 set menu $fakerowmenu
6505 $menu entryconfigure "Diff this*" -state $state
6506 $menu entryconfigure "Diff selected*" -state $state
6507 $menu entryconfigure "Make patch" -state $state
6508 tk_popup $menu $x $y
6511 proc diffvssel {dirn} {
6512 global rowmenuid selectedline
6514 if {![info exists selectedline]} return
6516 set oldid [commitonrow $selectedline]
6517 set newid $rowmenuid
6519 set oldid $rowmenuid
6520 set newid [commitonrow $selectedline]
6522 addtohistory [list doseldiff $oldid $newid]
6523 doseldiff $oldid $newid
6526 proc doseldiff {oldid newid} {
6530 $ctext conf -state normal
6533 $ctext insert end "From "
6534 $ctext insert end $oldid link0
6535 setlink $oldid link0
6536 $ctext insert end "\n "
6537 $ctext insert end [lindex $commitinfo($oldid) 0]
6538 $ctext insert end "\n\nTo "
6539 $ctext insert end $newid link1
6540 setlink $newid link1
6541 $ctext insert end "\n "
6542 $ctext insert end [lindex $commitinfo($newid) 0]
6543 $ctext insert end "\n"
6544 $ctext conf -state disabled
6545 $ctext tag remove found 1.0 end
6546 startdiff [list $oldid $newid]
6550 global rowmenuid currentid commitinfo patchtop patchnum
6552 if {![info exists currentid]} return
6553 set oldid $currentid
6554 set oldhead [lindex $commitinfo($oldid) 0]
6555 set newid $rowmenuid
6556 set newhead [lindex $commitinfo($newid) 0]
6559 catch {destroy $top}
6561 label $top.title -text "Generate patch"
6562 grid $top.title - -pady 10
6563 label $top.from -text "From:"
6564 entry $top.fromsha1 -width 40 -relief flat
6565 $top.fromsha1 insert 0 $oldid
6566 $top.fromsha1 conf -state readonly
6567 grid $top.from $top.fromsha1 -sticky w
6568 entry $top.fromhead -width 60 -relief flat
6569 $top.fromhead insert 0 $oldhead
6570 $top.fromhead conf -state readonly
6571 grid x $top.fromhead -sticky w
6572 label $top.to -text "To:"
6573 entry $top.tosha1 -width 40 -relief flat
6574 $top.tosha1 insert 0 $newid
6575 $top.tosha1 conf -state readonly
6576 grid $top.to $top.tosha1 -sticky w
6577 entry $top.tohead -width 60 -relief flat
6578 $top.tohead insert 0 $newhead
6579 $top.tohead conf -state readonly
6580 grid x $top.tohead -sticky w
6581 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6582 grid $top.rev x -pady 10
6583 label $top.flab -text "Output file:"
6584 entry $top.fname -width 60
6585 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6587 grid $top.flab $top.fname -sticky w
6589 button $top.buts.gen -text "Generate" -command mkpatchgo
6590 button $top.buts.can -text "Cancel" -command mkpatchcan
6591 grid $top.buts.gen $top.buts.can
6592 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6593 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6594 grid $top.buts - -pady 10 -sticky ew
6598 proc mkpatchrev {} {
6601 set oldid [$patchtop.fromsha1 get]
6602 set oldhead [$patchtop.fromhead get]
6603 set newid [$patchtop.tosha1 get]
6604 set newhead [$patchtop.tohead get]
6605 foreach e [list fromsha1 fromhead tosha1 tohead] \
6606 v [list $newid $newhead $oldid $oldhead] {
6607 $patchtop.$e conf -state normal
6608 $patchtop.$e delete 0 end
6609 $patchtop.$e insert 0 $v
6610 $patchtop.$e conf -state readonly
6615 global patchtop nullid nullid2
6617 set oldid [$patchtop.fromsha1 get]
6618 set newid [$patchtop.tosha1 get]
6619 set fname [$patchtop.fname get]
6620 set cmd [diffcmd [list $oldid $newid] -p]
6621 # trim off the initial "|"
6622 set cmd [lrange $cmd 1 end]
6623 lappend cmd >$fname &
6624 if {[catch {eval exec $cmd} err]} {
6625 error_popup "Error creating patch: $err"
6627 catch {destroy $patchtop}
6631 proc mkpatchcan {} {
6634 catch {destroy $patchtop}
6639 global rowmenuid mktagtop commitinfo
6643 catch {destroy $top}
6645 label $top.title -text "Create tag"
6646 grid $top.title - -pady 10
6647 label $top.id -text "ID:"
6648 entry $top.sha1 -width 40 -relief flat
6649 $top.sha1 insert 0 $rowmenuid
6650 $top.sha1 conf -state readonly
6651 grid $top.id $top.sha1 -sticky w
6652 entry $top.head -width 60 -relief flat
6653 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6654 $top.head conf -state readonly
6655 grid x $top.head -sticky w
6656 label $top.tlab -text "Tag name:"
6657 entry $top.tag -width 60
6658 grid $top.tlab $top.tag -sticky w
6660 button $top.buts.gen -text "Create" -command mktaggo
6661 button $top.buts.can -text "Cancel" -command mktagcan
6662 grid $top.buts.gen $top.buts.can
6663 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6664 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6665 grid $top.buts - -pady 10 -sticky ew
6670 global mktagtop env tagids idtags
6672 set id [$mktagtop.sha1 get]
6673 set tag [$mktagtop.tag get]
6675 error_popup "No tag name specified"
6678 if {[info exists tagids($tag)]} {
6679 error_popup "Tag \"$tag\" already exists"
6684 set fname [file join $dir "refs/tags" $tag]
6685 set f [open $fname w]
6689 error_popup "Error creating tag: $err"
6693 set tagids($tag) $id
6694 lappend idtags($id) $tag
6701 proc redrawtags {id} {
6702 global canv linehtag idpos selectedline curview
6703 global canvxmax iddrawn
6705 if {![commitinview $id $curview]} return
6706 if {![info exists iddrawn($id)]} return
6707 drawcommits [rowofcommit $id]
6708 $canv delete tag.$id
6709 set xt [eval drawtags $id $idpos($id)]
6710 $canv coords $linehtag([rowofcommit $id]) $xt [lindex $idpos($id) 2]
6711 set text [$canv itemcget $linehtag([rowofcommit $id]) -text]
6712 set xr [expr {$xt + [font measure mainfont $text]}]
6713 if {$xr > $canvxmax} {
6717 if {[info exists selectedline]
6718 && $selectedline == [rowofcommit $id]} {
6719 selectline $selectedline 0
6726 catch {destroy $mktagtop}
6735 proc writecommit {} {
6736 global rowmenuid wrcomtop commitinfo wrcomcmd
6738 set top .writecommit
6740 catch {destroy $top}
6742 label $top.title -text "Write commit to file"
6743 grid $top.title - -pady 10
6744 label $top.id -text "ID:"
6745 entry $top.sha1 -width 40 -relief flat
6746 $top.sha1 insert 0 $rowmenuid
6747 $top.sha1 conf -state readonly
6748 grid $top.id $top.sha1 -sticky w
6749 entry $top.head -width 60 -relief flat
6750 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6751 $top.head conf -state readonly
6752 grid x $top.head -sticky w
6753 label $top.clab -text "Command:"
6754 entry $top.cmd -width 60 -textvariable wrcomcmd
6755 grid $top.clab $top.cmd -sticky w -pady 10
6756 label $top.flab -text "Output file:"
6757 entry $top.fname -width 60
6758 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6759 grid $top.flab $top.fname -sticky w
6761 button $top.buts.gen -text "Write" -command wrcomgo
6762 button $top.buts.can -text "Cancel" -command wrcomcan
6763 grid $top.buts.gen $top.buts.can
6764 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6765 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6766 grid $top.buts - -pady 10 -sticky ew
6773 set id [$wrcomtop.sha1 get]
6774 set cmd "echo $id | [$wrcomtop.cmd get]"
6775 set fname [$wrcomtop.fname get]
6776 if {[catch {exec sh -c $cmd >$fname &} err]} {
6777 error_popup "Error writing commit: $err"
6779 catch {destroy $wrcomtop}
6786 catch {destroy $wrcomtop}
6791 global rowmenuid mkbrtop
6794 catch {destroy $top}
6796 label $top.title -text "Create new branch"
6797 grid $top.title - -pady 10
6798 label $top.id -text "ID:"
6799 entry $top.sha1 -width 40 -relief flat
6800 $top.sha1 insert 0 $rowmenuid
6801 $top.sha1 conf -state readonly
6802 grid $top.id $top.sha1 -sticky w
6803 label $top.nlab -text "Name:"
6804 entry $top.name -width 40
6805 grid $top.nlab $top.name -sticky w
6807 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6808 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6809 grid $top.buts.go $top.buts.can
6810 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6811 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6812 grid $top.buts - -pady 10 -sticky ew
6817 global headids idheads
6819 set name [$top.name get]
6820 set id [$top.sha1 get]
6822 error_popup "Please specify a name for the new branch"
6825 catch {destroy $top}
6829 exec git branch $name $id
6834 set headids($name) $id
6835 lappend idheads($id) $name
6844 proc cherrypick {} {
6845 global rowmenuid curview
6848 set oldhead [exec git rev-parse HEAD]
6849 set dheads [descheads $rowmenuid]
6850 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6851 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6852 included in branch $mainhead -- really re-apply it?"]
6855 nowbusy cherrypick "Cherry-picking"
6857 # Unfortunately git-cherry-pick writes stuff to stderr even when
6858 # no error occurs, and exec takes that as an indication of error...
6859 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6864 set newhead [exec git rev-parse HEAD]
6865 if {$newhead eq $oldhead} {
6867 error_popup "No changes committed"
6870 addnewchild $newhead $oldhead
6871 if {[commitinview $oldhead $curview]} {
6872 insertrow $newhead $oldhead $curview
6873 if {$mainhead ne {}} {
6874 movehead $newhead $mainhead
6875 movedhead $newhead $mainhead
6884 global mainheadid mainhead rowmenuid confirm_ok resettype
6887 set w ".confirmreset"
6890 wm title $w "Confirm reset"
6891 message $w.m -text \
6892 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6893 -justify center -aspect 1000
6894 pack $w.m -side top -fill x -padx 20 -pady 20
6895 frame $w.f -relief sunken -border 2
6896 message $w.f.rt -text "Reset type:" -aspect 1000
6897 grid $w.f.rt -sticky w
6899 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6900 -text "Soft: Leave working tree and index untouched"
6901 grid $w.f.soft -sticky w
6902 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6903 -text "Mixed: Leave working tree untouched, reset index"
6904 grid $w.f.mixed -sticky w
6905 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6906 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6907 grid $w.f.hard -sticky w
6908 pack $w.f -side top -fill x
6909 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6910 pack $w.ok -side left -fill x -padx 20 -pady 20
6911 button $w.cancel -text Cancel -command "destroy $w"
6912 pack $w.cancel -side right -fill x -padx 20 -pady 20
6913 bind $w <Visibility> "grab $w; focus $w"
6915 if {!$confirm_ok} return
6916 if {[catch {set fd [open \
6917 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6921 filerun $fd [list readresetstat $fd]
6922 nowbusy reset "Resetting"
6926 proc readresetstat {fd} {
6927 global mainhead mainheadid showlocalchanges rprogcoord
6929 if {[gets $fd line] >= 0} {
6930 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6931 set rprogcoord [expr {1.0 * $m / $n}]
6939 if {[catch {close $fd} err]} {
6942 set oldhead $mainheadid
6943 set newhead [exec git rev-parse HEAD]
6944 if {$newhead ne $oldhead} {
6945 movehead $newhead $mainhead
6946 movedhead $newhead $mainhead
6947 set mainheadid $newhead
6951 if {$showlocalchanges} {
6957 # context menu for a head
6958 proc headmenu {x y id head} {
6959 global headmenuid headmenuhead headctxmenu mainhead
6963 set headmenuhead $head
6965 if {$head eq $mainhead} {
6968 $headctxmenu entryconfigure 0 -state $state
6969 $headctxmenu entryconfigure 1 -state $state
6970 tk_popup $headctxmenu $x $y
6974 global headmenuid headmenuhead mainhead headids
6975 global showlocalchanges mainheadid
6977 # check the tree is clean first??
6978 set oldmainhead $mainhead
6979 nowbusy checkout "Checking out"
6983 exec git checkout -q $headmenuhead
6989 set mainhead $headmenuhead
6990 set mainheadid $headmenuid
6991 if {[info exists headids($oldmainhead)]} {
6992 redrawtags $headids($oldmainhead)
6994 redrawtags $headmenuid
6996 if {$showlocalchanges} {
7002 global headmenuid headmenuhead mainhead
7005 set head $headmenuhead
7007 # this check shouldn't be needed any more...
7008 if {$head eq $mainhead} {
7009 error_popup "Cannot delete the currently checked-out branch"
7012 set dheads [descheads $id]
7013 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7014 # the stuff on this branch isn't on any other branch
7015 if {![confirm_popup "The commits on branch $head aren't on any other\
7016 branch.\nReally delete branch $head?"]} return
7020 if {[catch {exec git branch -D $head} err]} {
7025 removehead $id $head
7026 removedhead $id $head
7033 # Display a list of tags and heads
7035 global showrefstop bgcolor fgcolor selectbgcolor
7036 global bglist fglist reflistfilter reflist maincursor
7039 set showrefstop $top
7040 if {[winfo exists $top]} {
7046 wm title $top "Tags and heads: [file tail [pwd]]"
7047 text $top.list -background $bgcolor -foreground $fgcolor \
7048 -selectbackground $selectbgcolor -font mainfont \
7049 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7050 -width 30 -height 20 -cursor $maincursor \
7051 -spacing1 1 -spacing3 1 -state disabled
7052 $top.list tag configure highlight -background $selectbgcolor
7053 lappend bglist $top.list
7054 lappend fglist $top.list
7055 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7056 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7057 grid $top.list $top.ysb -sticky nsew
7058 grid $top.xsb x -sticky ew
7060 label $top.f.l -text "Filter: " -font uifont
7061 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
7062 set reflistfilter "*"
7063 trace add variable reflistfilter write reflistfilter_change
7064 pack $top.f.e -side right -fill x -expand 1
7065 pack $top.f.l -side left
7066 grid $top.f - -sticky ew -pady 2
7067 button $top.close -command [list destroy $top] -text "Close" \
7070 grid columnconfigure $top 0 -weight 1
7071 grid rowconfigure $top 0 -weight 1
7072 bind $top.list <1> {break}
7073 bind $top.list <B1-Motion> {break}
7074 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7079 proc sel_reflist {w x y} {
7080 global showrefstop reflist headids tagids otherrefids
7082 if {![winfo exists $showrefstop]} return
7083 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7084 set ref [lindex $reflist [expr {$l-1}]]
7085 set n [lindex $ref 0]
7086 switch -- [lindex $ref 1] {
7087 "H" {selbyid $headids($n)}
7088 "T" {selbyid $tagids($n)}
7089 "o" {selbyid $otherrefids($n)}
7091 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7094 proc unsel_reflist {} {
7097 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7098 $showrefstop.list tag remove highlight 0.0 end
7101 proc reflistfilter_change {n1 n2 op} {
7102 global reflistfilter
7104 after cancel refill_reflist
7105 after 200 refill_reflist
7108 proc refill_reflist {} {
7109 global reflist reflistfilter showrefstop headids tagids otherrefids
7110 global curview commitinterest
7112 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7114 foreach n [array names headids] {
7115 if {[string match $reflistfilter $n]} {
7116 if {[commitinview $headids($n) $curview]} {
7117 lappend refs [list $n H]
7119 set commitinterest($headids($n)) {run refill_reflist}
7123 foreach n [array names tagids] {
7124 if {[string match $reflistfilter $n]} {
7125 if {[commitinview $tagids($n) $curview]} {
7126 lappend refs [list $n T]
7128 set commitinterest($tagids($n)) {run refill_reflist}
7132 foreach n [array names otherrefids] {
7133 if {[string match $reflistfilter $n]} {
7134 if {[commitinview $otherrefids($n) $curview]} {
7135 lappend refs [list $n o]
7137 set commitinterest($otherrefids($n)) {run refill_reflist}
7141 set refs [lsort -index 0 $refs]
7142 if {$refs eq $reflist} return
7144 # Update the contents of $showrefstop.list according to the
7145 # differences between $reflist (old) and $refs (new)
7146 $showrefstop.list conf -state normal
7147 $showrefstop.list insert end "\n"
7150 while {$i < [llength $reflist] || $j < [llength $refs]} {
7151 if {$i < [llength $reflist]} {
7152 if {$j < [llength $refs]} {
7153 set cmp [string compare [lindex $reflist $i 0] \
7154 [lindex $refs $j 0]]
7156 set cmp [string compare [lindex $reflist $i 1] \
7157 [lindex $refs $j 1]]
7167 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7175 set l [expr {$j + 1}]
7176 $showrefstop.list image create $l.0 -align baseline \
7177 -image reficon-[lindex $refs $j 1] -padx 2
7178 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7184 # delete last newline
7185 $showrefstop.list delete end-2c end-1c
7186 $showrefstop.list conf -state disabled
7189 # Stuff for finding nearby tags
7190 proc getallcommits {} {
7191 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7192 global idheads idtags idotherrefs allparents tagobjid
7194 if {![info exists allcommits]} {
7200 set allccache [file join [gitdir] "gitk.cache"]
7202 set f [open $allccache r]
7211 set cmd [list | git rev-list --parents]
7212 set allcupdate [expr {$seeds ne {}}]
7216 set refs [concat [array names idheads] [array names idtags] \
7217 [array names idotherrefs]]
7220 foreach name [array names tagobjid] {
7221 lappend tagobjs $tagobjid($name)
7223 foreach id [lsort -unique $refs] {
7224 if {![info exists allparents($id)] &&
7225 [lsearch -exact $tagobjs $id] < 0} {
7236 set fd [open [concat $cmd $ids] r]
7237 fconfigure $fd -blocking 0
7240 filerun $fd [list getallclines $fd]
7246 # Since most commits have 1 parent and 1 child, we group strings of
7247 # such commits into "arcs" joining branch/merge points (BMPs), which
7248 # are commits that either don't have 1 parent or don't have 1 child.
7250 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7251 # arcout(id) - outgoing arcs for BMP
7252 # arcids(a) - list of IDs on arc including end but not start
7253 # arcstart(a) - BMP ID at start of arc
7254 # arcend(a) - BMP ID at end of arc
7255 # growing(a) - arc a is still growing
7256 # arctags(a) - IDs out of arcids (excluding end) that have tags
7257 # archeads(a) - IDs out of arcids (excluding end) that have heads
7258 # The start of an arc is at the descendent end, so "incoming" means
7259 # coming from descendents, and "outgoing" means going towards ancestors.
7261 proc getallclines {fd} {
7262 global allparents allchildren idtags idheads nextarc
7263 global arcnos arcids arctags arcout arcend arcstart archeads growing
7264 global seeds allcommits cachedarcs allcupdate
7267 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7268 set id [lindex $line 0]
7269 if {[info exists allparents($id)]} {
7274 set olds [lrange $line 1 end]
7275 set allparents($id) $olds
7276 if {![info exists allchildren($id)]} {
7277 set allchildren($id) {}
7282 if {[llength $olds] == 1 && [llength $a] == 1} {
7283 lappend arcids($a) $id
7284 if {[info exists idtags($id)]} {
7285 lappend arctags($a) $id
7287 if {[info exists idheads($id)]} {
7288 lappend archeads($a) $id
7290 if {[info exists allparents($olds)]} {
7291 # seen parent already
7292 if {![info exists arcout($olds)]} {
7295 lappend arcids($a) $olds
7296 set arcend($a) $olds
7299 lappend allchildren($olds) $id
7300 lappend arcnos($olds) $a
7304 foreach a $arcnos($id) {
7305 lappend arcids($a) $id
7312 lappend allchildren($p) $id
7313 set a [incr nextarc]
7314 set arcstart($a) $id
7321 if {[info exists allparents($p)]} {
7322 # seen it already, may need to make a new branch
7323 if {![info exists arcout($p)]} {
7326 lappend arcids($a) $p
7330 lappend arcnos($p) $a
7335 global cached_dheads cached_dtags cached_atags
7336 catch {unset cached_dheads}
7337 catch {unset cached_dtags}
7338 catch {unset cached_atags}
7341 return [expr {$nid >= 1000? 2: 1}]
7345 fconfigure $fd -blocking 1
7348 # got an error reading the list of commits
7349 # if we were updating, try rereading the whole thing again
7355 error_popup "Error reading commit topology information;\
7356 branch and preceding/following tag information\
7357 will be incomplete.\n($err)"
7360 if {[incr allcommits -1] == 0} {
7370 proc recalcarc {a} {
7371 global arctags archeads arcids idtags idheads
7375 foreach id [lrange $arcids($a) 0 end-1] {
7376 if {[info exists idtags($id)]} {
7379 if {[info exists idheads($id)]} {
7384 set archeads($a) $ah
7388 global arcnos arcids nextarc arctags archeads idtags idheads
7389 global arcstart arcend arcout allparents growing
7392 if {[llength $a] != 1} {
7393 puts "oops splitarc called but [llength $a] arcs already"
7397 set i [lsearch -exact $arcids($a) $p]
7399 puts "oops splitarc $p not in arc $a"
7402 set na [incr nextarc]
7403 if {[info exists arcend($a)]} {
7404 set arcend($na) $arcend($a)
7406 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7407 set j [lsearch -exact $arcnos($l) $a]
7408 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7410 set tail [lrange $arcids($a) [expr {$i+1}] end]
7411 set arcids($a) [lrange $arcids($a) 0 $i]
7413 set arcstart($na) $p
7415 set arcids($na) $tail
7416 if {[info exists growing($a)]} {
7422 if {[llength $arcnos($id)] == 1} {
7425 set j [lsearch -exact $arcnos($id) $a]
7426 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7430 # reconstruct tags and heads lists
7431 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7436 set archeads($na) {}
7440 # Update things for a new commit added that is a child of one
7441 # existing commit. Used when cherry-picking.
7442 proc addnewchild {id p} {
7443 global allparents allchildren idtags nextarc
7444 global arcnos arcids arctags arcout arcend arcstart archeads growing
7445 global seeds allcommits
7447 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7448 set allparents($id) [list $p]
7449 set allchildren($id) {}
7452 lappend allchildren($p) $id
7453 set a [incr nextarc]
7454 set arcstart($a) $id
7457 set arcids($a) [list $p]
7459 if {![info exists arcout($p)]} {
7462 lappend arcnos($p) $a
7463 set arcout($id) [list $a]
7466 # This implements a cache for the topology information.
7467 # The cache saves, for each arc, the start and end of the arc,
7468 # the ids on the arc, and the outgoing arcs from the end.
7469 proc readcache {f} {
7470 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7471 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7476 if {$lim - $a > 500} {
7477 set lim [expr {$a + 500}]
7481 # finish reading the cache and setting up arctags, etc.
7483 if {$line ne "1"} {error "bad final version"}
7485 foreach id [array names idtags] {
7486 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7487 [llength $allparents($id)] == 1} {
7488 set a [lindex $arcnos($id) 0]
7489 if {$arctags($a) eq {}} {
7494 foreach id [array names idheads] {
7495 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7496 [llength $allparents($id)] == 1} {
7497 set a [lindex $arcnos($id) 0]
7498 if {$archeads($a) eq {}} {
7503 foreach id [lsort -unique $possible_seeds] {
7504 if {$arcnos($id) eq {}} {
7510 while {[incr a] <= $lim} {
7512 if {[llength $line] != 3} {error "bad line"}
7513 set s [lindex $line 0]
7515 lappend arcout($s) $a
7516 if {![info exists arcnos($s)]} {
7517 lappend possible_seeds $s
7520 set e [lindex $line 1]
7525 if {![info exists arcout($e)]} {
7529 set arcids($a) [lindex $line 2]
7530 foreach id $arcids($a) {
7531 lappend allparents($s) $id
7533 lappend arcnos($id) $a
7535 if {![info exists allparents($s)]} {
7536 set allparents($s) {}
7541 set nextarc [expr {$a - 1}]
7554 global nextarc cachedarcs possible_seeds
7558 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7559 # make sure it's an integer
7560 set cachedarcs [expr {int([lindex $line 1])}]
7561 if {$cachedarcs < 0} {error "bad number of arcs"}
7563 set possible_seeds {}
7571 proc dropcache {err} {
7572 global allcwait nextarc cachedarcs seeds
7574 #puts "dropping cache ($err)"
7575 foreach v {arcnos arcout arcids arcstart arcend growing \
7576 arctags archeads allparents allchildren} {
7587 proc writecache {f} {
7588 global cachearc cachedarcs allccache
7589 global arcstart arcend arcnos arcids arcout
7593 if {$lim - $a > 1000} {
7594 set lim [expr {$a + 1000}]
7597 while {[incr a] <= $lim} {
7598 if {[info exists arcend($a)]} {
7599 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7601 puts $f [list $arcstart($a) {} $arcids($a)]
7606 catch {file delete $allccache}
7607 #puts "writing cache failed ($err)"
7610 set cachearc [expr {$a - 1}]
7611 if {$a > $cachedarcs} {
7620 global nextarc cachedarcs cachearc allccache
7622 if {$nextarc == $cachedarcs} return
7624 set cachedarcs $nextarc
7626 set f [open $allccache w]
7627 puts $f [list 1 $cachedarcs]
7632 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7633 # or 0 if neither is true.
7634 proc anc_or_desc {a b} {
7635 global arcout arcstart arcend arcnos cached_isanc
7637 if {$arcnos($a) eq $arcnos($b)} {
7638 # Both are on the same arc(s); either both are the same BMP,
7639 # or if one is not a BMP, the other is also not a BMP or is
7640 # the BMP at end of the arc (and it only has 1 incoming arc).
7641 # Or both can be BMPs with no incoming arcs.
7642 if {$a eq $b || $arcnos($a) eq {}} {
7645 # assert {[llength $arcnos($a)] == 1}
7646 set arc [lindex $arcnos($a) 0]
7647 set i [lsearch -exact $arcids($arc) $a]
7648 set j [lsearch -exact $arcids($arc) $b]
7649 if {$i < 0 || $i > $j} {
7656 if {![info exists arcout($a)]} {
7657 set arc [lindex $arcnos($a) 0]
7658 if {[info exists arcend($arc)]} {
7659 set aend $arcend($arc)
7663 set a $arcstart($arc)
7667 if {![info exists arcout($b)]} {
7668 set arc [lindex $arcnos($b) 0]
7669 if {[info exists arcend($arc)]} {
7670 set bend $arcend($arc)
7674 set b $arcstart($arc)
7684 if {[info exists cached_isanc($a,$bend)]} {
7685 if {$cached_isanc($a,$bend)} {
7689 if {[info exists cached_isanc($b,$aend)]} {
7690 if {$cached_isanc($b,$aend)} {
7693 if {[info exists cached_isanc($a,$bend)]} {
7698 set todo [list $a $b]
7701 for {set i 0} {$i < [llength $todo]} {incr i} {
7702 set x [lindex $todo $i]
7703 if {$anc($x) eq {}} {
7706 foreach arc $arcnos($x) {
7707 set xd $arcstart($arc)
7709 set cached_isanc($a,$bend) 1
7710 set cached_isanc($b,$aend) 0
7712 } elseif {$xd eq $aend} {
7713 set cached_isanc($b,$aend) 1
7714 set cached_isanc($a,$bend) 0
7717 if {![info exists anc($xd)]} {
7718 set anc($xd) $anc($x)
7720 } elseif {$anc($xd) ne $anc($x)} {
7725 set cached_isanc($a,$bend) 0
7726 set cached_isanc($b,$aend) 0
7730 # This identifies whether $desc has an ancestor that is
7731 # a growing tip of the graph and which is not an ancestor of $anc
7732 # and returns 0 if so and 1 if not.
7733 # If we subsequently discover a tag on such a growing tip, and that
7734 # turns out to be a descendent of $anc (which it could, since we
7735 # don't necessarily see children before parents), then $desc
7736 # isn't a good choice to display as a descendent tag of
7737 # $anc (since it is the descendent of another tag which is
7738 # a descendent of $anc). Similarly, $anc isn't a good choice to
7739 # display as a ancestor tag of $desc.
7741 proc is_certain {desc anc} {
7742 global arcnos arcout arcstart arcend growing problems
7745 if {[llength $arcnos($anc)] == 1} {
7746 # tags on the same arc are certain
7747 if {$arcnos($desc) eq $arcnos($anc)} {
7750 if {![info exists arcout($anc)]} {
7751 # if $anc is partway along an arc, use the start of the arc instead
7752 set a [lindex $arcnos($anc) 0]
7753 set anc $arcstart($a)
7756 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7759 set a [lindex $arcnos($desc) 0]
7765 set anclist [list $x]
7769 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7770 set x [lindex $anclist $i]
7775 foreach a $arcout($x) {
7776 if {[info exists growing($a)]} {
7777 if {![info exists growanc($x)] && $dl($x)} {
7783 if {[info exists dl($y)]} {
7787 if {![info exists done($y)]} {
7790 if {[info exists growanc($x)]} {
7794 for {set k 0} {$k < [llength $xl]} {incr k} {
7795 set z [lindex $xl $k]
7796 foreach c $arcout($z) {
7797 if {[info exists arcend($c)]} {
7799 if {[info exists dl($v)] && $dl($v)} {
7801 if {![info exists done($v)]} {
7804 if {[info exists growanc($v)]} {
7814 } elseif {$y eq $anc || !$dl($x)} {
7825 foreach x [array names growanc] {
7834 proc validate_arctags {a} {
7835 global arctags idtags
7839 foreach id $arctags($a) {
7841 if {![info exists idtags($id)]} {
7842 set na [lreplace $na $i $i]
7849 proc validate_archeads {a} {
7850 global archeads idheads
7853 set na $archeads($a)
7854 foreach id $archeads($a) {
7856 if {![info exists idheads($id)]} {
7857 set na [lreplace $na $i $i]
7861 set archeads($a) $na
7864 # Return the list of IDs that have tags that are descendents of id,
7865 # ignoring IDs that are descendents of IDs already reported.
7866 proc desctags {id} {
7867 global arcnos arcstart arcids arctags idtags allparents
7868 global growing cached_dtags
7870 if {![info exists allparents($id)]} {
7873 set t1 [clock clicks -milliseconds]
7875 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7876 # part-way along an arc; check that arc first
7877 set a [lindex $arcnos($id) 0]
7878 if {$arctags($a) ne {}} {
7880 set i [lsearch -exact $arcids($a) $id]
7882 foreach t $arctags($a) {
7883 set j [lsearch -exact $arcids($a) $t]
7891 set id $arcstart($a)
7892 if {[info exists idtags($id)]} {
7896 if {[info exists cached_dtags($id)]} {
7897 return $cached_dtags($id)
7904 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7905 set id [lindex $todo $i]
7907 set ta [info exists hastaggedancestor($id)]
7911 # ignore tags on starting node
7912 if {!$ta && $i > 0} {
7913 if {[info exists idtags($id)]} {
7916 } elseif {[info exists cached_dtags($id)]} {
7917 set tagloc($id) $cached_dtags($id)
7921 foreach a $arcnos($id) {
7923 if {!$ta && $arctags($a) ne {}} {
7925 if {$arctags($a) ne {}} {
7926 lappend tagloc($id) [lindex $arctags($a) end]
7929 if {$ta || $arctags($a) ne {}} {
7930 set tomark [list $d]
7931 for {set j 0} {$j < [llength $tomark]} {incr j} {
7932 set dd [lindex $tomark $j]
7933 if {![info exists hastaggedancestor($dd)]} {
7934 if {[info exists done($dd)]} {
7935 foreach b $arcnos($dd) {
7936 lappend tomark $arcstart($b)
7938 if {[info exists tagloc($dd)]} {
7941 } elseif {[info exists queued($dd)]} {
7944 set hastaggedancestor($dd) 1
7948 if {![info exists queued($d)]} {
7951 if {![info exists hastaggedancestor($d)]} {
7958 foreach id [array names tagloc] {
7959 if {![info exists hastaggedancestor($id)]} {
7960 foreach t $tagloc($id) {
7961 if {[lsearch -exact $tags $t] < 0} {
7967 set t2 [clock clicks -milliseconds]
7970 # remove tags that are descendents of other tags
7971 for {set i 0} {$i < [llength $tags]} {incr i} {
7972 set a [lindex $tags $i]
7973 for {set j 0} {$j < $i} {incr j} {
7974 set b [lindex $tags $j]
7975 set r [anc_or_desc $a $b]
7977 set tags [lreplace $tags $j $j]
7980 } elseif {$r == -1} {
7981 set tags [lreplace $tags $i $i]
7988 if {[array names growing] ne {}} {
7989 # graph isn't finished, need to check if any tag could get
7990 # eclipsed by another tag coming later. Simply ignore any
7991 # tags that could later get eclipsed.
7994 if {[is_certain $t $origid]} {
7998 if {$tags eq $ctags} {
7999 set cached_dtags($origid) $tags
8004 set cached_dtags($origid) $tags
8006 set t3 [clock clicks -milliseconds]
8007 if {0 && $t3 - $t1 >= 100} {
8008 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8009 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8015 global arcnos arcids arcout arcend arctags idtags allparents
8016 global growing cached_atags
8018 if {![info exists allparents($id)]} {
8021 set t1 [clock clicks -milliseconds]
8023 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8024 # part-way along an arc; check that arc first
8025 set a [lindex $arcnos($id) 0]
8026 if {$arctags($a) ne {}} {
8028 set i [lsearch -exact $arcids($a) $id]
8029 foreach t $arctags($a) {
8030 set j [lsearch -exact $arcids($a) $t]
8036 if {![info exists arcend($a)]} {
8040 if {[info exists idtags($id)]} {
8044 if {[info exists cached_atags($id)]} {
8045 return $cached_atags($id)
8053 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8054 set id [lindex $todo $i]
8056 set td [info exists hastaggeddescendent($id)]
8060 # ignore tags on starting node
8061 if {!$td && $i > 0} {
8062 if {[info exists idtags($id)]} {
8065 } elseif {[info exists cached_atags($id)]} {
8066 set tagloc($id) $cached_atags($id)
8070 foreach a $arcout($id) {
8071 if {!$td && $arctags($a) ne {}} {
8073 if {$arctags($a) ne {}} {
8074 lappend tagloc($id) [lindex $arctags($a) 0]
8077 if {![info exists arcend($a)]} continue
8079 if {$td || $arctags($a) ne {}} {
8080 set tomark [list $d]
8081 for {set j 0} {$j < [llength $tomark]} {incr j} {
8082 set dd [lindex $tomark $j]
8083 if {![info exists hastaggeddescendent($dd)]} {
8084 if {[info exists done($dd)]} {
8085 foreach b $arcout($dd) {
8086 if {[info exists arcend($b)]} {
8087 lappend tomark $arcend($b)
8090 if {[info exists tagloc($dd)]} {
8093 } elseif {[info exists queued($dd)]} {
8096 set hastaggeddescendent($dd) 1
8100 if {![info exists queued($d)]} {
8103 if {![info exists hastaggeddescendent($d)]} {
8109 set t2 [clock clicks -milliseconds]
8112 foreach id [array names tagloc] {
8113 if {![info exists hastaggeddescendent($id)]} {
8114 foreach t $tagloc($id) {
8115 if {[lsearch -exact $tags $t] < 0} {
8122 # remove tags that are ancestors of other tags
8123 for {set i 0} {$i < [llength $tags]} {incr i} {
8124 set a [lindex $tags $i]
8125 for {set j 0} {$j < $i} {incr j} {
8126 set b [lindex $tags $j]
8127 set r [anc_or_desc $a $b]
8129 set tags [lreplace $tags $j $j]
8132 } elseif {$r == 1} {
8133 set tags [lreplace $tags $i $i]
8140 if {[array names growing] ne {}} {
8141 # graph isn't finished, need to check if any tag could get
8142 # eclipsed by another tag coming later. Simply ignore any
8143 # tags that could later get eclipsed.
8146 if {[is_certain $origid $t]} {
8150 if {$tags eq $ctags} {
8151 set cached_atags($origid) $tags
8156 set cached_atags($origid) $tags
8158 set t3 [clock clicks -milliseconds]
8159 if {0 && $t3 - $t1 >= 100} {
8160 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8161 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8166 # Return the list of IDs that have heads that are descendents of id,
8167 # including id itself if it has a head.
8168 proc descheads {id} {
8169 global arcnos arcstart arcids archeads idheads cached_dheads
8172 if {![info exists allparents($id)]} {
8176 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8177 # part-way along an arc; check it first
8178 set a [lindex $arcnos($id) 0]
8179 if {$archeads($a) ne {}} {
8180 validate_archeads $a
8181 set i [lsearch -exact $arcids($a) $id]
8182 foreach t $archeads($a) {
8183 set j [lsearch -exact $arcids($a) $t]
8188 set id $arcstart($a)
8194 for {set i 0} {$i < [llength $todo]} {incr i} {
8195 set id [lindex $todo $i]
8196 if {[info exists cached_dheads($id)]} {
8197 set ret [concat $ret $cached_dheads($id)]
8199 if {[info exists idheads($id)]} {
8202 foreach a $arcnos($id) {
8203 if {$archeads($a) ne {}} {
8204 validate_archeads $a
8205 if {$archeads($a) ne {}} {
8206 set ret [concat $ret $archeads($a)]
8210 if {![info exists seen($d)]} {
8217 set ret [lsort -unique $ret]
8218 set cached_dheads($origid) $ret
8219 return [concat $ret $aret]
8222 proc addedtag {id} {
8223 global arcnos arcout cached_dtags cached_atags
8225 if {![info exists arcnos($id)]} return
8226 if {![info exists arcout($id)]} {
8227 recalcarc [lindex $arcnos($id) 0]
8229 catch {unset cached_dtags}
8230 catch {unset cached_atags}
8233 proc addedhead {hid head} {
8234 global arcnos arcout cached_dheads
8236 if {![info exists arcnos($hid)]} return
8237 if {![info exists arcout($hid)]} {
8238 recalcarc [lindex $arcnos($hid) 0]
8240 catch {unset cached_dheads}
8243 proc removedhead {hid head} {
8244 global cached_dheads
8246 catch {unset cached_dheads}
8249 proc movedhead {hid head} {
8250 global arcnos arcout cached_dheads
8252 if {![info exists arcnos($hid)]} return
8253 if {![info exists arcout($hid)]} {
8254 recalcarc [lindex $arcnos($hid) 0]
8256 catch {unset cached_dheads}
8259 proc changedrefs {} {
8260 global cached_dheads cached_dtags cached_atags
8261 global arctags archeads arcnos arcout idheads idtags
8263 foreach id [concat [array names idheads] [array names idtags]] {
8264 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8265 set a [lindex $arcnos($id) 0]
8266 if {![info exists donearc($a)]} {
8272 catch {unset cached_dtags}
8273 catch {unset cached_atags}
8274 catch {unset cached_dheads}
8277 proc rereadrefs {} {
8278 global idtags idheads idotherrefs mainhead
8280 set refids [concat [array names idtags] \
8281 [array names idheads] [array names idotherrefs]]
8282 foreach id $refids {
8283 if {![info exists ref($id)]} {
8284 set ref($id) [listrefs $id]
8287 set oldmainhead $mainhead
8290 set refids [lsort -unique [concat $refids [array names idtags] \
8291 [array names idheads] [array names idotherrefs]]]
8292 foreach id $refids {
8293 set v [listrefs $id]
8294 if {![info exists ref($id)] || $ref($id) != $v ||
8295 ($id eq $oldmainhead && $id ne $mainhead) ||
8296 ($id eq $mainhead && $id ne $oldmainhead)} {
8303 proc listrefs {id} {
8304 global idtags idheads idotherrefs
8307 if {[info exists idtags($id)]} {
8311 if {[info exists idheads($id)]} {
8315 if {[info exists idotherrefs($id)]} {
8316 set z $idotherrefs($id)
8318 return [list $x $y $z]
8321 proc showtag {tag isnew} {
8322 global ctext tagcontents tagids linknum tagobjid
8325 addtohistory [list showtag $tag 0]
8327 $ctext conf -state normal
8331 if {![info exists tagcontents($tag)]} {
8333 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8336 if {[info exists tagcontents($tag)]} {
8337 set text $tagcontents($tag)
8339 set text "Tag: $tag\nId: $tagids($tag)"
8341 appendwithlinks $text {}
8342 $ctext conf -state disabled
8353 proc mkfontdisp {font top which} {
8354 global fontattr fontpref $font
8356 set fontpref($font) [set $font]
8357 button $top.${font}but -text $which -font optionfont \
8358 -command [list choosefont $font $which]
8359 label $top.$font -relief flat -font $font \
8360 -text $fontattr($font,family) -justify left
8361 grid x $top.${font}but $top.$font -sticky w
8364 proc choosefont {font which} {
8365 global fontparam fontlist fonttop fontattr
8367 set fontparam(which) $which
8368 set fontparam(font) $font
8369 set fontparam(family) [font actual $font -family]
8370 set fontparam(size) $fontattr($font,size)
8371 set fontparam(weight) $fontattr($font,weight)
8372 set fontparam(slant) $fontattr($font,slant)
8375 if {![winfo exists $top]} {
8377 eval font config sample [font actual $font]
8379 wm title $top "Gitk font chooser"
8380 label $top.l -textvariable fontparam(which) -font uifont
8381 pack $top.l -side top
8382 set fontlist [lsort [font families]]
8384 listbox $top.f.fam -listvariable fontlist \
8385 -yscrollcommand [list $top.f.sb set]
8386 bind $top.f.fam <<ListboxSelect>> selfontfam
8387 scrollbar $top.f.sb -command [list $top.f.fam yview]
8388 pack $top.f.sb -side right -fill y
8389 pack $top.f.fam -side left -fill both -expand 1
8390 pack $top.f -side top -fill both -expand 1
8392 spinbox $top.g.size -from 4 -to 40 -width 4 \
8393 -textvariable fontparam(size) \
8394 -validatecommand {string is integer -strict %s}
8395 checkbutton $top.g.bold -padx 5 \
8396 -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
8397 -variable fontparam(weight) -onvalue bold -offvalue normal
8398 checkbutton $top.g.ital -padx 5 \
8399 -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0 \
8400 -variable fontparam(slant) -onvalue italic -offvalue roman
8401 pack $top.g.size $top.g.bold $top.g.ital -side left
8402 pack $top.g -side top
8403 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8405 $top.c create text 100 25 -anchor center -text $which -font sample \
8406 -fill black -tags text
8407 bind $top.c <Configure> [list centertext $top.c]
8408 pack $top.c -side top -fill x
8410 button $top.buts.ok -text "OK" -command fontok -default active \
8412 button $top.buts.can -text "Cancel" -command fontcan -default normal \
8414 grid $top.buts.ok $top.buts.can
8415 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8416 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8417 pack $top.buts -side bottom -fill x
8418 trace add variable fontparam write chg_fontparam
8421 $top.c itemconf text -text $which
8423 set i [lsearch -exact $fontlist $fontparam(family)]
8425 $top.f.fam selection set $i
8430 proc centertext {w} {
8431 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8435 global fontparam fontpref prefstop
8437 set f $fontparam(font)
8438 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8439 if {$fontparam(weight) eq "bold"} {
8440 lappend fontpref($f) "bold"
8442 if {$fontparam(slant) eq "italic"} {
8443 lappend fontpref($f) "italic"
8446 $w conf -text $fontparam(family) -font $fontpref($f)
8452 global fonttop fontparam
8454 if {[info exists fonttop]} {
8455 catch {destroy $fonttop}
8456 catch {font delete sample}
8462 proc selfontfam {} {
8463 global fonttop fontparam
8465 set i [$fonttop.f.fam curselection]
8467 set fontparam(family) [$fonttop.f.fam get $i]
8471 proc chg_fontparam {v sub op} {
8474 font config sample -$sub $fontparam($sub)
8478 global maxwidth maxgraphpct
8479 global oldprefs prefstop showneartags showlocalchanges
8480 global bgcolor fgcolor ctext diffcolors selectbgcolor
8481 global uifont tabstop limitdiffs
8485 if {[winfo exists $top]} {
8489 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8490 limitdiffs tabstop} {
8491 set oldprefs($v) [set $v]
8494 wm title $top "Gitk preferences"
8495 label $top.ldisp -text "Commit list display options"
8496 $top.ldisp configure -font uifont
8497 grid $top.ldisp - -sticky w -pady 10
8498 label $top.spacer -text " "
8499 label $top.maxwidthl -text "Maximum graph width (lines)" \
8501 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8502 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8503 label $top.maxpctl -text "Maximum graph width (% of pane)" \
8505 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8506 grid x $top.maxpctl $top.maxpct -sticky w
8507 frame $top.showlocal
8508 label $top.showlocal.l -text "Show local changes" -font optionfont
8509 checkbutton $top.showlocal.b -variable showlocalchanges
8510 pack $top.showlocal.b $top.showlocal.l -side left
8511 grid x $top.showlocal -sticky w
8513 label $top.ddisp -text "Diff display options"
8514 $top.ddisp configure -font uifont
8515 grid $top.ddisp - -sticky w -pady 10
8516 label $top.tabstopl -text "Tab spacing" -font optionfont
8517 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8518 grid x $top.tabstopl $top.tabstop -sticky w
8520 label $top.ntag.l -text "Display nearby tags" -font optionfont
8521 checkbutton $top.ntag.b -variable showneartags
8522 pack $top.ntag.b $top.ntag.l -side left
8523 grid x $top.ntag -sticky w
8525 label $top.ldiff.l -text "Limit diffs to listed paths" -font optionfont
8526 checkbutton $top.ldiff.b -variable limitdiffs
8527 pack $top.ldiff.b $top.ldiff.l -side left
8528 grid x $top.ldiff -sticky w
8530 label $top.cdisp -text "Colors: press to choose"
8531 $top.cdisp configure -font uifont
8532 grid $top.cdisp - -sticky w -pady 10
8533 label $top.bg -padx 40 -relief sunk -background $bgcolor
8534 button $top.bgbut -text "Background" -font optionfont \
8535 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8536 grid x $top.bgbut $top.bg -sticky w
8537 label $top.fg -padx 40 -relief sunk -background $fgcolor
8538 button $top.fgbut -text "Foreground" -font optionfont \
8539 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8540 grid x $top.fgbut $top.fg -sticky w
8541 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8542 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8543 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8544 [list $ctext tag conf d0 -foreground]]
8545 grid x $top.diffoldbut $top.diffold -sticky w
8546 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8547 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8548 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8549 [list $ctext tag conf d1 -foreground]]
8550 grid x $top.diffnewbut $top.diffnew -sticky w
8551 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8552 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8553 -command [list choosecolor diffcolors 2 $top.hunksep \
8554 "diff hunk header" \
8555 [list $ctext tag conf hunksep -foreground]]
8556 grid x $top.hunksepbut $top.hunksep -sticky w
8557 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8558 button $top.selbgbut -text "Select bg" -font optionfont \
8559 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8560 grid x $top.selbgbut $top.selbgsep -sticky w
8562 label $top.cfont -text "Fonts: press to choose"
8563 $top.cfont configure -font uifont
8564 grid $top.cfont - -sticky w -pady 10
8565 mkfontdisp mainfont $top "Main font"
8566 mkfontdisp textfont $top "Diff display font"
8567 mkfontdisp uifont $top "User interface font"
8570 button $top.buts.ok -text "OK" -command prefsok -default active
8571 $top.buts.ok configure -font uifont
8572 button $top.buts.can -text "Cancel" -command prefscan -default normal
8573 $top.buts.can configure -font uifont
8574 grid $top.buts.ok $top.buts.can
8575 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8576 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8577 grid $top.buts - - -pady 10 -sticky ew
8578 bind $top <Visibility> "focus $top.buts.ok"
8581 proc choosecolor {v vi w x cmd} {
8584 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8585 -title "Gitk: choose color for $x"]
8586 if {$c eq {}} return
8587 $w conf -background $c
8593 global bglist cflist
8595 $w configure -selectbackground $c
8597 $cflist tag configure highlight \
8598 -background [$cflist cget -selectbackground]
8599 allcanvs itemconf secsel -fill $c
8606 $w conf -background $c
8614 $w conf -foreground $c
8616 allcanvs itemconf text -fill $c
8617 $canv itemconf circle -outline $c
8621 global oldprefs prefstop
8623 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8624 limitdiffs tabstop} {
8626 set $v $oldprefs($v)
8628 catch {destroy $prefstop}
8634 global maxwidth maxgraphpct
8635 global oldprefs prefstop showneartags showlocalchanges
8636 global fontpref mainfont textfont uifont
8637 global limitdiffs treediffs
8639 catch {destroy $prefstop}
8643 if {$mainfont ne $fontpref(mainfont)} {
8644 set mainfont $fontpref(mainfont)
8645 parsefont mainfont $mainfont
8646 eval font configure mainfont [fontflags mainfont]
8647 eval font configure mainfontbold [fontflags mainfont 1]
8651 if {$textfont ne $fontpref(textfont)} {
8652 set textfont $fontpref(textfont)
8653 parsefont textfont $textfont
8654 eval font configure textfont [fontflags textfont]
8655 eval font configure textfontbold [fontflags textfont 1]
8657 if {$uifont ne $fontpref(uifont)} {
8658 set uifont $fontpref(uifont)
8659 parsefont uifont $uifont
8660 eval font configure uifont [fontflags uifont]
8663 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8664 if {$showlocalchanges} {
8670 if {$limitdiffs != $oldprefs(limitdiffs)} {
8671 # treediffs elements are limited by path
8672 catch {unset treediffs}
8674 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8675 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8677 } elseif {$showneartags != $oldprefs(showneartags) ||
8678 $limitdiffs != $oldprefs(limitdiffs)} {
8683 proc formatdate {d} {
8684 global datetimeformat
8686 set d [clock format $d -format $datetimeformat]
8691 # This list of encoding names and aliases is distilled from
8692 # http://www.iana.org/assignments/character-sets.
8693 # Not all of them are supported by Tcl.
8694 set encoding_aliases {
8695 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8696 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8697 { ISO-10646-UTF-1 csISO10646UTF1 }
8698 { ISO_646.basic:1983 ref csISO646basic1983 }
8699 { INVARIANT csINVARIANT }
8700 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8701 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8702 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8703 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8704 { NATS-DANO iso-ir-9-1 csNATSDANO }
8705 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8706 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8707 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8708 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8709 { ISO-2022-KR csISO2022KR }
8711 { ISO-2022-JP csISO2022JP }
8712 { ISO-2022-JP-2 csISO2022JP2 }
8713 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8715 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8716 { IT iso-ir-15 ISO646-IT csISO15Italian }
8717 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8718 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8719 { greek7-old iso-ir-18 csISO18Greek7Old }
8720 { latin-greek iso-ir-19 csISO19LatinGreek }
8721 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8722 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8723 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8724 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8725 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8726 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8727 { INIS iso-ir-49 csISO49INIS }
8728 { INIS-8 iso-ir-50 csISO50INIS8 }
8729 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8730 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8731 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8732 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8733 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8734 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8736 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8737 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8738 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8739 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8740 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8741 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8742 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8743 { greek7 iso-ir-88 csISO88Greek7 }
8744 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8745 { iso-ir-90 csISO90 }
8746 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8747 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8748 csISO92JISC62991984b }
8749 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8750 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8751 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8752 csISO95JIS62291984handadd }
8753 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8754 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8755 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8756 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8758 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8759 { T.61-7bit iso-ir-102 csISO102T617bit }
8760 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8761 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8762 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8763 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8764 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8765 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8766 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8767 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8768 arabic csISOLatinArabic }
8769 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8770 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8771 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8772 greek greek8 csISOLatinGreek }
8773 { T.101-G2 iso-ir-128 csISO128T101G2 }
8774 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8776 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8777 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8778 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8779 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8780 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8781 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8782 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8783 csISOLatinCyrillic }
8784 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8785 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8786 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8787 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8788 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8789 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8790 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8791 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8792 { ISO_10367-box iso-ir-155 csISO10367Box }
8793 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8794 { latin-lap lap iso-ir-158 csISO158Lap }
8795 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8796 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8799 { JIS_X0201 X0201 csHalfWidthKatakana }
8800 { KSC5636 ISO646-KR csKSC5636 }
8801 { ISO-10646-UCS-2 csUnicode }
8802 { ISO-10646-UCS-4 csUCS4 }
8803 { DEC-MCS dec csDECMCS }
8804 { hp-roman8 roman8 r8 csHPRoman8 }
8805 { macintosh mac csMacintosh }
8806 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8808 { IBM038 EBCDIC-INT cp038 csIBM038 }
8809 { IBM273 CP273 csIBM273 }
8810 { IBM274 EBCDIC-BE CP274 csIBM274 }
8811 { IBM275 EBCDIC-BR cp275 csIBM275 }
8812 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8813 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8814 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8815 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8816 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8817 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8818 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8819 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8820 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8821 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8822 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8823 { IBM437 cp437 437 csPC8CodePage437 }
8824 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8825 { IBM775 cp775 csPC775Baltic }
8826 { IBM850 cp850 850 csPC850Multilingual }
8827 { IBM851 cp851 851 csIBM851 }
8828 { IBM852 cp852 852 csPCp852 }
8829 { IBM855 cp855 855 csIBM855 }
8830 { IBM857 cp857 857 csIBM857 }
8831 { IBM860 cp860 860 csIBM860 }
8832 { IBM861 cp861 861 cp-is csIBM861 }
8833 { IBM862 cp862 862 csPC862LatinHebrew }
8834 { IBM863 cp863 863 csIBM863 }
8835 { IBM864 cp864 csIBM864 }
8836 { IBM865 cp865 865 csIBM865 }
8837 { IBM866 cp866 866 csIBM866 }
8838 { IBM868 CP868 cp-ar csIBM868 }
8839 { IBM869 cp869 869 cp-gr csIBM869 }
8840 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8841 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8842 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8843 { IBM891 cp891 csIBM891 }
8844 { IBM903 cp903 csIBM903 }
8845 { IBM904 cp904 904 csIBBM904 }
8846 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8847 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8848 { IBM1026 CP1026 csIBM1026 }
8849 { EBCDIC-AT-DE csIBMEBCDICATDE }
8850 { EBCDIC-AT-DE-A csEBCDICATDEA }
8851 { EBCDIC-CA-FR csEBCDICCAFR }
8852 { EBCDIC-DK-NO csEBCDICDKNO }
8853 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8854 { EBCDIC-FI-SE csEBCDICFISE }
8855 { EBCDIC-FI-SE-A csEBCDICFISEA }
8856 { EBCDIC-FR csEBCDICFR }
8857 { EBCDIC-IT csEBCDICIT }
8858 { EBCDIC-PT csEBCDICPT }
8859 { EBCDIC-ES csEBCDICES }
8860 { EBCDIC-ES-A csEBCDICESA }
8861 { EBCDIC-ES-S csEBCDICESS }
8862 { EBCDIC-UK csEBCDICUK }
8863 { EBCDIC-US csEBCDICUS }
8864 { UNKNOWN-8BIT csUnknown8BiT }
8865 { MNEMONIC csMnemonic }
8870 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8871 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8872 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8873 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8874 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8875 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8876 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8877 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8878 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8879 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8880 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8881 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8882 { IBM1047 IBM-1047 }
8883 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8884 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8885 { UNICODE-1-1 csUnicode11 }
8888 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8889 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8891 { ISO-8859-15 ISO_8859-15 Latin-9 }
8892 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8893 { GBK CP936 MS936 windows-936 }
8894 { JIS_Encoding csJISEncoding }
8895 { Shift_JIS MS_Kanji csShiftJIS }
8896 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8898 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8899 { ISO-10646-UCS-Basic csUnicodeASCII }
8900 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8901 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8902 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8903 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8904 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8905 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8906 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8907 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8908 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8909 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8910 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8911 { Ventura-US csVenturaUS }
8912 { Ventura-International csVenturaInternational }
8913 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8914 { PC8-Turkish csPC8Turkish }
8915 { IBM-Symbols csIBMSymbols }
8916 { IBM-Thai csIBMThai }
8917 { HP-Legal csHPLegal }
8918 { HP-Pi-font csHPPiFont }
8919 { HP-Math8 csHPMath8 }
8920 { Adobe-Symbol-Encoding csHPPSMath }
8921 { HP-DeskTop csHPDesktop }
8922 { Ventura-Math csVenturaMath }
8923 { Microsoft-Publishing csMicrosoftPublishing }
8924 { Windows-31J csWindows31J }
8929 proc tcl_encoding {enc} {
8930 global encoding_aliases
8931 set names [encoding names]
8932 set lcnames [string tolower $names]
8933 set enc [string tolower $enc]
8934 set i [lsearch -exact $lcnames $enc]
8936 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8937 if {[regsub {^iso[-_]} $enc iso encx]} {
8938 set i [lsearch -exact $lcnames $encx]
8942 foreach l $encoding_aliases {
8943 set ll [string tolower $l]
8944 if {[lsearch -exact $ll $enc] < 0} continue
8945 # look through the aliases for one that tcl knows about
8947 set i [lsearch -exact $lcnames $e]
8949 if {[regsub {^iso[-_]} $e iso ex]} {
8950 set i [lsearch -exact $lcnames $ex]
8959 return [lindex $names $i]
8964 # First check that Tcl/Tk is recent enough
8965 if {[catch {package require Tk 8.4} err]} {
8966 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8967 Gitk requires at least Tcl/Tk 8.4."
8973 set wrcomcmd "git diff-tree --stdin -p --pretty"
8977 set gitencoding [exec git config --get i18n.commitencoding]
8979 if {$gitencoding == ""} {
8980 set gitencoding "utf-8"
8982 set tclencoding [tcl_encoding $gitencoding]
8983 if {$tclencoding == {}} {
8984 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8987 set mainfont {Helvetica 9}
8988 set textfont {Courier 9}
8989 set uifont {Helvetica 9 bold}
8991 set findmergefiles 0
8999 set cmitmode "patch"
9000 set wrapcomment "none"
9004 set showlocalchanges 1
9006 set datetimeformat "%Y-%m-%d %H:%M:%S"
9008 set colors {green red blue magenta darkgrey brown orange}
9011 set diffcolors {red "#00a000" blue}
9013 set selectbgcolor gray85
9015 catch {source ~/.gitk}
9017 font create optionfont -family sans-serif -size -12
9019 parsefont mainfont $mainfont
9020 eval font create mainfont [fontflags mainfont]
9021 eval font create mainfontbold [fontflags mainfont 1]
9023 parsefont textfont $textfont
9024 eval font create textfont [fontflags textfont]
9025 eval font create textfontbold [fontflags textfont 1]
9027 parsefont uifont $uifont
9028 eval font create uifont [fontflags uifont]
9030 # check that we can find a .git directory somewhere...
9031 if {[catch {set gitdir [gitdir]}]} {
9032 show_error {} . "Cannot find a git repository here."
9035 if {![file isdirectory $gitdir]} {
9036 show_error {} . "Cannot find the git directory \"$gitdir\"."
9042 set cmdline_files {}
9047 "-d" { set datemode 1 }
9050 lappend revtreeargs $arg
9053 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9057 lappend revtreeargs $arg
9063 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9064 # no -- on command line, but some arguments (other than -d)
9066 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9067 set cmdline_files [split $f "\n"]
9068 set n [llength $cmdline_files]
9069 set revtreeargs [lrange $revtreeargs 0 end-$n]
9070 # Unfortunately git rev-parse doesn't produce an error when
9071 # something is both a revision and a filename. To be consistent
9072 # with git log and git rev-list, check revtreeargs for filenames.
9073 foreach arg $revtreeargs {
9074 if {[file exists $arg]} {
9075 show_error {} . "Ambiguous argument '$arg': both revision\
9081 # unfortunately we get both stdout and stderr in $err,
9082 # so look for "fatal:".
9083 set i [string first "fatal:" $err]
9085 set err [string range $err [expr {$i + 6}] end]
9087 show_error {} . "Bad arguments to gitk:\n$err"
9093 # find the list of unmerged files
9097 set fd [open "| git ls-files -u" r]
9099 show_error {} . "Couldn't get list of unmerged files: $err"
9102 while {[gets $fd line] >= 0} {
9103 set i [string first "\t" $line]
9104 if {$i < 0} continue
9105 set fname [string range $line [expr {$i+1}] end]
9106 if {[lsearch -exact $mlist $fname] >= 0} continue
9108 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9109 lappend mlist $fname
9114 if {$nr_unmerged == 0} {
9115 show_error {} . "No files selected: --merge specified but\
9116 no files are unmerged."
9118 show_error {} . "No files selected: --merge specified but\
9119 no unmerged files are within file limit."
9123 set cmdline_files $mlist
9126 set nullid "0000000000000000000000000000000000000000"
9127 set nullid2 "0000000000000000000000000000000000000001"
9129 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9136 set highlight_paths {}
9138 set searchdirn -forwards
9142 set markingmatches 0
9143 set linkentercount 0
9144 set need_redisplay 0
9151 set selectedhlview None
9152 set highlight_related None
9153 set highlight_files {}
9167 # wait for the window to become visible
9169 wm title . "[file tail $argv0]: [file tail [pwd]]"
9172 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9173 # create a view for the files/dirs specified on the command line
9177 set viewname(1) "Command line"
9178 set viewfiles(1) $cmdline_files
9179 set viewargs(1) $revtreeargs
9182 .bar.view entryconf Edit* -state normal
9183 .bar.view entryconf Delete* -state normal
9186 if {[info exists permviews]} {
9187 foreach v $permviews {
9190 set viewname($n) [lindex $v 0]
9191 set viewfiles($n) [lindex $v 1]
9192 set viewargs($n) [lindex $v 2]