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
101 global pending_select mainheadid
103 set startmsecs [clock clicks -milliseconds]
104 set commitidx($view) 0
105 set viewcomplete($view) 0
106 set viewactive($view) 1
107 set vnextroot($view) 0
110 set commits [eval exec git rev-parse --default HEAD --revs-only \
112 set viewincl($view) {}
114 if {[regexp {^[0-9a-fA-F]{40}$} $c]} {
115 lappend viewincl($view) $c
119 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
120 --boundary $commits "--" $viewfiles($view)] r]
122 error_popup "[mc "Error executing git log:"] $err"
125 set i [incr loginstance]
126 set viewinstances($view) [list $i]
129 if {$showlocalchanges} {
130 lappend commitinterest($mainheadid) {dodiffindex}
132 fconfigure $fd -blocking 0 -translation lf -eofchar {}
133 if {$tclencoding != {}} {
134 fconfigure $fd -encoding $tclencoding
136 filerun $fd [list getcommitlines $fd $i $view]
137 nowbusy $view [mc "Reading"]
138 if {$view == $curview} {
140 set progresscoords {0 0}
142 set pending_select $mainheadid
146 proc stop_rev_list {view} {
147 global commfd viewinstances leftover
149 foreach inst $viewinstances($view) {
150 set fd $commfd($inst)
158 unset leftover($inst)
160 set viewinstances($view) {}
167 start_rev_list $curview
168 show_status [mc "Reading commits..."]
171 proc updatecommits {} {
172 global curview viewargs viewfiles viewincl viewinstances
173 global viewactive viewcomplete loginstance tclencoding mainheadid
174 global varcid startmsecs commfd showneartags showlocalchanges leftover
175 global mainheadid pending_select
177 set oldmainid $mainheadid
179 if {$showlocalchanges} {
180 if {$mainheadid ne $oldmainid} {
183 if {[commitinview $mainheadid $curview]} {
188 set commits [exec git rev-parse --default HEAD --revs-only \
194 if {[string match "^*" $c]} {
196 } elseif {[regexp {^[0-9a-fA-F]{40}$} $c]} {
197 if {!([info exists varcid($view,$c)] ||
198 [lsearch -exact $viewincl($view) $c] >= 0)} {
208 foreach id $viewincl($view) {
211 set viewincl($view) [concat $viewincl($view) $pos]
213 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
214 --boundary $pos $neg $flags "--" $viewfiles($view)] r]
216 error_popup "Error executing git log: $err"
219 if {$viewactive($view) == 0} {
220 set startmsecs [clock clicks -milliseconds]
222 set i [incr loginstance]
223 lappend viewinstances($view) $i
226 fconfigure $fd -blocking 0 -translation lf -eofchar {}
227 if {$tclencoding != {}} {
228 fconfigure $fd -encoding $tclencoding
230 filerun $fd [list getcommitlines $fd $i $view]
231 incr viewactive($view)
232 set viewcomplete($view) 0
233 set pending_select $mainheadid
234 nowbusy $view "Reading"
240 proc reloadcommits {} {
241 global curview viewcomplete selectedline currentid thickerline
242 global showneartags treediffs commitinterest cached_commitrow
243 global progresscoords targetid
245 if {!$viewcomplete($curview)} {
246 stop_rev_list $curview
247 set progresscoords {0 0}
251 catch {unset selectedline}
252 catch {unset currentid}
253 catch {unset thickerline}
254 catch {unset treediffs}
261 catch {unset commitinterest}
262 catch {unset cached_commitrow}
263 catch {unset targetid}
269 # This makes a string representation of a positive integer which
270 # sorts as a string in numerical order
273 return [format "%x" $n]
274 } elseif {$n < 256} {
275 return [format "x%.2x" $n]
276 } elseif {$n < 65536} {
277 return [format "y%.4x" $n]
279 return [format "z%.8x" $n]
282 # Procedures used in reordering commits from git log (without
283 # --topo-order) into the order for display.
285 proc varcinit {view} {
286 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
287 global vtokmod varcmod vrowmod varcix vlastins
289 set varcstart($view) {{}}
290 set vupptr($view) {0}
291 set vdownptr($view) {0}
292 set vleftptr($view) {0}
293 set vbackptr($view) {0}
294 set varctok($view) {{}}
295 set varcrow($view) {{}}
296 set vtokmod($view) {}
299 set varcix($view) {{}}
300 set vlastins($view) {0}
303 proc resetvarcs {view} {
304 global varcid varccommits parents children vseedcount ordertok
306 foreach vid [array names varcid $view,*] {
311 # some commits might have children but haven't been seen yet
312 foreach vid [array names children $view,*] {
315 foreach va [array names varccommits $view,*] {
316 unset varccommits($va)
318 foreach vd [array names vseedcount $view,*] {
319 unset vseedcount($vd)
321 catch {unset ordertok}
324 proc newvarc {view id} {
325 global varcid varctok parents children datemode
326 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
327 global commitdata commitinfo vseedcount varccommits vlastins
329 set a [llength $varctok($view)]
331 if {[llength $children($vid)] == 0 || $datemode} {
332 if {![info exists commitinfo($id)]} {
333 parsecommit $id $commitdata($id) 1
335 set cdate [lindex $commitinfo($id) 4]
336 if {![string is integer -strict $cdate]} {
339 if {![info exists vseedcount($view,$cdate)]} {
340 set vseedcount($view,$cdate) -1
342 set c [incr vseedcount($view,$cdate)]
343 set cdate [expr {$cdate ^ 0xffffffff}]
344 set tok "s[strrep $cdate][strrep $c]"
349 if {[llength $children($vid)] > 0} {
350 set kid [lindex $children($vid) end]
351 set k $varcid($view,$kid)
352 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
355 set tok [lindex $varctok($view) $k]
359 set i [lsearch -exact $parents($view,$ki) $id]
360 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
361 append tok [strrep $j]
363 set c [lindex $vlastins($view) $ka]
364 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
366 set b [lindex $vdownptr($view) $ka]
368 set b [lindex $vleftptr($view) $c]
370 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
372 set b [lindex $vleftptr($view) $c]
375 lset vdownptr($view) $ka $a
376 lappend vbackptr($view) 0
378 lset vleftptr($view) $c $a
379 lappend vbackptr($view) $c
381 lset vlastins($view) $ka $a
382 lappend vupptr($view) $ka
383 lappend vleftptr($view) $b
385 lset vbackptr($view) $b $a
387 lappend varctok($view) $tok
388 lappend varcstart($view) $id
389 lappend vdownptr($view) 0
390 lappend varcrow($view) {}
391 lappend varcix($view) {}
392 set varccommits($view,$a) {}
393 lappend vlastins($view) 0
397 proc splitvarc {p v} {
398 global varcid varcstart varccommits varctok
399 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
401 set oa $varcid($v,$p)
402 set ac $varccommits($v,$oa)
403 set i [lsearch -exact $varccommits($v,$oa) $p]
405 set na [llength $varctok($v)]
406 # "%" sorts before "0"...
407 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
408 lappend varctok($v) $tok
409 lappend varcrow($v) {}
410 lappend varcix($v) {}
411 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
412 set varccommits($v,$na) [lrange $ac $i end]
413 lappend varcstart($v) $p
414 foreach id $varccommits($v,$na) {
415 set varcid($v,$id) $na
417 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
418 lset vdownptr($v) $oa $na
419 lappend vupptr($v) $oa
420 lappend vleftptr($v) 0
421 lappend vbackptr($v) 0
422 lappend vlastins($v) 0
423 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
424 lset vupptr($v) $b $na
428 proc renumbervarc {a v} {
429 global parents children varctok varcstart varccommits
430 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
432 set t1 [clock clicks -milliseconds]
438 if {[info exists isrelated($a)]} {
440 set id [lindex $varccommits($v,$a) end]
441 foreach p $parents($v,$id) {
442 if {[info exists varcid($v,$p)]} {
443 set isrelated($varcid($v,$p)) 1
448 set b [lindex $vdownptr($v) $a]
451 set b [lindex $vleftptr($v) $a]
453 set a [lindex $vupptr($v) $a]
459 if {![info exists kidchanged($a)]} continue
460 set id [lindex $varcstart($v) $a]
461 if {[llength $children($v,$id)] > 1} {
462 set children($v,$id) [lsort -command [list vtokcmp $v] \
465 set oldtok [lindex $varctok($v) $a]
472 set kid [last_real_child $v,$id]
474 set k $varcid($v,$kid)
475 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
478 set tok [lindex $varctok($v) $k]
482 set i [lsearch -exact $parents($v,$ki) $id]
483 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
484 append tok [strrep $j]
486 if {$tok eq $oldtok} {
489 set id [lindex $varccommits($v,$a) end]
490 foreach p $parents($v,$id) {
491 if {[info exists varcid($v,$p)]} {
492 set kidchanged($varcid($v,$p)) 1
497 lset varctok($v) $a $tok
498 set b [lindex $vupptr($v) $a]
500 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
503 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
506 set c [lindex $vbackptr($v) $a]
507 set d [lindex $vleftptr($v) $a]
509 lset vdownptr($v) $b $d
511 lset vleftptr($v) $c $d
514 lset vbackptr($v) $d $c
516 lset vupptr($v) $a $ka
517 set c [lindex $vlastins($v) $ka]
519 [string compare $tok [lindex $varctok($v) $c]] < 0} {
521 set b [lindex $vdownptr($v) $ka]
523 set b [lindex $vleftptr($v) $c]
526 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
528 set b [lindex $vleftptr($v) $c]
531 lset vdownptr($v) $ka $a
532 lset vbackptr($v) $a 0
534 lset vleftptr($v) $c $a
535 lset vbackptr($v) $a $c
537 lset vleftptr($v) $a $b
539 lset vbackptr($v) $b $a
541 lset vlastins($v) $ka $a
544 foreach id [array names sortkids] {
545 if {[llength $children($v,$id)] > 1} {
546 set children($v,$id) [lsort -command [list vtokcmp $v] \
550 set t2 [clock clicks -milliseconds]
551 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
554 proc fix_reversal {p a v} {
555 global varcid varcstart varctok vupptr
557 set pa $varcid($v,$p)
558 if {$p ne [lindex $varcstart($v) $pa]} {
560 set pa $varcid($v,$p)
562 # seeds always need to be renumbered
563 if {[lindex $vupptr($v) $pa] == 0 ||
564 [string compare [lindex $varctok($v) $a] \
565 [lindex $varctok($v) $pa]] > 0} {
570 proc insertrow {id p v} {
571 global cmitlisted children parents varcid varctok vtokmod
572 global varccommits ordertok commitidx numcommits curview
573 global targetid targetrow
577 set cmitlisted($vid) 1
578 set children($vid) {}
579 set parents($vid) [list $p]
580 set a [newvarc $v $id]
582 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
585 lappend varccommits($v,$a) $id
587 if {[llength [lappend children($vp) $id]] > 1} {
588 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
589 catch {unset ordertok}
591 fix_reversal $p $a $v
593 if {$v == $curview} {
594 set numcommits $commitidx($v)
596 if {[info exists targetid]} {
597 if {![comes_before $targetid $p]} {
604 proc insertfakerow {id p} {
605 global varcid varccommits parents children cmitlisted
606 global commitidx varctok vtokmod targetid targetrow curview numcommits
610 set i [lsearch -exact $varccommits($v,$a) $p]
612 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
615 set children($v,$id) {}
616 set parents($v,$id) [list $p]
617 set varcid($v,$id) $a
618 lappend children($v,$p) $id
619 set cmitlisted($v,$id) 1
620 set numcommits [incr commitidx($v)]
621 # note we deliberately don't update varcstart($v) even if $i == 0
622 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
623 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
626 if {[info exists targetid]} {
627 if {![comes_before $targetid $p]} {
635 proc removefakerow {id} {
636 global varcid varccommits parents children commitidx
637 global varctok vtokmod cmitlisted currentid selectedline
638 global targetid curview numcommits
641 if {[llength $parents($v,$id)] != 1} {
642 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
645 set p [lindex $parents($v,$id) 0]
646 set a $varcid($v,$id)
647 set i [lsearch -exact $varccommits($v,$a) $id]
649 puts "oops: removefakerow can't find [shortids $id] on arc $a"
653 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
654 unset parents($v,$id)
655 unset children($v,$id)
656 unset cmitlisted($v,$id)
657 set numcommits [incr commitidx($v) -1]
658 set j [lsearch -exact $children($v,$p) $id]
660 set children($v,$p) [lreplace $children($v,$p) $j $j]
662 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
665 if {[info exist currentid] && $id eq $currentid} {
669 if {[info exists targetid] && $targetid eq $id} {
676 proc first_real_child {vp} {
677 global children nullid nullid2
679 foreach id $children($vp) {
680 if {$id ne $nullid && $id ne $nullid2} {
687 proc last_real_child {vp} {
688 global children nullid nullid2
690 set kids $children($vp)
691 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
692 set id [lindex $kids $i]
693 if {$id ne $nullid && $id ne $nullid2} {
700 proc vtokcmp {v a b} {
701 global varctok varcid
703 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
704 [lindex $varctok($v) $varcid($v,$b)]]
707 proc modify_arc {v a {lim {}}} {
708 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
710 set vtokmod($v) [lindex $varctok($v) $a]
712 if {$v == $curview} {
713 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
714 set a [lindex $vupptr($v) $a]
720 set lim [llength $varccommits($v,$a)]
722 set r [expr {[lindex $varcrow($v) $a] + $lim}]
729 proc update_arcrows {v} {
730 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
731 global varcid vrownum varcorder varcix varccommits
732 global vupptr vdownptr vleftptr varctok
733 global displayorder parentlist curview cached_commitrow
735 set narctot [expr {[llength $varctok($v)] - 1}]
737 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
738 # go up the tree until we find something that has a row number,
739 # or we get to a seed
740 set a [lindex $vupptr($v) $a]
743 set a [lindex $vdownptr($v) 0]
746 set varcorder($v) [list $a]
748 lset varcrow($v) $a 0
752 set arcn [lindex $varcix($v) $a]
753 # see if a is the last arc; if so, nothing to do
754 if {$arcn == $narctot - 1} {
757 if {[llength $vrownum($v)] > $arcn + 1} {
758 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
759 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
761 set row [lindex $varcrow($v) $a]
763 if {$v == $curview} {
764 if {[llength $displayorder] > $vrowmod($v)} {
765 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
766 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
768 catch {unset cached_commitrow}
772 incr row [llength $varccommits($v,$a)]
773 # go down if possible
774 set b [lindex $vdownptr($v) $a]
776 # if not, go left, or go up until we can go left
778 set b [lindex $vleftptr($v) $a]
780 set a [lindex $vupptr($v) $a]
786 lappend vrownum($v) $row
787 lappend varcorder($v) $a
788 lset varcix($v) $a $arcn
789 lset varcrow($v) $a $row
791 set vtokmod($v) [lindex $varctok($v) $p]
794 if {[info exists currentid]} {
795 set selectedline [rowofcommit $currentid]
799 # Test whether view $v contains commit $id
800 proc commitinview {id v} {
803 return [info exists varcid($v,$id)]
806 # Return the row number for commit $id in the current view
807 proc rowofcommit {id} {
808 global varcid varccommits varcrow curview cached_commitrow
809 global varctok vtokmod
812 if {![info exists varcid($v,$id)]} {
813 puts "oops rowofcommit no arc for [shortids $id]"
816 set a $varcid($v,$id)
817 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
820 if {[info exists cached_commitrow($id)]} {
821 return $cached_commitrow($id)
823 set i [lsearch -exact $varccommits($v,$a) $id]
825 puts "oops didn't find commit [shortids $id] in arc $a"
828 incr i [lindex $varcrow($v) $a]
829 set cached_commitrow($id) $i
833 # Returns 1 if a is on an earlier row than b, otherwise 0
834 proc comes_before {a b} {
835 global varcid varctok curview
838 if {$a eq $b || ![info exists varcid($v,$a)] || \
839 ![info exists varcid($v,$b)]} {
842 if {$varcid($v,$a) != $varcid($v,$b)} {
843 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
844 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
846 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
849 proc bsearch {l elt} {
850 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
855 while {$hi - $lo > 1} {
856 set mid [expr {int(($lo + $hi) / 2)}]
857 set t [lindex $l $mid]
860 } elseif {$elt > $t} {
869 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
870 proc make_disporder {start end} {
871 global vrownum curview commitidx displayorder parentlist
872 global varccommits varcorder parents vrowmod varcrow
873 global d_valid_start d_valid_end
875 if {$end > $vrowmod($curview)} {
876 update_arcrows $curview
878 set ai [bsearch $vrownum($curview) $start]
879 set start [lindex $vrownum($curview) $ai]
880 set narc [llength $vrownum($curview)]
881 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
882 set a [lindex $varcorder($curview) $ai]
883 set l [llength $displayorder]
884 set al [llength $varccommits($curview,$a)]
887 set pad [ntimes [expr {$r - $l}] {}]
888 set displayorder [concat $displayorder $pad]
889 set parentlist [concat $parentlist $pad]
891 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
892 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
894 foreach id $varccommits($curview,$a) {
895 lappend displayorder $id
896 lappend parentlist $parents($curview,$id)
898 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
900 foreach id $varccommits($curview,$a) {
901 lset displayorder $i $id
902 lset parentlist $i $parents($curview,$id)
910 proc commitonrow {row} {
913 set id [lindex $displayorder $row]
915 make_disporder $row [expr {$row + 1}]
916 set id [lindex $displayorder $row]
921 proc closevarcs {v} {
922 global varctok varccommits varcid parents children
923 global cmitlisted commitidx commitinterest vtokmod
925 set missing_parents 0
927 set narcs [llength $varctok($v)]
928 for {set a 1} {$a < $narcs} {incr a} {
929 set id [lindex $varccommits($v,$a) end]
930 foreach p $parents($v,$id) {
931 if {[info exists varcid($v,$p)]} continue
932 # add p as a new commit
934 set cmitlisted($v,$p) 0
935 set parents($v,$p) {}
936 if {[llength $children($v,$p)] == 1 &&
937 [llength $parents($v,$id)] == 1} {
940 set b [newvarc $v $p]
943 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
946 lappend varccommits($v,$b) $p
948 if {[info exists commitinterest($p)]} {
949 foreach script $commitinterest($p) {
950 lappend scripts [string map [list "%I" $p] $script]
952 unset commitinterest($id)
956 if {$missing_parents > 0} {
963 proc getcommitlines {fd inst view} {
964 global cmitlisted commitinterest leftover
965 global commitidx commitdata datemode
966 global parents children curview hlview
967 global vnextroot idpending ordertok
968 global varccommits varcid varctok vtokmod
970 set stuff [read $fd 500000]
971 # git log doesn't terminate the last commit with a null...
972 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
979 global commfd viewcomplete viewactive viewname progresscoords
982 set i [lsearch -exact $viewinstances($view) $inst]
984 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
986 # set it blocking so we wait for the process to terminate
987 fconfigure $fd -blocking 1
988 if {[catch {close $fd} err]} {
990 if {$view != $curview} {
991 set fv " for the \"$viewname($view)\" view"
993 if {[string range $err 0 4] == "usage"} {
994 set err "Gitk: error reading commits$fv:\
995 bad arguments to git rev-list."
996 if {$viewname($view) eq "Command line"} {
998 " (Note: arguments to gitk are passed to git rev-list\
999 to allow selection of commits to be displayed.)"
1002 set err "Error reading commits$fv: $err"
1006 if {[incr viewactive($view) -1] <= 0} {
1007 set viewcomplete($view) 1
1008 # Check if we have seen any ids listed as parents that haven't
1009 # appeared in the list
1012 set progresscoords {0 0}
1015 if {$view == $curview} {
1016 run chewcommits $view
1024 set i [string first "\0" $stuff $start]
1026 append leftover($inst) [string range $stuff $start end]
1030 set cmit $leftover($inst)
1031 append cmit [string range $stuff 0 [expr {$i - 1}]]
1032 set leftover($inst) {}
1034 set cmit [string range $stuff $start [expr {$i - 1}]]
1036 set start [expr {$i + 1}]
1037 set j [string first "\n" $cmit]
1040 if {$j >= 0 && [string match "commit *" $cmit]} {
1041 set ids [string range $cmit 7 [expr {$j - 1}]]
1042 if {[string match {[-<>]*} $ids]} {
1043 switch -- [string index $ids 0] {
1048 set ids [string range $ids 1 end]
1052 if {[string length $id] != 40} {
1060 if {[string length $shortcmit] > 80} {
1061 set shortcmit "[string range $shortcmit 0 80]..."
1063 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1066 set id [lindex $ids 0]
1069 if {[info exists varcid($vid)]} {
1070 if {$cmitlisted($vid) || !$listed} continue
1074 set olds [lrange $ids 1 end]
1078 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1079 set cmitlisted($vid) $listed
1080 set parents($vid) $olds
1081 if {![info exists children($vid)]} {
1082 set children($vid) {}
1083 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1084 set k [lindex $children($vid) 0]
1085 if {[llength $parents($view,$k)] == 1 &&
1087 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1088 set a $varcid($view,$k)
1093 set a [newvarc $view $id]
1095 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1098 if {![info exists varcid($vid)]} {
1100 lappend varccommits($view,$a) $id
1101 incr commitidx($view)
1106 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1108 if {[llength [lappend children($vp) $id]] > 1 &&
1109 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1110 set children($vp) [lsort -command [list vtokcmp $view] \
1112 catch {unset ordertok}
1114 if {[info exists varcid($view,$p)]} {
1115 fix_reversal $p $a $view
1121 if {[info exists commitinterest($id)]} {
1122 foreach script $commitinterest($id) {
1123 lappend scripts [string map [list "%I" $id] $script]
1125 unset commitinterest($id)
1130 run chewcommits $view
1131 foreach s $scripts {
1134 if {$view == $curview} {
1135 # update progress bar
1136 global progressdirn progresscoords proglastnc
1137 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1138 set proglastnc $commitidx($view)
1139 set l [lindex $progresscoords 0]
1140 set r [lindex $progresscoords 1]
1141 if {$progressdirn} {
1142 set r [expr {$r + $inc}]
1148 set l [expr {$r - 0.2}]
1151 set l [expr {$l - $inc}]
1156 set r [expr {$l + 0.2}]
1158 set progresscoords [list $l $r]
1165 proc chewcommits {view} {
1166 global curview hlview viewcomplete
1167 global pending_select
1169 if {$view == $curview} {
1171 if {$viewcomplete($view)} {
1172 global commitidx varctok
1173 global numcommits startmsecs
1174 global mainheadid commitinfo nullid
1176 if {[info exists pending_select]} {
1177 set row [first_real_row]
1180 if {$commitidx($curview) > 0} {
1181 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1182 #puts "overall $ms ms for $numcommits commits"
1183 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1185 show_status [mc "No commits selected"]
1190 if {[info exists hlview] && $view == $hlview} {
1196 proc readcommit {id} {
1197 if {[catch {set contents [exec git cat-file commit $id]}]} return
1198 parsecommit $id $contents 0
1201 proc parsecommit {id contents listed} {
1202 global commitinfo cdate
1211 set hdrend [string first "\n\n" $contents]
1213 # should never happen...
1214 set hdrend [string length $contents]
1216 set header [string range $contents 0 [expr {$hdrend - 1}]]
1217 set comment [string range $contents [expr {$hdrend + 2}] end]
1218 foreach line [split $header "\n"] {
1219 set tag [lindex $line 0]
1220 if {$tag == "author"} {
1221 set audate [lindex $line end-1]
1222 set auname [lrange $line 1 end-2]
1223 } elseif {$tag == "committer"} {
1224 set comdate [lindex $line end-1]
1225 set comname [lrange $line 1 end-2]
1229 # take the first non-blank line of the comment as the headline
1230 set headline [string trimleft $comment]
1231 set i [string first "\n" $headline]
1233 set headline [string range $headline 0 $i]
1235 set headline [string trimright $headline]
1236 set i [string first "\r" $headline]
1238 set headline [string trimright [string range $headline 0 $i]]
1241 # git rev-list indents the comment by 4 spaces;
1242 # if we got this via git cat-file, add the indentation
1244 foreach line [split $comment "\n"] {
1245 append newcomment " "
1246 append newcomment $line
1247 append newcomment "\n"
1249 set comment $newcomment
1251 if {$comdate != {}} {
1252 set cdate($id) $comdate
1254 set commitinfo($id) [list $headline $auname $audate \
1255 $comname $comdate $comment]
1258 proc getcommit {id} {
1259 global commitdata commitinfo
1261 if {[info exists commitdata($id)]} {
1262 parsecommit $id $commitdata($id) 1
1265 if {![info exists commitinfo($id)]} {
1266 set commitinfo($id) [list [mc "No commit information available"]]
1273 global tagids idtags headids idheads tagobjid
1274 global otherrefids idotherrefs mainhead mainheadid
1276 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1279 set refd [open [list | git show-ref -d] r]
1280 while {[gets $refd line] >= 0} {
1281 if {[string index $line 40] ne " "} continue
1282 set id [string range $line 0 39]
1283 set ref [string range $line 41 end]
1284 if {![string match "refs/*" $ref]} continue
1285 set name [string range $ref 5 end]
1286 if {[string match "remotes/*" $name]} {
1287 if {![string match "*/HEAD" $name]} {
1288 set headids($name) $id
1289 lappend idheads($id) $name
1291 } elseif {[string match "heads/*" $name]} {
1292 set name [string range $name 6 end]
1293 set headids($name) $id
1294 lappend idheads($id) $name
1295 } elseif {[string match "tags/*" $name]} {
1296 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1297 # which is what we want since the former is the commit ID
1298 set name [string range $name 5 end]
1299 if {[string match "*^{}" $name]} {
1300 set name [string range $name 0 end-3]
1302 set tagobjid($name) $id
1304 set tagids($name) $id
1305 lappend idtags($id) $name
1307 set otherrefids($name) $id
1308 lappend idotherrefs($id) $name
1315 set thehead [exec git symbolic-ref HEAD]
1316 if {[string match "refs/heads/*" $thehead]} {
1317 set mainhead [string range $thehead 11 end]
1318 if {[info exists headids($mainhead)]} {
1319 set mainheadid $headids($mainhead)
1325 # skip over fake commits
1326 proc first_real_row {} {
1327 global nullid nullid2 numcommits
1329 for {set row 0} {$row < $numcommits} {incr row} {
1330 set id [commitonrow $row]
1331 if {$id ne $nullid && $id ne $nullid2} {
1338 # update things for a head moved to a child of its previous location
1339 proc movehead {id name} {
1340 global headids idheads
1342 removehead $headids($name) $name
1343 set headids($name) $id
1344 lappend idheads($id) $name
1347 # update things when a head has been removed
1348 proc removehead {id name} {
1349 global headids idheads
1351 if {$idheads($id) eq $name} {
1354 set i [lsearch -exact $idheads($id) $name]
1356 set idheads($id) [lreplace $idheads($id) $i $i]
1359 unset headids($name)
1362 proc show_error {w top msg} {
1363 message $w.m -text $msg -justify center -aspect 400
1364 pack $w.m -side top -fill x -padx 20 -pady 20
1365 button $w.ok -text [mc OK] -command "destroy $top"
1366 pack $w.ok -side bottom -fill x
1367 bind $top <Visibility> "grab $top; focus $top"
1368 bind $top <Key-Return> "destroy $top"
1372 proc error_popup msg {
1376 show_error $w $w $msg
1379 proc confirm_popup msg {
1385 message $w.m -text $msg -justify center -aspect 400
1386 pack $w.m -side top -fill x -padx 20 -pady 20
1387 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1388 pack $w.ok -side left -fill x
1389 button $w.cancel -text [mc Cancel] -command "destroy $w"
1390 pack $w.cancel -side right -fill x
1391 bind $w <Visibility> "grab $w; focus $w"
1396 proc setoptions {} {
1397 option add *Panedwindow.showHandle 1 startupFile
1398 option add *Panedwindow.sashRelief raised startupFile
1399 option add *Button.font uifont startupFile
1400 option add *Checkbutton.font uifont startupFile
1401 option add *Radiobutton.font uifont startupFile
1402 option add *Menu.font uifont startupFile
1403 option add *Menubutton.font uifont startupFile
1404 option add *Label.font uifont startupFile
1405 option add *Message.font uifont startupFile
1406 option add *Entry.font uifont startupFile
1409 proc makewindow {} {
1410 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1412 global findtype findtypemenu findloc findstring fstring geometry
1413 global entries sha1entry sha1string sha1but
1414 global diffcontextstring diffcontext
1415 global maincursor textcursor curtextcursor
1416 global rowctxmenu fakerowmenu mergemax wrapcomment
1417 global highlight_files gdttype
1418 global searchstring sstring
1419 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1420 global headctxmenu progresscanv progressitem progresscoords statusw
1421 global fprogitem fprogcoord lastprogupdate progupdatepending
1422 global rprogitem rprogcoord
1426 .bar add cascade -label [mc "File"] -menu .bar.file
1428 .bar.file add command -label [mc "Update"] -command updatecommits
1429 .bar.file add command -label [mc "Reload"] -command reloadcommits
1430 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1431 .bar.file add command -label [mc "List references"] -command showrefs
1432 .bar.file add command -label [mc "Quit"] -command doquit
1434 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1435 .bar.edit add command -label [mc "Preferences"] -command doprefs
1438 .bar add cascade -label [mc "View"] -menu .bar.view
1439 .bar.view add command -label [mc "New view..."] -command {newview 0}
1440 .bar.view add command -label [mc "Edit view..."] -command editview \
1442 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1443 .bar.view add separator
1444 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1445 -variable selectedview -value 0
1448 .bar add cascade -label [mc "Help"] -menu .bar.help
1449 .bar.help add command -label [mc "About gitk"] -command about
1450 .bar.help add command -label [mc "Key bindings"] -command keys
1452 . configure -menu .bar
1454 # the gui has upper and lower half, parts of a paned window.
1455 panedwindow .ctop -orient vertical
1457 # possibly use assumed geometry
1458 if {![info exists geometry(pwsash0)]} {
1459 set geometry(topheight) [expr {15 * $linespc}]
1460 set geometry(topwidth) [expr {80 * $charspc}]
1461 set geometry(botheight) [expr {15 * $linespc}]
1462 set geometry(botwidth) [expr {50 * $charspc}]
1463 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1464 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1467 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1468 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1470 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1472 # create three canvases
1473 set cscroll .tf.histframe.csb
1474 set canv .tf.histframe.pwclist.canv
1476 -selectbackground $selectbgcolor \
1477 -background $bgcolor -bd 0 \
1478 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1479 .tf.histframe.pwclist add $canv
1480 set canv2 .tf.histframe.pwclist.canv2
1482 -selectbackground $selectbgcolor \
1483 -background $bgcolor -bd 0 -yscrollincr $linespc
1484 .tf.histframe.pwclist add $canv2
1485 set canv3 .tf.histframe.pwclist.canv3
1487 -selectbackground $selectbgcolor \
1488 -background $bgcolor -bd 0 -yscrollincr $linespc
1489 .tf.histframe.pwclist add $canv3
1490 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1491 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1493 # a scroll bar to rule them
1494 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1495 pack $cscroll -side right -fill y
1496 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1497 lappend bglist $canv $canv2 $canv3
1498 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1500 # we have two button bars at bottom of top frame. Bar 1
1502 frame .tf.lbar -height 15
1504 set sha1entry .tf.bar.sha1
1505 set entries $sha1entry
1506 set sha1but .tf.bar.sha1label
1507 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1508 -command gotocommit -width 8
1509 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1510 pack .tf.bar.sha1label -side left
1511 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1512 trace add variable sha1string write sha1change
1513 pack $sha1entry -side left -pady 2
1515 image create bitmap bm-left -data {
1516 #define left_width 16
1517 #define left_height 16
1518 static unsigned char left_bits[] = {
1519 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1520 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1521 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1523 image create bitmap bm-right -data {
1524 #define right_width 16
1525 #define right_height 16
1526 static unsigned char right_bits[] = {
1527 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1528 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1529 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1531 button .tf.bar.leftbut -image bm-left -command goback \
1532 -state disabled -width 26
1533 pack .tf.bar.leftbut -side left -fill y
1534 button .tf.bar.rightbut -image bm-right -command goforw \
1535 -state disabled -width 26
1536 pack .tf.bar.rightbut -side left -fill y
1538 # Status label and progress bar
1539 set statusw .tf.bar.status
1540 label $statusw -width 15 -relief sunken
1541 pack $statusw -side left -padx 5
1542 set h [expr {[font metrics uifont -linespace] + 2}]
1543 set progresscanv .tf.bar.progress
1544 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1545 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1546 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1547 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1548 pack $progresscanv -side right -expand 1 -fill x
1549 set progresscoords {0 0}
1552 bind $progresscanv <Configure> adjustprogress
1553 set lastprogupdate [clock clicks -milliseconds]
1554 set progupdatepending 0
1556 # build up the bottom bar of upper window
1557 label .tf.lbar.flabel -text "[mc "Find"] "
1558 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1559 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1560 label .tf.lbar.flab2 -text " [mc "commit"] "
1561 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1563 set gdttype [mc "containing:"]
1564 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1565 [mc "containing:"] \
1566 [mc "touching paths:"] \
1567 [mc "adding/removing string:"]]
1568 trace add variable gdttype write gdttype_change
1569 pack .tf.lbar.gdttype -side left -fill y
1572 set fstring .tf.lbar.findstring
1573 lappend entries $fstring
1574 entry $fstring -width 30 -font textfont -textvariable findstring
1575 trace add variable findstring write find_change
1576 set findtype [mc "Exact"]
1577 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1578 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1579 trace add variable findtype write findcom_change
1580 set findloc [mc "All fields"]
1581 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1582 [mc "Comments"] [mc "Author"] [mc "Committer"]
1583 trace add variable findloc write find_change
1584 pack .tf.lbar.findloc -side right
1585 pack .tf.lbar.findtype -side right
1586 pack $fstring -side left -expand 1 -fill x
1588 # Finish putting the upper half of the viewer together
1589 pack .tf.lbar -in .tf -side bottom -fill x
1590 pack .tf.bar -in .tf -side bottom -fill x
1591 pack .tf.histframe -fill both -side top -expand 1
1593 .ctop paneconfigure .tf -height $geometry(topheight)
1594 .ctop paneconfigure .tf -width $geometry(topwidth)
1596 # now build up the bottom
1597 panedwindow .pwbottom -orient horizontal
1599 # lower left, a text box over search bar, scroll bar to the right
1600 # if we know window height, then that will set the lower text height, otherwise
1601 # we set lower text height which will drive window height
1602 if {[info exists geometry(main)]} {
1603 frame .bleft -width $geometry(botwidth)
1605 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1610 button .bleft.top.search -text [mc "Search"] -command dosearch
1611 pack .bleft.top.search -side left -padx 5
1612 set sstring .bleft.top.sstring
1613 entry $sstring -width 20 -font textfont -textvariable searchstring
1614 lappend entries $sstring
1615 trace add variable searchstring write incrsearch
1616 pack $sstring -side left -expand 1 -fill x
1617 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1618 -command changediffdisp -variable diffelide -value {0 0}
1619 radiobutton .bleft.mid.old -text [mc "Old version"] \
1620 -command changediffdisp -variable diffelide -value {0 1}
1621 radiobutton .bleft.mid.new -text [mc "New version"] \
1622 -command changediffdisp -variable diffelide -value {1 0}
1623 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1624 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1625 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1626 -from 1 -increment 1 -to 10000000 \
1627 -validate all -validatecommand "diffcontextvalidate %P" \
1628 -textvariable diffcontextstring
1629 .bleft.mid.diffcontext set $diffcontext
1630 trace add variable diffcontextstring write diffcontextchange
1631 lappend entries .bleft.mid.diffcontext
1632 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1633 set ctext .bleft.ctext
1634 text $ctext -background $bgcolor -foreground $fgcolor \
1635 -state disabled -font textfont \
1636 -yscrollcommand scrolltext -wrap none
1638 $ctext conf -tabstyle wordprocessor
1640 scrollbar .bleft.sb -command "$ctext yview"
1641 pack .bleft.top -side top -fill x
1642 pack .bleft.mid -side top -fill x
1643 pack .bleft.sb -side right -fill y
1644 pack $ctext -side left -fill both -expand 1
1645 lappend bglist $ctext
1646 lappend fglist $ctext
1648 $ctext tag conf comment -wrap $wrapcomment
1649 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1650 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1651 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1652 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1653 $ctext tag conf m0 -fore red
1654 $ctext tag conf m1 -fore blue
1655 $ctext tag conf m2 -fore green
1656 $ctext tag conf m3 -fore purple
1657 $ctext tag conf m4 -fore brown
1658 $ctext tag conf m5 -fore "#009090"
1659 $ctext tag conf m6 -fore magenta
1660 $ctext tag conf m7 -fore "#808000"
1661 $ctext tag conf m8 -fore "#009000"
1662 $ctext tag conf m9 -fore "#ff0080"
1663 $ctext tag conf m10 -fore cyan
1664 $ctext tag conf m11 -fore "#b07070"
1665 $ctext tag conf m12 -fore "#70b0f0"
1666 $ctext tag conf m13 -fore "#70f0b0"
1667 $ctext tag conf m14 -fore "#f0b070"
1668 $ctext tag conf m15 -fore "#ff70b0"
1669 $ctext tag conf mmax -fore darkgrey
1671 $ctext tag conf mresult -font textfontbold
1672 $ctext tag conf msep -font textfontbold
1673 $ctext tag conf found -back yellow
1675 .pwbottom add .bleft
1676 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1681 radiobutton .bright.mode.patch -text [mc "Patch"] \
1682 -command reselectline -variable cmitmode -value "patch"
1683 radiobutton .bright.mode.tree -text [mc "Tree"] \
1684 -command reselectline -variable cmitmode -value "tree"
1685 grid .bright.mode.patch .bright.mode.tree -sticky ew
1686 pack .bright.mode -side top -fill x
1687 set cflist .bright.cfiles
1688 set indent [font measure mainfont "nn"]
1690 -selectbackground $selectbgcolor \
1691 -background $bgcolor -foreground $fgcolor \
1693 -tabs [list $indent [expr {2 * $indent}]] \
1694 -yscrollcommand ".bright.sb set" \
1695 -cursor [. cget -cursor] \
1696 -spacing1 1 -spacing3 1
1697 lappend bglist $cflist
1698 lappend fglist $cflist
1699 scrollbar .bright.sb -command "$cflist yview"
1700 pack .bright.sb -side right -fill y
1701 pack $cflist -side left -fill both -expand 1
1702 $cflist tag configure highlight \
1703 -background [$cflist cget -selectbackground]
1704 $cflist tag configure bold -font mainfontbold
1706 .pwbottom add .bright
1709 # restore window position if known
1710 if {[info exists geometry(main)]} {
1711 wm geometry . "$geometry(main)"
1714 if {[tk windowingsystem] eq {aqua}} {
1720 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1721 pack .ctop -fill both -expand 1
1722 bindall <1> {selcanvline %W %x %y}
1723 #bindall <B1-Motion> {selcanvline %W %x %y}
1724 if {[tk windowingsystem] == "win32"} {
1725 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1726 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1728 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1729 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1730 if {[tk windowingsystem] eq "aqua"} {
1731 bindall <MouseWheel> {
1732 set delta [expr {- (%D)}]
1733 allcanvs yview scroll $delta units
1737 bindall <2> "canvscan mark %W %x %y"
1738 bindall <B2-Motion> "canvscan dragto %W %x %y"
1739 bindkey <Home> selfirstline
1740 bindkey <End> sellastline
1741 bind . <Key-Up> "selnextline -1"
1742 bind . <Key-Down> "selnextline 1"
1743 bind . <Shift-Key-Up> "dofind -1 0"
1744 bind . <Shift-Key-Down> "dofind 1 0"
1745 bindkey <Key-Right> "goforw"
1746 bindkey <Key-Left> "goback"
1747 bind . <Key-Prior> "selnextpage -1"
1748 bind . <Key-Next> "selnextpage 1"
1749 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1750 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1751 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1752 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1753 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1754 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1755 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1756 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1757 bindkey <Key-space> "$ctext yview scroll 1 pages"
1758 bindkey p "selnextline -1"
1759 bindkey n "selnextline 1"
1762 bindkey i "selnextline -1"
1763 bindkey k "selnextline 1"
1766 bindkey b "$ctext yview scroll -1 pages"
1767 bindkey d "$ctext yview scroll 18 units"
1768 bindkey u "$ctext yview scroll -18 units"
1769 bindkey / {dofind 1 1}
1770 bindkey <Key-Return> {dofind 1 1}
1771 bindkey ? {dofind -1 1}
1773 bindkey <F5> updatecommits
1774 bind . <$M1B-q> doquit
1775 bind . <$M1B-f> {dofind 1 1}
1776 bind . <$M1B-g> {dofind 1 0}
1777 bind . <$M1B-r> dosearchback
1778 bind . <$M1B-s> dosearch
1779 bind . <$M1B-equal> {incrfont 1}
1780 bind . <$M1B-KP_Add> {incrfont 1}
1781 bind . <$M1B-minus> {incrfont -1}
1782 bind . <$M1B-KP_Subtract> {incrfont -1}
1783 wm protocol . WM_DELETE_WINDOW doquit
1784 bind . <Button-1> "click %W"
1785 bind $fstring <Key-Return> {dofind 1 1}
1786 bind $sha1entry <Key-Return> gotocommit
1787 bind $sha1entry <<PasteSelection>> clearsha1
1788 bind $cflist <1> {sel_flist %W %x %y; break}
1789 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1790 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1791 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1793 set maincursor [. cget -cursor]
1794 set textcursor [$ctext cget -cursor]
1795 set curtextcursor $textcursor
1797 set rowctxmenu .rowctxmenu
1798 menu $rowctxmenu -tearoff 0
1799 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1800 -command {diffvssel 0}
1801 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1802 -command {diffvssel 1}
1803 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1804 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1805 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1806 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1807 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1809 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1812 set fakerowmenu .fakerowmenu
1813 menu $fakerowmenu -tearoff 0
1814 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1815 -command {diffvssel 0}
1816 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1817 -command {diffvssel 1}
1818 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1819 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1820 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1821 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1823 set headctxmenu .headctxmenu
1824 menu $headctxmenu -tearoff 0
1825 $headctxmenu add command -label [mc "Check out this branch"] \
1827 $headctxmenu add command -label [mc "Remove this branch"] \
1831 set flist_menu .flistctxmenu
1832 menu $flist_menu -tearoff 0
1833 $flist_menu add command -label [mc "Highlight this too"] \
1834 -command {flist_hl 0}
1835 $flist_menu add command -label [mc "Highlight this only"] \
1836 -command {flist_hl 1}
1839 # Windows sends all mouse wheel events to the current focused window, not
1840 # the one where the mouse hovers, so bind those events here and redirect
1841 # to the correct window
1842 proc windows_mousewheel_redirector {W X Y D} {
1843 global canv canv2 canv3
1844 set w [winfo containing -displayof $W $X $Y]
1846 set u [expr {$D < 0 ? 5 : -5}]
1847 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1848 allcanvs yview scroll $u units
1851 $w yview scroll $u units
1857 # mouse-2 makes all windows scan vertically, but only the one
1858 # the cursor is in scans horizontally
1859 proc canvscan {op w x y} {
1860 global canv canv2 canv3
1861 foreach c [list $canv $canv2 $canv3] {
1870 proc scrollcanv {cscroll f0 f1} {
1871 $cscroll set $f0 $f1
1876 # when we make a key binding for the toplevel, make sure
1877 # it doesn't get triggered when that key is pressed in the
1878 # find string entry widget.
1879 proc bindkey {ev script} {
1882 set escript [bind Entry $ev]
1883 if {$escript == {}} {
1884 set escript [bind Entry <Key>]
1886 foreach e $entries {
1887 bind $e $ev "$escript; break"
1891 # set the focus back to the toplevel for any click outside
1894 global ctext entries
1895 foreach e [concat $entries $ctext] {
1896 if {$w == $e} return
1901 # Adjust the progress bar for a change in requested extent or canvas size
1902 proc adjustprogress {} {
1903 global progresscanv progressitem progresscoords
1904 global fprogitem fprogcoord lastprogupdate progupdatepending
1905 global rprogitem rprogcoord
1907 set w [expr {[winfo width $progresscanv] - 4}]
1908 set x0 [expr {$w * [lindex $progresscoords 0]}]
1909 set x1 [expr {$w * [lindex $progresscoords 1]}]
1910 set h [winfo height $progresscanv]
1911 $progresscanv coords $progressitem $x0 0 $x1 $h
1912 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1913 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1914 set now [clock clicks -milliseconds]
1915 if {$now >= $lastprogupdate + 100} {
1916 set progupdatepending 0
1918 } elseif {!$progupdatepending} {
1919 set progupdatepending 1
1920 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1924 proc doprogupdate {} {
1925 global lastprogupdate progupdatepending
1927 if {$progupdatepending} {
1928 set progupdatepending 0
1929 set lastprogupdate [clock clicks -milliseconds]
1934 proc savestuff {w} {
1935 global canv canv2 canv3 mainfont textfont uifont tabstop
1936 global stuffsaved findmergefiles maxgraphpct
1937 global maxwidth showneartags showlocalchanges
1938 global viewname viewfiles viewargs viewperm nextviewnum
1939 global cmitmode wrapcomment datetimeformat limitdiffs
1940 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1942 if {$stuffsaved} return
1943 if {![winfo viewable .]} return
1945 set f [open "~/.gitk-new" w]
1946 puts $f [list set mainfont $mainfont]
1947 puts $f [list set textfont $textfont]
1948 puts $f [list set uifont $uifont]
1949 puts $f [list set tabstop $tabstop]
1950 puts $f [list set findmergefiles $findmergefiles]
1951 puts $f [list set maxgraphpct $maxgraphpct]
1952 puts $f [list set maxwidth $maxwidth]
1953 puts $f [list set cmitmode $cmitmode]
1954 puts $f [list set wrapcomment $wrapcomment]
1955 puts $f [list set showneartags $showneartags]
1956 puts $f [list set showlocalchanges $showlocalchanges]
1957 puts $f [list set datetimeformat $datetimeformat]
1958 puts $f [list set limitdiffs $limitdiffs]
1959 puts $f [list set bgcolor $bgcolor]
1960 puts $f [list set fgcolor $fgcolor]
1961 puts $f [list set colors $colors]
1962 puts $f [list set diffcolors $diffcolors]
1963 puts $f [list set diffcontext $diffcontext]
1964 puts $f [list set selectbgcolor $selectbgcolor]
1966 puts $f "set geometry(main) [wm geometry .]"
1967 puts $f "set geometry(topwidth) [winfo width .tf]"
1968 puts $f "set geometry(topheight) [winfo height .tf]"
1969 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1970 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1971 puts $f "set geometry(botwidth) [winfo width .bleft]"
1972 puts $f "set geometry(botheight) [winfo height .bleft]"
1974 puts -nonewline $f "set permviews {"
1975 for {set v 0} {$v < $nextviewnum} {incr v} {
1976 if {$viewperm($v)} {
1977 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1982 file rename -force "~/.gitk-new" "~/.gitk"
1987 proc resizeclistpanes {win w} {
1989 if {[info exists oldwidth($win)]} {
1990 set s0 [$win sash coord 0]
1991 set s1 [$win sash coord 1]
1993 set sash0 [expr {int($w/2 - 2)}]
1994 set sash1 [expr {int($w*5/6 - 2)}]
1996 set factor [expr {1.0 * $w / $oldwidth($win)}]
1997 set sash0 [expr {int($factor * [lindex $s0 0])}]
1998 set sash1 [expr {int($factor * [lindex $s1 0])}]
2002 if {$sash1 < $sash0 + 20} {
2003 set sash1 [expr {$sash0 + 20}]
2005 if {$sash1 > $w - 10} {
2006 set sash1 [expr {$w - 10}]
2007 if {$sash0 > $sash1 - 20} {
2008 set sash0 [expr {$sash1 - 20}]
2012 $win sash place 0 $sash0 [lindex $s0 1]
2013 $win sash place 1 $sash1 [lindex $s1 1]
2015 set oldwidth($win) $w
2018 proc resizecdetpanes {win w} {
2020 if {[info exists oldwidth($win)]} {
2021 set s0 [$win sash coord 0]
2023 set sash0 [expr {int($w*3/4 - 2)}]
2025 set factor [expr {1.0 * $w / $oldwidth($win)}]
2026 set sash0 [expr {int($factor * [lindex $s0 0])}]
2030 if {$sash0 > $w - 15} {
2031 set sash0 [expr {$w - 15}]
2034 $win sash place 0 $sash0 [lindex $s0 1]
2036 set oldwidth($win) $w
2039 proc allcanvs args {
2040 global canv canv2 canv3
2046 proc bindall {event action} {
2047 global canv canv2 canv3
2048 bind $canv $event $action
2049 bind $canv2 $event $action
2050 bind $canv3 $event $action
2056 if {[winfo exists $w]} {
2061 wm title $w [mc "About gitk"]
2062 message $w.m -text [mc "
2063 Gitk - a commit viewer for git
2065 Copyright © 2005-2006 Paul Mackerras
2067 Use and redistribute under the terms of the GNU General Public License"] \
2068 -justify center -aspect 400 -border 2 -bg white -relief groove
2069 pack $w.m -side top -fill x -padx 2 -pady 2
2070 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2071 pack $w.ok -side bottom
2072 bind $w <Visibility> "focus $w.ok"
2073 bind $w <Key-Escape> "destroy $w"
2074 bind $w <Key-Return> "destroy $w"
2079 if {[winfo exists $w]} {
2083 if {[tk windowingsystem] eq {aqua}} {
2089 wm title $w [mc "Gitk key bindings"]
2090 message $w.m -text [mc "
2094 <Home> Move to first commit
2095 <End> Move to last commit
2096 <Up>, p, i Move up one commit
2097 <Down>, n, k Move down one commit
2098 <Left>, z, j Go back in history list
2099 <Right>, x, l Go forward in history list
2100 <PageUp> Move up one page in commit list
2101 <PageDown> Move down one page in commit list
2102 <$M1T-Home> Scroll to top of commit list
2103 <$M1T-End> Scroll to bottom of commit list
2104 <$M1T-Up> Scroll commit list up one line
2105 <$M1T-Down> Scroll commit list down one line
2106 <$M1T-PageUp> Scroll commit list up one page
2107 <$M1T-PageDown> Scroll commit list down one page
2108 <Shift-Up> Find backwards (upwards, later commits)
2109 <Shift-Down> Find forwards (downwards, earlier commits)
2110 <Delete>, b Scroll diff view up one page
2111 <Backspace> Scroll diff view up one page
2112 <Space> Scroll diff view down one page
2113 u Scroll diff view up 18 lines
2114 d Scroll diff view down 18 lines
2116 <$M1T-G> Move to next find hit
2117 <Return> Move to next find hit
2118 / Move to next find hit, or redo find
2119 ? Move to previous find hit
2120 f Scroll diff view to next file
2121 <$M1T-S> Search for next hit in diff view
2122 <$M1T-R> Search for previous hit in diff view
2123 <$M1T-KP+> Increase font size
2124 <$M1T-plus> Increase font size
2125 <$M1T-KP-> Decrease font size
2126 <$M1T-minus> Decrease font size
2129 -justify left -bg white -border 2 -relief groove
2130 pack $w.m -side top -fill both -padx 2 -pady 2
2131 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2132 pack $w.ok -side bottom
2133 bind $w <Visibility> "focus $w.ok"
2134 bind $w <Key-Escape> "destroy $w"
2135 bind $w <Key-Return> "destroy $w"
2138 # Procedures for manipulating the file list window at the
2139 # bottom right of the overall window.
2141 proc treeview {w l openlevs} {
2142 global treecontents treediropen treeheight treeparent treeindex
2152 set treecontents() {}
2153 $w conf -state normal
2155 while {[string range $f 0 $prefixend] ne $prefix} {
2156 if {$lev <= $openlevs} {
2157 $w mark set e:$treeindex($prefix) "end -1c"
2158 $w mark gravity e:$treeindex($prefix) left
2160 set treeheight($prefix) $ht
2161 incr ht [lindex $htstack end]
2162 set htstack [lreplace $htstack end end]
2163 set prefixend [lindex $prefendstack end]
2164 set prefendstack [lreplace $prefendstack end end]
2165 set prefix [string range $prefix 0 $prefixend]
2168 set tail [string range $f [expr {$prefixend+1}] end]
2169 while {[set slash [string first "/" $tail]] >= 0} {
2172 lappend prefendstack $prefixend
2173 incr prefixend [expr {$slash + 1}]
2174 set d [string range $tail 0 $slash]
2175 lappend treecontents($prefix) $d
2176 set oldprefix $prefix
2178 set treecontents($prefix) {}
2179 set treeindex($prefix) [incr ix]
2180 set treeparent($prefix) $oldprefix
2181 set tail [string range $tail [expr {$slash+1}] end]
2182 if {$lev <= $openlevs} {
2184 set treediropen($prefix) [expr {$lev < $openlevs}]
2185 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2186 $w mark set d:$ix "end -1c"
2187 $w mark gravity d:$ix left
2189 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2191 $w image create end -align center -image $bm -padx 1 \
2193 $w insert end $d [highlight_tag $prefix]
2194 $w mark set s:$ix "end -1c"
2195 $w mark gravity s:$ix left
2200 if {$lev <= $openlevs} {
2203 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2205 $w insert end $tail [highlight_tag $f]
2207 lappend treecontents($prefix) $tail
2210 while {$htstack ne {}} {
2211 set treeheight($prefix) $ht
2212 incr ht [lindex $htstack end]
2213 set htstack [lreplace $htstack end end]
2214 set prefixend [lindex $prefendstack end]
2215 set prefendstack [lreplace $prefendstack end end]
2216 set prefix [string range $prefix 0 $prefixend]
2218 $w conf -state disabled
2221 proc linetoelt {l} {
2222 global treeheight treecontents
2227 foreach e $treecontents($prefix) {
2232 if {[string index $e end] eq "/"} {
2233 set n $treeheight($prefix$e)
2245 proc highlight_tree {y prefix} {
2246 global treeheight treecontents cflist
2248 foreach e $treecontents($prefix) {
2250 if {[highlight_tag $path] ne {}} {
2251 $cflist tag add bold $y.0 "$y.0 lineend"
2254 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2255 set y [highlight_tree $y $path]
2261 proc treeclosedir {w dir} {
2262 global treediropen treeheight treeparent treeindex
2264 set ix $treeindex($dir)
2265 $w conf -state normal
2266 $w delete s:$ix e:$ix
2267 set treediropen($dir) 0
2268 $w image configure a:$ix -image tri-rt
2269 $w conf -state disabled
2270 set n [expr {1 - $treeheight($dir)}]
2271 while {$dir ne {}} {
2272 incr treeheight($dir) $n
2273 set dir $treeparent($dir)
2277 proc treeopendir {w dir} {
2278 global treediropen treeheight treeparent treecontents treeindex
2280 set ix $treeindex($dir)
2281 $w conf -state normal
2282 $w image configure a:$ix -image tri-dn
2283 $w mark set e:$ix s:$ix
2284 $w mark gravity e:$ix right
2287 set n [llength $treecontents($dir)]
2288 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2291 incr treeheight($x) $n
2293 foreach e $treecontents($dir) {
2295 if {[string index $e end] eq "/"} {
2296 set iy $treeindex($de)
2297 $w mark set d:$iy e:$ix
2298 $w mark gravity d:$iy left
2299 $w insert e:$ix $str
2300 set treediropen($de) 0
2301 $w image create e:$ix -align center -image tri-rt -padx 1 \
2303 $w insert e:$ix $e [highlight_tag $de]
2304 $w mark set s:$iy e:$ix
2305 $w mark gravity s:$iy left
2306 set treeheight($de) 1
2308 $w insert e:$ix $str
2309 $w insert e:$ix $e [highlight_tag $de]
2312 $w mark gravity e:$ix left
2313 $w conf -state disabled
2314 set treediropen($dir) 1
2315 set top [lindex [split [$w index @0,0] .] 0]
2316 set ht [$w cget -height]
2317 set l [lindex [split [$w index s:$ix] .] 0]
2320 } elseif {$l + $n + 1 > $top + $ht} {
2321 set top [expr {$l + $n + 2 - $ht}]
2329 proc treeclick {w x y} {
2330 global treediropen cmitmode ctext cflist cflist_top
2332 if {$cmitmode ne "tree"} return
2333 if {![info exists cflist_top]} return
2334 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2335 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2336 $cflist tag add highlight $l.0 "$l.0 lineend"
2342 set e [linetoelt $l]
2343 if {[string index $e end] ne "/"} {
2345 } elseif {$treediropen($e)} {
2352 proc setfilelist {id} {
2353 global treefilelist cflist
2355 treeview $cflist $treefilelist($id) 0
2358 image create bitmap tri-rt -background black -foreground blue -data {
2359 #define tri-rt_width 13
2360 #define tri-rt_height 13
2361 static unsigned char tri-rt_bits[] = {
2362 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2363 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2366 #define tri-rt-mask_width 13
2367 #define tri-rt-mask_height 13
2368 static unsigned char tri-rt-mask_bits[] = {
2369 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2370 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2373 image create bitmap tri-dn -background black -foreground blue -data {
2374 #define tri-dn_width 13
2375 #define tri-dn_height 13
2376 static unsigned char tri-dn_bits[] = {
2377 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2378 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2381 #define tri-dn-mask_width 13
2382 #define tri-dn-mask_height 13
2383 static unsigned char tri-dn-mask_bits[] = {
2384 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2385 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2389 image create bitmap reficon-T -background black -foreground yellow -data {
2390 #define tagicon_width 13
2391 #define tagicon_height 9
2392 static unsigned char tagicon_bits[] = {
2393 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2394 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2396 #define tagicon-mask_width 13
2397 #define tagicon-mask_height 9
2398 static unsigned char tagicon-mask_bits[] = {
2399 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2400 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2403 #define headicon_width 13
2404 #define headicon_height 9
2405 static unsigned char headicon_bits[] = {
2406 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2407 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2410 #define headicon-mask_width 13
2411 #define headicon-mask_height 9
2412 static unsigned char headicon-mask_bits[] = {
2413 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2414 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2416 image create bitmap reficon-H -background black -foreground green \
2417 -data $rectdata -maskdata $rectmask
2418 image create bitmap reficon-o -background black -foreground "#ddddff" \
2419 -data $rectdata -maskdata $rectmask
2421 proc init_flist {first} {
2422 global cflist cflist_top difffilestart
2424 $cflist conf -state normal
2425 $cflist delete 0.0 end
2427 $cflist insert end $first
2429 $cflist tag add highlight 1.0 "1.0 lineend"
2431 catch {unset cflist_top}
2433 $cflist conf -state disabled
2434 set difffilestart {}
2437 proc highlight_tag {f} {
2438 global highlight_paths
2440 foreach p $highlight_paths {
2441 if {[string match $p $f]} {
2448 proc highlight_filelist {} {
2449 global cmitmode cflist
2451 $cflist conf -state normal
2452 if {$cmitmode ne "tree"} {
2453 set end [lindex [split [$cflist index end] .] 0]
2454 for {set l 2} {$l < $end} {incr l} {
2455 set line [$cflist get $l.0 "$l.0 lineend"]
2456 if {[highlight_tag $line] ne {}} {
2457 $cflist tag add bold $l.0 "$l.0 lineend"
2463 $cflist conf -state disabled
2466 proc unhighlight_filelist {} {
2469 $cflist conf -state normal
2470 $cflist tag remove bold 1.0 end
2471 $cflist conf -state disabled
2474 proc add_flist {fl} {
2477 $cflist conf -state normal
2479 $cflist insert end "\n"
2480 $cflist insert end $f [highlight_tag $f]
2482 $cflist conf -state disabled
2485 proc sel_flist {w x y} {
2486 global ctext difffilestart cflist cflist_top cmitmode
2488 if {$cmitmode eq "tree"} return
2489 if {![info exists cflist_top]} return
2490 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2491 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2492 $cflist tag add highlight $l.0 "$l.0 lineend"
2497 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2501 proc pop_flist_menu {w X Y x y} {
2502 global ctext cflist cmitmode flist_menu flist_menu_file
2503 global treediffs diffids
2506 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2508 if {$cmitmode eq "tree"} {
2509 set e [linetoelt $l]
2510 if {[string index $e end] eq "/"} return
2512 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2514 set flist_menu_file $e
2515 tk_popup $flist_menu $X $Y
2518 proc flist_hl {only} {
2519 global flist_menu_file findstring gdttype
2521 set x [shellquote $flist_menu_file]
2522 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2525 append findstring " " $x
2527 set gdttype [mc "touching paths:"]
2530 # Functions for adding and removing shell-type quoting
2532 proc shellquote {str} {
2533 if {![string match "*\['\"\\ \t]*" $str]} {
2536 if {![string match "*\['\"\\]*" $str]} {
2539 if {![string match "*'*" $str]} {
2542 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2545 proc shellarglist {l} {
2551 append str [shellquote $a]
2556 proc shelldequote {str} {
2561 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2562 append ret [string range $str $used end]
2563 set used [string length $str]
2566 set first [lindex $first 0]
2567 set ch [string index $str $first]
2568 if {$first > $used} {
2569 append ret [string range $str $used [expr {$first - 1}]]
2572 if {$ch eq " " || $ch eq "\t"} break
2575 set first [string first "'" $str $used]
2577 error "unmatched single-quote"
2579 append ret [string range $str $used [expr {$first - 1}]]
2584 if {$used >= [string length $str]} {
2585 error "trailing backslash"
2587 append ret [string index $str $used]
2592 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2593 error "unmatched double-quote"
2595 set first [lindex $first 0]
2596 set ch [string index $str $first]
2597 if {$first > $used} {
2598 append ret [string range $str $used [expr {$first - 1}]]
2601 if {$ch eq "\""} break
2603 append ret [string index $str $used]
2607 return [list $used $ret]
2610 proc shellsplit {str} {
2613 set str [string trimleft $str]
2614 if {$str eq {}} break
2615 set dq [shelldequote $str]
2616 set n [lindex $dq 0]
2617 set word [lindex $dq 1]
2618 set str [string range $str $n end]
2624 # Code to implement multiple views
2626 proc newview {ishighlight} {
2627 global nextviewnum newviewname newviewperm newishighlight
2628 global newviewargs revtreeargs
2630 set newishighlight $ishighlight
2632 if {[winfo exists $top]} {
2636 set newviewname($nextviewnum) "View $nextviewnum"
2637 set newviewperm($nextviewnum) 0
2638 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2639 vieweditor $top $nextviewnum [mc "Gitk view definition"]
2644 global viewname viewperm newviewname newviewperm
2645 global viewargs newviewargs
2647 set top .gitkvedit-$curview
2648 if {[winfo exists $top]} {
2652 set newviewname($curview) $viewname($curview)
2653 set newviewperm($curview) $viewperm($curview)
2654 set newviewargs($curview) [shellarglist $viewargs($curview)]
2655 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2658 proc vieweditor {top n title} {
2659 global newviewname newviewperm viewfiles bgcolor
2662 wm title $top $title
2663 label $top.nl -text [mc "Name"]
2664 entry $top.name -width 20 -textvariable newviewname($n)
2665 grid $top.nl $top.name -sticky w -pady 5
2666 checkbutton $top.perm -text [mc "Remember this view"] \
2667 -variable newviewperm($n)
2668 grid $top.perm - -pady 5 -sticky w
2669 message $top.al -aspect 1000 \
2670 -text [mc "Commits to include (arguments to git rev-list):"]
2671 grid $top.al - -sticky w -pady 5
2672 entry $top.args -width 50 -textvariable newviewargs($n) \
2673 -background $bgcolor
2674 grid $top.args - -sticky ew -padx 5
2675 message $top.l -aspect 1000 \
2676 -text [mc "Enter files and directories to include, one per line:"]
2677 grid $top.l - -sticky w
2678 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
2679 if {[info exists viewfiles($n)]} {
2680 foreach f $viewfiles($n) {
2681 $top.t insert end $f
2682 $top.t insert end "\n"
2684 $top.t delete {end - 1c} end
2685 $top.t mark set insert 0.0
2687 grid $top.t - -sticky ew -padx 5
2689 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
2690 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
2691 grid $top.buts.ok $top.buts.can
2692 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2693 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2694 grid $top.buts - -pady 10 -sticky ew
2698 proc doviewmenu {m first cmd op argv} {
2699 set nmenu [$m index end]
2700 for {set i $first} {$i <= $nmenu} {incr i} {
2701 if {[$m entrycget $i -command] eq $cmd} {
2702 eval $m $op $i $argv
2708 proc allviewmenus {n op args} {
2711 doviewmenu .bar.view 5 [list showview $n] $op $args
2712 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2715 proc newviewok {top n} {
2716 global nextviewnum newviewperm newviewname newishighlight
2717 global viewname viewfiles viewperm selectedview curview
2718 global viewargs newviewargs viewhlmenu
2721 set newargs [shellsplit $newviewargs($n)]
2723 error_popup "[mc "Error in commit selection arguments:"] $err"
2729 foreach f [split [$top.t get 0.0 end] "\n"] {
2730 set ft [string trim $f]
2735 if {![info exists viewfiles($n)]} {
2736 # creating a new view
2738 set viewname($n) $newviewname($n)
2739 set viewperm($n) $newviewperm($n)
2740 set viewfiles($n) $files
2741 set viewargs($n) $newargs
2743 if {!$newishighlight} {
2746 run addvhighlight $n
2749 # editing an existing view
2750 set viewperm($n) $newviewperm($n)
2751 if {$newviewname($n) ne $viewname($n)} {
2752 set viewname($n) $newviewname($n)
2753 doviewmenu .bar.view 5 [list showview $n] \
2754 entryconf [list -label $viewname($n)]
2755 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2756 # entryconf [list -label $viewname($n) -value $viewname($n)]
2758 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2759 set viewfiles($n) $files
2760 set viewargs($n) $newargs
2761 if {$curview == $n} {
2766 catch {destroy $top}
2770 global curview viewperm hlview selectedhlview
2772 if {$curview == 0} return
2773 if {[info exists hlview] && $hlview == $curview} {
2774 set selectedhlview [mc "None"]
2777 allviewmenus $curview delete
2778 set viewperm($curview) 0
2782 proc addviewmenu {n} {
2783 global viewname viewhlmenu
2785 .bar.view add radiobutton -label $viewname($n) \
2786 -command [list showview $n] -variable selectedview -value $n
2787 #$viewhlmenu add radiobutton -label $viewname($n) \
2788 # -command [list addvhighlight $n] -variable selectedhlview
2792 global curview viewfiles cached_commitrow ordertok
2793 global displayorder parentlist rowidlist rowisopt rowfinal
2794 global colormap rowtextx nextcolor canvxmax
2795 global numcommits viewcomplete
2796 global selectedline currentid canv canvy0
2798 global pending_select mainheadid
2801 global hlview selectedhlview commitinterest
2803 if {$n == $curview} return
2805 set ymax [lindex [$canv cget -scrollregion] 3]
2806 set span [$canv yview]
2807 set ytop [expr {[lindex $span 0] * $ymax}]
2808 set ybot [expr {[lindex $span 1] * $ymax}]
2809 set yscreen [expr {($ybot - $ytop) / 2}]
2810 if {[info exists selectedline]} {
2811 set selid $currentid
2812 set y [yc $selectedline]
2813 if {$ytop < $y && $y < $ybot} {
2814 set yscreen [expr {$y - $ytop}]
2816 } elseif {[info exists pending_select]} {
2817 set selid $pending_select
2818 unset pending_select
2822 catch {unset treediffs}
2824 if {[info exists hlview] && $hlview == $n} {
2826 set selectedhlview [mc "None"]
2828 catch {unset commitinterest}
2829 catch {unset cached_commitrow}
2830 catch {unset ordertok}
2834 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
2835 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
2838 if {![info exists viewcomplete($n)]} {
2840 set pending_select $selid
2851 set numcommits $commitidx($n)
2853 catch {unset colormap}
2854 catch {unset rowtextx}
2856 set canvxmax [$canv cget -width]
2862 if {$selid ne {} && [commitinview $selid $n]} {
2863 set row [rowofcommit $selid]
2864 # try to get the selected row in the same position on the screen
2865 set ymax [lindex [$canv cget -scrollregion] 3]
2866 set ytop [expr {[yc $row] - $yscreen}]
2870 set yf [expr {$ytop * 1.0 / $ymax}]
2872 allcanvs yview moveto $yf
2876 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
2877 selectline [rowofcommit $mainheadid] 1
2878 } elseif {!$viewcomplete($n)} {
2880 set pending_select $selid
2882 set pending_select $mainheadid
2885 set row [first_real_row]
2886 if {$row < $numcommits} {
2890 if {!$viewcomplete($n)} {
2891 if {$numcommits == 0} {
2892 show_status [mc "Reading commits..."]
2894 } elseif {$numcommits == 0} {
2895 show_status [mc "No commits selected"]
2899 # Stuff relating to the highlighting facility
2901 proc ishighlighted {id} {
2902 global vhighlights fhighlights nhighlights rhighlights
2904 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
2905 return $nhighlights($id)
2907 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
2908 return $vhighlights($id)
2910 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
2911 return $fhighlights($id)
2913 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
2914 return $rhighlights($id)
2919 proc bolden {row font} {
2920 global canv linehtag selectedline boldrows
2922 lappend boldrows $row
2923 $canv itemconf $linehtag($row) -font $font
2924 if {[info exists selectedline] && $row == $selectedline} {
2926 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2927 -outline {{}} -tags secsel \
2928 -fill [$canv cget -selectbackground]]
2933 proc bolden_name {row font} {
2934 global canv2 linentag selectedline boldnamerows
2936 lappend boldnamerows $row
2937 $canv2 itemconf $linentag($row) -font $font
2938 if {[info exists selectedline] && $row == $selectedline} {
2939 $canv2 delete secsel
2940 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2941 -outline {{}} -tags secsel \
2942 -fill [$canv2 cget -selectbackground]]
2951 foreach row $boldrows {
2952 if {![ishighlighted [commitonrow $row]]} {
2953 bolden $row mainfont
2955 lappend stillbold $row
2958 set boldrows $stillbold
2961 proc addvhighlight {n} {
2962 global hlview viewcomplete curview vhl_done commitidx
2964 if {[info exists hlview]} {
2968 if {$n != $curview && ![info exists viewcomplete($n)]} {
2971 set vhl_done $commitidx($hlview)
2972 if {$vhl_done > 0} {
2977 proc delvhighlight {} {
2978 global hlview vhighlights
2980 if {![info exists hlview]} return
2982 catch {unset vhighlights}
2986 proc vhighlightmore {} {
2987 global hlview vhl_done commitidx vhighlights curview
2989 set max $commitidx($hlview)
2990 set vr [visiblerows]
2991 set r0 [lindex $vr 0]
2992 set r1 [lindex $vr 1]
2993 for {set i $vhl_done} {$i < $max} {incr i} {
2994 set id [commitonrow $i $hlview]
2995 if {[commitinview $id $curview]} {
2996 set row [rowofcommit $id]
2997 if {$r0 <= $row && $row <= $r1} {
2998 if {![highlighted $row]} {
2999 bolden $row mainfontbold
3001 set vhighlights($id) 1
3008 proc askvhighlight {row id} {
3009 global hlview vhighlights iddrawn
3011 if {[commitinview $id $hlview]} {
3012 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3013 bolden $row mainfontbold
3015 set vhighlights($id) 1
3017 set vhighlights($id) 0
3021 proc hfiles_change {} {
3022 global highlight_files filehighlight fhighlights fh_serial
3023 global highlight_paths gdttype
3025 if {[info exists filehighlight]} {
3026 # delete previous highlights
3027 catch {close $filehighlight}
3029 catch {unset fhighlights}
3031 unhighlight_filelist
3033 set highlight_paths {}
3034 after cancel do_file_hl $fh_serial
3036 if {$highlight_files ne {}} {
3037 after 300 do_file_hl $fh_serial
3041 proc gdttype_change {name ix op} {
3042 global gdttype highlight_files findstring findpattern
3045 if {$findstring ne {}} {
3046 if {$gdttype eq [mc "containing:"]} {
3047 if {$highlight_files ne {}} {
3048 set highlight_files {}
3053 if {$findpattern ne {}} {
3057 set highlight_files $findstring
3062 # enable/disable findtype/findloc menus too
3065 proc find_change {name ix op} {
3066 global gdttype findstring highlight_files
3069 if {$gdttype eq [mc "containing:"]} {
3072 if {$highlight_files ne $findstring} {
3073 set highlight_files $findstring
3080 proc findcom_change args {
3081 global nhighlights boldnamerows
3082 global findpattern findtype findstring gdttype
3085 # delete previous highlights, if any
3086 foreach row $boldnamerows {
3087 bolden_name $row mainfont
3090 catch {unset nhighlights}
3093 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3095 } elseif {$findtype eq [mc "Regexp"]} {
3096 set findpattern $findstring
3098 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3100 set findpattern "*$e*"
3104 proc makepatterns {l} {
3107 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3108 if {[string index $ee end] eq "/"} {
3118 proc do_file_hl {serial} {
3119 global highlight_files filehighlight highlight_paths gdttype fhl_list
3121 if {$gdttype eq [mc "touching paths:"]} {
3122 if {[catch {set paths [shellsplit $highlight_files]}]} return
3123 set highlight_paths [makepatterns $paths]
3125 set gdtargs [concat -- $paths]
3126 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3127 set gdtargs [list "-S$highlight_files"]
3129 # must be "containing:", i.e. we're searching commit info
3132 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3133 set filehighlight [open $cmd r+]
3134 fconfigure $filehighlight -blocking 0
3135 filerun $filehighlight readfhighlight
3141 proc flushhighlights {} {
3142 global filehighlight fhl_list
3144 if {[info exists filehighlight]} {
3146 puts $filehighlight ""
3147 flush $filehighlight
3151 proc askfilehighlight {row id} {
3152 global filehighlight fhighlights fhl_list
3154 lappend fhl_list $id
3155 set fhighlights($id) -1
3156 puts $filehighlight $id
3159 proc readfhighlight {} {
3160 global filehighlight fhighlights curview iddrawn
3161 global fhl_list find_dirn
3163 if {![info exists filehighlight]} {
3167 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3168 set line [string trim $line]
3169 set i [lsearch -exact $fhl_list $line]
3170 if {$i < 0} continue
3171 for {set j 0} {$j < $i} {incr j} {
3172 set id [lindex $fhl_list $j]
3173 set fhighlights($id) 0
3175 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3176 if {$line eq {}} continue
3177 if {![commitinview $line $curview]} continue
3178 set row [rowofcommit $line]
3179 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3180 bolden $row mainfontbold
3182 set fhighlights($line) 1
3184 if {[eof $filehighlight]} {
3186 puts "oops, git diff-tree died"
3187 catch {close $filehighlight}
3191 if {[info exists find_dirn]} {
3197 proc doesmatch {f} {
3198 global findtype findpattern
3200 if {$findtype eq [mc "Regexp"]} {
3201 return [regexp $findpattern $f]
3202 } elseif {$findtype eq [mc "IgnCase"]} {
3203 return [string match -nocase $findpattern $f]
3205 return [string match $findpattern $f]
3209 proc askfindhighlight {row id} {
3210 global nhighlights commitinfo iddrawn
3212 global markingmatches
3214 if {![info exists commitinfo($id)]} {
3217 set info $commitinfo($id)
3219 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3220 foreach f $info ty $fldtypes {
3221 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3223 if {$ty eq [mc "Author"]} {
3230 if {$isbold && [info exists iddrawn($id)]} {
3231 if {![ishighlighted $id]} {
3232 bolden $row mainfontbold
3234 bolden_name $row mainfontbold
3237 if {$markingmatches} {
3238 markrowmatches $row $id
3241 set nhighlights($id) $isbold
3244 proc markrowmatches {row id} {
3245 global canv canv2 linehtag linentag commitinfo findloc
3247 set headline [lindex $commitinfo($id) 0]
3248 set author [lindex $commitinfo($id) 1]
3249 $canv delete match$row
3250 $canv2 delete match$row
3251 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3252 set m [findmatches $headline]
3254 markmatches $canv $row $headline $linehtag($row) $m \
3255 [$canv itemcget $linehtag($row) -font] $row
3258 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3259 set m [findmatches $author]
3261 markmatches $canv2 $row $author $linentag($row) $m \
3262 [$canv2 itemcget $linentag($row) -font] $row
3267 proc vrel_change {name ix op} {
3268 global highlight_related
3271 if {$highlight_related ne [mc "None"]} {
3276 # prepare for testing whether commits are descendents or ancestors of a
3277 proc rhighlight_sel {a} {
3278 global descendent desc_todo ancestor anc_todo
3279 global highlight_related
3281 catch {unset descendent}
3282 set desc_todo [list $a]
3283 catch {unset ancestor}
3284 set anc_todo [list $a]
3285 if {$highlight_related ne [mc "None"]} {
3291 proc rhighlight_none {} {
3294 catch {unset rhighlights}
3298 proc is_descendent {a} {
3299 global curview children descendent desc_todo
3302 set la [rowofcommit $a]
3306 for {set i 0} {$i < [llength $todo]} {incr i} {
3307 set do [lindex $todo $i]
3308 if {[rowofcommit $do] < $la} {
3309 lappend leftover $do
3312 foreach nk $children($v,$do) {
3313 if {![info exists descendent($nk)]} {
3314 set descendent($nk) 1
3322 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3326 set descendent($a) 0
3327 set desc_todo $leftover
3330 proc is_ancestor {a} {
3331 global curview parents ancestor anc_todo
3334 set la [rowofcommit $a]
3338 for {set i 0} {$i < [llength $todo]} {incr i} {
3339 set do [lindex $todo $i]
3340 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3341 lappend leftover $do
3344 foreach np $parents($v,$do) {
3345 if {![info exists ancestor($np)]} {
3354 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3359 set anc_todo $leftover
3362 proc askrelhighlight {row id} {
3363 global descendent highlight_related iddrawn rhighlights
3364 global selectedline ancestor
3366 if {![info exists selectedline]} return
3368 if {$highlight_related eq [mc "Descendent"] ||
3369 $highlight_related eq [mc "Not descendent"]} {
3370 if {![info exists descendent($id)]} {
3373 if {$descendent($id) == ($highlight_related eq [mc "Descendent"])} {
3376 } elseif {$highlight_related eq [mc "Ancestor"] ||
3377 $highlight_related eq [mc "Not ancestor"]} {
3378 if {![info exists ancestor($id)]} {
3381 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3385 if {[info exists iddrawn($id)]} {
3386 if {$isbold && ![ishighlighted $id]} {
3387 bolden $row mainfontbold
3390 set rhighlights($id) $isbold
3393 # Graph layout functions
3395 proc shortids {ids} {
3398 if {[llength $id] > 1} {
3399 lappend res [shortids $id]
3400 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3401 lappend res [string range $id 0 7]
3412 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3413 if {($n & $mask) != 0} {
3414 set ret [concat $ret $o]
3416 set o [concat $o $o]
3421 proc ordertoken {id} {
3422 global ordertok curview varcid varcstart varctok curview parents children
3423 global nullid nullid2
3425 if {[info exists ordertok($id)]} {
3426 return $ordertok($id)
3431 if {[info exists varcid($curview,$id)]} {
3432 set a $varcid($curview,$id)
3433 set p [lindex $varcstart($curview) $a]
3435 set p [lindex $children($curview,$id) 0]
3437 if {[info exists ordertok($p)]} {
3438 set tok $ordertok($p)
3441 set id [first_real_child $curview,$p]
3444 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3447 if {[llength $parents($curview,$id)] == 1} {
3448 lappend todo [list $p {}]
3450 set j [lsearch -exact $parents($curview,$id) $p]
3452 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3454 lappend todo [list $p [strrep $j]]
3457 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3458 set p [lindex $todo $i 0]
3459 append tok [lindex $todo $i 1]
3460 set ordertok($p) $tok
3462 set ordertok($origid) $tok
3466 # Work out where id should go in idlist so that order-token
3467 # values increase from left to right
3468 proc idcol {idlist id {i 0}} {
3469 set t [ordertoken $id]
3473 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3474 if {$i > [llength $idlist]} {
3475 set i [llength $idlist]
3477 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3480 if {$t > [ordertoken [lindex $idlist $i]]} {
3481 while {[incr i] < [llength $idlist] &&
3482 $t >= [ordertoken [lindex $idlist $i]]} {}
3488 proc initlayout {} {
3489 global rowidlist rowisopt rowfinal displayorder parentlist
3490 global numcommits canvxmax canv
3492 global colormap rowtextx
3501 set canvxmax [$canv cget -width]
3502 catch {unset colormap}
3503 catch {unset rowtextx}
3506 proc setcanvscroll {} {
3507 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3509 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3510 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3511 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3512 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3515 proc visiblerows {} {
3516 global canv numcommits linespc
3518 set ymax [lindex [$canv cget -scrollregion] 3]
3519 if {$ymax eq {} || $ymax == 0} return
3521 set y0 [expr {int([lindex $f 0] * $ymax)}]
3522 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3526 set y1 [expr {int([lindex $f 1] * $ymax)}]
3527 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3528 if {$r1 >= $numcommits} {
3529 set r1 [expr {$numcommits - 1}]
3531 return [list $r0 $r1]
3534 proc layoutmore {} {
3535 global commitidx viewcomplete curview
3536 global numcommits pending_select selectedline curview
3537 global lastscrollset commitinterest
3539 set canshow $commitidx($curview)
3540 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3541 if {$numcommits == 0} {
3545 set prev $numcommits
3546 set numcommits $canshow
3547 set t [clock clicks -milliseconds]
3548 if {$prev < 100 || $viewcomplete($curview) || $t - $lastscrollset > 500} {
3549 set lastscrollset $t
3552 set rows [visiblerows]
3553 set r1 [lindex $rows 1]
3554 if {$r1 >= $canshow} {
3555 set r1 [expr {$canshow - 1}]
3560 if {[info exists pending_select] &&
3561 [commitinview $pending_select $curview]} {
3562 selectline [rowofcommit $pending_select] 1
3566 proc doshowlocalchanges {} {
3567 global curview mainheadid
3569 if {[commitinview $mainheadid $curview]} {
3572 lappend commitinterest($mainheadid) {dodiffindex}
3576 proc dohidelocalchanges {} {
3577 global nullid nullid2 lserial curview
3579 if {[commitinview $nullid $curview]} {
3580 removefakerow $nullid
3582 if {[commitinview $nullid2 $curview]} {
3583 removefakerow $nullid2
3588 # spawn off a process to do git diff-index --cached HEAD
3589 proc dodiffindex {} {
3590 global lserial showlocalchanges
3592 if {!$showlocalchanges} return
3594 set fd [open "|git diff-index --cached HEAD" r]
3595 fconfigure $fd -blocking 0
3596 filerun $fd [list readdiffindex $fd $lserial]
3599 proc readdiffindex {fd serial} {
3600 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3603 if {[gets $fd line] < 0} {
3609 # we only need to see one line and we don't really care what it says...
3612 if {$serial != $lserial} {
3616 # now see if there are any local changes not checked in to the index
3617 set fd [open "|git diff-files" r]
3618 fconfigure $fd -blocking 0
3619 filerun $fd [list readdifffiles $fd $serial]
3621 if {$isdiff && ![commitinview $nullid2 $curview]} {
3622 # add the line for the changes in the index to the graph
3623 set hl [mc "Local changes checked in to index but not committed"]
3624 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3625 set commitdata($nullid2) "\n $hl\n"
3626 if {[commitinview $nullid $curview]} {
3627 removefakerow $nullid
3629 insertfakerow $nullid2 $mainheadid
3630 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
3631 removefakerow $nullid2
3636 proc readdifffiles {fd serial} {
3637 global mainheadid nullid nullid2 curview
3638 global commitinfo commitdata lserial
3641 if {[gets $fd line] < 0} {
3647 # we only need to see one line and we don't really care what it says...
3650 if {$serial != $lserial} {
3654 if {$isdiff && ![commitinview $nullid $curview]} {
3655 # add the line for the local diff to the graph
3656 set hl [mc "Local uncommitted changes, not checked in to index"]
3657 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3658 set commitdata($nullid) "\n $hl\n"
3659 if {[commitinview $nullid2 $curview]} {
3664 insertfakerow $nullid $p
3665 } elseif {!$isdiff && [commitinview $nullid $curview]} {
3666 removefakerow $nullid
3671 proc nextuse {id row} {
3672 global curview children
3674 if {[info exists children($curview,$id)]} {
3675 foreach kid $children($curview,$id) {
3676 if {![commitinview $kid $curview]} {
3679 if {[rowofcommit $kid] > $row} {
3680 return [rowofcommit $kid]
3684 if {[commitinview $id $curview]} {
3685 return [rowofcommit $id]
3690 proc prevuse {id row} {
3691 global curview children
3694 if {[info exists children($curview,$id)]} {
3695 foreach kid $children($curview,$id) {
3696 if {![commitinview $kid $curview]} break
3697 if {[rowofcommit $kid] < $row} {
3698 set ret [rowofcommit $kid]
3705 proc make_idlist {row} {
3706 global displayorder parentlist uparrowlen downarrowlen mingaplen
3707 global commitidx curview children
3709 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3713 set ra [expr {$row - $downarrowlen}]
3717 set rb [expr {$row + $uparrowlen}]
3718 if {$rb > $commitidx($curview)} {
3719 set rb $commitidx($curview)
3721 make_disporder $r [expr {$rb + 1}]
3723 for {} {$r < $ra} {incr r} {
3724 set nextid [lindex $displayorder [expr {$r + 1}]]
3725 foreach p [lindex $parentlist $r] {
3726 if {$p eq $nextid} continue
3727 set rn [nextuse $p $r]
3729 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3730 lappend ids [list [ordertoken $p] $p]
3734 for {} {$r < $row} {incr r} {
3735 set nextid [lindex $displayorder [expr {$r + 1}]]
3736 foreach p [lindex $parentlist $r] {
3737 if {$p eq $nextid} continue
3738 set rn [nextuse $p $r]
3739 if {$rn < 0 || $rn >= $row} {
3740 lappend ids [list [ordertoken $p] $p]
3744 set id [lindex $displayorder $row]
3745 lappend ids [list [ordertoken $id] $id]
3747 foreach p [lindex $parentlist $r] {
3748 set firstkid [lindex $children($curview,$p) 0]
3749 if {[rowofcommit $firstkid] < $row} {
3750 lappend ids [list [ordertoken $p] $p]
3754 set id [lindex $displayorder $r]
3756 set firstkid [lindex $children($curview,$id) 0]
3757 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3758 lappend ids [list [ordertoken $id] $id]
3763 foreach idx [lsort -unique $ids] {
3764 lappend idlist [lindex $idx 1]
3769 proc rowsequal {a b} {
3770 while {[set i [lsearch -exact $a {}]] >= 0} {
3771 set a [lreplace $a $i $i]
3773 while {[set i [lsearch -exact $b {}]] >= 0} {
3774 set b [lreplace $b $i $i]
3776 return [expr {$a eq $b}]
3779 proc makeupline {id row rend col} {
3780 global rowidlist uparrowlen downarrowlen mingaplen
3782 for {set r $rend} {1} {set r $rstart} {
3783 set rstart [prevuse $id $r]
3784 if {$rstart < 0} return
3785 if {$rstart < $row} break
3787 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3788 set rstart [expr {$rend - $uparrowlen - 1}]
3790 for {set r $rstart} {[incr r] <= $row} {} {
3791 set idlist [lindex $rowidlist $r]
3792 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3793 set col [idcol $idlist $id $col]
3794 lset rowidlist $r [linsert $idlist $col $id]
3800 proc layoutrows {row endrow} {
3801 global rowidlist rowisopt rowfinal displayorder
3802 global uparrowlen downarrowlen maxwidth mingaplen
3803 global children parentlist
3804 global commitidx viewcomplete curview
3806 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3809 set rm1 [expr {$row - 1}]
3810 foreach id [lindex $rowidlist $rm1] {
3815 set final [lindex $rowfinal $rm1]
3817 for {} {$row < $endrow} {incr row} {
3818 set rm1 [expr {$row - 1}]
3819 if {$rm1 < 0 || $idlist eq {}} {
3820 set idlist [make_idlist $row]
3823 set id [lindex $displayorder $rm1]
3824 set col [lsearch -exact $idlist $id]
3825 set idlist [lreplace $idlist $col $col]
3826 foreach p [lindex $parentlist $rm1] {
3827 if {[lsearch -exact $idlist $p] < 0} {
3828 set col [idcol $idlist $p $col]
3829 set idlist [linsert $idlist $col $p]
3830 # if not the first child, we have to insert a line going up
3831 if {$id ne [lindex $children($curview,$p) 0]} {
3832 makeupline $p $rm1 $row $col
3836 set id [lindex $displayorder $row]
3837 if {$row > $downarrowlen} {
3838 set termrow [expr {$row - $downarrowlen - 1}]
3839 foreach p [lindex $parentlist $termrow] {
3840 set i [lsearch -exact $idlist $p]
3841 if {$i < 0} continue
3842 set nr [nextuse $p $termrow]
3843 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3844 set idlist [lreplace $idlist $i $i]
3848 set col [lsearch -exact $idlist $id]
3850 set col [idcol $idlist $id]
3851 set idlist [linsert $idlist $col $id]
3852 if {$children($curview,$id) ne {}} {
3853 makeupline $id $rm1 $row $col
3856 set r [expr {$row + $uparrowlen - 1}]
3857 if {$r < $commitidx($curview)} {
3859 foreach p [lindex $parentlist $r] {
3860 if {[lsearch -exact $idlist $p] >= 0} continue
3861 set fk [lindex $children($curview,$p) 0]
3862 if {[rowofcommit $fk] < $row} {
3863 set x [idcol $idlist $p $x]
3864 set idlist [linsert $idlist $x $p]
3867 if {[incr r] < $commitidx($curview)} {
3868 set p [lindex $displayorder $r]
3869 if {[lsearch -exact $idlist $p] < 0} {
3870 set fk [lindex $children($curview,$p) 0]
3871 if {$fk ne {} && [rowofcommit $fk] < $row} {
3872 set x [idcol $idlist $p $x]
3873 set idlist [linsert $idlist $x $p]
3879 if {$final && !$viewcomplete($curview) &&
3880 $row + $uparrowlen + $mingaplen + $downarrowlen
3881 >= $commitidx($curview)} {
3884 set l [llength $rowidlist]
3886 lappend rowidlist $idlist
3888 lappend rowfinal $final
3889 } elseif {$row < $l} {
3890 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3891 lset rowidlist $row $idlist
3894 lset rowfinal $row $final
3896 set pad [ntimes [expr {$row - $l}] {}]
3897 set rowidlist [concat $rowidlist $pad]
3898 lappend rowidlist $idlist
3899 set rowfinal [concat $rowfinal $pad]
3900 lappend rowfinal $final
3901 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3907 proc changedrow {row} {
3908 global displayorder iddrawn rowisopt need_redisplay
3910 set l [llength $rowisopt]
3912 lset rowisopt $row 0
3913 if {$row + 1 < $l} {
3914 lset rowisopt [expr {$row + 1}] 0
3915 if {$row + 2 < $l} {
3916 lset rowisopt [expr {$row + 2}] 0
3920 set id [lindex $displayorder $row]
3921 if {[info exists iddrawn($id)]} {
3922 set need_redisplay 1
3926 proc insert_pad {row col npad} {
3929 set pad [ntimes $npad {}]
3930 set idlist [lindex $rowidlist $row]
3931 set bef [lrange $idlist 0 [expr {$col - 1}]]
3932 set aft [lrange $idlist $col end]
3933 set i [lsearch -exact $aft {}]
3935 set aft [lreplace $aft $i $i]
3937 lset rowidlist $row [concat $bef $pad $aft]
3941 proc optimize_rows {row col endrow} {
3942 global rowidlist rowisopt displayorder curview children
3947 for {} {$row < $endrow} {incr row; set col 0} {
3948 if {[lindex $rowisopt $row]} continue
3950 set y0 [expr {$row - 1}]
3951 set ym [expr {$row - 2}]
3952 set idlist [lindex $rowidlist $row]
3953 set previdlist [lindex $rowidlist $y0]
3954 if {$idlist eq {} || $previdlist eq {}} continue
3956 set pprevidlist [lindex $rowidlist $ym]
3957 if {$pprevidlist eq {}} continue
3963 for {} {$col < [llength $idlist]} {incr col} {
3964 set id [lindex $idlist $col]
3965 if {[lindex $previdlist $col] eq $id} continue
3970 set x0 [lsearch -exact $previdlist $id]
3971 if {$x0 < 0} continue
3972 set z [expr {$x0 - $col}]
3976 set xm [lsearch -exact $pprevidlist $id]
3978 set z0 [expr {$xm - $x0}]
3982 # if row y0 is the first child of $id then it's not an arrow
3983 if {[lindex $children($curview,$id) 0] ne
3984 [lindex $displayorder $y0]} {
3988 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3989 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3992 # Looking at lines from this row to the previous row,
3993 # make them go straight up if they end in an arrow on
3994 # the previous row; otherwise make them go straight up
3996 if {$z < -1 || ($z < 0 && $isarrow)} {
3997 # Line currently goes left too much;
3998 # insert pads in the previous row, then optimize it
3999 set npad [expr {-1 - $z + $isarrow}]
4000 insert_pad $y0 $x0 $npad
4002 optimize_rows $y0 $x0 $row
4004 set previdlist [lindex $rowidlist $y0]
4005 set x0 [lsearch -exact $previdlist $id]
4006 set z [expr {$x0 - $col}]
4008 set pprevidlist [lindex $rowidlist $ym]
4009 set xm [lsearch -exact $pprevidlist $id]
4010 set z0 [expr {$xm - $x0}]
4012 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4013 # Line currently goes right too much;
4014 # insert pads in this line
4015 set npad [expr {$z - 1 + $isarrow}]
4016 insert_pad $row $col $npad
4017 set idlist [lindex $rowidlist $row]
4019 set z [expr {$x0 - $col}]
4022 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4023 # this line links to its first child on row $row-2
4024 set id [lindex $displayorder $ym]
4025 set xc [lsearch -exact $pprevidlist $id]
4027 set z0 [expr {$xc - $x0}]
4030 # avoid lines jigging left then immediately right
4031 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4032 insert_pad $y0 $x0 1
4034 optimize_rows $y0 $x0 $row
4035 set previdlist [lindex $rowidlist $y0]
4039 # Find the first column that doesn't have a line going right
4040 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4041 set id [lindex $idlist $col]
4042 if {$id eq {}} break
4043 set x0 [lsearch -exact $previdlist $id]
4045 # check if this is the link to the first child
4046 set kid [lindex $displayorder $y0]
4047 if {[lindex $children($curview,$id) 0] eq $kid} {
4048 # it is, work out offset to child
4049 set x0 [lsearch -exact $previdlist $kid]
4052 if {$x0 <= $col} break
4054 # Insert a pad at that column as long as it has a line and
4055 # isn't the last column
4056 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4057 set idlist [linsert $idlist $col {}]
4058 lset rowidlist $row $idlist
4066 global canvx0 linespc
4067 return [expr {$canvx0 + $col * $linespc}]
4071 global canvy0 linespc
4072 return [expr {$canvy0 + $row * $linespc}]
4075 proc linewidth {id} {
4076 global thickerline lthickness
4079 if {[info exists thickerline] && $id eq $thickerline} {
4080 set wid [expr {2 * $lthickness}]
4085 proc rowranges {id} {
4086 global curview children uparrowlen downarrowlen
4089 set kids $children($curview,$id)
4095 foreach child $kids {
4096 if {![commitinview $child $curview]} break
4097 set row [rowofcommit $child]
4098 if {![info exists prev]} {
4099 lappend ret [expr {$row + 1}]
4101 if {$row <= $prevrow} {
4102 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4104 # see if the line extends the whole way from prevrow to row
4105 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4106 [lsearch -exact [lindex $rowidlist \
4107 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4108 # it doesn't, see where it ends
4109 set r [expr {$prevrow + $downarrowlen}]
4110 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4111 while {[incr r -1] > $prevrow &&
4112 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4114 while {[incr r] <= $row &&
4115 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4119 # see where it starts up again
4120 set r [expr {$row - $uparrowlen}]
4121 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4122 while {[incr r] < $row &&
4123 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4125 while {[incr r -1] >= $prevrow &&
4126 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4132 if {$child eq $id} {
4141 proc drawlineseg {id row endrow arrowlow} {
4142 global rowidlist displayorder iddrawn linesegs
4143 global canv colormap linespc curview maxlinelen parentlist
4145 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4146 set le [expr {$row + 1}]
4149 set c [lsearch -exact [lindex $rowidlist $le] $id]
4155 set x [lindex $displayorder $le]
4160 if {[info exists iddrawn($x)] || $le == $endrow} {
4161 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4177 if {[info exists linesegs($id)]} {
4178 set lines $linesegs($id)
4180 set r0 [lindex $li 0]
4182 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4192 set li [lindex $lines [expr {$i-1}]]
4193 set r1 [lindex $li 1]
4194 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4199 set x [lindex $cols [expr {$le - $row}]]
4200 set xp [lindex $cols [expr {$le - 1 - $row}]]
4201 set dir [expr {$xp - $x}]
4203 set ith [lindex $lines $i 2]
4204 set coords [$canv coords $ith]
4205 set ah [$canv itemcget $ith -arrow]
4206 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4207 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4208 if {$x2 ne {} && $x - $x2 == $dir} {
4209 set coords [lrange $coords 0 end-2]
4212 set coords [list [xc $le $x] [yc $le]]
4215 set itl [lindex $lines [expr {$i-1}] 2]
4216 set al [$canv itemcget $itl -arrow]
4217 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4218 } elseif {$arrowlow} {
4219 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4220 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4224 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4225 for {set y $le} {[incr y -1] > $row} {} {
4227 set xp [lindex $cols [expr {$y - 1 - $row}]]
4228 set ndir [expr {$xp - $x}]
4229 if {$dir != $ndir || $xp < 0} {
4230 lappend coords [xc $y $x] [yc $y]
4236 # join parent line to first child
4237 set ch [lindex $displayorder $row]
4238 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4240 puts "oops: drawlineseg: child $ch not on row $row"
4241 } elseif {$xc != $x} {
4242 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4243 set d [expr {int(0.5 * $linespc)}]
4246 set x2 [expr {$x1 - $d}]
4248 set x2 [expr {$x1 + $d}]
4251 set y1 [expr {$y2 + $d}]
4252 lappend coords $x1 $y1 $x2 $y2
4253 } elseif {$xc < $x - 1} {
4254 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4255 } elseif {$xc > $x + 1} {
4256 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4260 lappend coords [xc $row $x] [yc $row]
4262 set xn [xc $row $xp]
4264 lappend coords $xn $yn
4268 set t [$canv create line $coords -width [linewidth $id] \
4269 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4272 set lines [linsert $lines $i [list $row $le $t]]
4274 $canv coords $ith $coords
4275 if {$arrow ne $ah} {
4276 $canv itemconf $ith -arrow $arrow
4278 lset lines $i 0 $row
4281 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4282 set ndir [expr {$xo - $xp}]
4283 set clow [$canv coords $itl]
4284 if {$dir == $ndir} {
4285 set clow [lrange $clow 2 end]
4287 set coords [concat $coords $clow]
4289 lset lines [expr {$i-1}] 1 $le
4291 # coalesce two pieces
4293 set b [lindex $lines [expr {$i-1}] 0]
4294 set e [lindex $lines $i 1]
4295 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4297 $canv coords $itl $coords
4298 if {$arrow ne $al} {
4299 $canv itemconf $itl -arrow $arrow
4303 set linesegs($id) $lines
4307 proc drawparentlinks {id row} {
4308 global rowidlist canv colormap curview parentlist
4309 global idpos linespc
4311 set rowids [lindex $rowidlist $row]
4312 set col [lsearch -exact $rowids $id]
4313 if {$col < 0} return
4314 set olds [lindex $parentlist $row]
4315 set row2 [expr {$row + 1}]
4316 set x [xc $row $col]
4319 set d [expr {int(0.5 * $linespc)}]
4320 set ymid [expr {$y + $d}]
4321 set ids [lindex $rowidlist $row2]
4322 # rmx = right-most X coord used
4325 set i [lsearch -exact $ids $p]
4327 puts "oops, parent $p of $id not in list"
4330 set x2 [xc $row2 $i]
4334 set j [lsearch -exact $rowids $p]
4336 # drawlineseg will do this one for us
4340 # should handle duplicated parents here...
4341 set coords [list $x $y]
4343 # if attaching to a vertical segment, draw a smaller
4344 # slant for visual distinctness
4347 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4349 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4351 } elseif {$i < $col && $i < $j} {
4352 # segment slants towards us already
4353 lappend coords [xc $row $j] $y
4355 if {$i < $col - 1} {
4356 lappend coords [expr {$x2 + $linespc}] $y
4357 } elseif {$i > $col + 1} {
4358 lappend coords [expr {$x2 - $linespc}] $y
4360 lappend coords $x2 $y2
4363 lappend coords $x2 $y2
4365 set t [$canv create line $coords -width [linewidth $p] \
4366 -fill $colormap($p) -tags lines.$p]
4370 if {$rmx > [lindex $idpos($id) 1]} {
4371 lset idpos($id) 1 $rmx
4376 proc drawlines {id} {
4379 $canv itemconf lines.$id -width [linewidth $id]
4382 proc drawcmittext {id row col} {
4383 global linespc canv canv2 canv3 fgcolor curview
4384 global cmitlisted commitinfo rowidlist parentlist
4385 global rowtextx idpos idtags idheads idotherrefs
4386 global linehtag linentag linedtag selectedline
4387 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4389 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4390 set listed $cmitlisted($curview,$id)
4391 if {$id eq $nullid} {
4393 } elseif {$id eq $nullid2} {
4396 set ofill [expr {$listed != 0? "blue": "white"}]
4398 set x [xc $row $col]
4400 set orad [expr {$linespc / 3}]
4402 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4403 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4404 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4405 } elseif {$listed == 2} {
4406 # triangle pointing left for left-side commits
4407 set t [$canv create polygon \
4408 [expr {$x - $orad}] $y \
4409 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4410 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4411 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4413 # triangle pointing right for right-side commits
4414 set t [$canv create polygon \
4415 [expr {$x + $orad - 1}] $y \
4416 [expr {$x - $orad}] [expr {$y - $orad}] \
4417 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4418 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4421 $canv bind $t <1> {selcanvline {} %x %y}
4422 set rmx [llength [lindex $rowidlist $row]]
4423 set olds [lindex $parentlist $row]
4425 set nextids [lindex $rowidlist [expr {$row + 1}]]
4427 set i [lsearch -exact $nextids $p]
4433 set xt [xc $row $rmx]
4434 set rowtextx($row) $xt
4435 set idpos($id) [list $x $xt $y]
4436 if {[info exists idtags($id)] || [info exists idheads($id)]
4437 || [info exists idotherrefs($id)]} {
4438 set xt [drawtags $id $x $xt $y]
4440 set headline [lindex $commitinfo($id) 0]
4441 set name [lindex $commitinfo($id) 1]
4442 set date [lindex $commitinfo($id) 2]
4443 set date [formatdate $date]
4446 set isbold [ishighlighted $id]
4448 lappend boldrows $row
4449 set font mainfontbold
4451 lappend boldnamerows $row
4452 set nfont mainfontbold
4455 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4456 -text $headline -font $font -tags text]
4457 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4458 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4459 -text $name -font $nfont -tags text]
4460 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4461 -text $date -font mainfont -tags text]
4462 if {[info exists selectedline] && $selectedline == $row} {
4465 set xr [expr {$xt + [font measure $font $headline]}]
4466 if {$xr > $canvxmax} {
4472 proc drawcmitrow {row} {
4473 global displayorder rowidlist nrows_drawn
4474 global iddrawn markingmatches
4475 global commitinfo numcommits
4476 global filehighlight fhighlights findpattern nhighlights
4477 global hlview vhighlights
4478 global highlight_related rhighlights
4480 if {$row >= $numcommits} return
4482 set id [lindex $displayorder $row]
4483 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4484 askvhighlight $row $id
4486 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4487 askfilehighlight $row $id
4489 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4490 askfindhighlight $row $id
4492 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4493 askrelhighlight $row $id
4495 if {![info exists iddrawn($id)]} {
4496 set col [lsearch -exact [lindex $rowidlist $row] $id]
4498 puts "oops, row $row id $id not in list"
4501 if {![info exists commitinfo($id)]} {
4505 drawcmittext $id $row $col
4509 if {$markingmatches} {
4510 markrowmatches $row $id
4514 proc drawcommits {row {endrow {}}} {
4515 global numcommits iddrawn displayorder curview need_redisplay
4516 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4521 if {$endrow eq {}} {
4524 if {$endrow >= $numcommits} {
4525 set endrow [expr {$numcommits - 1}]
4528 set rl1 [expr {$row - $downarrowlen - 3}]
4532 set ro1 [expr {$row - 3}]
4536 set r2 [expr {$endrow + $uparrowlen + 3}]
4537 if {$r2 > $numcommits} {
4540 for {set r $rl1} {$r < $r2} {incr r} {
4541 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4545 set rl1 [expr {$r + 1}]
4551 optimize_rows $ro1 0 $r2
4552 if {$need_redisplay || $nrows_drawn > 2000} {
4557 # make the lines join to already-drawn rows either side
4558 set r [expr {$row - 1}]
4559 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4562 set er [expr {$endrow + 1}]
4563 if {$er >= $numcommits ||
4564 ![info exists iddrawn([lindex $displayorder $er])]} {
4567 for {} {$r <= $er} {incr r} {
4568 set id [lindex $displayorder $r]
4569 set wasdrawn [info exists iddrawn($id)]
4571 if {$r == $er} break
4572 set nextid [lindex $displayorder [expr {$r + 1}]]
4573 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4574 drawparentlinks $id $r
4576 set rowids [lindex $rowidlist $r]
4577 foreach lid $rowids {
4578 if {$lid eq {}} continue
4579 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4581 # see if this is the first child of any of its parents
4582 foreach p [lindex $parentlist $r] {
4583 if {[lsearch -exact $rowids $p] < 0} {
4584 # make this line extend up to the child
4585 set lineend($p) [drawlineseg $p $r $er 0]
4589 set lineend($lid) [drawlineseg $lid $r $er 1]
4595 proc undolayout {row} {
4596 global uparrowlen mingaplen downarrowlen
4597 global rowidlist rowisopt rowfinal need_redisplay
4599 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4603 if {[llength $rowidlist] > $r} {
4605 set rowidlist [lrange $rowidlist 0 $r]
4606 set rowfinal [lrange $rowfinal 0 $r]
4607 set rowisopt [lrange $rowisopt 0 $r]
4608 set need_redisplay 1
4613 proc drawvisible {} {
4614 global canv linespc curview vrowmod selectedline targetrow targetid
4615 global need_redisplay cscroll numcommits
4617 set fs [$canv yview]
4618 set ymax [lindex [$canv cget -scrollregion] 3]
4619 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
4620 set f0 [lindex $fs 0]
4621 set f1 [lindex $fs 1]
4622 set y0 [expr {int($f0 * $ymax)}]
4623 set y1 [expr {int($f1 * $ymax)}]
4625 if {[info exists targetid]} {
4626 if {[commitinview $targetid $curview]} {
4627 set r [rowofcommit $targetid]
4628 if {$r != $targetrow} {
4629 # Fix up the scrollregion and change the scrolling position
4630 # now that our target row has moved.
4631 set diff [expr {($r - $targetrow) * $linespc}]
4634 set ymax [lindex [$canv cget -scrollregion] 3]
4637 set f0 [expr {$y0 / $ymax}]
4638 set f1 [expr {$y1 / $ymax}]
4639 allcanvs yview moveto $f0
4640 $cscroll set $f0 $f1
4641 set need_redisplay 1
4648 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4649 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4650 if {$endrow >= $vrowmod($curview)} {
4651 update_arcrows $curview
4653 if {[info exists selectedline] &&
4654 $row <= $selectedline && $selectedline <= $endrow} {
4655 set targetrow $selectedline
4657 set targetrow [expr {int(($row + $endrow) / 2)}]
4659 if {$targetrow >= $numcommits} {
4660 set targetrow [expr {$numcommits - 1}]
4662 set targetid [commitonrow $targetrow]
4663 drawcommits $row $endrow
4666 proc clear_display {} {
4667 global iddrawn linesegs need_redisplay nrows_drawn
4668 global vhighlights fhighlights nhighlights rhighlights
4671 catch {unset iddrawn}
4672 catch {unset linesegs}
4673 catch {unset vhighlights}
4674 catch {unset fhighlights}
4675 catch {unset nhighlights}
4676 catch {unset rhighlights}
4677 set need_redisplay 0
4681 proc findcrossings {id} {
4682 global rowidlist parentlist numcommits displayorder
4686 foreach {s e} [rowranges $id] {
4687 if {$e >= $numcommits} {
4688 set e [expr {$numcommits - 1}]
4690 if {$e <= $s} continue
4691 for {set row $e} {[incr row -1] >= $s} {} {
4692 set x [lsearch -exact [lindex $rowidlist $row] $id]
4694 set olds [lindex $parentlist $row]
4695 set kid [lindex $displayorder $row]
4696 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4697 if {$kidx < 0} continue
4698 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4700 set px [lsearch -exact $nextrow $p]
4701 if {$px < 0} continue
4702 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4703 if {[lsearch -exact $ccross $p] >= 0} continue
4704 if {$x == $px + ($kidx < $px? -1: 1)} {
4706 } elseif {[lsearch -exact $cross $p] < 0} {
4713 return [concat $ccross {{}} $cross]
4716 proc assigncolor {id} {
4717 global colormap colors nextcolor
4718 global parents children children curview
4720 if {[info exists colormap($id)]} return
4721 set ncolors [llength $colors]
4722 if {[info exists children($curview,$id)]} {
4723 set kids $children($curview,$id)
4727 if {[llength $kids] == 1} {
4728 set child [lindex $kids 0]
4729 if {[info exists colormap($child)]
4730 && [llength $parents($curview,$child)] == 1} {
4731 set colormap($id) $colormap($child)
4737 foreach x [findcrossings $id] {
4739 # delimiter between corner crossings and other crossings
4740 if {[llength $badcolors] >= $ncolors - 1} break
4741 set origbad $badcolors
4743 if {[info exists colormap($x)]
4744 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4745 lappend badcolors $colormap($x)
4748 if {[llength $badcolors] >= $ncolors} {
4749 set badcolors $origbad
4751 set origbad $badcolors
4752 if {[llength $badcolors] < $ncolors - 1} {
4753 foreach child $kids {
4754 if {[info exists colormap($child)]
4755 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4756 lappend badcolors $colormap($child)
4758 foreach p $parents($curview,$child) {
4759 if {[info exists colormap($p)]
4760 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4761 lappend badcolors $colormap($p)
4765 if {[llength $badcolors] >= $ncolors} {
4766 set badcolors $origbad
4769 for {set i 0} {$i <= $ncolors} {incr i} {
4770 set c [lindex $colors $nextcolor]
4771 if {[incr nextcolor] >= $ncolors} {
4774 if {[lsearch -exact $badcolors $c]} break
4776 set colormap($id) $c
4779 proc bindline {t id} {
4782 $canv bind $t <Enter> "lineenter %x %y $id"
4783 $canv bind $t <Motion> "linemotion %x %y $id"
4784 $canv bind $t <Leave> "lineleave $id"
4785 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4788 proc drawtags {id x xt y1} {
4789 global idtags idheads idotherrefs mainhead
4790 global linespc lthickness
4791 global canv rowtextx curview fgcolor bgcolor
4796 if {[info exists idtags($id)]} {
4797 set marks $idtags($id)
4798 set ntags [llength $marks]
4800 if {[info exists idheads($id)]} {
4801 set marks [concat $marks $idheads($id)]
4802 set nheads [llength $idheads($id)]
4804 if {[info exists idotherrefs($id)]} {
4805 set marks [concat $marks $idotherrefs($id)]
4811 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4812 set yt [expr {$y1 - 0.5 * $linespc}]
4813 set yb [expr {$yt + $linespc - 1}]
4817 foreach tag $marks {
4819 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4820 set wid [font measure mainfontbold $tag]
4822 set wid [font measure mainfont $tag]
4826 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4828 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4829 -width $lthickness -fill black -tags tag.$id]
4831 foreach tag $marks x $xvals wid $wvals {
4832 set xl [expr {$x + $delta}]
4833 set xr [expr {$x + $delta + $wid + $lthickness}]
4835 if {[incr ntags -1] >= 0} {
4837 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4838 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4839 -width 1 -outline black -fill yellow -tags tag.$id]
4840 $canv bind $t <1> [list showtag $tag 1]
4841 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4843 # draw a head or other ref
4844 if {[incr nheads -1] >= 0} {
4846 if {$tag eq $mainhead} {
4847 set font mainfontbold
4852 set xl [expr {$xl - $delta/2}]
4853 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4854 -width 1 -outline black -fill $col -tags tag.$id
4855 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4856 set rwid [font measure mainfont $remoteprefix]
4857 set xi [expr {$x + 1}]
4858 set yti [expr {$yt + 1}]
4859 set xri [expr {$x + $rwid}]
4860 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4861 -width 0 -fill "#ffddaa" -tags tag.$id
4864 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4865 -font $font -tags [list tag.$id text]]
4867 $canv bind $t <1> [list showtag $tag 1]
4868 } elseif {$nheads >= 0} {
4869 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4875 proc xcoord {i level ln} {
4876 global canvx0 xspc1 xspc2
4878 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4879 if {$i > 0 && $i == $level} {
4880 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4881 } elseif {$i > $level} {
4882 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4887 proc show_status {msg} {
4891 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4892 -tags text -fill $fgcolor
4895 # Don't change the text pane cursor if it is currently the hand cursor,
4896 # showing that we are over a sha1 ID link.
4897 proc settextcursor {c} {
4898 global ctext curtextcursor
4900 if {[$ctext cget -cursor] == $curtextcursor} {
4901 $ctext config -cursor $c
4903 set curtextcursor $c
4906 proc nowbusy {what {name {}}} {
4907 global isbusy busyname statusw
4909 if {[array names isbusy] eq {}} {
4910 . config -cursor watch
4914 set busyname($what) $name
4916 $statusw conf -text $name
4920 proc notbusy {what} {
4921 global isbusy maincursor textcursor busyname statusw
4925 if {$busyname($what) ne {} &&
4926 [$statusw cget -text] eq $busyname($what)} {
4927 $statusw conf -text {}
4930 if {[array names isbusy] eq {}} {
4931 . config -cursor $maincursor
4932 settextcursor $textcursor
4936 proc findmatches {f} {
4937 global findtype findstring
4938 if {$findtype == [mc "Regexp"]} {
4939 set matches [regexp -indices -all -inline $findstring $f]
4942 if {$findtype == [mc "IgnCase"]} {
4943 set f [string tolower $f]
4944 set fs [string tolower $fs]
4948 set l [string length $fs]
4949 while {[set j [string first $fs $f $i]] >= 0} {
4950 lappend matches [list $j [expr {$j+$l-1}]]
4951 set i [expr {$j + $l}]
4957 proc dofind {{dirn 1} {wrap 1}} {
4958 global findstring findstartline findcurline selectedline numcommits
4959 global gdttype filehighlight fh_serial find_dirn findallowwrap
4961 if {[info exists find_dirn]} {
4962 if {$find_dirn == $dirn} return
4966 if {$findstring eq {} || $numcommits == 0} return
4967 if {![info exists selectedline]} {
4968 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4970 set findstartline $selectedline
4972 set findcurline $findstartline
4973 nowbusy finding [mc "Searching"]
4974 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
4975 after cancel do_file_hl $fh_serial
4976 do_file_hl $fh_serial
4979 set findallowwrap $wrap
4983 proc stopfinding {} {
4984 global find_dirn findcurline fprogcoord
4986 if {[info exists find_dirn]} {
4996 global commitdata commitinfo numcommits findpattern findloc
4997 global findstartline findcurline findallowwrap
4998 global find_dirn gdttype fhighlights fprogcoord
4999 global curview varcorder vrownum varccommits vrowmod
5001 if {![info exists find_dirn]} {
5004 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5007 if {$find_dirn > 0} {
5009 if {$l >= $numcommits} {
5012 if {$l <= $findstartline} {
5013 set lim [expr {$findstartline + 1}]
5016 set moretodo $findallowwrap
5023 if {$l >= $findstartline} {
5024 set lim [expr {$findstartline - 1}]
5027 set moretodo $findallowwrap
5030 set n [expr {($lim - $l) * $find_dirn}]
5035 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5036 update_arcrows $curview
5040 set ai [bsearch $vrownum($curview) $l]
5041 set a [lindex $varcorder($curview) $ai]
5042 set arow [lindex $vrownum($curview) $ai]
5043 set ids [lindex $varccommits($curview,$a)]
5044 set arowend [expr {$arow + [llength $ids]}]
5045 if {$gdttype eq [mc "containing:"]} {
5046 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5047 if {$l < $arow || $l >= $arowend} {
5049 set a [lindex $varcorder($curview) $ai]
5050 set arow [lindex $vrownum($curview) $ai]
5051 set ids [lindex $varccommits($curview,$a)]
5052 set arowend [expr {$arow + [llength $ids]}]
5054 set id [lindex $ids [expr {$l - $arow}]]
5055 # shouldn't happen unless git log doesn't give all the commits...
5056 if {![info exists commitdata($id)] ||
5057 ![doesmatch $commitdata($id)]} {
5060 if {![info exists commitinfo($id)]} {
5063 set info $commitinfo($id)
5064 foreach f $info ty $fldtypes {
5065 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5074 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5075 if {$l < $arow || $l >= $arowend} {
5077 set a [lindex $varcorder($curview) $ai]
5078 set arow [lindex $vrownum($curview) $ai]
5079 set ids [lindex $varccommits($curview,$a)]
5080 set arowend [expr {$arow + [llength $ids]}]
5082 set id [lindex $ids [expr {$l - $arow}]]
5083 if {![info exists fhighlights($id)]} {
5084 # this sets fhighlights($id) to -1
5085 askfilehighlight $l $id
5087 if {$fhighlights($id) > 0} {
5091 if {$fhighlights($id) < 0} {
5094 set findcurline [expr {$l - $find_dirn}]
5099 if {$found || ($domore && !$moretodo)} {
5115 set findcurline [expr {$l - $find_dirn}]
5117 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5121 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5126 proc findselectline {l} {
5127 global findloc commentend ctext findcurline markingmatches gdttype
5129 set markingmatches 1
5132 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5133 # highlight the matches in the comments
5134 set f [$ctext get 1.0 $commentend]
5135 set matches [findmatches $f]
5136 foreach match $matches {
5137 set start [lindex $match 0]
5138 set end [expr {[lindex $match 1] + 1}]
5139 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5145 # mark the bits of a headline or author that match a find string
5146 proc markmatches {canv l str tag matches font row} {
5149 set bbox [$canv bbox $tag]
5150 set x0 [lindex $bbox 0]
5151 set y0 [lindex $bbox 1]
5152 set y1 [lindex $bbox 3]
5153 foreach match $matches {
5154 set start [lindex $match 0]
5155 set end [lindex $match 1]
5156 if {$start > $end} continue
5157 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5158 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5159 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5160 [expr {$x0+$xlen+2}] $y1 \
5161 -outline {} -tags [list match$l matches] -fill yellow]
5163 if {[info exists selectedline] && $row == $selectedline} {
5164 $canv raise $t secsel
5169 proc unmarkmatches {} {
5170 global markingmatches
5172 allcanvs delete matches
5173 set markingmatches 0
5177 proc selcanvline {w x y} {
5178 global canv canvy0 ctext linespc
5180 set ymax [lindex [$canv cget -scrollregion] 3]
5181 if {$ymax == {}} return
5182 set yfrac [lindex [$canv yview] 0]
5183 set y [expr {$y + $yfrac * $ymax}]
5184 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5189 set xmax [lindex [$canv cget -scrollregion] 2]
5190 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5191 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5197 proc commit_descriptor {p} {
5199 if {![info exists commitinfo($p)]} {
5203 if {[llength $commitinfo($p)] > 1} {
5204 set l [lindex $commitinfo($p) 0]
5209 # append some text to the ctext widget, and make any SHA1 ID
5210 # that we know about be a clickable link.
5211 proc appendwithlinks {text tags} {
5212 global ctext linknum curview pendinglinks
5214 set start [$ctext index "end - 1c"]
5215 $ctext insert end $text $tags
5216 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5220 set linkid [string range $text $s $e]
5222 $ctext tag delete link$linknum
5223 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5224 setlink $linkid link$linknum
5229 proc setlink {id lk} {
5230 global curview ctext pendinglinks commitinterest
5232 if {[commitinview $id $curview]} {
5233 $ctext tag conf $lk -foreground blue -underline 1
5234 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5235 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5236 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5238 lappend pendinglinks($id) $lk
5239 lappend commitinterest($id) {makelink %I}
5243 proc makelink {id} {
5246 if {![info exists pendinglinks($id)]} return
5247 foreach lk $pendinglinks($id) {
5250 unset pendinglinks($id)
5253 proc linkcursor {w inc} {
5254 global linkentercount curtextcursor
5256 if {[incr linkentercount $inc] > 0} {
5257 $w configure -cursor hand2
5259 $w configure -cursor $curtextcursor
5260 if {$linkentercount < 0} {
5261 set linkentercount 0
5266 proc viewnextline {dir} {
5270 set ymax [lindex [$canv cget -scrollregion] 3]
5271 set wnow [$canv yview]
5272 set wtop [expr {[lindex $wnow 0] * $ymax}]
5273 set newtop [expr {$wtop + $dir * $linespc}]
5276 } elseif {$newtop > $ymax} {
5279 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5282 # add a list of tag or branch names at position pos
5283 # returns the number of names inserted
5284 proc appendrefs {pos ids var} {
5285 global ctext linknum curview $var maxrefs
5287 if {[catch {$ctext index $pos}]} {
5290 $ctext conf -state normal
5291 $ctext delete $pos "$pos lineend"
5294 foreach tag [set $var\($id\)] {
5295 lappend tags [list $tag $id]
5298 if {[llength $tags] > $maxrefs} {
5299 $ctext insert $pos "many ([llength $tags])"
5301 set tags [lsort -index 0 -decreasing $tags]
5304 set id [lindex $ti 1]
5307 $ctext tag delete $lk
5308 $ctext insert $pos $sep
5309 $ctext insert $pos [lindex $ti 0] $lk
5314 $ctext conf -state disabled
5315 return [llength $tags]
5318 # called when we have finished computing the nearby tags
5319 proc dispneartags {delay} {
5320 global selectedline currentid showneartags tagphase
5322 if {![info exists selectedline] || !$showneartags} return
5323 after cancel dispnexttag
5325 after 200 dispnexttag
5328 after idle dispnexttag
5333 proc dispnexttag {} {
5334 global selectedline currentid showneartags tagphase ctext
5336 if {![info exists selectedline] || !$showneartags} return
5337 switch -- $tagphase {
5339 set dtags [desctags $currentid]
5341 appendrefs precedes $dtags idtags
5345 set atags [anctags $currentid]
5347 appendrefs follows $atags idtags
5351 set dheads [descheads $currentid]
5352 if {$dheads ne {}} {
5353 if {[appendrefs branch $dheads idheads] > 1
5354 && [$ctext get "branch -3c"] eq "h"} {
5355 # turn "Branch" into "Branches"
5356 $ctext conf -state normal
5357 $ctext insert "branch -2c" "es"
5358 $ctext conf -state disabled
5363 if {[incr tagphase] <= 2} {
5364 after idle dispnexttag
5368 proc make_secsel {l} {
5369 global linehtag linentag linedtag canv canv2 canv3
5371 if {![info exists linehtag($l)]} return
5373 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5374 -tags secsel -fill [$canv cget -selectbackground]]
5376 $canv2 delete secsel
5377 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5378 -tags secsel -fill [$canv2 cget -selectbackground]]
5380 $canv3 delete secsel
5381 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5382 -tags secsel -fill [$canv3 cget -selectbackground]]
5386 proc selectline {l isnew} {
5387 global canv ctext commitinfo selectedline
5388 global canvy0 linespc parents children curview
5389 global currentid sha1entry
5390 global commentend idtags linknum
5391 global mergemax numcommits pending_select
5392 global cmitmode showneartags allcommits
5393 global targetrow targetid
5395 catch {unset pending_select}
5400 if {$l < 0 || $l >= $numcommits} return
5401 set y [expr {$canvy0 + $l * $linespc}]
5402 set ymax [lindex [$canv cget -scrollregion] 3]
5403 set ytop [expr {$y - $linespc - 1}]
5404 set ybot [expr {$y + $linespc + 1}]
5405 set wnow [$canv yview]
5406 set wtop [expr {[lindex $wnow 0] * $ymax}]
5407 set wbot [expr {[lindex $wnow 1] * $ymax}]
5408 set wh [expr {$wbot - $wtop}]
5410 if {$ytop < $wtop} {
5411 if {$ybot < $wtop} {
5412 set newtop [expr {$y - $wh / 2.0}]
5415 if {$newtop > $wtop - $linespc} {
5416 set newtop [expr {$wtop - $linespc}]
5419 } elseif {$ybot > $wbot} {
5420 if {$ytop > $wbot} {
5421 set newtop [expr {$y - $wh / 2.0}]
5423 set newtop [expr {$ybot - $wh}]
5424 if {$newtop < $wtop + $linespc} {
5425 set newtop [expr {$wtop + $linespc}]
5429 if {$newtop != $wtop} {
5433 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5439 set id [commitonrow $l]
5441 addtohistory [list selbyid $id]
5448 $sha1entry delete 0 end
5449 $sha1entry insert 0 $id
5450 $sha1entry selection from 0
5451 $sha1entry selection to end
5454 $ctext conf -state normal
5457 set info $commitinfo($id)
5458 set date [formatdate [lindex $info 2]]
5459 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5460 set date [formatdate [lindex $info 4]]
5461 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5462 if {[info exists idtags($id)]} {
5463 $ctext insert end [mc "Tags:"]
5464 foreach tag $idtags($id) {
5465 $ctext insert end " $tag"
5467 $ctext insert end "\n"
5471 set olds $parents($curview,$id)
5472 if {[llength $olds] > 1} {
5475 if {$np >= $mergemax} {
5480 $ctext insert end "[mc "Parent"]: " $tag
5481 appendwithlinks [commit_descriptor $p] {}
5486 append headers "[mc "Parent"]: [commit_descriptor $p]"
5490 foreach c $children($curview,$id) {
5491 append headers "[mc "Child"]: [commit_descriptor $c]"
5494 # make anything that looks like a SHA1 ID be a clickable link
5495 appendwithlinks $headers {}
5496 if {$showneartags} {
5497 if {![info exists allcommits]} {
5500 $ctext insert end "[mc "Branch"]: "
5501 $ctext mark set branch "end -1c"
5502 $ctext mark gravity branch left
5503 $ctext insert end "\n[mc "Follows"]: "
5504 $ctext mark set follows "end -1c"
5505 $ctext mark gravity follows left
5506 $ctext insert end "\n[mc "Precedes"]: "
5507 $ctext mark set precedes "end -1c"
5508 $ctext mark gravity precedes left
5509 $ctext insert end "\n"
5512 $ctext insert end "\n"
5513 set comment [lindex $info 5]
5514 if {[string first "\r" $comment] >= 0} {
5515 set comment [string map {"\r" "\n "} $comment]
5517 appendwithlinks $comment {comment}
5519 $ctext tag remove found 1.0 end
5520 $ctext conf -state disabled
5521 set commentend [$ctext index "end - 1c"]
5523 init_flist [mc "Comments"]
5524 if {$cmitmode eq "tree"} {
5526 } elseif {[llength $olds] <= 1} {
5533 proc selfirstline {} {
5538 proc sellastline {} {
5541 set l [expr {$numcommits - 1}]
5545 proc selnextline {dir} {
5548 if {![info exists selectedline]} return
5549 set l [expr {$selectedline + $dir}]
5554 proc selnextpage {dir} {
5555 global canv linespc selectedline numcommits
5557 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5561 allcanvs yview scroll [expr {$dir * $lpp}] units
5563 if {![info exists selectedline]} return
5564 set l [expr {$selectedline + $dir * $lpp}]
5567 } elseif {$l >= $numcommits} {
5568 set l [expr $numcommits - 1]
5574 proc unselectline {} {
5575 global selectedline currentid
5577 catch {unset selectedline}
5578 catch {unset currentid}
5579 allcanvs delete secsel
5583 proc reselectline {} {
5586 if {[info exists selectedline]} {
5587 selectline $selectedline 0
5591 proc addtohistory {cmd} {
5592 global history historyindex curview
5594 set elt [list $curview $cmd]
5595 if {$historyindex > 0
5596 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5600 if {$historyindex < [llength $history]} {
5601 set history [lreplace $history $historyindex end $elt]
5603 lappend history $elt
5606 if {$historyindex > 1} {
5607 .tf.bar.leftbut conf -state normal
5609 .tf.bar.leftbut conf -state disabled
5611 .tf.bar.rightbut conf -state disabled
5617 set view [lindex $elt 0]
5618 set cmd [lindex $elt 1]
5619 if {$curview != $view} {
5626 global history historyindex
5629 if {$historyindex > 1} {
5630 incr historyindex -1
5631 godo [lindex $history [expr {$historyindex - 1}]]
5632 .tf.bar.rightbut conf -state normal
5634 if {$historyindex <= 1} {
5635 .tf.bar.leftbut conf -state disabled
5640 global history historyindex
5643 if {$historyindex < [llength $history]} {
5644 set cmd [lindex $history $historyindex]
5647 .tf.bar.leftbut conf -state normal
5649 if {$historyindex >= [llength $history]} {
5650 .tf.bar.rightbut conf -state disabled
5655 global treefilelist treeidlist diffids diffmergeid treepending
5656 global nullid nullid2
5659 catch {unset diffmergeid}
5660 if {![info exists treefilelist($id)]} {
5661 if {![info exists treepending]} {
5662 if {$id eq $nullid} {
5663 set cmd [list | git ls-files]
5664 } elseif {$id eq $nullid2} {
5665 set cmd [list | git ls-files --stage -t]
5667 set cmd [list | git ls-tree -r $id]
5669 if {[catch {set gtf [open $cmd r]}]} {
5673 set treefilelist($id) {}
5674 set treeidlist($id) {}
5675 fconfigure $gtf -blocking 0
5676 filerun $gtf [list gettreeline $gtf $id]
5683 proc gettreeline {gtf id} {
5684 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5687 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5688 if {$diffids eq $nullid} {
5691 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5692 set i [string first "\t" $line]
5693 if {$i < 0} continue
5694 set sha1 [lindex $line 2]
5695 set fname [string range $line [expr {$i+1}] end]
5696 if {[string index $fname 0] eq "\""} {
5697 set fname [lindex $fname 0]
5699 lappend treeidlist($id) $sha1
5701 lappend treefilelist($id) $fname
5704 return [expr {$nl >= 1000? 2: 1}]
5708 if {$cmitmode ne "tree"} {
5709 if {![info exists diffmergeid]} {
5710 gettreediffs $diffids
5712 } elseif {$id ne $diffids} {
5721 global treefilelist treeidlist diffids nullid nullid2
5722 global ctext commentend
5724 set i [lsearch -exact $treefilelist($diffids) $f]
5726 puts "oops, $f not in list for id $diffids"
5729 if {$diffids eq $nullid} {
5730 if {[catch {set bf [open $f r]} err]} {
5731 puts "oops, can't read $f: $err"
5735 set blob [lindex $treeidlist($diffids) $i]
5736 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5737 puts "oops, error reading blob $blob: $err"
5741 fconfigure $bf -blocking 0
5742 filerun $bf [list getblobline $bf $diffids]
5743 $ctext config -state normal
5744 clear_ctext $commentend
5745 $ctext insert end "\n"
5746 $ctext insert end "$f\n" filesep
5747 $ctext config -state disabled
5748 $ctext yview $commentend
5752 proc getblobline {bf id} {
5753 global diffids cmitmode ctext
5755 if {$id ne $diffids || $cmitmode ne "tree"} {
5759 $ctext config -state normal
5761 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5762 $ctext insert end "$line\n"
5765 # delete last newline
5766 $ctext delete "end - 2c" "end - 1c"
5770 $ctext config -state disabled
5771 return [expr {$nl >= 1000? 2: 1}]
5774 proc mergediff {id} {
5775 global diffmergeid mdifffd
5778 global limitdiffs viewfiles curview
5782 # this doesn't seem to actually affect anything...
5783 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5784 if {$limitdiffs && $viewfiles($curview) ne {}} {
5785 set cmd [concat $cmd -- $viewfiles($curview)]
5787 if {[catch {set mdf [open $cmd r]} err]} {
5788 error_popup "[mc "Error getting merge diffs:"] $err"
5791 fconfigure $mdf -blocking 0
5792 set mdifffd($id) $mdf
5793 set np [llength $parents($curview,$id)]
5795 filerun $mdf [list getmergediffline $mdf $id $np]
5798 proc getmergediffline {mdf id np} {
5799 global diffmergeid ctext cflist mergemax
5800 global difffilestart mdifffd
5802 $ctext conf -state normal
5804 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5805 if {![info exists diffmergeid] || $id != $diffmergeid
5806 || $mdf != $mdifffd($id)} {
5810 if {[regexp {^diff --cc (.*)} $line match fname]} {
5811 # start of a new file
5812 $ctext insert end "\n"
5813 set here [$ctext index "end - 1c"]
5814 lappend difffilestart $here
5815 add_flist [list $fname]
5816 set l [expr {(78 - [string length $fname]) / 2}]
5817 set pad [string range "----------------------------------------" 1 $l]
5818 $ctext insert end "$pad $fname $pad\n" filesep
5819 } elseif {[regexp {^@@} $line]} {
5820 $ctext insert end "$line\n" hunksep
5821 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5824 # parse the prefix - one ' ', '-' or '+' for each parent
5829 for {set j 0} {$j < $np} {incr j} {
5830 set c [string range $line $j $j]
5833 } elseif {$c == "-"} {
5835 } elseif {$c == "+"} {
5844 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5845 # line doesn't appear in result, parents in $minuses have the line
5846 set num [lindex $minuses 0]
5847 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5848 # line appears in result, parents in $pluses don't have the line
5849 lappend tags mresult
5850 set num [lindex $spaces 0]
5853 if {$num >= $mergemax} {
5858 $ctext insert end "$line\n" $tags
5861 $ctext conf -state disabled
5866 return [expr {$nr >= 1000? 2: 1}]
5869 proc startdiff {ids} {
5870 global treediffs diffids treepending diffmergeid nullid nullid2
5874 catch {unset diffmergeid}
5875 if {![info exists treediffs($ids)] ||
5876 [lsearch -exact $ids $nullid] >= 0 ||
5877 [lsearch -exact $ids $nullid2] >= 0} {
5878 if {![info exists treepending]} {
5886 proc path_filter {filter name} {
5888 set l [string length $p]
5889 if {[string index $p end] eq "/"} {
5890 if {[string compare -length $l $p $name] == 0} {
5894 if {[string compare -length $l $p $name] == 0 &&
5895 ([string length $name] == $l ||
5896 [string index $name $l] eq "/")} {
5904 proc addtocflist {ids} {
5907 add_flist $treediffs($ids)
5911 proc diffcmd {ids flags} {
5912 global nullid nullid2
5914 set i [lsearch -exact $ids $nullid]
5915 set j [lsearch -exact $ids $nullid2]
5917 if {[llength $ids] > 1 && $j < 0} {
5918 # comparing working directory with some specific revision
5919 set cmd [concat | git diff-index $flags]
5921 lappend cmd -R [lindex $ids 1]
5923 lappend cmd [lindex $ids 0]
5926 # comparing working directory with index
5927 set cmd [concat | git diff-files $flags]
5932 } elseif {$j >= 0} {
5933 set cmd [concat | git diff-index --cached $flags]
5934 if {[llength $ids] > 1} {
5935 # comparing index with specific revision
5937 lappend cmd -R [lindex $ids 1]
5939 lappend cmd [lindex $ids 0]
5942 # comparing index with HEAD
5946 set cmd [concat | git diff-tree -r $flags $ids]
5951 proc gettreediffs {ids} {
5952 global treediff treepending
5954 set treepending $ids
5956 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5957 fconfigure $gdtf -blocking 0
5958 filerun $gdtf [list gettreediffline $gdtf $ids]
5961 proc gettreediffline {gdtf ids} {
5962 global treediff treediffs treepending diffids diffmergeid
5963 global cmitmode viewfiles curview limitdiffs
5966 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5967 set i [string first "\t" $line]
5969 set file [string range $line [expr {$i+1}] end]
5970 if {[string index $file 0] eq "\""} {
5971 set file [lindex $file 0]
5973 lappend treediff $file
5977 return [expr {$nr >= 1000? 2: 1}]
5980 if {$limitdiffs && $viewfiles($curview) ne {}} {
5982 foreach f $treediff {
5983 if {[path_filter $viewfiles($curview) $f]} {
5987 set treediffs($ids) $flist
5989 set treediffs($ids) $treediff
5992 if {$cmitmode eq "tree"} {
5994 } elseif {$ids != $diffids} {
5995 if {![info exists diffmergeid]} {
5996 gettreediffs $diffids
6004 # empty string or positive integer
6005 proc diffcontextvalidate {v} {
6006 return [regexp {^(|[1-9][0-9]*)$} $v]
6009 proc diffcontextchange {n1 n2 op} {
6010 global diffcontextstring diffcontext
6012 if {[string is integer -strict $diffcontextstring]} {
6013 if {$diffcontextstring > 0} {
6014 set diffcontext $diffcontextstring
6020 proc getblobdiffs {ids} {
6021 global blobdifffd diffids env
6022 global diffinhdr treediffs
6024 global limitdiffs viewfiles curview
6026 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6027 if {$limitdiffs && $viewfiles($curview) ne {}} {
6028 set cmd [concat $cmd -- $viewfiles($curview)]
6030 if {[catch {set bdf [open $cmd r]} err]} {
6031 puts "error getting diffs: $err"
6035 fconfigure $bdf -blocking 0
6036 set blobdifffd($ids) $bdf
6037 filerun $bdf [list getblobdiffline $bdf $diffids]
6040 proc setinlist {var i val} {
6043 while {[llength [set $var]] < $i} {
6046 if {[llength [set $var]] == $i} {
6053 proc makediffhdr {fname ids} {
6054 global ctext curdiffstart treediffs
6056 set i [lsearch -exact $treediffs($ids) $fname]
6058 setinlist difffilestart $i $curdiffstart
6060 set l [expr {(78 - [string length $fname]) / 2}]
6061 set pad [string range "----------------------------------------" 1 $l]
6062 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6065 proc getblobdiffline {bdf ids} {
6066 global diffids blobdifffd ctext curdiffstart
6067 global diffnexthead diffnextnote difffilestart
6068 global diffinhdr treediffs
6071 $ctext conf -state normal
6072 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6073 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6077 if {![string compare -length 11 "diff --git " $line]} {
6078 # trim off "diff --git "
6079 set line [string range $line 11 end]
6081 # start of a new file
6082 $ctext insert end "\n"
6083 set curdiffstart [$ctext index "end - 1c"]
6084 $ctext insert end "\n" filesep
6085 # If the name hasn't changed the length will be odd,
6086 # the middle char will be a space, and the two bits either
6087 # side will be a/name and b/name, or "a/name" and "b/name".
6088 # If the name has changed we'll get "rename from" and
6089 # "rename to" or "copy from" and "copy to" lines following this,
6090 # and we'll use them to get the filenames.
6091 # This complexity is necessary because spaces in the filename(s)
6092 # don't get escaped.
6093 set l [string length $line]
6094 set i [expr {$l / 2}]
6095 if {!(($l & 1) && [string index $line $i] eq " " &&
6096 [string range $line 2 [expr {$i - 1}]] eq \
6097 [string range $line [expr {$i + 3}] end])} {
6100 # unescape if quoted and chop off the a/ from the front
6101 if {[string index $line 0] eq "\""} {
6102 set fname [string range [lindex $line 0] 2 end]
6104 set fname [string range $line 2 [expr {$i - 1}]]
6106 makediffhdr $fname $ids
6108 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6109 $line match f1l f1c f2l f2c rest]} {
6110 $ctext insert end "$line\n" hunksep
6113 } elseif {$diffinhdr} {
6114 if {![string compare -length 12 "rename from " $line]} {
6115 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6116 if {[string index $fname 0] eq "\""} {
6117 set fname [lindex $fname 0]
6119 set i [lsearch -exact $treediffs($ids) $fname]
6121 setinlist difffilestart $i $curdiffstart
6123 } elseif {![string compare -length 10 $line "rename to "] ||
6124 ![string compare -length 8 $line "copy to "]} {
6125 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6126 if {[string index $fname 0] eq "\""} {
6127 set fname [lindex $fname 0]
6129 makediffhdr $fname $ids
6130 } elseif {[string compare -length 3 $line "---"] == 0} {
6133 } elseif {[string compare -length 3 $line "+++"] == 0} {
6137 $ctext insert end "$line\n" filesep
6140 set x [string range $line 0 0]
6141 if {$x == "-" || $x == "+"} {
6142 set tag [expr {$x == "+"}]
6143 $ctext insert end "$line\n" d$tag
6144 } elseif {$x == " "} {
6145 $ctext insert end "$line\n"
6147 # "\ No newline at end of file",
6148 # or something else we don't recognize
6149 $ctext insert end "$line\n" hunksep
6153 $ctext conf -state disabled
6158 return [expr {$nr >= 1000? 2: 1}]
6161 proc changediffdisp {} {
6162 global ctext diffelide
6164 $ctext tag conf d0 -elide [lindex $diffelide 0]
6165 $ctext tag conf d1 -elide [lindex $diffelide 1]
6169 global difffilestart ctext
6170 set prev [lindex $difffilestart 0]
6171 set here [$ctext index @0,0]
6172 foreach loc $difffilestart {
6173 if {[$ctext compare $loc >= $here]} {
6183 global difffilestart ctext
6184 set here [$ctext index @0,0]
6185 foreach loc $difffilestart {
6186 if {[$ctext compare $loc > $here]} {
6193 proc clear_ctext {{first 1.0}} {
6194 global ctext smarktop smarkbot
6197 set l [lindex [split $first .] 0]
6198 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6201 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6204 $ctext delete $first end
6205 if {$first eq "1.0"} {
6206 catch {unset pendinglinks}
6210 proc settabs {{firstab {}}} {
6211 global firsttabstop tabstop ctext have_tk85
6213 if {$firstab ne {} && $have_tk85} {
6214 set firsttabstop $firstab
6216 set w [font measure textfont "0"]
6217 if {$firsttabstop != 0} {
6218 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6219 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6220 } elseif {$have_tk85 || $tabstop != 8} {
6221 $ctext conf -tabs [expr {$tabstop * $w}]
6223 $ctext conf -tabs {}
6227 proc incrsearch {name ix op} {
6228 global ctext searchstring searchdirn
6230 $ctext tag remove found 1.0 end
6231 if {[catch {$ctext index anchor}]} {
6232 # no anchor set, use start of selection, or of visible area
6233 set sel [$ctext tag ranges sel]
6235 $ctext mark set anchor [lindex $sel 0]
6236 } elseif {$searchdirn eq "-forwards"} {
6237 $ctext mark set anchor @0,0
6239 $ctext mark set anchor @0,[winfo height $ctext]
6242 if {$searchstring ne {}} {
6243 set here [$ctext search $searchdirn -- $searchstring anchor]
6252 global sstring ctext searchstring searchdirn
6255 $sstring icursor end
6256 set searchdirn -forwards
6257 if {$searchstring ne {}} {
6258 set sel [$ctext tag ranges sel]
6260 set start "[lindex $sel 0] + 1c"
6261 } elseif {[catch {set start [$ctext index anchor]}]} {
6264 set match [$ctext search -count mlen -- $searchstring $start]
6265 $ctext tag remove sel 1.0 end
6271 set mend "$match + $mlen c"
6272 $ctext tag add sel $match $mend
6273 $ctext mark unset anchor
6277 proc dosearchback {} {
6278 global sstring ctext searchstring searchdirn
6281 $sstring icursor end
6282 set searchdirn -backwards
6283 if {$searchstring ne {}} {
6284 set sel [$ctext tag ranges sel]
6286 set start [lindex $sel 0]
6287 } elseif {[catch {set start [$ctext index anchor]}]} {
6288 set start @0,[winfo height $ctext]
6290 set match [$ctext search -backwards -count ml -- $searchstring $start]
6291 $ctext tag remove sel 1.0 end
6297 set mend "$match + $ml c"
6298 $ctext tag add sel $match $mend
6299 $ctext mark unset anchor
6303 proc searchmark {first last} {
6304 global ctext searchstring
6308 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6309 if {$match eq {}} break
6310 set mend "$match + $mlen c"
6311 $ctext tag add found $match $mend
6315 proc searchmarkvisible {doall} {
6316 global ctext smarktop smarkbot
6318 set topline [lindex [split [$ctext index @0,0] .] 0]
6319 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6320 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6321 # no overlap with previous
6322 searchmark $topline $botline
6323 set smarktop $topline
6324 set smarkbot $botline
6326 if {$topline < $smarktop} {
6327 searchmark $topline [expr {$smarktop-1}]
6328 set smarktop $topline
6330 if {$botline > $smarkbot} {
6331 searchmark [expr {$smarkbot+1}] $botline
6332 set smarkbot $botline
6337 proc scrolltext {f0 f1} {
6340 .bleft.sb set $f0 $f1
6341 if {$searchstring ne {}} {
6347 global linespc charspc canvx0 canvy0
6348 global xspc1 xspc2 lthickness
6350 set linespc [font metrics mainfont -linespace]
6351 set charspc [font measure mainfont "m"]
6352 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6353 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6354 set lthickness [expr {int($linespc / 9) + 1}]
6355 set xspc1(0) $linespc
6363 set ymax [lindex [$canv cget -scrollregion] 3]
6364 if {$ymax eq {} || $ymax == 0} return
6365 set span [$canv yview]
6368 allcanvs yview moveto [lindex $span 0]
6370 if {[info exists selectedline]} {
6371 selectline $selectedline 0
6372 allcanvs yview moveto [lindex $span 0]
6376 proc parsefont {f n} {
6379 set fontattr($f,family) [lindex $n 0]
6381 if {$s eq {} || $s == 0} {
6384 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6386 set fontattr($f,size) $s
6387 set fontattr($f,weight) normal
6388 set fontattr($f,slant) roman
6389 foreach style [lrange $n 2 end] {
6392 "bold" {set fontattr($f,weight) $style}
6394 "italic" {set fontattr($f,slant) $style}
6399 proc fontflags {f {isbold 0}} {
6402 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6403 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6404 -slant $fontattr($f,slant)]
6410 set n [list $fontattr($f,family) $fontattr($f,size)]
6411 if {$fontattr($f,weight) eq "bold"} {
6414 if {$fontattr($f,slant) eq "italic"} {
6420 proc incrfont {inc} {
6421 global mainfont textfont ctext canv cflist showrefstop
6422 global stopped entries fontattr
6425 set s $fontattr(mainfont,size)
6430 set fontattr(mainfont,size) $s
6431 font config mainfont -size $s
6432 font config mainfontbold -size $s
6433 set mainfont [fontname mainfont]
6434 set s $fontattr(textfont,size)
6439 set fontattr(textfont,size) $s
6440 font config textfont -size $s
6441 font config textfontbold -size $s
6442 set textfont [fontname textfont]
6449 global sha1entry sha1string
6450 if {[string length $sha1string] == 40} {
6451 $sha1entry delete 0 end
6455 proc sha1change {n1 n2 op} {
6456 global sha1string currentid sha1but
6457 if {$sha1string == {}
6458 || ([info exists currentid] && $sha1string == $currentid)} {
6463 if {[$sha1but cget -state] == $state} return
6464 if {$state == "normal"} {
6465 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6467 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6471 proc gotocommit {} {
6472 global sha1string tagids headids curview varcid
6474 if {$sha1string == {}
6475 || ([info exists currentid] && $sha1string == $currentid)} return
6476 if {[info exists tagids($sha1string)]} {
6477 set id $tagids($sha1string)
6478 } elseif {[info exists headids($sha1string)]} {
6479 set id $headids($sha1string)
6481 set id [string tolower $sha1string]
6482 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6483 set matches [array names varcid "$curview,$id*"]
6484 if {$matches ne {}} {
6485 if {[llength $matches] > 1} {
6486 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6489 set id [lindex [split [lindex $matches 0] ","] 1]
6493 if {[commitinview $id $curview]} {
6494 selectline [rowofcommit $id] 1
6497 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6498 set msg [mc "SHA1 id %s is not known" $sha1string]
6500 set msg [mc "Tag/Head %s is not known" $sha1string]
6505 proc lineenter {x y id} {
6506 global hoverx hovery hoverid hovertimer
6507 global commitinfo canv
6509 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6513 if {[info exists hovertimer]} {
6514 after cancel $hovertimer
6516 set hovertimer [after 500 linehover]
6520 proc linemotion {x y id} {
6521 global hoverx hovery hoverid hovertimer
6523 if {[info exists hoverid] && $id == $hoverid} {
6526 if {[info exists hovertimer]} {
6527 after cancel $hovertimer
6529 set hovertimer [after 500 linehover]
6533 proc lineleave {id} {
6534 global hoverid hovertimer canv
6536 if {[info exists hoverid] && $id == $hoverid} {
6538 if {[info exists hovertimer]} {
6539 after cancel $hovertimer
6547 global hoverx hovery hoverid hovertimer
6548 global canv linespc lthickness
6551 set text [lindex $commitinfo($hoverid) 0]
6552 set ymax [lindex [$canv cget -scrollregion] 3]
6553 if {$ymax == {}} return
6554 set yfrac [lindex [$canv yview] 0]
6555 set x [expr {$hoverx + 2 * $linespc}]
6556 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6557 set x0 [expr {$x - 2 * $lthickness}]
6558 set y0 [expr {$y - 2 * $lthickness}]
6559 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6560 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6561 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6562 -fill \#ffff80 -outline black -width 1 -tags hover]
6564 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6569 proc clickisonarrow {id y} {
6572 set ranges [rowranges $id]
6573 set thresh [expr {2 * $lthickness + 6}]
6574 set n [expr {[llength $ranges] - 1}]
6575 for {set i 1} {$i < $n} {incr i} {
6576 set row [lindex $ranges $i]
6577 if {abs([yc $row] - $y) < $thresh} {
6584 proc arrowjump {id n y} {
6587 # 1 <-> 2, 3 <-> 4, etc...
6588 set n [expr {(($n - 1) ^ 1) + 1}]
6589 set row [lindex [rowranges $id] $n]
6591 set ymax [lindex [$canv cget -scrollregion] 3]
6592 if {$ymax eq {} || $ymax <= 0} return
6593 set view [$canv yview]
6594 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6595 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6599 allcanvs yview moveto $yfrac
6602 proc lineclick {x y id isnew} {
6603 global ctext commitinfo children canv thickerline curview
6605 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6610 # draw this line thicker than normal
6614 set ymax [lindex [$canv cget -scrollregion] 3]
6615 if {$ymax eq {}} return
6616 set yfrac [lindex [$canv yview] 0]
6617 set y [expr {$y + $yfrac * $ymax}]
6619 set dirn [clickisonarrow $id $y]
6621 arrowjump $id $dirn $y
6626 addtohistory [list lineclick $x $y $id 0]
6628 # fill the details pane with info about this line
6629 $ctext conf -state normal
6632 $ctext insert end "[mc "Parent"]:\t"
6633 $ctext insert end $id link0
6635 set info $commitinfo($id)
6636 $ctext insert end "\n\t[lindex $info 0]\n"
6637 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
6638 set date [formatdate [lindex $info 2]]
6639 $ctext insert end "\t[mc "Date"]:\t$date\n"
6640 set kids $children($curview,$id)
6642 $ctext insert end "\n[mc "Children"]:"
6644 foreach child $kids {
6646 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6647 set info $commitinfo($child)
6648 $ctext insert end "\n\t"
6649 $ctext insert end $child link$i
6650 setlink $child link$i
6651 $ctext insert end "\n\t[lindex $info 0]"
6652 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
6653 set date [formatdate [lindex $info 2]]
6654 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
6657 $ctext conf -state disabled
6661 proc normalline {} {
6663 if {[info exists thickerline]} {
6672 if {[commitinview $id $curview]} {
6673 selectline [rowofcommit $id] 1
6679 if {![info exists startmstime]} {
6680 set startmstime [clock clicks -milliseconds]
6682 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6685 proc rowmenu {x y id} {
6686 global rowctxmenu selectedline rowmenuid curview
6687 global nullid nullid2 fakerowmenu mainhead
6691 if {![info exists selectedline]
6692 || [rowofcommit $id] eq $selectedline} {
6697 if {$id ne $nullid && $id ne $nullid2} {
6698 set menu $rowctxmenu
6699 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6701 set menu $fakerowmenu
6703 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6704 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6705 $menu entryconfigure [mc "Make patch"] -state $state
6706 tk_popup $menu $x $y
6709 proc diffvssel {dirn} {
6710 global rowmenuid selectedline
6712 if {![info exists selectedline]} return
6714 set oldid [commitonrow $selectedline]
6715 set newid $rowmenuid
6717 set oldid $rowmenuid
6718 set newid [commitonrow $selectedline]
6720 addtohistory [list doseldiff $oldid $newid]
6721 doseldiff $oldid $newid
6724 proc doseldiff {oldid newid} {
6728 $ctext conf -state normal
6730 init_flist [mc "Top"]
6731 $ctext insert end "[mc "From"] "
6732 $ctext insert end $oldid link0
6733 setlink $oldid link0
6734 $ctext insert end "\n "
6735 $ctext insert end [lindex $commitinfo($oldid) 0]
6736 $ctext insert end "\n\n[mc "To"] "
6737 $ctext insert end $newid link1
6738 setlink $newid link1
6739 $ctext insert end "\n "
6740 $ctext insert end [lindex $commitinfo($newid) 0]
6741 $ctext insert end "\n"
6742 $ctext conf -state disabled
6743 $ctext tag remove found 1.0 end
6744 startdiff [list $oldid $newid]
6748 global rowmenuid currentid commitinfo patchtop patchnum
6750 if {![info exists currentid]} return
6751 set oldid $currentid
6752 set oldhead [lindex $commitinfo($oldid) 0]
6753 set newid $rowmenuid
6754 set newhead [lindex $commitinfo($newid) 0]
6757 catch {destroy $top}
6759 label $top.title -text [mc "Generate patch"]
6760 grid $top.title - -pady 10
6761 label $top.from -text [mc "From:"]
6762 entry $top.fromsha1 -width 40 -relief flat
6763 $top.fromsha1 insert 0 $oldid
6764 $top.fromsha1 conf -state readonly
6765 grid $top.from $top.fromsha1 -sticky w
6766 entry $top.fromhead -width 60 -relief flat
6767 $top.fromhead insert 0 $oldhead
6768 $top.fromhead conf -state readonly
6769 grid x $top.fromhead -sticky w
6770 label $top.to -text [mc "To:"]
6771 entry $top.tosha1 -width 40 -relief flat
6772 $top.tosha1 insert 0 $newid
6773 $top.tosha1 conf -state readonly
6774 grid $top.to $top.tosha1 -sticky w
6775 entry $top.tohead -width 60 -relief flat
6776 $top.tohead insert 0 $newhead
6777 $top.tohead conf -state readonly
6778 grid x $top.tohead -sticky w
6779 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6780 grid $top.rev x -pady 10
6781 label $top.flab -text [mc "Output file:"]
6782 entry $top.fname -width 60
6783 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6785 grid $top.flab $top.fname -sticky w
6787 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6788 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6789 grid $top.buts.gen $top.buts.can
6790 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6791 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6792 grid $top.buts - -pady 10 -sticky ew
6796 proc mkpatchrev {} {
6799 set oldid [$patchtop.fromsha1 get]
6800 set oldhead [$patchtop.fromhead get]
6801 set newid [$patchtop.tosha1 get]
6802 set newhead [$patchtop.tohead get]
6803 foreach e [list fromsha1 fromhead tosha1 tohead] \
6804 v [list $newid $newhead $oldid $oldhead] {
6805 $patchtop.$e conf -state normal
6806 $patchtop.$e delete 0 end
6807 $patchtop.$e insert 0 $v
6808 $patchtop.$e conf -state readonly
6813 global patchtop nullid nullid2
6815 set oldid [$patchtop.fromsha1 get]
6816 set newid [$patchtop.tosha1 get]
6817 set fname [$patchtop.fname get]
6818 set cmd [diffcmd [list $oldid $newid] -p]
6819 # trim off the initial "|"
6820 set cmd [lrange $cmd 1 end]
6821 lappend cmd >$fname &
6822 if {[catch {eval exec $cmd} err]} {
6823 error_popup "[mc "Error creating patch:"] $err"
6825 catch {destroy $patchtop}
6829 proc mkpatchcan {} {
6832 catch {destroy $patchtop}
6837 global rowmenuid mktagtop commitinfo
6841 catch {destroy $top}
6843 label $top.title -text [mc "Create tag"]
6844 grid $top.title - -pady 10
6845 label $top.id -text [mc "ID:"]
6846 entry $top.sha1 -width 40 -relief flat
6847 $top.sha1 insert 0 $rowmenuid
6848 $top.sha1 conf -state readonly
6849 grid $top.id $top.sha1 -sticky w
6850 entry $top.head -width 60 -relief flat
6851 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6852 $top.head conf -state readonly
6853 grid x $top.head -sticky w
6854 label $top.tlab -text [mc "Tag name:"]
6855 entry $top.tag -width 60
6856 grid $top.tlab $top.tag -sticky w
6858 button $top.buts.gen -text [mc "Create"] -command mktaggo
6859 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6860 grid $top.buts.gen $top.buts.can
6861 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6862 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6863 grid $top.buts - -pady 10 -sticky ew
6868 global mktagtop env tagids idtags
6870 set id [$mktagtop.sha1 get]
6871 set tag [$mktagtop.tag get]
6873 error_popup [mc "No tag name specified"]
6876 if {[info exists tagids($tag)]} {
6877 error_popup [mc "Tag \"%s\" already exists" $tag]
6882 set fname [file join $dir "refs/tags" $tag]
6883 set f [open $fname w]
6887 error_popup "[mc "Error creating tag:"] $err"
6891 set tagids($tag) $id
6892 lappend idtags($id) $tag
6899 proc redrawtags {id} {
6900 global canv linehtag idpos currentid curview
6901 global canvxmax iddrawn
6903 if {![commitinview $id $curview]} return
6904 if {![info exists iddrawn($id)]} return
6905 set row [rowofcommit $id]
6906 $canv delete tag.$id
6907 set xt [eval drawtags $id $idpos($id)]
6908 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
6909 set text [$canv itemcget $linehtag($row) -text]
6910 set font [$canv itemcget $linehtag($row) -font]
6911 set xr [expr {$xt + [font measure $font $text]}]
6912 if {$xr > $canvxmax} {
6916 if {[info exists currentid] && $currentid == $id} {
6924 catch {destroy $mktagtop}
6933 proc writecommit {} {
6934 global rowmenuid wrcomtop commitinfo wrcomcmd
6936 set top .writecommit
6938 catch {destroy $top}
6940 label $top.title -text [mc "Write commit to file"]
6941 grid $top.title - -pady 10
6942 label $top.id -text [mc "ID:"]
6943 entry $top.sha1 -width 40 -relief flat
6944 $top.sha1 insert 0 $rowmenuid
6945 $top.sha1 conf -state readonly
6946 grid $top.id $top.sha1 -sticky w
6947 entry $top.head -width 60 -relief flat
6948 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6949 $top.head conf -state readonly
6950 grid x $top.head -sticky w
6951 label $top.clab -text [mc "Command:"]
6952 entry $top.cmd -width 60 -textvariable wrcomcmd
6953 grid $top.clab $top.cmd -sticky w -pady 10
6954 label $top.flab -text [mc "Output file:"]
6955 entry $top.fname -width 60
6956 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6957 grid $top.flab $top.fname -sticky w
6959 button $top.buts.gen -text [mc "Write"] -command wrcomgo
6960 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
6961 grid $top.buts.gen $top.buts.can
6962 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6963 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6964 grid $top.buts - -pady 10 -sticky ew
6971 set id [$wrcomtop.sha1 get]
6972 set cmd "echo $id | [$wrcomtop.cmd get]"
6973 set fname [$wrcomtop.fname get]
6974 if {[catch {exec sh -c $cmd >$fname &} err]} {
6975 error_popup "[mc "Error writing commit:"] $err"
6977 catch {destroy $wrcomtop}
6984 catch {destroy $wrcomtop}
6989 global rowmenuid mkbrtop
6992 catch {destroy $top}
6994 label $top.title -text [mc "Create new branch"]
6995 grid $top.title - -pady 10
6996 label $top.id -text [mc "ID:"]
6997 entry $top.sha1 -width 40 -relief flat
6998 $top.sha1 insert 0 $rowmenuid
6999 $top.sha1 conf -state readonly
7000 grid $top.id $top.sha1 -sticky w
7001 label $top.nlab -text [mc "Name:"]
7002 entry $top.name -width 40
7003 grid $top.nlab $top.name -sticky w
7005 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7006 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7007 grid $top.buts.go $top.buts.can
7008 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7009 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7010 grid $top.buts - -pady 10 -sticky ew
7015 global headids idheads
7017 set name [$top.name get]
7018 set id [$top.sha1 get]
7020 error_popup [mc "Please specify a name for the new branch"]
7023 catch {destroy $top}
7027 exec git branch $name $id
7032 set headids($name) $id
7033 lappend idheads($id) $name
7042 proc cherrypick {} {
7043 global rowmenuid curview viewincl
7044 global mainhead mainheadid
7046 set oldhead [exec git rev-parse HEAD]
7047 set dheads [descheads $rowmenuid]
7048 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7049 set ok [confirm_popup [mc "Commit %s is already\
7050 included in branch %s -- really re-apply it?" \
7051 [string range $rowmenuid 0 7] $mainhead]]
7054 nowbusy cherrypick [mc "Cherry-picking"]
7056 # Unfortunately git-cherry-pick writes stuff to stderr even when
7057 # no error occurs, and exec takes that as an indication of error...
7058 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7063 set newhead [exec git rev-parse HEAD]
7064 if {$newhead eq $oldhead} {
7066 error_popup [mc "No changes committed"]
7069 addnewchild $newhead $oldhead
7070 if {[commitinview $oldhead $curview]} {
7071 insertrow $newhead $oldhead $curview
7072 if {$mainhead ne {}} {
7073 movehead $newhead $mainhead
7074 movedhead $newhead $mainhead
7075 set mainheadid $newhead
7077 # remove oldhead from viewincl and add newhead
7078 set i [lsearch -exact $viewincl($curview) $oldhead]
7080 set viewincl($curview) [lreplace $viewincl($curview) $i $i]
7082 lappend viewincl($curview) $newhead
7091 global mainhead rowmenuid confirm_ok resettype
7094 set w ".confirmreset"
7097 wm title $w [mc "Confirm reset"]
7098 message $w.m -text \
7099 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7100 -justify center -aspect 1000
7101 pack $w.m -side top -fill x -padx 20 -pady 20
7102 frame $w.f -relief sunken -border 2
7103 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7104 grid $w.f.rt -sticky w
7106 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7107 -text [mc "Soft: Leave working tree and index untouched"]
7108 grid $w.f.soft -sticky w
7109 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7110 -text [mc "Mixed: Leave working tree untouched, reset index"]
7111 grid $w.f.mixed -sticky w
7112 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7113 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7114 grid $w.f.hard -sticky w
7115 pack $w.f -side top -fill x
7116 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7117 pack $w.ok -side left -fill x -padx 20 -pady 20
7118 button $w.cancel -text [mc Cancel] -command "destroy $w"
7119 pack $w.cancel -side right -fill x -padx 20 -pady 20
7120 bind $w <Visibility> "grab $w; focus $w"
7122 if {!$confirm_ok} return
7123 if {[catch {set fd [open \
7124 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
7128 filerun $fd [list readresetstat $fd]
7129 nowbusy reset [mc "Resetting"]
7134 proc readresetstat {fd} {
7135 global mainhead mainheadid showlocalchanges rprogcoord
7137 if {[gets $fd line] >= 0} {
7138 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7139 set rprogcoord [expr {1.0 * $m / $n}]
7147 if {[catch {close $fd} err]} {
7150 set oldhead $mainheadid
7151 set newhead [exec git rev-parse HEAD]
7152 if {$newhead ne $oldhead} {
7153 movehead $newhead $mainhead
7154 movedhead $newhead $mainhead
7155 set mainheadid $newhead
7159 if {$showlocalchanges} {
7165 # context menu for a head
7166 proc headmenu {x y id head} {
7167 global headmenuid headmenuhead headctxmenu mainhead
7171 set headmenuhead $head
7173 if {$head eq $mainhead} {
7176 $headctxmenu entryconfigure 0 -state $state
7177 $headctxmenu entryconfigure 1 -state $state
7178 tk_popup $headctxmenu $x $y
7182 global headmenuid headmenuhead mainhead headids
7183 global showlocalchanges mainheadid
7185 # check the tree is clean first??
7186 set oldmainhead $mainhead
7187 nowbusy checkout [mc "Checking out"]
7191 exec git checkout -q $headmenuhead
7197 set mainhead $headmenuhead
7198 set mainheadid $headmenuid
7199 if {[info exists headids($oldmainhead)]} {
7200 redrawtags $headids($oldmainhead)
7202 redrawtags $headmenuid
7205 if {$showlocalchanges} {
7211 global headmenuid headmenuhead mainhead
7214 set head $headmenuhead
7216 # this check shouldn't be needed any more...
7217 if {$head eq $mainhead} {
7218 error_popup [mc "Cannot delete the currently checked-out branch"]
7221 set dheads [descheads $id]
7222 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7223 # the stuff on this branch isn't on any other branch
7224 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7225 branch.\nReally delete branch %s?" $head $head]]} return
7229 if {[catch {exec git branch -D $head} err]} {
7234 removehead $id $head
7235 removedhead $id $head
7242 # Display a list of tags and heads
7244 global showrefstop bgcolor fgcolor selectbgcolor
7245 global bglist fglist reflistfilter reflist maincursor
7248 set showrefstop $top
7249 if {[winfo exists $top]} {
7255 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7256 text $top.list -background $bgcolor -foreground $fgcolor \
7257 -selectbackground $selectbgcolor -font mainfont \
7258 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7259 -width 30 -height 20 -cursor $maincursor \
7260 -spacing1 1 -spacing3 1 -state disabled
7261 $top.list tag configure highlight -background $selectbgcolor
7262 lappend bglist $top.list
7263 lappend fglist $top.list
7264 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7265 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7266 grid $top.list $top.ysb -sticky nsew
7267 grid $top.xsb x -sticky ew
7269 label $top.f.l -text "[mc "Filter"]: "
7270 entry $top.f.e -width 20 -textvariable reflistfilter
7271 set reflistfilter "*"
7272 trace add variable reflistfilter write reflistfilter_change
7273 pack $top.f.e -side right -fill x -expand 1
7274 pack $top.f.l -side left
7275 grid $top.f - -sticky ew -pady 2
7276 button $top.close -command [list destroy $top] -text [mc "Close"]
7278 grid columnconfigure $top 0 -weight 1
7279 grid rowconfigure $top 0 -weight 1
7280 bind $top.list <1> {break}
7281 bind $top.list <B1-Motion> {break}
7282 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7287 proc sel_reflist {w x y} {
7288 global showrefstop reflist headids tagids otherrefids
7290 if {![winfo exists $showrefstop]} return
7291 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7292 set ref [lindex $reflist [expr {$l-1}]]
7293 set n [lindex $ref 0]
7294 switch -- [lindex $ref 1] {
7295 "H" {selbyid $headids($n)}
7296 "T" {selbyid $tagids($n)}
7297 "o" {selbyid $otherrefids($n)}
7299 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7302 proc unsel_reflist {} {
7305 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7306 $showrefstop.list tag remove highlight 0.0 end
7309 proc reflistfilter_change {n1 n2 op} {
7310 global reflistfilter
7312 after cancel refill_reflist
7313 after 200 refill_reflist
7316 proc refill_reflist {} {
7317 global reflist reflistfilter showrefstop headids tagids otherrefids
7318 global curview commitinterest
7320 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7322 foreach n [array names headids] {
7323 if {[string match $reflistfilter $n]} {
7324 if {[commitinview $headids($n) $curview]} {
7325 lappend refs [list $n H]
7327 set commitinterest($headids($n)) {run refill_reflist}
7331 foreach n [array names tagids] {
7332 if {[string match $reflistfilter $n]} {
7333 if {[commitinview $tagids($n) $curview]} {
7334 lappend refs [list $n T]
7336 set commitinterest($tagids($n)) {run refill_reflist}
7340 foreach n [array names otherrefids] {
7341 if {[string match $reflistfilter $n]} {
7342 if {[commitinview $otherrefids($n) $curview]} {
7343 lappend refs [list $n o]
7345 set commitinterest($otherrefids($n)) {run refill_reflist}
7349 set refs [lsort -index 0 $refs]
7350 if {$refs eq $reflist} return
7352 # Update the contents of $showrefstop.list according to the
7353 # differences between $reflist (old) and $refs (new)
7354 $showrefstop.list conf -state normal
7355 $showrefstop.list insert end "\n"
7358 while {$i < [llength $reflist] || $j < [llength $refs]} {
7359 if {$i < [llength $reflist]} {
7360 if {$j < [llength $refs]} {
7361 set cmp [string compare [lindex $reflist $i 0] \
7362 [lindex $refs $j 0]]
7364 set cmp [string compare [lindex $reflist $i 1] \
7365 [lindex $refs $j 1]]
7375 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7383 set l [expr {$j + 1}]
7384 $showrefstop.list image create $l.0 -align baseline \
7385 -image reficon-[lindex $refs $j 1] -padx 2
7386 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7392 # delete last newline
7393 $showrefstop.list delete end-2c end-1c
7394 $showrefstop.list conf -state disabled
7397 # Stuff for finding nearby tags
7398 proc getallcommits {} {
7399 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7400 global idheads idtags idotherrefs allparents tagobjid
7402 if {![info exists allcommits]} {
7408 set allccache [file join [gitdir] "gitk.cache"]
7410 set f [open $allccache r]
7419 set cmd [list | git rev-list --parents]
7420 set allcupdate [expr {$seeds ne {}}]
7424 set refs [concat [array names idheads] [array names idtags] \
7425 [array names idotherrefs]]
7428 foreach name [array names tagobjid] {
7429 lappend tagobjs $tagobjid($name)
7431 foreach id [lsort -unique $refs] {
7432 if {![info exists allparents($id)] &&
7433 [lsearch -exact $tagobjs $id] < 0} {
7444 set fd [open [concat $cmd $ids] r]
7445 fconfigure $fd -blocking 0
7448 filerun $fd [list getallclines $fd]
7454 # Since most commits have 1 parent and 1 child, we group strings of
7455 # such commits into "arcs" joining branch/merge points (BMPs), which
7456 # are commits that either don't have 1 parent or don't have 1 child.
7458 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7459 # arcout(id) - outgoing arcs for BMP
7460 # arcids(a) - list of IDs on arc including end but not start
7461 # arcstart(a) - BMP ID at start of arc
7462 # arcend(a) - BMP ID at end of arc
7463 # growing(a) - arc a is still growing
7464 # arctags(a) - IDs out of arcids (excluding end) that have tags
7465 # archeads(a) - IDs out of arcids (excluding end) that have heads
7466 # The start of an arc is at the descendent end, so "incoming" means
7467 # coming from descendents, and "outgoing" means going towards ancestors.
7469 proc getallclines {fd} {
7470 global allparents allchildren idtags idheads nextarc
7471 global arcnos arcids arctags arcout arcend arcstart archeads growing
7472 global seeds allcommits cachedarcs allcupdate
7475 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7476 set id [lindex $line 0]
7477 if {[info exists allparents($id)]} {
7482 set olds [lrange $line 1 end]
7483 set allparents($id) $olds
7484 if {![info exists allchildren($id)]} {
7485 set allchildren($id) {}
7490 if {[llength $olds] == 1 && [llength $a] == 1} {
7491 lappend arcids($a) $id
7492 if {[info exists idtags($id)]} {
7493 lappend arctags($a) $id
7495 if {[info exists idheads($id)]} {
7496 lappend archeads($a) $id
7498 if {[info exists allparents($olds)]} {
7499 # seen parent already
7500 if {![info exists arcout($olds)]} {
7503 lappend arcids($a) $olds
7504 set arcend($a) $olds
7507 lappend allchildren($olds) $id
7508 lappend arcnos($olds) $a
7512 foreach a $arcnos($id) {
7513 lappend arcids($a) $id
7520 lappend allchildren($p) $id
7521 set a [incr nextarc]
7522 set arcstart($a) $id
7529 if {[info exists allparents($p)]} {
7530 # seen it already, may need to make a new branch
7531 if {![info exists arcout($p)]} {
7534 lappend arcids($a) $p
7538 lappend arcnos($p) $a
7543 global cached_dheads cached_dtags cached_atags
7544 catch {unset cached_dheads}
7545 catch {unset cached_dtags}
7546 catch {unset cached_atags}
7549 return [expr {$nid >= 1000? 2: 1}]
7553 fconfigure $fd -blocking 1
7556 # got an error reading the list of commits
7557 # if we were updating, try rereading the whole thing again
7563 error_popup "[mc "Error reading commit topology information;\
7564 branch and preceding/following tag information\
7565 will be incomplete."]\n($err)"
7568 if {[incr allcommits -1] == 0} {
7578 proc recalcarc {a} {
7579 global arctags archeads arcids idtags idheads
7583 foreach id [lrange $arcids($a) 0 end-1] {
7584 if {[info exists idtags($id)]} {
7587 if {[info exists idheads($id)]} {
7592 set archeads($a) $ah
7596 global arcnos arcids nextarc arctags archeads idtags idheads
7597 global arcstart arcend arcout allparents growing
7600 if {[llength $a] != 1} {
7601 puts "oops splitarc called but [llength $a] arcs already"
7605 set i [lsearch -exact $arcids($a) $p]
7607 puts "oops splitarc $p not in arc $a"
7610 set na [incr nextarc]
7611 if {[info exists arcend($a)]} {
7612 set arcend($na) $arcend($a)
7614 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7615 set j [lsearch -exact $arcnos($l) $a]
7616 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7618 set tail [lrange $arcids($a) [expr {$i+1}] end]
7619 set arcids($a) [lrange $arcids($a) 0 $i]
7621 set arcstart($na) $p
7623 set arcids($na) $tail
7624 if {[info exists growing($a)]} {
7630 if {[llength $arcnos($id)] == 1} {
7633 set j [lsearch -exact $arcnos($id) $a]
7634 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7638 # reconstruct tags and heads lists
7639 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7644 set archeads($na) {}
7648 # Update things for a new commit added that is a child of one
7649 # existing commit. Used when cherry-picking.
7650 proc addnewchild {id p} {
7651 global allparents allchildren idtags nextarc
7652 global arcnos arcids arctags arcout arcend arcstart archeads growing
7653 global seeds allcommits
7655 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7656 set allparents($id) [list $p]
7657 set allchildren($id) {}
7660 lappend allchildren($p) $id
7661 set a [incr nextarc]
7662 set arcstart($a) $id
7665 set arcids($a) [list $p]
7667 if {![info exists arcout($p)]} {
7670 lappend arcnos($p) $a
7671 set arcout($id) [list $a]
7674 # This implements a cache for the topology information.
7675 # The cache saves, for each arc, the start and end of the arc,
7676 # the ids on the arc, and the outgoing arcs from the end.
7677 proc readcache {f} {
7678 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7679 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7684 if {$lim - $a > 500} {
7685 set lim [expr {$a + 500}]
7689 # finish reading the cache and setting up arctags, etc.
7691 if {$line ne "1"} {error "bad final version"}
7693 foreach id [array names idtags] {
7694 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7695 [llength $allparents($id)] == 1} {
7696 set a [lindex $arcnos($id) 0]
7697 if {$arctags($a) eq {}} {
7702 foreach id [array names idheads] {
7703 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7704 [llength $allparents($id)] == 1} {
7705 set a [lindex $arcnos($id) 0]
7706 if {$archeads($a) eq {}} {
7711 foreach id [lsort -unique $possible_seeds] {
7712 if {$arcnos($id) eq {}} {
7718 while {[incr a] <= $lim} {
7720 if {[llength $line] != 3} {error "bad line"}
7721 set s [lindex $line 0]
7723 lappend arcout($s) $a
7724 if {![info exists arcnos($s)]} {
7725 lappend possible_seeds $s
7728 set e [lindex $line 1]
7733 if {![info exists arcout($e)]} {
7737 set arcids($a) [lindex $line 2]
7738 foreach id $arcids($a) {
7739 lappend allparents($s) $id
7741 lappend arcnos($id) $a
7743 if {![info exists allparents($s)]} {
7744 set allparents($s) {}
7749 set nextarc [expr {$a - 1}]
7762 global nextarc cachedarcs possible_seeds
7766 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7767 # make sure it's an integer
7768 set cachedarcs [expr {int([lindex $line 1])}]
7769 if {$cachedarcs < 0} {error "bad number of arcs"}
7771 set possible_seeds {}
7779 proc dropcache {err} {
7780 global allcwait nextarc cachedarcs seeds
7782 #puts "dropping cache ($err)"
7783 foreach v {arcnos arcout arcids arcstart arcend growing \
7784 arctags archeads allparents allchildren} {
7795 proc writecache {f} {
7796 global cachearc cachedarcs allccache
7797 global arcstart arcend arcnos arcids arcout
7801 if {$lim - $a > 1000} {
7802 set lim [expr {$a + 1000}]
7805 while {[incr a] <= $lim} {
7806 if {[info exists arcend($a)]} {
7807 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7809 puts $f [list $arcstart($a) {} $arcids($a)]
7814 catch {file delete $allccache}
7815 #puts "writing cache failed ($err)"
7818 set cachearc [expr {$a - 1}]
7819 if {$a > $cachedarcs} {
7828 global nextarc cachedarcs cachearc allccache
7830 if {$nextarc == $cachedarcs} return
7832 set cachedarcs $nextarc
7834 set f [open $allccache w]
7835 puts $f [list 1 $cachedarcs]
7840 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7841 # or 0 if neither is true.
7842 proc anc_or_desc {a b} {
7843 global arcout arcstart arcend arcnos cached_isanc
7845 if {$arcnos($a) eq $arcnos($b)} {
7846 # Both are on the same arc(s); either both are the same BMP,
7847 # or if one is not a BMP, the other is also not a BMP or is
7848 # the BMP at end of the arc (and it only has 1 incoming arc).
7849 # Or both can be BMPs with no incoming arcs.
7850 if {$a eq $b || $arcnos($a) eq {}} {
7853 # assert {[llength $arcnos($a)] == 1}
7854 set arc [lindex $arcnos($a) 0]
7855 set i [lsearch -exact $arcids($arc) $a]
7856 set j [lsearch -exact $arcids($arc) $b]
7857 if {$i < 0 || $i > $j} {
7864 if {![info exists arcout($a)]} {
7865 set arc [lindex $arcnos($a) 0]
7866 if {[info exists arcend($arc)]} {
7867 set aend $arcend($arc)
7871 set a $arcstart($arc)
7875 if {![info exists arcout($b)]} {
7876 set arc [lindex $arcnos($b) 0]
7877 if {[info exists arcend($arc)]} {
7878 set bend $arcend($arc)
7882 set b $arcstart($arc)
7892 if {[info exists cached_isanc($a,$bend)]} {
7893 if {$cached_isanc($a,$bend)} {
7897 if {[info exists cached_isanc($b,$aend)]} {
7898 if {$cached_isanc($b,$aend)} {
7901 if {[info exists cached_isanc($a,$bend)]} {
7906 set todo [list $a $b]
7909 for {set i 0} {$i < [llength $todo]} {incr i} {
7910 set x [lindex $todo $i]
7911 if {$anc($x) eq {}} {
7914 foreach arc $arcnos($x) {
7915 set xd $arcstart($arc)
7917 set cached_isanc($a,$bend) 1
7918 set cached_isanc($b,$aend) 0
7920 } elseif {$xd eq $aend} {
7921 set cached_isanc($b,$aend) 1
7922 set cached_isanc($a,$bend) 0
7925 if {![info exists anc($xd)]} {
7926 set anc($xd) $anc($x)
7928 } elseif {$anc($xd) ne $anc($x)} {
7933 set cached_isanc($a,$bend) 0
7934 set cached_isanc($b,$aend) 0
7938 # This identifies whether $desc has an ancestor that is
7939 # a growing tip of the graph and which is not an ancestor of $anc
7940 # and returns 0 if so and 1 if not.
7941 # If we subsequently discover a tag on such a growing tip, and that
7942 # turns out to be a descendent of $anc (which it could, since we
7943 # don't necessarily see children before parents), then $desc
7944 # isn't a good choice to display as a descendent tag of
7945 # $anc (since it is the descendent of another tag which is
7946 # a descendent of $anc). Similarly, $anc isn't a good choice to
7947 # display as a ancestor tag of $desc.
7949 proc is_certain {desc anc} {
7950 global arcnos arcout arcstart arcend growing problems
7953 if {[llength $arcnos($anc)] == 1} {
7954 # tags on the same arc are certain
7955 if {$arcnos($desc) eq $arcnos($anc)} {
7958 if {![info exists arcout($anc)]} {
7959 # if $anc is partway along an arc, use the start of the arc instead
7960 set a [lindex $arcnos($anc) 0]
7961 set anc $arcstart($a)
7964 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7967 set a [lindex $arcnos($desc) 0]
7973 set anclist [list $x]
7977 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7978 set x [lindex $anclist $i]
7983 foreach a $arcout($x) {
7984 if {[info exists growing($a)]} {
7985 if {![info exists growanc($x)] && $dl($x)} {
7991 if {[info exists dl($y)]} {
7995 if {![info exists done($y)]} {
7998 if {[info exists growanc($x)]} {
8002 for {set k 0} {$k < [llength $xl]} {incr k} {
8003 set z [lindex $xl $k]
8004 foreach c $arcout($z) {
8005 if {[info exists arcend($c)]} {
8007 if {[info exists dl($v)] && $dl($v)} {
8009 if {![info exists done($v)]} {
8012 if {[info exists growanc($v)]} {
8022 } elseif {$y eq $anc || !$dl($x)} {
8033 foreach x [array names growanc] {
8042 proc validate_arctags {a} {
8043 global arctags idtags
8047 foreach id $arctags($a) {
8049 if {![info exists idtags($id)]} {
8050 set na [lreplace $na $i $i]
8057 proc validate_archeads {a} {
8058 global archeads idheads
8061 set na $archeads($a)
8062 foreach id $archeads($a) {
8064 if {![info exists idheads($id)]} {
8065 set na [lreplace $na $i $i]
8069 set archeads($a) $na
8072 # Return the list of IDs that have tags that are descendents of id,
8073 # ignoring IDs that are descendents of IDs already reported.
8074 proc desctags {id} {
8075 global arcnos arcstart arcids arctags idtags allparents
8076 global growing cached_dtags
8078 if {![info exists allparents($id)]} {
8081 set t1 [clock clicks -milliseconds]
8083 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8084 # part-way along an arc; check that arc first
8085 set a [lindex $arcnos($id) 0]
8086 if {$arctags($a) ne {}} {
8088 set i [lsearch -exact $arcids($a) $id]
8090 foreach t $arctags($a) {
8091 set j [lsearch -exact $arcids($a) $t]
8099 set id $arcstart($a)
8100 if {[info exists idtags($id)]} {
8104 if {[info exists cached_dtags($id)]} {
8105 return $cached_dtags($id)
8112 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8113 set id [lindex $todo $i]
8115 set ta [info exists hastaggedancestor($id)]
8119 # ignore tags on starting node
8120 if {!$ta && $i > 0} {
8121 if {[info exists idtags($id)]} {
8124 } elseif {[info exists cached_dtags($id)]} {
8125 set tagloc($id) $cached_dtags($id)
8129 foreach a $arcnos($id) {
8131 if {!$ta && $arctags($a) ne {}} {
8133 if {$arctags($a) ne {}} {
8134 lappend tagloc($id) [lindex $arctags($a) end]
8137 if {$ta || $arctags($a) ne {}} {
8138 set tomark [list $d]
8139 for {set j 0} {$j < [llength $tomark]} {incr j} {
8140 set dd [lindex $tomark $j]
8141 if {![info exists hastaggedancestor($dd)]} {
8142 if {[info exists done($dd)]} {
8143 foreach b $arcnos($dd) {
8144 lappend tomark $arcstart($b)
8146 if {[info exists tagloc($dd)]} {
8149 } elseif {[info exists queued($dd)]} {
8152 set hastaggedancestor($dd) 1
8156 if {![info exists queued($d)]} {
8159 if {![info exists hastaggedancestor($d)]} {
8166 foreach id [array names tagloc] {
8167 if {![info exists hastaggedancestor($id)]} {
8168 foreach t $tagloc($id) {
8169 if {[lsearch -exact $tags $t] < 0} {
8175 set t2 [clock clicks -milliseconds]
8178 # remove tags that are descendents of other tags
8179 for {set i 0} {$i < [llength $tags]} {incr i} {
8180 set a [lindex $tags $i]
8181 for {set j 0} {$j < $i} {incr j} {
8182 set b [lindex $tags $j]
8183 set r [anc_or_desc $a $b]
8185 set tags [lreplace $tags $j $j]
8188 } elseif {$r == -1} {
8189 set tags [lreplace $tags $i $i]
8196 if {[array names growing] ne {}} {
8197 # graph isn't finished, need to check if any tag could get
8198 # eclipsed by another tag coming later. Simply ignore any
8199 # tags that could later get eclipsed.
8202 if {[is_certain $t $origid]} {
8206 if {$tags eq $ctags} {
8207 set cached_dtags($origid) $tags
8212 set cached_dtags($origid) $tags
8214 set t3 [clock clicks -milliseconds]
8215 if {0 && $t3 - $t1 >= 100} {
8216 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8217 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8223 global arcnos arcids arcout arcend arctags idtags allparents
8224 global growing cached_atags
8226 if {![info exists allparents($id)]} {
8229 set t1 [clock clicks -milliseconds]
8231 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8232 # part-way along an arc; check that arc first
8233 set a [lindex $arcnos($id) 0]
8234 if {$arctags($a) ne {}} {
8236 set i [lsearch -exact $arcids($a) $id]
8237 foreach t $arctags($a) {
8238 set j [lsearch -exact $arcids($a) $t]
8244 if {![info exists arcend($a)]} {
8248 if {[info exists idtags($id)]} {
8252 if {[info exists cached_atags($id)]} {
8253 return $cached_atags($id)
8261 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8262 set id [lindex $todo $i]
8264 set td [info exists hastaggeddescendent($id)]
8268 # ignore tags on starting node
8269 if {!$td && $i > 0} {
8270 if {[info exists idtags($id)]} {
8273 } elseif {[info exists cached_atags($id)]} {
8274 set tagloc($id) $cached_atags($id)
8278 foreach a $arcout($id) {
8279 if {!$td && $arctags($a) ne {}} {
8281 if {$arctags($a) ne {}} {
8282 lappend tagloc($id) [lindex $arctags($a) 0]
8285 if {![info exists arcend($a)]} continue
8287 if {$td || $arctags($a) ne {}} {
8288 set tomark [list $d]
8289 for {set j 0} {$j < [llength $tomark]} {incr j} {
8290 set dd [lindex $tomark $j]
8291 if {![info exists hastaggeddescendent($dd)]} {
8292 if {[info exists done($dd)]} {
8293 foreach b $arcout($dd) {
8294 if {[info exists arcend($b)]} {
8295 lappend tomark $arcend($b)
8298 if {[info exists tagloc($dd)]} {
8301 } elseif {[info exists queued($dd)]} {
8304 set hastaggeddescendent($dd) 1
8308 if {![info exists queued($d)]} {
8311 if {![info exists hastaggeddescendent($d)]} {
8317 set t2 [clock clicks -milliseconds]
8320 foreach id [array names tagloc] {
8321 if {![info exists hastaggeddescendent($id)]} {
8322 foreach t $tagloc($id) {
8323 if {[lsearch -exact $tags $t] < 0} {
8330 # remove tags that are ancestors of other tags
8331 for {set i 0} {$i < [llength $tags]} {incr i} {
8332 set a [lindex $tags $i]
8333 for {set j 0} {$j < $i} {incr j} {
8334 set b [lindex $tags $j]
8335 set r [anc_or_desc $a $b]
8337 set tags [lreplace $tags $j $j]
8340 } elseif {$r == 1} {
8341 set tags [lreplace $tags $i $i]
8348 if {[array names growing] ne {}} {
8349 # graph isn't finished, need to check if any tag could get
8350 # eclipsed by another tag coming later. Simply ignore any
8351 # tags that could later get eclipsed.
8354 if {[is_certain $origid $t]} {
8358 if {$tags eq $ctags} {
8359 set cached_atags($origid) $tags
8364 set cached_atags($origid) $tags
8366 set t3 [clock clicks -milliseconds]
8367 if {0 && $t3 - $t1 >= 100} {
8368 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8369 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8374 # Return the list of IDs that have heads that are descendents of id,
8375 # including id itself if it has a head.
8376 proc descheads {id} {
8377 global arcnos arcstart arcids archeads idheads cached_dheads
8380 if {![info exists allparents($id)]} {
8384 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8385 # part-way along an arc; check it first
8386 set a [lindex $arcnos($id) 0]
8387 if {$archeads($a) ne {}} {
8388 validate_archeads $a
8389 set i [lsearch -exact $arcids($a) $id]
8390 foreach t $archeads($a) {
8391 set j [lsearch -exact $arcids($a) $t]
8396 set id $arcstart($a)
8402 for {set i 0} {$i < [llength $todo]} {incr i} {
8403 set id [lindex $todo $i]
8404 if {[info exists cached_dheads($id)]} {
8405 set ret [concat $ret $cached_dheads($id)]
8407 if {[info exists idheads($id)]} {
8410 foreach a $arcnos($id) {
8411 if {$archeads($a) ne {}} {
8412 validate_archeads $a
8413 if {$archeads($a) ne {}} {
8414 set ret [concat $ret $archeads($a)]
8418 if {![info exists seen($d)]} {
8425 set ret [lsort -unique $ret]
8426 set cached_dheads($origid) $ret
8427 return [concat $ret $aret]
8430 proc addedtag {id} {
8431 global arcnos arcout cached_dtags cached_atags
8433 if {![info exists arcnos($id)]} return
8434 if {![info exists arcout($id)]} {
8435 recalcarc [lindex $arcnos($id) 0]
8437 catch {unset cached_dtags}
8438 catch {unset cached_atags}
8441 proc addedhead {hid head} {
8442 global arcnos arcout cached_dheads
8444 if {![info exists arcnos($hid)]} return
8445 if {![info exists arcout($hid)]} {
8446 recalcarc [lindex $arcnos($hid) 0]
8448 catch {unset cached_dheads}
8451 proc removedhead {hid head} {
8452 global cached_dheads
8454 catch {unset cached_dheads}
8457 proc movedhead {hid head} {
8458 global arcnos arcout cached_dheads
8460 if {![info exists arcnos($hid)]} return
8461 if {![info exists arcout($hid)]} {
8462 recalcarc [lindex $arcnos($hid) 0]
8464 catch {unset cached_dheads}
8467 proc changedrefs {} {
8468 global cached_dheads cached_dtags cached_atags
8469 global arctags archeads arcnos arcout idheads idtags
8471 foreach id [concat [array names idheads] [array names idtags]] {
8472 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8473 set a [lindex $arcnos($id) 0]
8474 if {![info exists donearc($a)]} {
8480 catch {unset cached_dtags}
8481 catch {unset cached_atags}
8482 catch {unset cached_dheads}
8485 proc rereadrefs {} {
8486 global idtags idheads idotherrefs mainheadid
8488 set refids [concat [array names idtags] \
8489 [array names idheads] [array names idotherrefs]]
8490 foreach id $refids {
8491 if {![info exists ref($id)]} {
8492 set ref($id) [listrefs $id]
8495 set oldmainhead $mainheadid
8498 set refids [lsort -unique [concat $refids [array names idtags] \
8499 [array names idheads] [array names idotherrefs]]]
8500 foreach id $refids {
8501 set v [listrefs $id]
8502 if {![info exists ref($id)] || $ref($id) != $v ||
8503 ($id eq $oldmainhead && $id ne $mainheadid) ||
8504 ($id eq $mainheadid && $id ne $oldmainhead)} {
8511 proc listrefs {id} {
8512 global idtags idheads idotherrefs
8515 if {[info exists idtags($id)]} {
8519 if {[info exists idheads($id)]} {
8523 if {[info exists idotherrefs($id)]} {
8524 set z $idotherrefs($id)
8526 return [list $x $y $z]
8529 proc showtag {tag isnew} {
8530 global ctext tagcontents tagids linknum tagobjid
8533 addtohistory [list showtag $tag 0]
8535 $ctext conf -state normal
8539 if {![info exists tagcontents($tag)]} {
8541 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8544 if {[info exists tagcontents($tag)]} {
8545 set text $tagcontents($tag)
8547 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
8549 appendwithlinks $text {}
8550 $ctext conf -state disabled
8561 proc mkfontdisp {font top which} {
8562 global fontattr fontpref $font
8564 set fontpref($font) [set $font]
8565 button $top.${font}but -text $which -font optionfont \
8566 -command [list choosefont $font $which]
8567 label $top.$font -relief flat -font $font \
8568 -text $fontattr($font,family) -justify left
8569 grid x $top.${font}but $top.$font -sticky w
8572 proc choosefont {font which} {
8573 global fontparam fontlist fonttop fontattr
8575 set fontparam(which) $which
8576 set fontparam(font) $font
8577 set fontparam(family) [font actual $font -family]
8578 set fontparam(size) $fontattr($font,size)
8579 set fontparam(weight) $fontattr($font,weight)
8580 set fontparam(slant) $fontattr($font,slant)
8583 if {![winfo exists $top]} {
8585 eval font config sample [font actual $font]
8587 wm title $top [mc "Gitk font chooser"]
8588 label $top.l -textvariable fontparam(which)
8589 pack $top.l -side top
8590 set fontlist [lsort [font families]]
8592 listbox $top.f.fam -listvariable fontlist \
8593 -yscrollcommand [list $top.f.sb set]
8594 bind $top.f.fam <<ListboxSelect>> selfontfam
8595 scrollbar $top.f.sb -command [list $top.f.fam yview]
8596 pack $top.f.sb -side right -fill y
8597 pack $top.f.fam -side left -fill both -expand 1
8598 pack $top.f -side top -fill both -expand 1
8600 spinbox $top.g.size -from 4 -to 40 -width 4 \
8601 -textvariable fontparam(size) \
8602 -validatecommand {string is integer -strict %s}
8603 checkbutton $top.g.bold -padx 5 \
8604 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8605 -variable fontparam(weight) -onvalue bold -offvalue normal
8606 checkbutton $top.g.ital -padx 5 \
8607 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8608 -variable fontparam(slant) -onvalue italic -offvalue roman
8609 pack $top.g.size $top.g.bold $top.g.ital -side left
8610 pack $top.g -side top
8611 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8613 $top.c create text 100 25 -anchor center -text $which -font sample \
8614 -fill black -tags text
8615 bind $top.c <Configure> [list centertext $top.c]
8616 pack $top.c -side top -fill x
8618 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8619 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8620 grid $top.buts.ok $top.buts.can
8621 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8622 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8623 pack $top.buts -side bottom -fill x
8624 trace add variable fontparam write chg_fontparam
8627 $top.c itemconf text -text $which
8629 set i [lsearch -exact $fontlist $fontparam(family)]
8631 $top.f.fam selection set $i
8636 proc centertext {w} {
8637 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8641 global fontparam fontpref prefstop
8643 set f $fontparam(font)
8644 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8645 if {$fontparam(weight) eq "bold"} {
8646 lappend fontpref($f) "bold"
8648 if {$fontparam(slant) eq "italic"} {
8649 lappend fontpref($f) "italic"
8652 $w conf -text $fontparam(family) -font $fontpref($f)
8658 global fonttop fontparam
8660 if {[info exists fonttop]} {
8661 catch {destroy $fonttop}
8662 catch {font delete sample}
8668 proc selfontfam {} {
8669 global fonttop fontparam
8671 set i [$fonttop.f.fam curselection]
8673 set fontparam(family) [$fonttop.f.fam get $i]
8677 proc chg_fontparam {v sub op} {
8680 font config sample -$sub $fontparam($sub)
8684 global maxwidth maxgraphpct
8685 global oldprefs prefstop showneartags showlocalchanges
8686 global bgcolor fgcolor ctext diffcolors selectbgcolor
8687 global tabstop limitdiffs
8691 if {[winfo exists $top]} {
8695 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8696 limitdiffs tabstop} {
8697 set oldprefs($v) [set $v]
8700 wm title $top [mc "Gitk preferences"]
8701 label $top.ldisp -text [mc "Commit list display options"]
8702 grid $top.ldisp - -sticky w -pady 10
8703 label $top.spacer -text " "
8704 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8706 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8707 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8708 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8710 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8711 grid x $top.maxpctl $top.maxpct -sticky w
8712 frame $top.showlocal
8713 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8714 checkbutton $top.showlocal.b -variable showlocalchanges
8715 pack $top.showlocal.b $top.showlocal.l -side left
8716 grid x $top.showlocal -sticky w
8718 label $top.ddisp -text [mc "Diff display options"]
8719 grid $top.ddisp - -sticky w -pady 10
8720 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8721 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8722 grid x $top.tabstopl $top.tabstop -sticky w
8724 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8725 checkbutton $top.ntag.b -variable showneartags
8726 pack $top.ntag.b $top.ntag.l -side left
8727 grid x $top.ntag -sticky w
8729 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8730 checkbutton $top.ldiff.b -variable limitdiffs
8731 pack $top.ldiff.b $top.ldiff.l -side left
8732 grid x $top.ldiff -sticky w
8734 label $top.cdisp -text [mc "Colors: press to choose"]
8735 grid $top.cdisp - -sticky w -pady 10
8736 label $top.bg -padx 40 -relief sunk -background $bgcolor
8737 button $top.bgbut -text [mc "Background"] -font optionfont \
8738 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8739 grid x $top.bgbut $top.bg -sticky w
8740 label $top.fg -padx 40 -relief sunk -background $fgcolor
8741 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8742 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8743 grid x $top.fgbut $top.fg -sticky w
8744 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8745 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8746 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8747 [list $ctext tag conf d0 -foreground]]
8748 grid x $top.diffoldbut $top.diffold -sticky w
8749 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8750 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8751 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8752 [list $ctext tag conf d1 -foreground]]
8753 grid x $top.diffnewbut $top.diffnew -sticky w
8754 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8755 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8756 -command [list choosecolor diffcolors 2 $top.hunksep \
8757 "diff hunk header" \
8758 [list $ctext tag conf hunksep -foreground]]
8759 grid x $top.hunksepbut $top.hunksep -sticky w
8760 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8761 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8762 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8763 grid x $top.selbgbut $top.selbgsep -sticky w
8765 label $top.cfont -text [mc "Fonts: press to choose"]
8766 grid $top.cfont - -sticky w -pady 10
8767 mkfontdisp mainfont $top [mc "Main font"]
8768 mkfontdisp textfont $top [mc "Diff display font"]
8769 mkfontdisp uifont $top [mc "User interface font"]
8772 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8773 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8774 grid $top.buts.ok $top.buts.can
8775 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8776 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8777 grid $top.buts - - -pady 10 -sticky ew
8778 bind $top <Visibility> "focus $top.buts.ok"
8781 proc choosecolor {v vi w x cmd} {
8784 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8785 -title [mc "Gitk: choose color for %s" $x]]
8786 if {$c eq {}} return
8787 $w conf -background $c
8793 global bglist cflist
8795 $w configure -selectbackground $c
8797 $cflist tag configure highlight \
8798 -background [$cflist cget -selectbackground]
8799 allcanvs itemconf secsel -fill $c
8806 $w conf -background $c
8814 $w conf -foreground $c
8816 allcanvs itemconf text -fill $c
8817 $canv itemconf circle -outline $c
8821 global oldprefs prefstop
8823 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8824 limitdiffs tabstop} {
8826 set $v $oldprefs($v)
8828 catch {destroy $prefstop}
8834 global maxwidth maxgraphpct
8835 global oldprefs prefstop showneartags showlocalchanges
8836 global fontpref mainfont textfont uifont
8837 global limitdiffs treediffs
8839 catch {destroy $prefstop}
8843 if {$mainfont ne $fontpref(mainfont)} {
8844 set mainfont $fontpref(mainfont)
8845 parsefont mainfont $mainfont
8846 eval font configure mainfont [fontflags mainfont]
8847 eval font configure mainfontbold [fontflags mainfont 1]
8851 if {$textfont ne $fontpref(textfont)} {
8852 set textfont $fontpref(textfont)
8853 parsefont textfont $textfont
8854 eval font configure textfont [fontflags textfont]
8855 eval font configure textfontbold [fontflags textfont 1]
8857 if {$uifont ne $fontpref(uifont)} {
8858 set uifont $fontpref(uifont)
8859 parsefont uifont $uifont
8860 eval font configure uifont [fontflags uifont]
8863 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8864 if {$showlocalchanges} {
8870 if {$limitdiffs != $oldprefs(limitdiffs)} {
8871 # treediffs elements are limited by path
8872 catch {unset treediffs}
8874 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8875 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8877 } elseif {$showneartags != $oldprefs(showneartags) ||
8878 $limitdiffs != $oldprefs(limitdiffs)} {
8883 proc formatdate {d} {
8884 global datetimeformat
8886 set d [clock format $d -format $datetimeformat]
8891 # This list of encoding names and aliases is distilled from
8892 # http://www.iana.org/assignments/character-sets.
8893 # Not all of them are supported by Tcl.
8894 set encoding_aliases {
8895 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8896 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8897 { ISO-10646-UTF-1 csISO10646UTF1 }
8898 { ISO_646.basic:1983 ref csISO646basic1983 }
8899 { INVARIANT csINVARIANT }
8900 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8901 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8902 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8903 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8904 { NATS-DANO iso-ir-9-1 csNATSDANO }
8905 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8906 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8907 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8908 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8909 { ISO-2022-KR csISO2022KR }
8911 { ISO-2022-JP csISO2022JP }
8912 { ISO-2022-JP-2 csISO2022JP2 }
8913 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8915 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8916 { IT iso-ir-15 ISO646-IT csISO15Italian }
8917 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8918 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8919 { greek7-old iso-ir-18 csISO18Greek7Old }
8920 { latin-greek iso-ir-19 csISO19LatinGreek }
8921 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8922 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8923 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8924 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8925 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8926 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8927 { INIS iso-ir-49 csISO49INIS }
8928 { INIS-8 iso-ir-50 csISO50INIS8 }
8929 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8930 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8931 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8932 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8933 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8934 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8936 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8937 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8938 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8939 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8940 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8941 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8942 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8943 { greek7 iso-ir-88 csISO88Greek7 }
8944 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8945 { iso-ir-90 csISO90 }
8946 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8947 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8948 csISO92JISC62991984b }
8949 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8950 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8951 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8952 csISO95JIS62291984handadd }
8953 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8954 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8955 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8956 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8958 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8959 { T.61-7bit iso-ir-102 csISO102T617bit }
8960 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8961 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8962 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8963 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8964 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8965 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8966 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8967 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8968 arabic csISOLatinArabic }
8969 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8970 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8971 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8972 greek greek8 csISOLatinGreek }
8973 { T.101-G2 iso-ir-128 csISO128T101G2 }
8974 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8976 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8977 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8978 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8979 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8980 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8981 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8982 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8983 csISOLatinCyrillic }
8984 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8985 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8986 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8987 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8988 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8989 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8990 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8991 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8992 { ISO_10367-box iso-ir-155 csISO10367Box }
8993 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8994 { latin-lap lap iso-ir-158 csISO158Lap }
8995 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8996 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8999 { JIS_X0201 X0201 csHalfWidthKatakana }
9000 { KSC5636 ISO646-KR csKSC5636 }
9001 { ISO-10646-UCS-2 csUnicode }
9002 { ISO-10646-UCS-4 csUCS4 }
9003 { DEC-MCS dec csDECMCS }
9004 { hp-roman8 roman8 r8 csHPRoman8 }
9005 { macintosh mac csMacintosh }
9006 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9008 { IBM038 EBCDIC-INT cp038 csIBM038 }
9009 { IBM273 CP273 csIBM273 }
9010 { IBM274 EBCDIC-BE CP274 csIBM274 }
9011 { IBM275 EBCDIC-BR cp275 csIBM275 }
9012 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9013 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9014 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9015 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9016 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9017 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9018 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9019 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9020 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9021 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9022 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9023 { IBM437 cp437 437 csPC8CodePage437 }
9024 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9025 { IBM775 cp775 csPC775Baltic }
9026 { IBM850 cp850 850 csPC850Multilingual }
9027 { IBM851 cp851 851 csIBM851 }
9028 { IBM852 cp852 852 csPCp852 }
9029 { IBM855 cp855 855 csIBM855 }
9030 { IBM857 cp857 857 csIBM857 }
9031 { IBM860 cp860 860 csIBM860 }
9032 { IBM861 cp861 861 cp-is csIBM861 }
9033 { IBM862 cp862 862 csPC862LatinHebrew }
9034 { IBM863 cp863 863 csIBM863 }
9035 { IBM864 cp864 csIBM864 }
9036 { IBM865 cp865 865 csIBM865 }
9037 { IBM866 cp866 866 csIBM866 }
9038 { IBM868 CP868 cp-ar csIBM868 }
9039 { IBM869 cp869 869 cp-gr csIBM869 }
9040 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9041 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9042 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9043 { IBM891 cp891 csIBM891 }
9044 { IBM903 cp903 csIBM903 }
9045 { IBM904 cp904 904 csIBBM904 }
9046 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9047 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9048 { IBM1026 CP1026 csIBM1026 }
9049 { EBCDIC-AT-DE csIBMEBCDICATDE }
9050 { EBCDIC-AT-DE-A csEBCDICATDEA }
9051 { EBCDIC-CA-FR csEBCDICCAFR }
9052 { EBCDIC-DK-NO csEBCDICDKNO }
9053 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9054 { EBCDIC-FI-SE csEBCDICFISE }
9055 { EBCDIC-FI-SE-A csEBCDICFISEA }
9056 { EBCDIC-FR csEBCDICFR }
9057 { EBCDIC-IT csEBCDICIT }
9058 { EBCDIC-PT csEBCDICPT }
9059 { EBCDIC-ES csEBCDICES }
9060 { EBCDIC-ES-A csEBCDICESA }
9061 { EBCDIC-ES-S csEBCDICESS }
9062 { EBCDIC-UK csEBCDICUK }
9063 { EBCDIC-US csEBCDICUS }
9064 { UNKNOWN-8BIT csUnknown8BiT }
9065 { MNEMONIC csMnemonic }
9070 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9071 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9072 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9073 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9074 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9075 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9076 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9077 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9078 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9079 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9080 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9081 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9082 { IBM1047 IBM-1047 }
9083 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9084 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9085 { UNICODE-1-1 csUnicode11 }
9088 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9089 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9091 { ISO-8859-15 ISO_8859-15 Latin-9 }
9092 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9093 { GBK CP936 MS936 windows-936 }
9094 { JIS_Encoding csJISEncoding }
9095 { Shift_JIS MS_Kanji csShiftJIS }
9096 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9098 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9099 { ISO-10646-UCS-Basic csUnicodeASCII }
9100 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9101 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9102 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9103 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9104 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9105 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9106 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9107 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9108 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9109 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9110 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9111 { Ventura-US csVenturaUS }
9112 { Ventura-International csVenturaInternational }
9113 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9114 { PC8-Turkish csPC8Turkish }
9115 { IBM-Symbols csIBMSymbols }
9116 { IBM-Thai csIBMThai }
9117 { HP-Legal csHPLegal }
9118 { HP-Pi-font csHPPiFont }
9119 { HP-Math8 csHPMath8 }
9120 { Adobe-Symbol-Encoding csHPPSMath }
9121 { HP-DeskTop csHPDesktop }
9122 { Ventura-Math csVenturaMath }
9123 { Microsoft-Publishing csMicrosoftPublishing }
9124 { Windows-31J csWindows31J }
9129 proc tcl_encoding {enc} {
9130 global encoding_aliases
9131 set names [encoding names]
9132 set lcnames [string tolower $names]
9133 set enc [string tolower $enc]
9134 set i [lsearch -exact $lcnames $enc]
9136 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9137 if {[regsub {^iso[-_]} $enc iso encx]} {
9138 set i [lsearch -exact $lcnames $encx]
9142 foreach l $encoding_aliases {
9143 set ll [string tolower $l]
9144 if {[lsearch -exact $ll $enc] < 0} continue
9145 # look through the aliases for one that tcl knows about
9147 set i [lsearch -exact $lcnames $e]
9149 if {[regsub {^iso[-_]} $e iso ex]} {
9150 set i [lsearch -exact $lcnames $ex]
9159 return [lindex $names $i]
9164 # First check that Tcl/Tk is recent enough
9165 if {[catch {package require Tk 8.4} err]} {
9166 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9167 Gitk requires at least Tcl/Tk 8.4."]
9173 set wrcomcmd "git diff-tree --stdin -p --pretty"
9177 set gitencoding [exec git config --get i18n.commitencoding]
9179 if {$gitencoding == ""} {
9180 set gitencoding "utf-8"
9182 set tclencoding [tcl_encoding $gitencoding]
9183 if {$tclencoding == {}} {
9184 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9187 set mainfont {Helvetica 9}
9188 set textfont {Courier 9}
9189 set uifont {Helvetica 9 bold}
9191 set findmergefiles 0
9199 set cmitmode "patch"
9200 set wrapcomment "none"
9204 set showlocalchanges 1
9206 set datetimeformat "%Y-%m-%d %H:%M:%S"
9208 set colors {green red blue magenta darkgrey brown orange}
9211 set diffcolors {red "#00a000" blue}
9213 set selectbgcolor gray85
9215 ## For msgcat loading, first locate the installation location.
9216 if { [info exists ::env(GITK_MSGSDIR)] } {
9217 ## Msgsdir was manually set in the environment.
9218 set gitk_msgsdir $::env(GITK_MSGSDIR)
9220 ## Let's guess the prefix from argv0.
9221 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9222 set gitk_libdir [file join $gitk_prefix share gitk lib]
9223 set gitk_msgsdir [file join $gitk_libdir msgs]
9227 ## Internationalization (i18n) through msgcat and gettext. See
9228 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9229 package require msgcat
9230 namespace import ::msgcat::mc
9231 ## And eventually load the actual message catalog
9232 ::msgcat::mcload $gitk_msgsdir
9234 catch {source ~/.gitk}
9236 font create optionfont -family sans-serif -size -12
9238 parsefont mainfont $mainfont
9239 eval font create mainfont [fontflags mainfont]
9240 eval font create mainfontbold [fontflags mainfont 1]
9242 parsefont textfont $textfont
9243 eval font create textfont [fontflags textfont]
9244 eval font create textfontbold [fontflags textfont 1]
9246 parsefont uifont $uifont
9247 eval font create uifont [fontflags uifont]
9251 # check that we can find a .git directory somewhere...
9252 if {[catch {set gitdir [gitdir]}]} {
9253 show_error {} . [mc "Cannot find a git repository here."]
9256 if {![file isdirectory $gitdir]} {
9257 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9263 set cmdline_files {}
9268 "-d" { set datemode 1 }
9271 lappend revtreeargs $arg
9274 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9278 lappend revtreeargs $arg
9284 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9285 # no -- on command line, but some arguments (other than -d)
9287 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9288 set cmdline_files [split $f "\n"]
9289 set n [llength $cmdline_files]
9290 set revtreeargs [lrange $revtreeargs 0 end-$n]
9291 # Unfortunately git rev-parse doesn't produce an error when
9292 # something is both a revision and a filename. To be consistent
9293 # with git log and git rev-list, check revtreeargs for filenames.
9294 foreach arg $revtreeargs {
9295 if {[file exists $arg]} {
9296 show_error {} . [mc "Ambiguous argument '%s': both revision\
9302 # unfortunately we get both stdout and stderr in $err,
9303 # so look for "fatal:".
9304 set i [string first "fatal:" $err]
9306 set err [string range $err [expr {$i + 6}] end]
9308 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9314 # find the list of unmerged files
9318 set fd [open "| git ls-files -u" r]
9320 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9323 while {[gets $fd line] >= 0} {
9324 set i [string first "\t" $line]
9325 if {$i < 0} continue
9326 set fname [string range $line [expr {$i+1}] end]
9327 if {[lsearch -exact $mlist $fname] >= 0} continue
9329 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9330 lappend mlist $fname
9335 if {$nr_unmerged == 0} {
9336 show_error {} . [mc "No files selected: --merge specified but\
9337 no files are unmerged."]
9339 show_error {} . [mc "No files selected: --merge specified but\
9340 no unmerged files are within file limit."]
9344 set cmdline_files $mlist
9347 set nullid "0000000000000000000000000000000000000000"
9348 set nullid2 "0000000000000000000000000000000000000001"
9350 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9357 set highlight_paths {}
9359 set searchdirn -forwards
9363 set markingmatches 0
9364 set linkentercount 0
9365 set need_redisplay 0
9372 set selectedhlview [mc "None"]
9373 set highlight_related [mc "None"]
9374 set highlight_files {}
9387 # wait for the window to become visible
9389 wm title . "[file tail $argv0]: [file tail [pwd]]"
9392 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9393 # create a view for the files/dirs specified on the command line
9397 set viewname(1) [mc "Command line"]
9398 set viewfiles(1) $cmdline_files
9399 set viewargs(1) $revtreeargs
9402 .bar.view entryconf [mc "Edit view..."] -state normal
9403 .bar.view entryconf [mc "Delete view"] -state normal
9406 if {[info exists permviews]} {
9407 foreach v $permviews {
9410 set viewname($n) [lindex $v 0]
9411 set viewfiles($n) [lindex $v 1]
9412 set viewargs($n) [lindex $v 2]